2016-06-16 Gary Dismukes <dismukes@adacore.com>
[official-gcc.git] / gcc / ada / sem_prag.adb
blob51f2e83822a30c6ddfdbd0418c2b24ba982a2952
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ P R A G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
45 with Ghost; use Ghost;
46 with Lib; use Lib;
47 with Lib.Writ; use Lib.Writ;
48 with Lib.Xref; use Lib.Xref;
49 with Namet.Sp; use Namet.Sp;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
52 with Output; use Output;
53 with Par_SCO; use Par_SCO;
54 with Restrict; use Restrict;
55 with Rident; use Rident;
56 with Rtsfind; use Rtsfind;
57 with Sem; use Sem;
58 with Sem_Aux; use Sem_Aux;
59 with Sem_Ch3; use Sem_Ch3;
60 with Sem_Ch6; use Sem_Ch6;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Ch12; use Sem_Ch12;
63 with Sem_Ch13; use Sem_Ch13;
64 with Sem_Disp; use Sem_Disp;
65 with Sem_Dist; use Sem_Dist;
66 with Sem_Elim; use Sem_Elim;
67 with Sem_Eval; use Sem_Eval;
68 with Sem_Intr; use Sem_Intr;
69 with Sem_Mech; use Sem_Mech;
70 with Sem_Res; use Sem_Res;
71 with Sem_Type; use Sem_Type;
72 with Sem_Util; use Sem_Util;
73 with Sem_Warn; use Sem_Warn;
74 with Stand; use Stand;
75 with Sinfo; use Sinfo;
76 with Sinfo.CN; use Sinfo.CN;
77 with Sinput; use Sinput;
78 with Stringt; use Stringt;
79 with Stylesw; use Stylesw;
80 with Table;
81 with Targparm; use Targparm;
82 with Tbuild; use Tbuild;
83 with Ttypes;
84 with Uintp; use Uintp;
85 with Uname; use Uname;
86 with Urealp; use Urealp;
87 with Validsw; use Validsw;
88 with Warnsw; use Warnsw;
90 package body Sem_Prag is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
100 -- pragma Export_xxx
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
105 -- pragma Import_xxx
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
111 -- IDENTIFIER
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all lower case letters.
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals is new Table.Table (
158 Table_Component_Type => Node_Id,
159 Table_Index_Type => Int,
160 Table_Low_Bound => 0,
161 Table_Initial => 100,
162 Table_Increment => 100,
163 Table_Name => "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
170 -- This routine is used for possible casing adjustment of an explicit
171 -- external name supplied as a string literal (the node N), according to
172 -- the casing requirement of Opt.External_Name_Casing. If this is set to
173 -- As_Is, then the string literal is returned unchanged, but if it is set
174 -- to Uppercase or Lowercase, then a new string literal with appropriate
175 -- casing is constructed.
177 procedure Analyze_Part_Of
178 (Indic : Node_Id;
179 Item_Id : Entity_Id;
180 Encap : Node_Id;
181 Encap_Id : out Entity_Id;
182 Legal : out Boolean);
183 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
184 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
185 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
186 -- package instantiation. Encap denotes the encapsulating state or single
187 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
188 -- the indicator is legal.
190 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
191 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
192 -- Query whether a particular item appears in a mixed list of nodes and
193 -- entities. It is assumed that all nodes in the list have entities.
195 procedure Check_Postcondition_Use_In_Inlined_Subprogram
196 (Prag : Node_Id;
197 Spec_Id : Entity_Id);
198 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
199 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
200 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
202 procedure Check_State_And_Constituent_Use
203 (States : Elist_Id;
204 Constits : Elist_Id;
205 Context : Node_Id);
206 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
207 -- Global and Initializes. Determine whether a state from list States and a
208 -- corresponding constituent from list Constits (if any) appear in the same
209 -- context denoted by Context. If this is the case, emit an error.
211 procedure Contract_Freeze_Error
212 (Contract_Id : Entity_Id;
213 Freeze_Id : Entity_Id);
214 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
215 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
216 -- of a body which caused contract "freezing" and Contract_Id denotes the
217 -- entity of the affected contstruct.
219 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
220 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
221 -- Prag that duplicates previous pragma Prev.
223 function Find_Related_Context
224 (Prag : Node_Id;
225 Do_Checks : Boolean := False) return Node_Id;
226 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
227 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
228 -- Part_Of. Find the first source declaration or statement found while
229 -- traversing the previous node chain starting from pragma Prag. If flag
230 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
231 -- returns Empty when reaching the start of the node chain.
233 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
234 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
235 -- original one, following the renaming chain) is returned. Otherwise the
236 -- entity is returned unchanged. Should be in Einfo???
238 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
239 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
240 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
241 -- value of type SPARK_Mode_Type.
243 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
244 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
245 -- Determine whether dependency clause Clause is surrounded by extra
246 -- parentheses. If this is the case, issue an error message.
248 function Is_CCT_Instance
249 (Ref_Id : Entity_Id;
250 Context_Id : Entity_Id) return Boolean;
251 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
252 -- Global. Determine whether entity Ref_Id denotes the current instance of
253 -- a concurrent type. Context_Id denotes the associated context where the
254 -- pragma appears.
256 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
257 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
258 -- pragma Depends. Determine whether the type of dependency item Item is
259 -- tagged, unconstrained array, unconstrained record or a record with at
260 -- least one unconstrained component.
262 procedure Record_Possible_Body_Reference
263 (State_Id : Entity_Id;
264 Ref : Node_Id);
265 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
266 -- Global. Given an abstract state denoted by State_Id and a reference Ref
267 -- to it, determine whether the reference appears in a package body that
268 -- will eventually refine the state. If this is the case, record the
269 -- reference for future checks (see Analyze_Refined_State_In_Decls).
271 procedure Resolve_State (N : Node_Id);
272 -- Handle the overloading of state names by functions. When N denotes a
273 -- function, this routine finds the corresponding state and sets the entity
274 -- of N to that of the state.
276 procedure Rewrite_Assertion_Kind (N : Node_Id);
277 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
278 -- then it is rewritten as an identifier with the corresponding special
279 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
280 -- and Check_Policy.
282 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
283 -- Place semantic information on the argument of an Elaborate/Elaborate_All
284 -- pragma. Entity name for unit and its parents is taken from item in
285 -- previous with_clause that mentions the unit.
287 Dummy : Integer := 0;
288 pragma Volatile (Dummy);
289 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
291 procedure ip;
292 pragma No_Inline (ip);
293 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
294 -- is just to help debugging the front end. If a pragma Inspection_Point
295 -- is added to a source program, then breaking on ip will get you to that
296 -- point in the program.
298 procedure rv;
299 pragma No_Inline (rv);
300 -- This is a dummy function called by the processing for pragma Reviewable.
301 -- It is there for assisting front end debugging. By placing a Reviewable
302 -- pragma in the source program, a breakpoint on rv catches this place in
303 -- the source, allowing convenient stepping to the point of interest.
305 -------------------------------
306 -- Adjust_External_Name_Case --
307 -------------------------------
309 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
310 CC : Char_Code;
312 begin
313 -- Adjust case of literal if required
315 if Opt.External_Name_Exp_Casing = As_Is then
316 return N;
318 else
319 -- Copy existing string
321 Start_String;
323 -- Set proper casing
325 for J in 1 .. String_Length (Strval (N)) loop
326 CC := Get_String_Char (Strval (N), J);
328 if Opt.External_Name_Exp_Casing = Uppercase
329 and then CC >= Get_Char_Code ('a')
330 and then CC <= Get_Char_Code ('z')
331 then
332 Store_String_Char (CC - 32);
334 elsif Opt.External_Name_Exp_Casing = Lowercase
335 and then CC >= Get_Char_Code ('A')
336 and then CC <= Get_Char_Code ('Z')
337 then
338 Store_String_Char (CC + 32);
340 else
341 Store_String_Char (CC);
342 end if;
343 end loop;
345 return
346 Make_String_Literal (Sloc (N),
347 Strval => End_String);
348 end if;
349 end Adjust_External_Name_Case;
351 -----------------------------------------
352 -- Analyze_Contract_Cases_In_Decl_Part --
353 -----------------------------------------
355 procedure Analyze_Contract_Cases_In_Decl_Part
356 (N : Node_Id;
357 Freeze_Id : Entity_Id := Empty)
359 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
360 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
362 Others_Seen : Boolean := False;
363 -- This flag is set when an "others" choice is encountered. It is used
364 -- to detect multiple illegal occurrences of "others".
366 procedure Analyze_Contract_Case (CCase : Node_Id);
367 -- Verify the legality of a single contract case
369 ---------------------------
370 -- Analyze_Contract_Case --
371 ---------------------------
373 procedure Analyze_Contract_Case (CCase : Node_Id) is
374 Case_Guard : Node_Id;
375 Conseq : Node_Id;
376 Errors : Nat;
377 Extra_Guard : Node_Id;
379 begin
380 if Nkind (CCase) = N_Component_Association then
381 Case_Guard := First (Choices (CCase));
382 Conseq := Expression (CCase);
384 -- Each contract case must have exactly one case guard
386 Extra_Guard := Next (Case_Guard);
388 if Present (Extra_Guard) then
389 Error_Msg_N
390 ("contract case must have exactly one case guard",
391 Extra_Guard);
392 end if;
394 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
396 if Nkind (Case_Guard) = N_Others_Choice then
397 if Others_Seen then
398 Error_Msg_N
399 ("only one others choice allowed in contract cases",
400 Case_Guard);
401 else
402 Others_Seen := True;
403 end if;
405 elsif Others_Seen then
406 Error_Msg_N
407 ("others must be the last choice in contract cases", N);
408 end if;
410 -- Preanalyze the case guard and consequence
412 if Nkind (Case_Guard) /= N_Others_Choice then
413 Errors := Serious_Errors_Detected;
414 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
416 -- Emit a clarification message when the case guard contains
417 -- at least one undefined reference, possibly due to contract
418 -- "freezing".
420 if Errors /= Serious_Errors_Detected
421 and then Present (Freeze_Id)
422 and then Has_Undefined_Reference (Case_Guard)
423 then
424 Contract_Freeze_Error (Spec_Id, Freeze_Id);
425 end if;
426 end if;
428 Errors := Serious_Errors_Detected;
429 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
431 -- Emit a clarification message when the consequence contains
432 -- at least one undefined reference, possibly due to contract
433 -- "freezing".
435 if Errors /= Serious_Errors_Detected
436 and then Present (Freeze_Id)
437 and then Has_Undefined_Reference (Conseq)
438 then
439 Contract_Freeze_Error (Spec_Id, Freeze_Id);
440 end if;
442 -- The contract case is malformed
444 else
445 Error_Msg_N ("wrong syntax in contract case", CCase);
446 end if;
447 end Analyze_Contract_Case;
449 -- Local variables
451 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
453 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
455 CCase : Node_Id;
456 Restore_Scope : Boolean := False;
458 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
460 begin
461 -- Do not analyze the pragma multiple times
463 if Is_Analyzed_Pragma (N) then
464 return;
465 end if;
467 -- Set the Ghost mode in effect from the pragma. Due to the delayed
468 -- analysis of the pragma, the Ghost mode at point of declaration and
469 -- point of analysis may not necessarily be the same. Use the mode in
470 -- effect at the point of declaration.
472 Set_Ghost_Mode (N);
474 -- Single and multiple contract cases must appear in aggregate form. If
475 -- this is not the case, then either the parser of the analysis of the
476 -- pragma failed to produce an aggregate.
478 pragma Assert (Nkind (CCases) = N_Aggregate);
480 if Present (Component_Associations (CCases)) then
482 -- Ensure that the formal parameters are visible when analyzing all
483 -- clauses. This falls out of the general rule of aspects pertaining
484 -- to subprogram declarations.
486 if not In_Open_Scopes (Spec_Id) then
487 Restore_Scope := True;
488 Push_Scope (Spec_Id);
490 if Is_Generic_Subprogram (Spec_Id) then
491 Install_Generic_Formals (Spec_Id);
492 else
493 Install_Formals (Spec_Id);
494 end if;
495 end if;
497 CCase := First (Component_Associations (CCases));
498 while Present (CCase) loop
499 Analyze_Contract_Case (CCase);
500 Next (CCase);
501 end loop;
503 if Restore_Scope then
504 End_Scope;
505 end if;
507 -- Currently it is not possible to inline pre/postconditions on a
508 -- subprogram subject to pragma Inline_Always.
510 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
512 -- Otherwise the pragma is illegal
514 else
515 Error_Msg_N ("wrong syntax for constract cases", N);
516 end if;
518 Ghost_Mode := Save_Ghost_Mode;
519 Set_Is_Analyzed_Pragma (N);
520 end Analyze_Contract_Cases_In_Decl_Part;
522 ----------------------------------
523 -- Analyze_Depends_In_Decl_Part --
524 ----------------------------------
526 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
527 Loc : constant Source_Ptr := Sloc (N);
528 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
529 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
531 All_Inputs_Seen : Elist_Id := No_Elist;
532 -- A list containing the entities of all the inputs processed so far.
533 -- The list is populated with unique entities because the same input
534 -- may appear in multiple input lists.
536 All_Outputs_Seen : Elist_Id := No_Elist;
537 -- A list containing the entities of all the outputs processed so far.
538 -- The list is populated with unique entities because output items are
539 -- unique in a dependence relation.
541 Constits_Seen : Elist_Id := No_Elist;
542 -- A list containing the entities of all constituents processed so far.
543 -- It aids in detecting illegal usage of a state and a corresponding
544 -- constituent in pragma [Refinde_]Depends.
546 Global_Seen : Boolean := False;
547 -- A flag set when pragma Global has been processed
549 Null_Output_Seen : Boolean := False;
550 -- A flag used to track the legality of a null output
552 Result_Seen : Boolean := False;
553 -- A flag set when Spec_Id'Result is processed
555 States_Seen : Elist_Id := No_Elist;
556 -- A list containing the entities of all states processed so far. It
557 -- helps in detecting illegal usage of a state and a corresponding
558 -- constituent in pragma [Refined_]Depends.
560 Subp_Inputs : Elist_Id := No_Elist;
561 Subp_Outputs : Elist_Id := No_Elist;
562 -- Two lists containing the full set of inputs and output of the related
563 -- subprograms. Note that these lists contain both nodes and entities.
565 Task_Input_Seen : Boolean := False;
566 Task_Output_Seen : Boolean := False;
567 -- Flags used to track the implicit dependence of a task unit on itself
569 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
570 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
571 -- to the name buffer. The individual kinds are as follows:
572 -- E_Abstract_State - "state"
573 -- E_Constant - "constant"
574 -- E_Discriminant - "discriminant"
575 -- E_Generic_In_Out_Parameter - "generic parameter"
576 -- E_Generic_In_Parameter - "generic parameter"
577 -- E_In_Parameter - "parameter"
578 -- E_In_Out_Parameter - "parameter"
579 -- E_Loop_Parameter - "loop parameter"
580 -- E_Out_Parameter - "parameter"
581 -- E_Protected_Type - "current instance of protected type"
582 -- E_Task_Type - "current instance of task type"
583 -- E_Variable - "global"
585 procedure Analyze_Dependency_Clause
586 (Clause : Node_Id;
587 Is_Last : Boolean);
588 -- Verify the legality of a single dependency clause. Flag Is_Last
589 -- denotes whether Clause is the last clause in the relation.
591 procedure Check_Function_Return;
592 -- Verify that Funtion'Result appears as one of the outputs
593 -- (SPARK RM 6.1.5(10)).
595 procedure Check_Role
596 (Item : Node_Id;
597 Item_Id : Entity_Id;
598 Is_Input : Boolean;
599 Self_Ref : Boolean);
600 -- Ensure that an item fulfills its designated input and/or output role
601 -- as specified by pragma Global (if any) or the enclosing context. If
602 -- this is not the case, emit an error. Item and Item_Id denote the
603 -- attributes of an item. Flag Is_Input should be set when item comes
604 -- from an input list. Flag Self_Ref should be set when the item is an
605 -- output and the dependency clause has operator "+".
607 procedure Check_Usage
608 (Subp_Items : Elist_Id;
609 Used_Items : Elist_Id;
610 Is_Input : Boolean);
611 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
612 -- error if this is not the case.
614 procedure Normalize_Clause (Clause : Node_Id);
615 -- Remove a self-dependency "+" from the input list of a clause
617 -----------------------------
618 -- Add_Item_To_Name_Buffer --
619 -----------------------------
621 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
622 begin
623 if Ekind (Item_Id) = E_Abstract_State then
624 Add_Str_To_Name_Buffer ("state");
626 elsif Ekind (Item_Id) = E_Constant then
627 Add_Str_To_Name_Buffer ("constant");
629 elsif Ekind (Item_Id) = E_Discriminant then
630 Add_Str_To_Name_Buffer ("discriminant");
632 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
633 E_Generic_In_Parameter)
634 then
635 Add_Str_To_Name_Buffer ("generic parameter");
637 elsif Is_Formal (Item_Id) then
638 Add_Str_To_Name_Buffer ("parameter");
640 elsif Ekind (Item_Id) = E_Loop_Parameter then
641 Add_Str_To_Name_Buffer ("loop parameter");
643 elsif Ekind (Item_Id) = E_Protected_Type
644 or else Is_Single_Protected_Object (Item_Id)
645 then
646 Add_Str_To_Name_Buffer ("current instance of protected type");
648 elsif Ekind (Item_Id) = E_Task_Type
649 or else Is_Single_Task_Object (Item_Id)
650 then
651 Add_Str_To_Name_Buffer ("current instance of task type");
653 elsif Ekind (Item_Id) = E_Variable then
654 Add_Str_To_Name_Buffer ("global");
656 -- The routine should not be called with non-SPARK items
658 else
659 raise Program_Error;
660 end if;
661 end Add_Item_To_Name_Buffer;
663 -------------------------------
664 -- Analyze_Dependency_Clause --
665 -------------------------------
667 procedure Analyze_Dependency_Clause
668 (Clause : Node_Id;
669 Is_Last : Boolean)
671 procedure Analyze_Input_List (Inputs : Node_Id);
672 -- Verify the legality of a single input list
674 procedure Analyze_Input_Output
675 (Item : Node_Id;
676 Is_Input : Boolean;
677 Self_Ref : Boolean;
678 Top_Level : Boolean;
679 Seen : in out Elist_Id;
680 Null_Seen : in out Boolean;
681 Non_Null_Seen : in out Boolean);
682 -- Verify the legality of a single input or output item. Flag
683 -- Is_Input should be set whenever Item is an input, False when it
684 -- denotes an output. Flag Self_Ref should be set when the item is an
685 -- output and the dependency clause has a "+". Flag Top_Level should
686 -- be set whenever Item appears immediately within an input or output
687 -- list. Seen is a collection of all abstract states, objects and
688 -- formals processed so far. Flag Null_Seen denotes whether a null
689 -- input or output has been encountered. Flag Non_Null_Seen denotes
690 -- whether a non-null input or output has been encountered.
692 ------------------------
693 -- Analyze_Input_List --
694 ------------------------
696 procedure Analyze_Input_List (Inputs : Node_Id) is
697 Inputs_Seen : Elist_Id := No_Elist;
698 -- A list containing the entities of all inputs that appear in the
699 -- current input list.
701 Non_Null_Input_Seen : Boolean := False;
702 Null_Input_Seen : Boolean := False;
703 -- Flags used to check the legality of an input list
705 Input : Node_Id;
707 begin
708 -- Multiple inputs appear as an aggregate
710 if Nkind (Inputs) = N_Aggregate then
711 if Present (Component_Associations (Inputs)) then
712 SPARK_Msg_N
713 ("nested dependency relations not allowed", Inputs);
715 elsif Present (Expressions (Inputs)) then
716 Input := First (Expressions (Inputs));
717 while Present (Input) loop
718 Analyze_Input_Output
719 (Item => Input,
720 Is_Input => True,
721 Self_Ref => False,
722 Top_Level => False,
723 Seen => Inputs_Seen,
724 Null_Seen => Null_Input_Seen,
725 Non_Null_Seen => Non_Null_Input_Seen);
727 Next (Input);
728 end loop;
730 -- Syntax error, always report
732 else
733 Error_Msg_N ("malformed input dependency list", Inputs);
734 end if;
736 -- Process a solitary input
738 else
739 Analyze_Input_Output
740 (Item => Inputs,
741 Is_Input => True,
742 Self_Ref => False,
743 Top_Level => False,
744 Seen => Inputs_Seen,
745 Null_Seen => Null_Input_Seen,
746 Non_Null_Seen => Non_Null_Input_Seen);
747 end if;
749 -- Detect an illegal dependency clause of the form
751 -- (null =>[+] null)
753 if Null_Output_Seen and then Null_Input_Seen then
754 SPARK_Msg_N
755 ("null dependency clause cannot have a null input list",
756 Inputs);
757 end if;
758 end Analyze_Input_List;
760 --------------------------
761 -- Analyze_Input_Output --
762 --------------------------
764 procedure Analyze_Input_Output
765 (Item : Node_Id;
766 Is_Input : Boolean;
767 Self_Ref : Boolean;
768 Top_Level : Boolean;
769 Seen : in out Elist_Id;
770 Null_Seen : in out Boolean;
771 Non_Null_Seen : in out Boolean)
773 procedure Current_Task_Instance_Seen;
774 -- Set the appropriate global flag when the current instance of a
775 -- task unit is encountered.
777 --------------------------------
778 -- Current_Task_Instance_Seen --
779 --------------------------------
781 procedure Current_Task_Instance_Seen is
782 begin
783 if Is_Input then
784 Task_Input_Seen := True;
785 else
786 Task_Output_Seen := True;
787 end if;
788 end Current_Task_Instance_Seen;
790 -- Local variables
792 Is_Output : constant Boolean := not Is_Input;
793 Grouped : Node_Id;
794 Item_Id : Entity_Id;
796 -- Start of processing for Analyze_Input_Output
798 begin
799 -- Multiple input or output items appear as an aggregate
801 if Nkind (Item) = N_Aggregate then
802 if not Top_Level then
803 SPARK_Msg_N ("nested grouping of items not allowed", Item);
805 elsif Present (Component_Associations (Item)) then
806 SPARK_Msg_N
807 ("nested dependency relations not allowed", Item);
809 -- Recursively analyze the grouped items
811 elsif Present (Expressions (Item)) then
812 Grouped := First (Expressions (Item));
813 while Present (Grouped) loop
814 Analyze_Input_Output
815 (Item => Grouped,
816 Is_Input => Is_Input,
817 Self_Ref => Self_Ref,
818 Top_Level => False,
819 Seen => Seen,
820 Null_Seen => Null_Seen,
821 Non_Null_Seen => Non_Null_Seen);
823 Next (Grouped);
824 end loop;
826 -- Syntax error, always report
828 else
829 Error_Msg_N ("malformed dependency list", Item);
830 end if;
832 -- Process attribute 'Result in the context of a dependency clause
834 elsif Is_Attribute_Result (Item) then
835 Non_Null_Seen := True;
837 Analyze (Item);
839 -- Attribute 'Result is allowed to appear on the output side of
840 -- a dependency clause (SPARK RM 6.1.5(6)).
842 if Is_Input then
843 SPARK_Msg_N ("function result cannot act as input", Item);
845 elsif Null_Seen then
846 SPARK_Msg_N
847 ("cannot mix null and non-null dependency items", Item);
849 else
850 Result_Seen := True;
851 end if;
853 -- Detect multiple uses of null in a single dependency list or
854 -- throughout the whole relation. Verify the placement of a null
855 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
857 elsif Nkind (Item) = N_Null then
858 if Null_Seen then
859 SPARK_Msg_N
860 ("multiple null dependency relations not allowed", Item);
862 elsif Non_Null_Seen then
863 SPARK_Msg_N
864 ("cannot mix null and non-null dependency items", Item);
866 else
867 Null_Seen := True;
869 if Is_Output then
870 if not Is_Last then
871 SPARK_Msg_N
872 ("null output list must be the last clause in a "
873 & "dependency relation", Item);
875 -- Catch a useless dependence of the form:
876 -- null =>+ ...
878 elsif Self_Ref then
879 SPARK_Msg_N
880 ("useless dependence, null depends on itself", Item);
881 end if;
882 end if;
883 end if;
885 -- Default case
887 else
888 Non_Null_Seen := True;
890 if Null_Seen then
891 SPARK_Msg_N ("cannot mix null and non-null items", Item);
892 end if;
894 Analyze (Item);
895 Resolve_State (Item);
897 -- Find the entity of the item. If this is a renaming, climb
898 -- the renaming chain to reach the root object. Renamings of
899 -- non-entire objects do not yield an entity (Empty).
901 Item_Id := Entity_Of (Item);
903 if Present (Item_Id) then
905 -- Constants
907 if Ekind_In (Item_Id, E_Constant,
908 E_Discriminant,
909 E_Loop_Parameter)
910 or else
912 -- Current instances of concurrent types
914 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
915 or else
917 -- Formal parameters
919 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
920 E_Generic_In_Parameter,
921 E_In_Parameter,
922 E_In_Out_Parameter,
923 E_Out_Parameter)
924 or else
926 -- States, variables
928 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
929 then
930 -- The item denotes a concurrent type. Note that single
931 -- protected/task types are not considered here because
932 -- they behave as objects in the context of pragma
933 -- [Refined_]Depends.
935 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
937 -- This use is legal as long as the concurrent type is
938 -- the current instance of an enclosing type.
940 if Is_CCT_Instance (Item_Id, Spec_Id) then
942 -- The dependence of a task unit on itself is
943 -- implicit and may or may not be explicitly
944 -- specified (SPARK RM 6.1.4).
946 if Ekind (Item_Id) = E_Task_Type then
947 Current_Task_Instance_Seen;
948 end if;
950 -- Otherwise this is not the current instance
952 else
953 SPARK_Msg_N
954 ("invalid use of subtype mark in dependency "
955 & "relation", Item);
956 end if;
958 -- The dependency of a task unit on itself is implicit
959 -- and may or may not be explicitly specified
960 -- (SPARK RM 6.1.4).
962 elsif Is_Single_Task_Object (Item_Id)
963 and then Is_CCT_Instance (Item_Id, Spec_Id)
964 then
965 Current_Task_Instance_Seen;
966 end if;
968 -- Ensure that the item fulfills its role as input and/or
969 -- output as specified by pragma Global or the enclosing
970 -- context.
972 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
974 -- Detect multiple uses of the same state, variable or
975 -- formal parameter. If this is not the case, add the
976 -- item to the list of processed relations.
978 if Contains (Seen, Item_Id) then
979 SPARK_Msg_NE
980 ("duplicate use of item &", Item, Item_Id);
981 else
982 Append_New_Elmt (Item_Id, Seen);
983 end if;
985 -- Detect illegal use of an input related to a null
986 -- output. Such input items cannot appear in other
987 -- input lists (SPARK RM 6.1.5(13)).
989 if Is_Input
990 and then Null_Output_Seen
991 and then Contains (All_Inputs_Seen, Item_Id)
992 then
993 SPARK_Msg_N
994 ("input of a null output list cannot appear in "
995 & "multiple input lists", Item);
996 end if;
998 -- Add an input or a self-referential output to the list
999 -- of all processed inputs.
1001 if Is_Input or else Self_Ref then
1002 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1003 end if;
1005 -- State related checks (SPARK RM 6.1.5(3))
1007 if Ekind (Item_Id) = E_Abstract_State then
1009 -- Package and subprogram bodies are instantiated
1010 -- individually in a separate compiler pass. Due to
1011 -- this mode of instantiation, the refinement of a
1012 -- state may no longer be visible when a subprogram
1013 -- body contract is instantiated. Since the generic
1014 -- template is legal, do not perform this check in
1015 -- the instance to circumvent this oddity.
1017 if Is_Generic_Instance (Spec_Id) then
1018 null;
1020 -- An abstract state with visible refinement cannot
1021 -- appear in pragma [Refined_]Depends as its place
1022 -- must be taken by some of its constituents
1023 -- (SPARK RM 6.1.4(7)).
1025 elsif Has_Visible_Refinement (Item_Id) then
1026 SPARK_Msg_NE
1027 ("cannot mention state & in dependence relation",
1028 Item, Item_Id);
1029 SPARK_Msg_N ("\use its constituents instead", Item);
1030 return;
1032 -- If the reference to the abstract state appears in
1033 -- an enclosing package body that will eventually
1034 -- refine the state, record the reference for future
1035 -- checks.
1037 else
1038 Record_Possible_Body_Reference
1039 (State_Id => Item_Id,
1040 Ref => Item);
1041 end if;
1042 end if;
1044 -- When the item renames an entire object, replace the
1045 -- item with a reference to the object.
1047 if Entity (Item) /= Item_Id then
1048 Rewrite (Item,
1049 New_Occurrence_Of (Item_Id, Sloc (Item)));
1050 Analyze (Item);
1051 end if;
1053 -- Add the entity of the current item to the list of
1054 -- processed items.
1056 if Ekind (Item_Id) = E_Abstract_State then
1057 Append_New_Elmt (Item_Id, States_Seen);
1059 -- The variable may eventually become a constituent of a
1060 -- single protected/task type. Record the reference now
1061 -- and verify its legality when analyzing the contract of
1062 -- the variable (SPARK RM 9.3).
1064 elsif Ekind (Item_Id) = E_Variable then
1065 Record_Possible_Part_Of_Reference
1066 (Var_Id => Item_Id,
1067 Ref => Item);
1068 end if;
1070 if Ekind_In (Item_Id, E_Abstract_State,
1071 E_Constant,
1072 E_Variable)
1073 and then Present (Encapsulating_State (Item_Id))
1074 then
1075 Append_New_Elmt (Item_Id, Constits_Seen);
1076 end if;
1078 -- All other input/output items are illegal
1079 -- (SPARK RM 6.1.5(1)).
1081 else
1082 SPARK_Msg_N
1083 ("item must denote parameter, variable, state or "
1084 & "current instance of concurren type", Item);
1085 end if;
1087 -- All other input/output items are illegal
1088 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1090 else
1091 Error_Msg_N
1092 ("item must denote parameter, variable, state or current "
1093 & "instance of concurrent type", Item);
1094 end if;
1095 end if;
1096 end Analyze_Input_Output;
1098 -- Local variables
1100 Inputs : Node_Id;
1101 Output : Node_Id;
1102 Self_Ref : Boolean;
1104 Non_Null_Output_Seen : Boolean := False;
1105 -- Flag used to check the legality of an output list
1107 -- Start of processing for Analyze_Dependency_Clause
1109 begin
1110 Inputs := Expression (Clause);
1111 Self_Ref := False;
1113 -- An input list with a self-dependency appears as operator "+" where
1114 -- the actuals inputs are the right operand.
1116 if Nkind (Inputs) = N_Op_Plus then
1117 Inputs := Right_Opnd (Inputs);
1118 Self_Ref := True;
1119 end if;
1121 -- Process the output_list of a dependency_clause
1123 Output := First (Choices (Clause));
1124 while Present (Output) loop
1125 Analyze_Input_Output
1126 (Item => Output,
1127 Is_Input => False,
1128 Self_Ref => Self_Ref,
1129 Top_Level => True,
1130 Seen => All_Outputs_Seen,
1131 Null_Seen => Null_Output_Seen,
1132 Non_Null_Seen => Non_Null_Output_Seen);
1134 Next (Output);
1135 end loop;
1137 -- Process the input_list of a dependency_clause
1139 Analyze_Input_List (Inputs);
1140 end Analyze_Dependency_Clause;
1142 ---------------------------
1143 -- Check_Function_Return --
1144 ---------------------------
1146 procedure Check_Function_Return is
1147 begin
1148 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1149 and then not Result_Seen
1150 then
1151 SPARK_Msg_NE
1152 ("result of & must appear in exactly one output list",
1153 N, Spec_Id);
1154 end if;
1155 end Check_Function_Return;
1157 ----------------
1158 -- Check_Role --
1159 ----------------
1161 procedure Check_Role
1162 (Item : Node_Id;
1163 Item_Id : Entity_Id;
1164 Is_Input : Boolean;
1165 Self_Ref : Boolean)
1167 procedure Find_Role
1168 (Item_Is_Input : out Boolean;
1169 Item_Is_Output : out Boolean);
1170 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1171 -- Item_Is_Output are set depending on the role.
1173 procedure Role_Error
1174 (Item_Is_Input : Boolean;
1175 Item_Is_Output : Boolean);
1176 -- Emit an error message concerning the incorrect use of Item in
1177 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1178 -- denote whether the item is an input and/or an output.
1180 ---------------
1181 -- Find_Role --
1182 ---------------
1184 procedure Find_Role
1185 (Item_Is_Input : out Boolean;
1186 Item_Is_Output : out Boolean)
1188 begin
1189 Item_Is_Input := False;
1190 Item_Is_Output := False;
1192 -- Abstract states
1194 if Ekind (Item_Id) = E_Abstract_State then
1196 -- When pragma Global is present, the mode of the state may be
1197 -- further constrained by setting a more restrictive mode.
1199 if Global_Seen then
1200 if Appears_In (Subp_Inputs, Item_Id) then
1201 Item_Is_Input := True;
1202 end if;
1204 if Appears_In (Subp_Outputs, Item_Id) then
1205 Item_Is_Output := True;
1206 end if;
1208 -- Otherwise the state has a default IN OUT mode
1210 else
1211 Item_Is_Input := True;
1212 Item_Is_Output := True;
1213 end if;
1215 -- Constants
1217 elsif Ekind_In (Item_Id, E_Constant,
1218 E_Discriminant,
1219 E_Loop_Parameter)
1220 then
1221 Item_Is_Input := True;
1223 -- Parameters
1225 elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
1226 E_In_Parameter)
1227 then
1228 Item_Is_Input := True;
1230 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
1231 E_In_Out_Parameter)
1232 then
1233 Item_Is_Input := True;
1234 Item_Is_Output := True;
1236 elsif Ekind (Item_Id) = E_Out_Parameter then
1237 if Scope (Item_Id) = Spec_Id then
1239 -- An OUT parameter of the related subprogram has mode IN
1240 -- if its type is unconstrained or tagged because array
1241 -- bounds, discriminants or tags can be read.
1243 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1244 Item_Is_Input := True;
1245 end if;
1247 Item_Is_Output := True;
1249 -- An OUT parameter of an enclosing subprogram behaves as a
1250 -- read-write variable in which case the mode is IN OUT.
1252 else
1253 Item_Is_Input := True;
1254 Item_Is_Output := True;
1255 end if;
1257 -- Protected types
1259 elsif Ekind (Item_Id) = E_Protected_Type then
1261 -- A protected type acts as a formal parameter of mode IN when
1262 -- it applies to a protected function.
1264 if Ekind (Spec_Id) = E_Function then
1265 Item_Is_Input := True;
1267 -- Otherwise the protected type acts as a formal of mode IN OUT
1269 else
1270 Item_Is_Input := True;
1271 Item_Is_Output := True;
1272 end if;
1274 -- Task types
1276 elsif Ekind (Item_Id) = E_Task_Type then
1277 Item_Is_Input := True;
1278 Item_Is_Output := True;
1280 -- Variable case
1282 else pragma Assert (Ekind (Item_Id) = E_Variable);
1284 -- When pragma Global is present, the mode of the variable may
1285 -- be further constrained by setting a more restrictive mode.
1287 if Global_Seen then
1289 -- A variable has mode IN when its type is unconstrained or
1290 -- tagged because array bounds, discriminants or tags can be
1291 -- read.
1293 if Appears_In (Subp_Inputs, Item_Id)
1294 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1295 then
1296 Item_Is_Input := True;
1297 end if;
1299 if Appears_In (Subp_Outputs, Item_Id) then
1300 Item_Is_Output := True;
1301 end if;
1303 -- Otherwise the variable has a default IN OUT mode
1305 else
1306 Item_Is_Input := True;
1307 Item_Is_Output := True;
1308 end if;
1309 end if;
1310 end Find_Role;
1312 ----------------
1313 -- Role_Error --
1314 ----------------
1316 procedure Role_Error
1317 (Item_Is_Input : Boolean;
1318 Item_Is_Output : Boolean)
1320 Error_Msg : Name_Id;
1322 begin
1323 Name_Len := 0;
1325 -- When the item is not part of the input and the output set of
1326 -- the related subprogram, then it appears as extra in pragma
1327 -- [Refined_]Depends.
1329 if not Item_Is_Input and then not Item_Is_Output then
1330 Add_Item_To_Name_Buffer (Item_Id);
1331 Add_Str_To_Name_Buffer
1332 (" & cannot appear in dependence relation");
1334 Error_Msg := Name_Find;
1335 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1337 Error_Msg_Name_1 := Chars (Spec_Id);
1338 SPARK_Msg_NE
1339 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1340 & "set of subprogram %"), Item, Item_Id);
1342 -- The mode of the item and its role in pragma [Refined_]Depends
1343 -- are in conflict. Construct a detailed message explaining the
1344 -- illegality (SPARK RM 6.1.5(5-6)).
1346 else
1347 if Item_Is_Input then
1348 Add_Str_To_Name_Buffer ("read-only");
1349 else
1350 Add_Str_To_Name_Buffer ("write-only");
1351 end if;
1353 Add_Char_To_Name_Buffer (' ');
1354 Add_Item_To_Name_Buffer (Item_Id);
1355 Add_Str_To_Name_Buffer (" & cannot appear as ");
1357 if Item_Is_Input then
1358 Add_Str_To_Name_Buffer ("output");
1359 else
1360 Add_Str_To_Name_Buffer ("input");
1361 end if;
1363 Add_Str_To_Name_Buffer (" in dependence relation");
1364 Error_Msg := Name_Find;
1365 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1366 end if;
1367 end Role_Error;
1369 -- Local variables
1371 Item_Is_Input : Boolean;
1372 Item_Is_Output : Boolean;
1374 -- Start of processing for Check_Role
1376 begin
1377 Find_Role (Item_Is_Input, Item_Is_Output);
1379 -- Input item
1381 if Is_Input then
1382 if not Item_Is_Input then
1383 Role_Error (Item_Is_Input, Item_Is_Output);
1384 end if;
1386 -- Self-referential item
1388 elsif Self_Ref then
1389 if not Item_Is_Input or else not Item_Is_Output then
1390 Role_Error (Item_Is_Input, Item_Is_Output);
1391 end if;
1393 -- Output item
1395 elsif not Item_Is_Output then
1396 Role_Error (Item_Is_Input, Item_Is_Output);
1397 end if;
1398 end Check_Role;
1400 -----------------
1401 -- Check_Usage --
1402 -----------------
1404 procedure Check_Usage
1405 (Subp_Items : Elist_Id;
1406 Used_Items : Elist_Id;
1407 Is_Input : Boolean)
1409 procedure Usage_Error (Item_Id : Entity_Id);
1410 -- Emit an error concerning the illegal usage of an item
1412 -----------------
1413 -- Usage_Error --
1414 -----------------
1416 procedure Usage_Error (Item_Id : Entity_Id) is
1417 Error_Msg : Name_Id;
1419 begin
1420 -- Input case
1422 if Is_Input then
1424 -- Unconstrained and tagged items are not part of the explicit
1425 -- input set of the related subprogram, they do not have to be
1426 -- present in a dependence relation and should not be flagged
1427 -- (SPARK RM 6.1.5(8)).
1429 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1430 Name_Len := 0;
1432 Add_Item_To_Name_Buffer (Item_Id);
1433 Add_Str_To_Name_Buffer
1434 (" & is missing from input dependence list");
1436 Error_Msg := Name_Find;
1437 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1438 end if;
1440 -- Output case (SPARK RM 6.1.5(10))
1442 else
1443 Name_Len := 0;
1445 Add_Item_To_Name_Buffer (Item_Id);
1446 Add_Str_To_Name_Buffer
1447 (" & is missing from output dependence list");
1449 Error_Msg := Name_Find;
1450 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1451 end if;
1452 end Usage_Error;
1454 -- Local variables
1456 Elmt : Elmt_Id;
1457 Item : Node_Id;
1458 Item_Id : Entity_Id;
1460 -- Start of processing for Check_Usage
1462 begin
1463 if No (Subp_Items) then
1464 return;
1465 end if;
1467 -- Each input or output of the subprogram must appear in a dependency
1468 -- relation.
1470 Elmt := First_Elmt (Subp_Items);
1471 while Present (Elmt) loop
1472 Item := Node (Elmt);
1474 if Nkind (Item) = N_Defining_Identifier then
1475 Item_Id := Item;
1476 else
1477 Item_Id := Entity_Of (Item);
1478 end if;
1480 -- The item does not appear in a dependency
1482 if Present (Item_Id)
1483 and then not Contains (Used_Items, Item_Id)
1484 then
1485 if Is_Formal (Item_Id) then
1486 Usage_Error (Item_Id);
1488 -- The current instance of a protected type behaves as a formal
1489 -- parameter (SPARK RM 6.1.4).
1491 elsif Ekind (Item_Id) = E_Protected_Type
1492 or else Is_Single_Protected_Object (Item_Id)
1493 then
1494 Usage_Error (Item_Id);
1496 -- The current instance of a task type behaves as a formal
1497 -- parameter (SPARK RM 6.1.4).
1499 elsif Ekind (Item_Id) = E_Task_Type
1500 or else Is_Single_Task_Object (Item_Id)
1501 then
1502 -- The dependence of a task unit on itself is implicit and
1503 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1504 -- Emit an error if only one input/output is present.
1506 if Task_Input_Seen /= Task_Output_Seen then
1507 Usage_Error (Item_Id);
1508 end if;
1510 -- States and global objects are not used properly only when
1511 -- the subprogram is subject to pragma Global.
1513 elsif Global_Seen then
1514 Usage_Error (Item_Id);
1515 end if;
1516 end if;
1518 Next_Elmt (Elmt);
1519 end loop;
1520 end Check_Usage;
1522 ----------------------
1523 -- Normalize_Clause --
1524 ----------------------
1526 procedure Normalize_Clause (Clause : Node_Id) is
1527 procedure Create_Or_Modify_Clause
1528 (Output : Node_Id;
1529 Outputs : Node_Id;
1530 Inputs : Node_Id;
1531 After : Node_Id;
1532 In_Place : Boolean;
1533 Multiple : Boolean);
1534 -- Create a brand new clause to represent the self-reference or
1535 -- modify the input and/or output lists of an existing clause. Output
1536 -- denotes a self-referencial output. Outputs is the output list of a
1537 -- clause. Inputs is the input list of a clause. After denotes the
1538 -- clause after which the new clause is to be inserted. Flag In_Place
1539 -- should be set when normalizing the last output of an output list.
1540 -- Flag Multiple should be set when Output comes from a list with
1541 -- multiple items.
1543 -----------------------------
1544 -- Create_Or_Modify_Clause --
1545 -----------------------------
1547 procedure Create_Or_Modify_Clause
1548 (Output : Node_Id;
1549 Outputs : Node_Id;
1550 Inputs : Node_Id;
1551 After : Node_Id;
1552 In_Place : Boolean;
1553 Multiple : Boolean)
1555 procedure Propagate_Output
1556 (Output : Node_Id;
1557 Inputs : Node_Id);
1558 -- Handle the various cases of output propagation to the input
1559 -- list. Output denotes a self-referencial output item. Inputs
1560 -- is the input list of a clause.
1562 ----------------------
1563 -- Propagate_Output --
1564 ----------------------
1566 procedure Propagate_Output
1567 (Output : Node_Id;
1568 Inputs : Node_Id)
1570 function In_Input_List
1571 (Item : Entity_Id;
1572 Inputs : List_Id) return Boolean;
1573 -- Determine whether a particulat item appears in the input
1574 -- list of a clause.
1576 -------------------
1577 -- In_Input_List --
1578 -------------------
1580 function In_Input_List
1581 (Item : Entity_Id;
1582 Inputs : List_Id) return Boolean
1584 Elmt : Node_Id;
1586 begin
1587 Elmt := First (Inputs);
1588 while Present (Elmt) loop
1589 if Entity_Of (Elmt) = Item then
1590 return True;
1591 end if;
1593 Next (Elmt);
1594 end loop;
1596 return False;
1597 end In_Input_List;
1599 -- Local variables
1601 Output_Id : constant Entity_Id := Entity_Of (Output);
1602 Grouped : List_Id;
1604 -- Start of processing for Propagate_Output
1606 begin
1607 -- The clause is of the form:
1609 -- (Output =>+ null)
1611 -- Remove null input and replace it with a copy of the output:
1613 -- (Output => Output)
1615 if Nkind (Inputs) = N_Null then
1616 Rewrite (Inputs, New_Copy_Tree (Output));
1618 -- The clause is of the form:
1620 -- (Output =>+ (Input1, ..., InputN))
1622 -- Determine whether the output is not already mentioned in the
1623 -- input list and if not, add it to the list of inputs:
1625 -- (Output => (Output, Input1, ..., InputN))
1627 elsif Nkind (Inputs) = N_Aggregate then
1628 Grouped := Expressions (Inputs);
1630 if not In_Input_List
1631 (Item => Output_Id,
1632 Inputs => Grouped)
1633 then
1634 Prepend_To (Grouped, New_Copy_Tree (Output));
1635 end if;
1637 -- The clause is of the form:
1639 -- (Output =>+ Input)
1641 -- If the input does not mention the output, group the two
1642 -- together:
1644 -- (Output => (Output, Input))
1646 elsif Entity_Of (Inputs) /= Output_Id then
1647 Rewrite (Inputs,
1648 Make_Aggregate (Loc,
1649 Expressions => New_List (
1650 New_Copy_Tree (Output),
1651 New_Copy_Tree (Inputs))));
1652 end if;
1653 end Propagate_Output;
1655 -- Local variables
1657 Loc : constant Source_Ptr := Sloc (Clause);
1658 New_Clause : Node_Id;
1660 -- Start of processing for Create_Or_Modify_Clause
1662 begin
1663 -- A null output depending on itself does not require any
1664 -- normalization.
1666 if Nkind (Output) = N_Null then
1667 return;
1669 -- A function result cannot depend on itself because it cannot
1670 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1672 elsif Is_Attribute_Result (Output) then
1673 SPARK_Msg_N ("function result cannot depend on itself", Output);
1674 return;
1675 end if;
1677 -- When performing the transformation in place, simply add the
1678 -- output to the list of inputs (if not already there). This
1679 -- case arises when dealing with the last output of an output
1680 -- list. Perform the normalization in place to avoid generating
1681 -- a malformed tree.
1683 if In_Place then
1684 Propagate_Output (Output, Inputs);
1686 -- A list with multiple outputs is slowly trimmed until only
1687 -- one element remains. When this happens, replace aggregate
1688 -- with the element itself.
1690 if Multiple then
1691 Remove (Output);
1692 Rewrite (Outputs, Output);
1693 end if;
1695 -- Default case
1697 else
1698 -- Unchain the output from its output list as it will appear in
1699 -- a new clause. Note that we cannot simply rewrite the output
1700 -- as null because this will violate the semantics of pragma
1701 -- Depends.
1703 Remove (Output);
1705 -- Generate a new clause of the form:
1706 -- (Output => Inputs)
1708 New_Clause :=
1709 Make_Component_Association (Loc,
1710 Choices => New_List (Output),
1711 Expression => New_Copy_Tree (Inputs));
1713 -- The new clause contains replicated content that has already
1714 -- been analyzed. There is not need to reanalyze or renormalize
1715 -- it again.
1717 Set_Analyzed (New_Clause);
1719 Propagate_Output
1720 (Output => First (Choices (New_Clause)),
1721 Inputs => Expression (New_Clause));
1723 Insert_After (After, New_Clause);
1724 end if;
1725 end Create_Or_Modify_Clause;
1727 -- Local variables
1729 Outputs : constant Node_Id := First (Choices (Clause));
1730 Inputs : Node_Id;
1731 Last_Output : Node_Id;
1732 Next_Output : Node_Id;
1733 Output : Node_Id;
1735 -- Start of processing for Normalize_Clause
1737 begin
1738 -- A self-dependency appears as operator "+". Remove the "+" from the
1739 -- tree by moving the real inputs to their proper place.
1741 if Nkind (Expression (Clause)) = N_Op_Plus then
1742 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1743 Inputs := Expression (Clause);
1745 -- Multiple outputs appear as an aggregate
1747 if Nkind (Outputs) = N_Aggregate then
1748 Last_Output := Last (Expressions (Outputs));
1750 Output := First (Expressions (Outputs));
1751 while Present (Output) loop
1753 -- Normalization may remove an output from its list,
1754 -- preserve the subsequent output now.
1756 Next_Output := Next (Output);
1758 Create_Or_Modify_Clause
1759 (Output => Output,
1760 Outputs => Outputs,
1761 Inputs => Inputs,
1762 After => Clause,
1763 In_Place => Output = Last_Output,
1764 Multiple => True);
1766 Output := Next_Output;
1767 end loop;
1769 -- Solitary output
1771 else
1772 Create_Or_Modify_Clause
1773 (Output => Outputs,
1774 Outputs => Empty,
1775 Inputs => Inputs,
1776 After => Empty,
1777 In_Place => True,
1778 Multiple => False);
1779 end if;
1780 end if;
1781 end Normalize_Clause;
1783 -- Local variables
1785 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1786 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1788 Clause : Node_Id;
1789 Errors : Nat;
1790 Last_Clause : Node_Id;
1791 Restore_Scope : Boolean := False;
1793 -- Start of processing for Analyze_Depends_In_Decl_Part
1795 begin
1796 -- Do not analyze the pragma multiple times
1798 if Is_Analyzed_Pragma (N) then
1799 return;
1800 end if;
1802 -- Empty dependency list
1804 if Nkind (Deps) = N_Null then
1806 -- Gather all states, objects and formal parameters that the
1807 -- subprogram may depend on. These items are obtained from the
1808 -- parameter profile or pragma [Refined_]Global (if available).
1810 Collect_Subprogram_Inputs_Outputs
1811 (Subp_Id => Subp_Id,
1812 Subp_Inputs => Subp_Inputs,
1813 Subp_Outputs => Subp_Outputs,
1814 Global_Seen => Global_Seen);
1816 -- Verify that every input or output of the subprogram appear in a
1817 -- dependency.
1819 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1820 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1821 Check_Function_Return;
1823 -- Dependency clauses appear as component associations of an aggregate
1825 elsif Nkind (Deps) = N_Aggregate then
1827 -- Do not attempt to perform analysis of a syntactically illegal
1828 -- clause as this will lead to misleading errors.
1830 if Has_Extra_Parentheses (Deps) then
1831 return;
1832 end if;
1834 if Present (Component_Associations (Deps)) then
1835 Last_Clause := Last (Component_Associations (Deps));
1837 -- Gather all states, objects and formal parameters that the
1838 -- subprogram may depend on. These items are obtained from the
1839 -- parameter profile or pragma [Refined_]Global (if available).
1841 Collect_Subprogram_Inputs_Outputs
1842 (Subp_Id => Subp_Id,
1843 Subp_Inputs => Subp_Inputs,
1844 Subp_Outputs => Subp_Outputs,
1845 Global_Seen => Global_Seen);
1847 -- When pragma [Refined_]Depends appears on a single concurrent
1848 -- type, it is relocated to the anonymous object.
1850 if Is_Single_Concurrent_Object (Spec_Id) then
1851 null;
1853 -- Ensure that the formal parameters are visible when analyzing
1854 -- all clauses. This falls out of the general rule of aspects
1855 -- pertaining to subprogram declarations.
1857 elsif not In_Open_Scopes (Spec_Id) then
1858 Restore_Scope := True;
1859 Push_Scope (Spec_Id);
1861 if Ekind (Spec_Id) = E_Task_Type then
1862 if Has_Discriminants (Spec_Id) then
1863 Install_Discriminants (Spec_Id);
1864 end if;
1866 elsif Is_Generic_Subprogram (Spec_Id) then
1867 Install_Generic_Formals (Spec_Id);
1869 else
1870 Install_Formals (Spec_Id);
1871 end if;
1872 end if;
1874 Clause := First (Component_Associations (Deps));
1875 while Present (Clause) loop
1876 Errors := Serious_Errors_Detected;
1878 -- The normalization mechanism may create extra clauses that
1879 -- contain replicated input and output names. There is no need
1880 -- to reanalyze them.
1882 if not Analyzed (Clause) then
1883 Set_Analyzed (Clause);
1885 Analyze_Dependency_Clause
1886 (Clause => Clause,
1887 Is_Last => Clause = Last_Clause);
1888 end if;
1890 -- Do not normalize a clause if errors were detected (count
1891 -- of Serious_Errors has increased) because the inputs and/or
1892 -- outputs may denote illegal items. Normalization is disabled
1893 -- in ASIS mode as it alters the tree by introducing new nodes
1894 -- similar to expansion.
1896 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1897 Normalize_Clause (Clause);
1898 end if;
1900 Next (Clause);
1901 end loop;
1903 if Restore_Scope then
1904 End_Scope;
1905 end if;
1907 -- Verify that every input or output of the subprogram appear in a
1908 -- dependency.
1910 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1911 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1912 Check_Function_Return;
1914 -- The dependency list is malformed. This is a syntax error, always
1915 -- report.
1917 else
1918 Error_Msg_N ("malformed dependency relation", Deps);
1919 return;
1920 end if;
1922 -- The top level dependency relation is malformed. This is a syntax
1923 -- error, always report.
1925 else
1926 Error_Msg_N ("malformed dependency relation", Deps);
1927 goto Leave;
1928 end if;
1930 -- Ensure that a state and a corresponding constituent do not appear
1931 -- together in pragma [Refined_]Depends.
1933 Check_State_And_Constituent_Use
1934 (States => States_Seen,
1935 Constits => Constits_Seen,
1936 Context => N);
1938 <<Leave>>
1939 Set_Is_Analyzed_Pragma (N);
1940 end Analyze_Depends_In_Decl_Part;
1942 --------------------------------------------
1943 -- Analyze_External_Property_In_Decl_Part --
1944 --------------------------------------------
1946 procedure Analyze_External_Property_In_Decl_Part
1947 (N : Node_Id;
1948 Expr_Val : out Boolean)
1950 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1951 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1952 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1953 Expr : Node_Id;
1955 begin
1956 Expr_Val := False;
1958 -- Do not analyze the pragma multiple times
1960 if Is_Analyzed_Pragma (N) then
1961 return;
1962 end if;
1964 Error_Msg_Name_1 := Pragma_Name (N);
1966 -- An external property pragma must apply to an effectively volatile
1967 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1968 -- The check is performed at the end of the declarative region due to a
1969 -- possible out-of-order arrangement of pragmas:
1971 -- Obj : ...;
1972 -- pragma Async_Readers (Obj);
1973 -- pragma Volatile (Obj);
1975 if not Is_Effectively_Volatile (Obj_Id) then
1976 SPARK_Msg_N
1977 ("external property % must apply to a volatile object", N);
1978 end if;
1980 -- Ensure that the Boolean expression (if present) is static. A missing
1981 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1983 Expr_Val := True;
1985 if Present (Arg1) then
1986 Expr := Get_Pragma_Arg (Arg1);
1988 if Is_OK_Static_Expression (Expr) then
1989 Expr_Val := Is_True (Expr_Value (Expr));
1990 end if;
1991 end if;
1993 Set_Is_Analyzed_Pragma (N);
1994 end Analyze_External_Property_In_Decl_Part;
1996 ---------------------------------
1997 -- Analyze_Global_In_Decl_Part --
1998 ---------------------------------
2000 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2001 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2002 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2003 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2005 Constits_Seen : Elist_Id := No_Elist;
2006 -- A list containing the entities of all constituents processed so far.
2007 -- It aids in detecting illegal usage of a state and a corresponding
2008 -- constituent in pragma [Refinde_]Global.
2010 Seen : Elist_Id := No_Elist;
2011 -- A list containing the entities of all the items processed so far. It
2012 -- plays a role in detecting distinct entities.
2014 States_Seen : Elist_Id := No_Elist;
2015 -- A list containing the entities of all states processed so far. It
2016 -- helps in detecting illegal usage of a state and a corresponding
2017 -- constituent in pragma [Refined_]Global.
2019 In_Out_Seen : Boolean := False;
2020 Input_Seen : Boolean := False;
2021 Output_Seen : Boolean := False;
2022 Proof_Seen : Boolean := False;
2023 -- Flags used to verify the consistency of modes
2025 procedure Analyze_Global_List
2026 (List : Node_Id;
2027 Global_Mode : Name_Id := Name_Input);
2028 -- Verify the legality of a single global list declaration. Global_Mode
2029 -- denotes the current mode in effect.
2031 -------------------------
2032 -- Analyze_Global_List --
2033 -------------------------
2035 procedure Analyze_Global_List
2036 (List : Node_Id;
2037 Global_Mode : Name_Id := Name_Input)
2039 procedure Analyze_Global_Item
2040 (Item : Node_Id;
2041 Global_Mode : Name_Id);
2042 -- Verify the legality of a single global item declaration denoted by
2043 -- Item. Global_Mode denotes the current mode in effect.
2045 procedure Check_Duplicate_Mode
2046 (Mode : Node_Id;
2047 Status : in out Boolean);
2048 -- Flag Status denotes whether a particular mode has been seen while
2049 -- processing a global list. This routine verifies that Mode is not a
2050 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2052 procedure Check_Mode_Restriction_In_Enclosing_Context
2053 (Item : Node_Id;
2054 Item_Id : Entity_Id);
2055 -- Verify that an item of mode In_Out or Output does not appear as an
2056 -- input in the Global aspect of an enclosing subprogram. If this is
2057 -- the case, emit an error. Item and Item_Id are respectively the
2058 -- item and its entity.
2060 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2061 -- Mode denotes either In_Out or Output. Depending on the kind of the
2062 -- related subprogram, emit an error if those two modes apply to a
2063 -- function (SPARK RM 6.1.4(10)).
2065 -------------------------
2066 -- Analyze_Global_Item --
2067 -------------------------
2069 procedure Analyze_Global_Item
2070 (Item : Node_Id;
2071 Global_Mode : Name_Id)
2073 Item_Id : Entity_Id;
2075 begin
2076 -- Detect one of the following cases
2078 -- with Global => (null, Name)
2079 -- with Global => (Name_1, null, Name_2)
2080 -- with Global => (Name, null)
2082 if Nkind (Item) = N_Null then
2083 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2084 return;
2085 end if;
2087 Analyze (Item);
2088 Resolve_State (Item);
2090 -- Find the entity of the item. If this is a renaming, climb the
2091 -- renaming chain to reach the root object. Renamings of non-
2092 -- entire objects do not yield an entity (Empty).
2094 Item_Id := Entity_Of (Item);
2096 if Present (Item_Id) then
2098 -- A global item may denote a formal parameter of an enclosing
2099 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2100 -- provide a better error diagnostic.
2102 if Is_Formal (Item_Id) then
2103 if Scope (Item_Id) = Spec_Id then
2104 SPARK_Msg_NE
2105 (Fix_Msg (Spec_Id, "global item cannot reference "
2106 & "parameter of subprogram &"), Item, Spec_Id);
2107 return;
2108 end if;
2110 -- A global item may denote a concurrent type as long as it is
2111 -- the current instance of an enclosing protected or task type
2112 -- (SPARK RM 6.1.4).
2114 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2115 if Is_CCT_Instance (Item_Id, Spec_Id) then
2117 -- Pragma [Refined_]Global associated with a protected
2118 -- subprogram cannot mention the current instance of a
2119 -- protected type because the instance behaves as a
2120 -- formal parameter.
2122 if Ekind (Item_Id) = E_Protected_Type then
2123 Error_Msg_Name_1 := Chars (Item_Id);
2124 SPARK_Msg_NE
2125 (Fix_Msg (Spec_Id, "global item of subprogram & "
2126 & "cannot reference current instance of protected "
2127 & "type %"), Item, Spec_Id);
2128 return;
2130 -- Pragma [Refined_]Global associated with a task type
2131 -- cannot mention the current instance of a task type
2132 -- because the instance behaves as a formal parameter.
2134 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2135 Error_Msg_Name_1 := Chars (Item_Id);
2136 SPARK_Msg_NE
2137 (Fix_Msg (Spec_Id, "global item of subprogram & "
2138 & "cannot reference current instance of task type "
2139 & "%"), Item, Spec_Id);
2140 return;
2141 end if;
2143 -- Otherwise the global item denotes a subtype mark that is
2144 -- not a current instance.
2146 else
2147 SPARK_Msg_N
2148 ("invalid use of subtype mark in global list", Item);
2149 return;
2150 end if;
2152 -- A global item may denote the anonymous object created for a
2153 -- single protected/task type as long as the current instance
2154 -- is the same single type (SPARK RM 6.1.4).
2156 elsif Is_Single_Concurrent_Object (Item_Id)
2157 and then Is_CCT_Instance (Item_Id, Spec_Id)
2158 then
2159 -- Pragma [Refined_]Global associated with a protected
2160 -- subprogram cannot mention the current instance of a
2161 -- protected type because the instance behaves as a formal
2162 -- parameter.
2164 if Is_Single_Protected_Object (Item_Id) then
2165 Error_Msg_Name_1 := Chars (Item_Id);
2166 SPARK_Msg_NE
2167 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2168 & "reference current instance of protected type %"),
2169 Item, Spec_Id);
2170 return;
2172 -- Pragma [Refined_]Global associated with a task type
2173 -- cannot mention the current instance of a task type
2174 -- because the instance behaves as a formal parameter.
2176 else pragma Assert (Is_Single_Task_Object (Item_Id));
2177 Error_Msg_Name_1 := Chars (Item_Id);
2178 SPARK_Msg_NE
2179 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2180 & "reference current instance of task type %"),
2181 Item, Spec_Id);
2182 return;
2183 end if;
2185 -- A formal object may act as a global item inside a generic
2187 elsif Is_Formal_Object (Item_Id) then
2188 null;
2190 -- The only legal references are those to abstract states,
2191 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2193 elsif not Ekind_In (Item_Id, E_Abstract_State,
2194 E_Constant,
2195 E_Discriminant,
2196 E_Loop_Parameter,
2197 E_Variable)
2198 then
2199 SPARK_Msg_N
2200 ("global item must denote object, state or current "
2201 & "instance of concurrent type", Item);
2202 return;
2203 end if;
2205 -- State related checks
2207 if Ekind (Item_Id) = E_Abstract_State then
2209 -- Package and subprogram bodies are instantiated
2210 -- individually in a separate compiler pass. Due to this
2211 -- mode of instantiation, the refinement of a state may
2212 -- no longer be visible when a subprogram body contract
2213 -- is instantiated. Since the generic template is legal,
2214 -- do not perform this check in the instance to circumvent
2215 -- this oddity.
2217 if Is_Generic_Instance (Spec_Id) then
2218 null;
2220 -- An abstract state with visible refinement cannot appear
2221 -- in pragma [Refined_]Global as its place must be taken by
2222 -- some of its constituents (SPARK RM 6.1.4(7)).
2224 elsif Has_Visible_Refinement (Item_Id) then
2225 SPARK_Msg_NE
2226 ("cannot mention state & in global refinement",
2227 Item, Item_Id);
2228 SPARK_Msg_N ("\use its constituents instead", Item);
2229 return;
2231 -- An external state cannot appear as a global item of a
2232 -- nonvolatile function (SPARK RM 7.1.3(8)).
2234 elsif Is_External_State (Item_Id)
2235 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2236 and then not Is_Volatile_Function (Spec_Id)
2237 then
2238 SPARK_Msg_NE
2239 ("external state & cannot act as global item of "
2240 & "nonvolatile function", Item, Item_Id);
2241 return;
2243 -- If the reference to the abstract state appears in an
2244 -- enclosing package body that will eventually refine the
2245 -- state, record the reference for future checks.
2247 else
2248 Record_Possible_Body_Reference
2249 (State_Id => Item_Id,
2250 Ref => Item);
2251 end if;
2253 -- Constant related checks
2255 elsif Ekind (Item_Id) = E_Constant then
2257 -- A constant is a read-only item, therefore it cannot act
2258 -- as an output.
2260 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2261 SPARK_Msg_NE
2262 ("constant & cannot act as output", Item, Item_Id);
2263 return;
2264 end if;
2266 -- Discriminant related checks
2268 elsif Ekind (Item_Id) = E_Discriminant then
2270 -- A discriminant is a read-only item, therefore it cannot
2271 -- act as an output.
2273 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2274 SPARK_Msg_NE
2275 ("discriminant & cannot act as output", Item, Item_Id);
2276 return;
2277 end if;
2279 -- Loop parameter related checks
2281 elsif Ekind (Item_Id) = E_Loop_Parameter then
2283 -- A loop parameter is a read-only item, therefore it cannot
2284 -- act as an output.
2286 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2287 SPARK_Msg_NE
2288 ("loop parameter & cannot act as output",
2289 Item, Item_Id);
2290 return;
2291 end if;
2293 -- Variable related checks. These are only relevant when
2294 -- SPARK_Mode is on as they are not standard Ada legality
2295 -- rules.
2297 elsif SPARK_Mode = On
2298 and then Ekind (Item_Id) = E_Variable
2299 and then Is_Effectively_Volatile (Item_Id)
2300 then
2301 -- An effectively volatile object cannot appear as a global
2302 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2304 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2305 and then not Is_Volatile_Function (Spec_Id)
2306 then
2307 Error_Msg_NE
2308 ("volatile object & cannot act as global item of a "
2309 & "function", Item, Item_Id);
2310 return;
2312 -- An effectively volatile object with external property
2313 -- Effective_Reads set to True must have mode Output or
2314 -- In_Out (SPARK RM 7.1.3(10)).
2316 elsif Effective_Reads_Enabled (Item_Id)
2317 and then Global_Mode = Name_Input
2318 then
2319 Error_Msg_NE
2320 ("volatile object & with property Effective_Reads must "
2321 & "have mode In_Out or Output", Item, Item_Id);
2322 return;
2323 end if;
2324 end if;
2326 -- When the item renames an entire object, replace the item
2327 -- with a reference to the object.
2329 if Entity (Item) /= Item_Id then
2330 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2331 Analyze (Item);
2332 end if;
2334 -- Some form of illegal construct masquerading as a name
2335 -- (SPARK RM 6.1.4(4)).
2337 else
2338 Error_Msg_N
2339 ("global item must denote object, state or current instance "
2340 & "of concurrent type", Item);
2341 return;
2342 end if;
2344 -- Verify that an output does not appear as an input in an
2345 -- enclosing subprogram.
2347 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2348 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2349 end if;
2351 -- The same entity might be referenced through various way.
2352 -- Check the entity of the item rather than the item itself
2353 -- (SPARK RM 6.1.4(10)).
2355 if Contains (Seen, Item_Id) then
2356 SPARK_Msg_N ("duplicate global item", Item);
2358 -- Add the entity of the current item to the list of processed
2359 -- items.
2361 else
2362 Append_New_Elmt (Item_Id, Seen);
2364 if Ekind (Item_Id) = E_Abstract_State then
2365 Append_New_Elmt (Item_Id, States_Seen);
2367 -- The variable may eventually become a constituent of a single
2368 -- protected/task type. Record the reference now and verify its
2369 -- legality when analyzing the contract of the variable
2370 -- (SPARK RM 9.3).
2372 elsif Ekind (Item_Id) = E_Variable then
2373 Record_Possible_Part_Of_Reference
2374 (Var_Id => Item_Id,
2375 Ref => Item);
2376 end if;
2378 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2379 and then Present (Encapsulating_State (Item_Id))
2380 then
2381 Append_New_Elmt (Item_Id, Constits_Seen);
2382 end if;
2383 end if;
2384 end Analyze_Global_Item;
2386 --------------------------
2387 -- Check_Duplicate_Mode --
2388 --------------------------
2390 procedure Check_Duplicate_Mode
2391 (Mode : Node_Id;
2392 Status : in out Boolean)
2394 begin
2395 if Status then
2396 SPARK_Msg_N ("duplicate global mode", Mode);
2397 end if;
2399 Status := True;
2400 end Check_Duplicate_Mode;
2402 -------------------------------------------------
2403 -- Check_Mode_Restriction_In_Enclosing_Context --
2404 -------------------------------------------------
2406 procedure Check_Mode_Restriction_In_Enclosing_Context
2407 (Item : Node_Id;
2408 Item_Id : Entity_Id)
2410 Context : Entity_Id;
2411 Dummy : Boolean;
2412 Inputs : Elist_Id := No_Elist;
2413 Outputs : Elist_Id := No_Elist;
2415 begin
2416 -- Traverse the scope stack looking for enclosing subprograms
2417 -- subject to pragma [Refined_]Global.
2419 Context := Scope (Subp_Id);
2420 while Present (Context) and then Context /= Standard_Standard loop
2421 if Is_Subprogram (Context)
2422 and then
2423 (Present (Get_Pragma (Context, Pragma_Global))
2424 or else
2425 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2426 then
2427 Collect_Subprogram_Inputs_Outputs
2428 (Subp_Id => Context,
2429 Subp_Inputs => Inputs,
2430 Subp_Outputs => Outputs,
2431 Global_Seen => Dummy);
2433 -- The item is classified as In_Out or Output but appears as
2434 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2436 if Appears_In (Inputs, Item_Id)
2437 and then not Appears_In (Outputs, Item_Id)
2438 then
2439 SPARK_Msg_NE
2440 ("global item & cannot have mode In_Out or Output",
2441 Item, Item_Id);
2443 SPARK_Msg_NE
2444 (Fix_Msg (Subp_Id, "\item already appears as input of "
2445 & "subprogram &"), Item, Context);
2447 -- Stop the traversal once an error has been detected
2449 exit;
2450 end if;
2451 end if;
2453 Context := Scope (Context);
2454 end loop;
2455 end Check_Mode_Restriction_In_Enclosing_Context;
2457 ----------------------------------------
2458 -- Check_Mode_Restriction_In_Function --
2459 ----------------------------------------
2461 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2462 begin
2463 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2464 SPARK_Msg_N
2465 ("global mode & is not applicable to functions", Mode);
2466 end if;
2467 end Check_Mode_Restriction_In_Function;
2469 -- Local variables
2471 Assoc : Node_Id;
2472 Item : Node_Id;
2473 Mode : Node_Id;
2475 -- Start of processing for Analyze_Global_List
2477 begin
2478 if Nkind (List) = N_Null then
2479 Set_Analyzed (List);
2481 -- Single global item declaration
2483 elsif Nkind_In (List, N_Expanded_Name,
2484 N_Identifier,
2485 N_Selected_Component)
2486 then
2487 Analyze_Global_Item (List, Global_Mode);
2489 -- Simple global list or moded global list declaration
2491 elsif Nkind (List) = N_Aggregate then
2492 Set_Analyzed (List);
2494 -- The declaration of a simple global list appear as a collection
2495 -- of expressions.
2497 if Present (Expressions (List)) then
2498 if Present (Component_Associations (List)) then
2499 SPARK_Msg_N
2500 ("cannot mix moded and non-moded global lists", List);
2501 end if;
2503 Item := First (Expressions (List));
2504 while Present (Item) loop
2505 Analyze_Global_Item (Item, Global_Mode);
2506 Next (Item);
2507 end loop;
2509 -- The declaration of a moded global list appears as a collection
2510 -- of component associations where individual choices denote
2511 -- modes.
2513 elsif Present (Component_Associations (List)) then
2514 if Present (Expressions (List)) then
2515 SPARK_Msg_N
2516 ("cannot mix moded and non-moded global lists", List);
2517 end if;
2519 Assoc := First (Component_Associations (List));
2520 while Present (Assoc) loop
2521 Mode := First (Choices (Assoc));
2523 if Nkind (Mode) = N_Identifier then
2524 if Chars (Mode) = Name_In_Out then
2525 Check_Duplicate_Mode (Mode, In_Out_Seen);
2526 Check_Mode_Restriction_In_Function (Mode);
2528 elsif Chars (Mode) = Name_Input then
2529 Check_Duplicate_Mode (Mode, Input_Seen);
2531 elsif Chars (Mode) = Name_Output then
2532 Check_Duplicate_Mode (Mode, Output_Seen);
2533 Check_Mode_Restriction_In_Function (Mode);
2535 elsif Chars (Mode) = Name_Proof_In then
2536 Check_Duplicate_Mode (Mode, Proof_Seen);
2538 else
2539 SPARK_Msg_N ("invalid mode selector", Mode);
2540 end if;
2542 else
2543 SPARK_Msg_N ("invalid mode selector", Mode);
2544 end if;
2546 -- Items in a moded list appear as a collection of
2547 -- expressions. Reuse the existing machinery to analyze
2548 -- them.
2550 Analyze_Global_List
2551 (List => Expression (Assoc),
2552 Global_Mode => Chars (Mode));
2554 Next (Assoc);
2555 end loop;
2557 -- Invalid tree
2559 else
2560 raise Program_Error;
2561 end if;
2563 -- Any other attempt to declare a global item is illegal. This is a
2564 -- syntax error, always report.
2566 else
2567 Error_Msg_N ("malformed global list", List);
2568 end if;
2569 end Analyze_Global_List;
2571 -- Local variables
2573 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2575 Restore_Scope : Boolean := False;
2577 -- Start of processing for Analyze_Global_In_Decl_Part
2579 begin
2580 -- Do not analyze the pragma multiple times
2582 if Is_Analyzed_Pragma (N) then
2583 return;
2584 end if;
2586 -- There is nothing to be done for a null global list
2588 if Nkind (Items) = N_Null then
2589 Set_Analyzed (Items);
2591 -- Analyze the various forms of global lists and items. Note that some
2592 -- of these may be malformed in which case the analysis emits error
2593 -- messages.
2595 else
2596 -- When pragma [Refined_]Global appears on a single concurrent type,
2597 -- it is relocated to the anonymous object.
2599 if Is_Single_Concurrent_Object (Spec_Id) then
2600 null;
2602 -- Ensure that the formal parameters are visible when processing an
2603 -- item. This falls out of the general rule of aspects pertaining to
2604 -- subprogram declarations.
2606 elsif not In_Open_Scopes (Spec_Id) then
2607 Restore_Scope := True;
2608 Push_Scope (Spec_Id);
2610 if Ekind (Spec_Id) = E_Task_Type then
2611 if Has_Discriminants (Spec_Id) then
2612 Install_Discriminants (Spec_Id);
2613 end if;
2615 elsif Is_Generic_Subprogram (Spec_Id) then
2616 Install_Generic_Formals (Spec_Id);
2618 else
2619 Install_Formals (Spec_Id);
2620 end if;
2621 end if;
2623 Analyze_Global_List (Items);
2625 if Restore_Scope then
2626 End_Scope;
2627 end if;
2628 end if;
2630 -- Ensure that a state and a corresponding constituent do not appear
2631 -- together in pragma [Refined_]Global.
2633 Check_State_And_Constituent_Use
2634 (States => States_Seen,
2635 Constits => Constits_Seen,
2636 Context => N);
2638 Set_Is_Analyzed_Pragma (N);
2639 end Analyze_Global_In_Decl_Part;
2641 --------------------------------------------
2642 -- Analyze_Initial_Condition_In_Decl_Part --
2643 --------------------------------------------
2645 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2646 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2647 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2648 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2650 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
2652 begin
2653 -- Do not analyze the pragma multiple times
2655 if Is_Analyzed_Pragma (N) then
2656 return;
2657 end if;
2659 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2660 -- analysis of the pragma, the Ghost mode at point of declaration and
2661 -- point of analysis may not necessarily be the same. Use the mode in
2662 -- effect at the point of declaration.
2664 Set_Ghost_Mode (N);
2666 -- The expression is preanalyzed because it has not been moved to its
2667 -- final place yet. A direct analysis may generate side effects and this
2668 -- is not desired at this point.
2670 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2671 Ghost_Mode := Save_Ghost_Mode;
2673 Set_Is_Analyzed_Pragma (N);
2674 end Analyze_Initial_Condition_In_Decl_Part;
2676 --------------------------------------
2677 -- Analyze_Initializes_In_Decl_Part --
2678 --------------------------------------
2680 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2681 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2682 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2684 Constits_Seen : Elist_Id := No_Elist;
2685 -- A list containing the entities of all constituents processed so far.
2686 -- It aids in detecting illegal usage of a state and a corresponding
2687 -- constituent in pragma Initializes.
2689 Items_Seen : Elist_Id := No_Elist;
2690 -- A list of all initialization items processed so far. This list is
2691 -- used to detect duplicate items.
2693 Non_Null_Seen : Boolean := False;
2694 Null_Seen : Boolean := False;
2695 -- Flags used to check the legality of a null initialization list
2697 States_And_Objs : Elist_Id := No_Elist;
2698 -- A list of all abstract states and objects declared in the visible
2699 -- declarations of the related package. This list is used to detect the
2700 -- legality of initialization items.
2702 States_Seen : Elist_Id := No_Elist;
2703 -- A list containing the entities of all states processed so far. It
2704 -- helps in detecting illegal usage of a state and a corresponding
2705 -- constituent in pragma Initializes.
2707 procedure Analyze_Initialization_Item (Item : Node_Id);
2708 -- Verify the legality of a single initialization item
2710 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2711 -- Verify the legality of a single initialization item followed by a
2712 -- list of input items.
2714 procedure Collect_States_And_Objects;
2715 -- Inspect the visible declarations of the related package and gather
2716 -- the entities of all abstract states and objects in States_And_Objs.
2718 ---------------------------------
2719 -- Analyze_Initialization_Item --
2720 ---------------------------------
2722 procedure Analyze_Initialization_Item (Item : Node_Id) is
2723 Item_Id : Entity_Id;
2725 begin
2726 -- Null initialization list
2728 if Nkind (Item) = N_Null then
2729 if Null_Seen then
2730 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2732 elsif Non_Null_Seen then
2733 SPARK_Msg_N
2734 ("cannot mix null and non-null initialization items", Item);
2735 else
2736 Null_Seen := True;
2737 end if;
2739 -- Initialization item
2741 else
2742 Non_Null_Seen := True;
2744 if Null_Seen then
2745 SPARK_Msg_N
2746 ("cannot mix null and non-null initialization items", Item);
2747 end if;
2749 Analyze (Item);
2750 Resolve_State (Item);
2752 if Is_Entity_Name (Item) then
2753 Item_Id := Entity_Of (Item);
2755 if Ekind_In (Item_Id, E_Abstract_State,
2756 E_Constant,
2757 E_Variable)
2758 then
2759 -- The state or variable must be declared in the visible
2760 -- declarations of the package (SPARK RM 7.1.5(7)).
2762 if not Contains (States_And_Objs, Item_Id) then
2763 Error_Msg_Name_1 := Chars (Pack_Id);
2764 SPARK_Msg_NE
2765 ("initialization item & must appear in the visible "
2766 & "declarations of package %", Item, Item_Id);
2768 -- Detect a duplicate use of the same initialization item
2769 -- (SPARK RM 7.1.5(5)).
2771 elsif Contains (Items_Seen, Item_Id) then
2772 SPARK_Msg_N ("duplicate initialization item", Item);
2774 -- The item is legal, add it to the list of processed states
2775 -- and variables.
2777 else
2778 Append_New_Elmt (Item_Id, Items_Seen);
2780 if Ekind (Item_Id) = E_Abstract_State then
2781 Append_New_Elmt (Item_Id, States_Seen);
2782 end if;
2784 if Present (Encapsulating_State (Item_Id)) then
2785 Append_New_Elmt (Item_Id, Constits_Seen);
2786 end if;
2787 end if;
2789 -- The item references something that is not a state or object
2790 -- (SPARK RM 7.1.5(3)).
2792 else
2793 SPARK_Msg_N
2794 ("initialization item must denote object or state", Item);
2795 end if;
2797 -- Some form of illegal construct masquerading as a name
2798 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2800 else
2801 Error_Msg_N
2802 ("initialization item must denote object or state", Item);
2803 end if;
2804 end if;
2805 end Analyze_Initialization_Item;
2807 ---------------------------------------------
2808 -- Analyze_Initialization_Item_With_Inputs --
2809 ---------------------------------------------
2811 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2812 Inputs_Seen : Elist_Id := No_Elist;
2813 -- A list of all inputs processed so far. This list is used to detect
2814 -- duplicate uses of an input.
2816 Non_Null_Seen : Boolean := False;
2817 Null_Seen : Boolean := False;
2818 -- Flags used to check the legality of an input list
2820 procedure Analyze_Input_Item (Input : Node_Id);
2821 -- Verify the legality of a single input item
2823 ------------------------
2824 -- Analyze_Input_Item --
2825 ------------------------
2827 procedure Analyze_Input_Item (Input : Node_Id) is
2828 Input_Id : Entity_Id;
2829 Input_OK : Boolean := True;
2831 begin
2832 -- Null input list
2834 if Nkind (Input) = N_Null then
2835 if Null_Seen then
2836 SPARK_Msg_N
2837 ("multiple null initializations not allowed", Item);
2839 elsif Non_Null_Seen then
2840 SPARK_Msg_N
2841 ("cannot mix null and non-null initialization item", Item);
2842 else
2843 Null_Seen := True;
2844 end if;
2846 -- Input item
2848 else
2849 Non_Null_Seen := True;
2851 if Null_Seen then
2852 SPARK_Msg_N
2853 ("cannot mix null and non-null initialization item", Item);
2854 end if;
2856 Analyze (Input);
2857 Resolve_State (Input);
2859 if Is_Entity_Name (Input) then
2860 Input_Id := Entity_Of (Input);
2862 if Ekind_In (Input_Id, E_Abstract_State,
2863 E_Constant,
2864 E_Generic_In_Out_Parameter,
2865 E_Generic_In_Parameter,
2866 E_In_Parameter,
2867 E_In_Out_Parameter,
2868 E_Out_Parameter,
2869 E_Variable)
2870 then
2871 -- The input cannot denote states or objects declared
2872 -- within the related package (SPARK RM 7.1.5(4)).
2874 if Within_Scope (Input_Id, Current_Scope) then
2876 -- Do not consider generic formal parameters or their
2877 -- respective mappings to generic formals. Even though
2878 -- the formals appear within the scope of the package,
2879 -- it is allowed for an initialization item to depend
2880 -- on an input item.
2882 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2883 E_Generic_In_Parameter)
2884 then
2885 null;
2887 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2888 and then Present (Corresponding_Generic_Association
2889 (Declaration_Node (Input_Id)))
2890 then
2891 null;
2893 else
2894 Input_OK := False;
2895 Error_Msg_Name_1 := Chars (Pack_Id);
2896 SPARK_Msg_NE
2897 ("input item & cannot denote a visible object or "
2898 & "state of package %", Input, Input_Id);
2899 end if;
2900 end if;
2902 -- Detect a duplicate use of the same input item
2903 -- (SPARK RM 7.1.5(5)).
2905 if Contains (Inputs_Seen, Input_Id) then
2906 Input_OK := False;
2907 SPARK_Msg_N ("duplicate input item", Input);
2908 end if;
2910 -- Input is legal, add it to the list of processed inputs
2912 if Input_OK then
2913 Append_New_Elmt (Input_Id, Inputs_Seen);
2915 if Ekind (Input_Id) = E_Abstract_State then
2916 Append_New_Elmt (Input_Id, States_Seen);
2917 end if;
2919 if Ekind_In (Input_Id, E_Abstract_State,
2920 E_Constant,
2921 E_Variable)
2922 and then Present (Encapsulating_State (Input_Id))
2923 then
2924 Append_New_Elmt (Input_Id, Constits_Seen);
2925 end if;
2926 end if;
2928 -- The input references something that is not a state or an
2929 -- object (SPARK RM 7.1.5(3)).
2931 else
2932 SPARK_Msg_N
2933 ("input item must denote object or state", Input);
2934 end if;
2936 -- Some form of illegal construct masquerading as a name
2937 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2939 else
2940 Error_Msg_N
2941 ("input item must denote object or state", Input);
2942 end if;
2943 end if;
2944 end Analyze_Input_Item;
2946 -- Local variables
2948 Inputs : constant Node_Id := Expression (Item);
2949 Elmt : Node_Id;
2950 Input : Node_Id;
2952 Name_Seen : Boolean := False;
2953 -- A flag used to detect multiple item names
2955 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2957 begin
2958 -- Inspect the name of an item with inputs
2960 Elmt := First (Choices (Item));
2961 while Present (Elmt) loop
2962 if Name_Seen then
2963 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2964 else
2965 Name_Seen := True;
2966 Analyze_Initialization_Item (Elmt);
2967 end if;
2969 Next (Elmt);
2970 end loop;
2972 -- Multiple input items appear as an aggregate
2974 if Nkind (Inputs) = N_Aggregate then
2975 if Present (Expressions (Inputs)) then
2976 Input := First (Expressions (Inputs));
2977 while Present (Input) loop
2978 Analyze_Input_Item (Input);
2979 Next (Input);
2980 end loop;
2981 end if;
2983 if Present (Component_Associations (Inputs)) then
2984 SPARK_Msg_N
2985 ("inputs must appear in named association form", Inputs);
2986 end if;
2988 -- Single input item
2990 else
2991 Analyze_Input_Item (Inputs);
2992 end if;
2993 end Analyze_Initialization_Item_With_Inputs;
2995 --------------------------------
2996 -- Collect_States_And_Objects --
2997 --------------------------------
2999 procedure Collect_States_And_Objects is
3000 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3001 Decl : Node_Id;
3003 begin
3004 -- Collect the abstract states defined in the package (if any)
3006 if Present (Abstract_States (Pack_Id)) then
3007 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3008 end if;
3010 -- Collect all objects the appear in the visible declarations of the
3011 -- related package.
3013 if Present (Visible_Declarations (Pack_Spec)) then
3014 Decl := First (Visible_Declarations (Pack_Spec));
3015 while Present (Decl) loop
3016 if Comes_From_Source (Decl)
3017 and then Nkind (Decl) = N_Object_Declaration
3018 then
3019 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3020 end if;
3022 Next (Decl);
3023 end loop;
3024 end if;
3025 end Collect_States_And_Objects;
3027 -- Local variables
3029 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3030 Init : Node_Id;
3032 -- Start of processing for Analyze_Initializes_In_Decl_Part
3034 begin
3035 -- Do not analyze the pragma multiple times
3037 if Is_Analyzed_Pragma (N) then
3038 return;
3039 end if;
3041 -- Nothing to do when the initialization list is empty
3043 if Nkind (Inits) = N_Null then
3044 return;
3045 end if;
3047 -- Single and multiple initialization clauses appear as an aggregate. If
3048 -- this is not the case, then either the parser or the analysis of the
3049 -- pragma failed to produce an aggregate.
3051 pragma Assert (Nkind (Inits) = N_Aggregate);
3053 -- Initialize the various lists used during analysis
3055 Collect_States_And_Objects;
3057 if Present (Expressions (Inits)) then
3058 Init := First (Expressions (Inits));
3059 while Present (Init) loop
3060 Analyze_Initialization_Item (Init);
3061 Next (Init);
3062 end loop;
3063 end if;
3065 if Present (Component_Associations (Inits)) then
3066 Init := First (Component_Associations (Inits));
3067 while Present (Init) loop
3068 Analyze_Initialization_Item_With_Inputs (Init);
3069 Next (Init);
3070 end loop;
3071 end if;
3073 -- Ensure that a state and a corresponding constituent do not appear
3074 -- together in pragma Initializes.
3076 Check_State_And_Constituent_Use
3077 (States => States_Seen,
3078 Constits => Constits_Seen,
3079 Context => N);
3081 Set_Is_Analyzed_Pragma (N);
3082 end Analyze_Initializes_In_Decl_Part;
3084 ---------------------
3085 -- Analyze_Part_Of --
3086 ---------------------
3088 procedure Analyze_Part_Of
3089 (Indic : Node_Id;
3090 Item_Id : Entity_Id;
3091 Encap : Node_Id;
3092 Encap_Id : out Entity_Id;
3093 Legal : out Boolean)
3095 Encap_Typ : Entity_Id;
3096 Item_Decl : Node_Id;
3097 Pack_Id : Entity_Id;
3098 Placement : State_Space_Kind;
3099 Parent_Unit : Entity_Id;
3101 begin
3102 -- Assume that the indicator is illegal
3104 Encap_Id := Empty;
3105 Legal := False;
3107 if Nkind_In (Encap, N_Expanded_Name,
3108 N_Identifier,
3109 N_Selected_Component)
3110 then
3111 Analyze (Encap);
3112 Resolve_State (Encap);
3114 Encap_Id := Entity (Encap);
3116 -- The encapsulator is an abstract state
3118 if Ekind (Encap_Id) = E_Abstract_State then
3119 null;
3121 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3123 elsif Is_Single_Concurrent_Object (Encap_Id) then
3124 null;
3126 -- Otherwise the encapsulator is not a legal choice
3128 else
3129 SPARK_Msg_N
3130 ("indicator Part_Of must denote abstract state, single "
3131 & "protected type or single task type", Encap);
3132 return;
3133 end if;
3135 -- This is a syntax error, always report
3137 else
3138 Error_Msg_N
3139 ("indicator Part_Of must denote abstract state, single protected "
3140 & "type or single task type", Encap);
3141 return;
3142 end if;
3144 -- Catch a case where indicator Part_Of denotes the abstract view of a
3145 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3147 if From_Limited_With (Encap_Id)
3148 and then Present (Non_Limited_View (Encap_Id))
3149 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3150 then
3151 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3152 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3153 return;
3154 end if;
3156 -- The encapsulator is an abstract state
3158 if Ekind (Encap_Id) = E_Abstract_State then
3160 -- Determine where the object, package instantiation or state lives
3161 -- with respect to the enclosing packages or package bodies.
3163 Find_Placement_In_State_Space
3164 (Item_Id => Item_Id,
3165 Placement => Placement,
3166 Pack_Id => Pack_Id);
3168 -- The item appears in a non-package construct with a declarative
3169 -- part (subprogram, block, etc). As such, the item is not allowed
3170 -- to be a part of an encapsulating state because the item is not
3171 -- visible.
3173 if Placement = Not_In_Package then
3174 SPARK_Msg_N
3175 ("indicator Part_Of cannot appear in this context "
3176 & "(SPARK RM 7.2.6(5))", Indic);
3177 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3178 SPARK_Msg_NE
3179 ("\& is not part of the hidden state of package %",
3180 Indic, Item_Id);
3182 -- The item appears in the visible state space of some package. In
3183 -- general this scenario does not warrant Part_Of except when the
3184 -- package is a private child unit and the encapsulating state is
3185 -- declared in a parent unit or a public descendant of that parent
3186 -- unit.
3188 elsif Placement = Visible_State_Space then
3189 if Is_Child_Unit (Pack_Id)
3190 and then Is_Private_Descendant (Pack_Id)
3191 then
3192 -- A variable or state abstraction which is part of the visible
3193 -- state of a private child unit (or one of its public
3194 -- descendants) must have its Part_Of indicator specified. The
3195 -- Part_Of indicator must denote a state abstraction declared
3196 -- by either the parent unit of the private unit or by a public
3197 -- descendant of that parent unit.
3199 -- Find nearest private ancestor (which can be the current unit
3200 -- itself).
3202 Parent_Unit := Pack_Id;
3203 while Present (Parent_Unit) loop
3204 exit when
3205 Private_Present
3206 (Parent (Unit_Declaration_Node (Parent_Unit)));
3207 Parent_Unit := Scope (Parent_Unit);
3208 end loop;
3210 Parent_Unit := Scope (Parent_Unit);
3212 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3213 SPARK_Msg_NE
3214 ("indicator Part_Of must denote abstract state or public "
3215 & "descendant of & (SPARK RM 7.2.6(3))",
3216 Indic, Parent_Unit);
3218 elsif Scope (Encap_Id) = Parent_Unit
3219 or else
3220 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3221 and then not Is_Private_Descendant (Scope (Encap_Id)))
3222 then
3223 null;
3225 else
3226 SPARK_Msg_NE
3227 ("indicator Part_Of must denote abstract state or public "
3228 & "descendant of & (SPARK RM 7.2.6(3))",
3229 Indic, Parent_Unit);
3230 end if;
3232 -- Indicator Part_Of is not needed when the related package is not
3233 -- a private child unit or a public descendant thereof.
3235 else
3236 SPARK_Msg_N
3237 ("indicator Part_Of cannot appear in this context "
3238 & "(SPARK RM 7.2.6(5))", Indic);
3239 Error_Msg_Name_1 := Chars (Pack_Id);
3240 SPARK_Msg_NE
3241 ("\& is declared in the visible part of package %",
3242 Indic, Item_Id);
3243 end if;
3245 -- When the item appears in the private state space of a package, the
3246 -- encapsulating state must be declared in the same package.
3248 elsif Placement = Private_State_Space then
3249 if Scope (Encap_Id) /= Pack_Id then
3250 SPARK_Msg_NE
3251 ("indicator Part_Of must designate an abstract state of "
3252 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3253 Error_Msg_Name_1 := Chars (Pack_Id);
3254 SPARK_Msg_NE
3255 ("\& is declared in the private part of package %",
3256 Indic, Item_Id);
3257 end if;
3259 -- Items declared in the body state space of a package do not need
3260 -- Part_Of indicators as the refinement has already been seen.
3262 else
3263 SPARK_Msg_N
3264 ("indicator Part_Of cannot appear in this context "
3265 & "(SPARK RM 7.2.6(5))", Indic);
3267 if Scope (Encap_Id) = Pack_Id then
3268 Error_Msg_Name_1 := Chars (Pack_Id);
3269 SPARK_Msg_NE
3270 ("\& is declared in the body of package %", Indic, Item_Id);
3271 end if;
3272 end if;
3274 -- The encapsulator is a single concurrent type
3276 else
3277 Encap_Typ := Etype (Encap_Id);
3279 -- Only abstract states and variables can act as constituents of an
3280 -- encapsulating single concurrent type.
3282 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3283 null;
3285 -- The constituent is a constant
3287 elsif Ekind (Item_Id) = E_Constant then
3288 Error_Msg_Name_1 := Chars (Encap_Id);
3289 SPARK_Msg_NE
3290 (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of "
3291 & "single protected type %"), Indic, Item_Id);
3293 -- The constituent is a package instantiation
3295 else
3296 Error_Msg_Name_1 := Chars (Encap_Id);
3297 SPARK_Msg_NE
3298 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3299 & "constituent of single protected type %"), Indic, Item_Id);
3300 end if;
3302 -- When the item denotes an abstract state of a nested package, use
3303 -- the declaration of the package to detect proper placement.
3305 -- package Pack is
3306 -- task T;
3307 -- package Nested
3308 -- with Abstract_State => (State with Part_Of => T)
3310 if Ekind (Item_Id) = E_Abstract_State then
3311 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3312 else
3313 Item_Decl := Declaration_Node (Item_Id);
3314 end if;
3316 -- Both the item and its encapsulating single concurrent type must
3317 -- appear in the same declarative region (SPARK RM 9.3). Note that
3318 -- privacy is ignored.
3320 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3321 Error_Msg_Name_1 := Chars (Encap_Id);
3322 SPARK_Msg_NE
3323 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3324 & "immediately within the same region as single protected "
3325 & "type %"), Indic, Item_Id);
3326 end if;
3327 end if;
3329 Legal := True;
3330 end Analyze_Part_Of;
3332 ----------------------------------
3333 -- Analyze_Part_Of_In_Decl_Part --
3334 ----------------------------------
3336 procedure Analyze_Part_Of_In_Decl_Part
3337 (N : Node_Id;
3338 Freeze_Id : Entity_Id := Empty)
3340 Encap : constant Node_Id :=
3341 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3342 Errors : constant Nat := Serious_Errors_Detected;
3343 Var_Decl : constant Node_Id := Find_Related_Context (N);
3344 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3345 Constits : Elist_Id;
3346 Encap_Id : Entity_Id;
3347 Legal : Boolean;
3349 begin
3350 -- Detect any discrepancies between the placement of the variable with
3351 -- respect to general state space and the encapsulating state or single
3352 -- concurrent type.
3354 Analyze_Part_Of
3355 (Indic => N,
3356 Item_Id => Var_Id,
3357 Encap => Encap,
3358 Encap_Id => Encap_Id,
3359 Legal => Legal);
3361 -- The Part_Of indicator turns the variable into a constituent of the
3362 -- encapsulating state or single concurrent type.
3364 if Legal then
3365 pragma Assert (Present (Encap_Id));
3366 Constits := Part_Of_Constituents (Encap_Id);
3368 if No (Constits) then
3369 Constits := New_Elmt_List;
3370 Set_Part_Of_Constituents (Encap_Id, Constits);
3371 end if;
3373 Append_Elmt (Var_Id, Constits);
3374 Set_Encapsulating_State (Var_Id, Encap_Id);
3375 end if;
3377 -- Emit a clarification message when the encapsulator is undefined,
3378 -- possibly due to contract "freezing".
3380 if Errors /= Serious_Errors_Detected
3381 and then Present (Freeze_Id)
3382 and then Has_Undefined_Reference (Encap)
3383 then
3384 Contract_Freeze_Error (Var_Id, Freeze_Id);
3385 end if;
3386 end Analyze_Part_Of_In_Decl_Part;
3388 --------------------
3389 -- Analyze_Pragma --
3390 --------------------
3392 procedure Analyze_Pragma (N : Node_Id) is
3393 Loc : constant Source_Ptr := Sloc (N);
3394 Prag_Id : Pragma_Id;
3396 Pname : Name_Id;
3397 -- Name of the source pragma, or name of the corresponding aspect for
3398 -- pragmas which originate in a source aspect. In the latter case, the
3399 -- name may be different from the pragma name.
3401 Pragma_Exit : exception;
3402 -- This exception is used to exit pragma processing completely. It
3403 -- is used when an error is detected, and no further processing is
3404 -- required. It is also used if an earlier error has left the tree in
3405 -- a state where the pragma should not be processed.
3407 Arg_Count : Nat;
3408 -- Number of pragma argument associations
3410 Arg1 : Node_Id;
3411 Arg2 : Node_Id;
3412 Arg3 : Node_Id;
3413 Arg4 : Node_Id;
3414 -- First four pragma arguments (pragma argument association nodes, or
3415 -- Empty if the corresponding argument does not exist).
3417 type Name_List is array (Natural range <>) of Name_Id;
3418 type Args_List is array (Natural range <>) of Node_Id;
3419 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3421 -----------------------
3422 -- Local Subprograms --
3423 -----------------------
3425 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3426 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3427 -- get the given string argument, and place it in Name_Buffer, adding
3428 -- leading and trailing asterisks if they are not already present. The
3429 -- caller has already checked that Arg is a static string expression.
3431 procedure Ada_2005_Pragma;
3432 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3433 -- Ada 95 mode, these are implementation defined pragmas, so should be
3434 -- caught by the No_Implementation_Pragmas restriction.
3436 procedure Ada_2012_Pragma;
3437 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3438 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3439 -- should be caught by the No_Implementation_Pragmas restriction.
3441 procedure Analyze_Depends_Global
3442 (Spec_Id : out Entity_Id;
3443 Subp_Decl : out Node_Id;
3444 Legal : out Boolean);
3445 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3446 -- legality of the placement and related context of the pragma. Spec_Id
3447 -- is the entity of the related subprogram. Subp_Decl is the declaration
3448 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3450 procedure Analyze_If_Present (Id : Pragma_Id);
3451 -- Inspect the remainder of the list containing pragma N and look for
3452 -- a pragma that matches Id. If found, analyze the pragma.
3454 procedure Analyze_Pre_Post_Condition;
3455 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3457 procedure Analyze_Refined_Depends_Global_Post
3458 (Spec_Id : out Entity_Id;
3459 Body_Id : out Entity_Id;
3460 Legal : out Boolean);
3461 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3462 -- Refined_Global and Refined_Post. Verify the legality of the placement
3463 -- and related context of the pragma. Spec_Id is the entity of the
3464 -- related subprogram. Body_Id is the entity of the subprogram body.
3465 -- Flag Legal is set when the pragma is legal.
3467 procedure Check_Ada_83_Warning;
3468 -- Issues a warning message for the current pragma if operating in Ada
3469 -- 83 mode (used for language pragmas that are not a standard part of
3470 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3471 -- of 95 pragma.
3473 procedure Check_Arg_Count (Required : Nat);
3474 -- Check argument count for pragma is equal to given parameter. If not,
3475 -- then issue an error message and raise Pragma_Exit.
3477 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3478 -- Arg which can either be a pragma argument association, in which case
3479 -- the check is applied to the expression of the association or an
3480 -- expression directly.
3482 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3483 -- Check that an argument has the right form for an EXTERNAL_NAME
3484 -- parameter of an extended import/export pragma. The rule is that the
3485 -- name must be an identifier or string literal (in Ada 83 mode) or a
3486 -- static string expression (in Ada 95 mode).
3488 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3489 -- Check the specified argument Arg to make sure that it is an
3490 -- identifier. If not give error and raise Pragma_Exit.
3492 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3493 -- Check the specified argument Arg to make sure that it is an integer
3494 -- literal. If not give error and raise Pragma_Exit.
3496 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3497 -- Check the specified argument Arg to make sure that it has the proper
3498 -- syntactic form for a local name and meets the semantic requirements
3499 -- for a local name. The local name is analyzed as part of the
3500 -- processing for this call. In addition, the local name is required
3501 -- to represent an entity at the library level.
3503 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3504 -- Check the specified argument Arg to make sure that it has the proper
3505 -- syntactic form for a local name and meets the semantic requirements
3506 -- for a local name. The local name is analyzed as part of the
3507 -- processing for this call.
3509 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3510 -- Check the specified argument Arg to make sure that it is a valid
3511 -- locking policy name. If not give error and raise Pragma_Exit.
3513 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3514 -- Check the specified argument Arg to make sure that it is a valid
3515 -- elaboration policy name. If not give error and raise Pragma_Exit.
3517 procedure Check_Arg_Is_One_Of
3518 (Arg : Node_Id;
3519 N1, N2 : Name_Id);
3520 procedure Check_Arg_Is_One_Of
3521 (Arg : Node_Id;
3522 N1, N2, N3 : Name_Id);
3523 procedure Check_Arg_Is_One_Of
3524 (Arg : Node_Id;
3525 N1, N2, N3, N4 : Name_Id);
3526 procedure Check_Arg_Is_One_Of
3527 (Arg : Node_Id;
3528 N1, N2, N3, N4, N5 : Name_Id);
3529 -- Check the specified argument Arg to make sure that it is an
3530 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3531 -- present). If not then give error and raise Pragma_Exit.
3533 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3534 -- Check the specified argument Arg to make sure that it is a valid
3535 -- queuing policy name. If not give error and raise Pragma_Exit.
3537 procedure Check_Arg_Is_OK_Static_Expression
3538 (Arg : Node_Id;
3539 Typ : Entity_Id := Empty);
3540 -- Check the specified argument Arg to make sure that it is a static
3541 -- expression of the given type (i.e. it will be analyzed and resolved
3542 -- using this type, which can be any valid argument to Resolve, e.g.
3543 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3544 -- Typ is left Empty, then any static expression is allowed. Includes
3545 -- checking that the argument does not raise Constraint_Error.
3547 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3548 -- Check the specified argument Arg to make sure that it is a valid task
3549 -- dispatching policy name. If not give error and raise Pragma_Exit.
3551 procedure Check_Arg_Order (Names : Name_List);
3552 -- Checks for an instance of two arguments with identifiers for the
3553 -- current pragma which are not in the sequence indicated by Names,
3554 -- and if so, generates a fatal message about bad order of arguments.
3556 procedure Check_At_Least_N_Arguments (N : Nat);
3557 -- Check there are at least N arguments present
3559 procedure Check_At_Most_N_Arguments (N : Nat);
3560 -- Check there are no more than N arguments present
3562 procedure Check_Component
3563 (Comp : Node_Id;
3564 UU_Typ : Entity_Id;
3565 In_Variant_Part : Boolean := False);
3566 -- Examine an Unchecked_Union component for correct use of per-object
3567 -- constrained subtypes, and for restrictions on finalizable components.
3568 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3569 -- should be set when Comp comes from a record variant.
3571 procedure Check_Duplicate_Pragma (E : Entity_Id);
3572 -- Check if a rep item of the same name as the current pragma is already
3573 -- chained as a rep pragma to the given entity. If so give a message
3574 -- about the duplicate, and then raise Pragma_Exit so does not return.
3575 -- Note that if E is a type, then this routine avoids flagging a pragma
3576 -- which applies to a parent type from which E is derived.
3578 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3579 -- Nam is an N_String_Literal node containing the external name set by
3580 -- an Import or Export pragma (or extended Import or Export pragma).
3581 -- This procedure checks for possible duplications if this is the export
3582 -- case, and if found, issues an appropriate error message.
3584 procedure Check_Expr_Is_OK_Static_Expression
3585 (Expr : Node_Id;
3586 Typ : Entity_Id := Empty);
3587 -- Check the specified expression Expr to make sure that it is a static
3588 -- expression of the given type (i.e. it will be analyzed and resolved
3589 -- using this type, which can be any valid argument to Resolve, e.g.
3590 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3591 -- Typ is left Empty, then any static expression is allowed. Includes
3592 -- checking that the expression does not raise Constraint_Error.
3594 procedure Check_First_Subtype (Arg : Node_Id);
3595 -- Checks that Arg, whose expression is an entity name, references a
3596 -- first subtype.
3598 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3599 -- Checks that the given argument has an identifier, and if so, requires
3600 -- it to match the given identifier name. If there is no identifier, or
3601 -- a non-matching identifier, then an error message is given and
3602 -- Pragma_Exit is raised.
3604 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3605 -- Checks that the given argument has an identifier, and if so, requires
3606 -- it to match one of the given identifier names. If there is no
3607 -- identifier, or a non-matching identifier, then an error message is
3608 -- given and Pragma_Exit is raised.
3610 procedure Check_In_Main_Program;
3611 -- Common checks for pragmas that appear within a main program
3612 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3614 procedure Check_Interrupt_Or_Attach_Handler;
3615 -- Common processing for first argument of pragma Interrupt_Handler or
3616 -- pragma Attach_Handler.
3618 procedure Check_Loop_Pragma_Placement;
3619 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3620 -- appear immediately within a construct restricted to loops, and that
3621 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3623 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3624 -- Check that pragma appears in a declarative part, or in a package
3625 -- specification, i.e. that it does not occur in a statement sequence
3626 -- in a body.
3628 procedure Check_No_Identifier (Arg : Node_Id);
3629 -- Checks that the given argument does not have an identifier. If
3630 -- an identifier is present, then an error message is issued, and
3631 -- Pragma_Exit is raised.
3633 procedure Check_No_Identifiers;
3634 -- Checks that none of the arguments to the pragma has an identifier.
3635 -- If any argument has an identifier, then an error message is issued,
3636 -- and Pragma_Exit is raised.
3638 procedure Check_No_Link_Name;
3639 -- Checks that no link name is specified
3641 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3642 -- Checks if the given argument has an identifier, and if so, requires
3643 -- it to match the given identifier name. If there is a non-matching
3644 -- identifier, then an error message is given and Pragma_Exit is raised.
3646 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3647 -- Checks if the given argument has an identifier, and if so, requires
3648 -- it to match the given identifier name. If there is a non-matching
3649 -- identifier, then an error message is given and Pragma_Exit is raised.
3650 -- In this version of the procedure, the identifier name is given as
3651 -- a string with lower case letters.
3653 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3654 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3655 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3656 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3657 -- is an OK static boolean expression. Emit an error if this is not the
3658 -- case.
3660 procedure Check_Static_Constraint (Constr : Node_Id);
3661 -- Constr is a constraint from an N_Subtype_Indication node from a
3662 -- component constraint in an Unchecked_Union type. This routine checks
3663 -- that the constraint is static as required by the restrictions for
3664 -- Unchecked_Union.
3666 procedure Check_Valid_Configuration_Pragma;
3667 -- Legality checks for placement of a configuration pragma
3669 procedure Check_Valid_Library_Unit_Pragma;
3670 -- Legality checks for library unit pragmas. A special case arises for
3671 -- pragmas in generic instances that come from copies of the original
3672 -- library unit pragmas in the generic templates. In the case of other
3673 -- than library level instantiations these can appear in contexts which
3674 -- would normally be invalid (they only apply to the original template
3675 -- and to library level instantiations), and they are simply ignored,
3676 -- which is implemented by rewriting them as null statements.
3678 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3679 -- Check an Unchecked_Union variant for lack of nested variants and
3680 -- presence of at least one component. UU_Typ is the related Unchecked_
3681 -- Union type.
3683 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3684 -- Subsidiary routine to the processing of pragmas Abstract_State,
3685 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3686 -- Refined_Global and Refined_State. Transform argument Arg into
3687 -- an aggregate if not one already. N_Null is never transformed.
3688 -- Arg may denote an aspect specification or a pragma argument
3689 -- association.
3691 procedure Error_Pragma (Msg : String);
3692 pragma No_Return (Error_Pragma);
3693 -- Outputs error message for current pragma. The message contains a %
3694 -- that will be replaced with the pragma name, and the flag is placed
3695 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3696 -- calls Fix_Error (see spec of that procedure for details).
3698 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3699 pragma No_Return (Error_Pragma_Arg);
3700 -- Outputs error message for current pragma. The message may contain
3701 -- a % that will be replaced with the pragma name. The parameter Arg
3702 -- may either be a pragma argument association, in which case the flag
3703 -- is placed on the expression of this association, or an expression,
3704 -- in which case the flag is placed directly on the expression. The
3705 -- message is placed using Error_Msg_N, so the message may also contain
3706 -- an & insertion character which will reference the given Arg value.
3707 -- After placing the message, Pragma_Exit is raised. Note: this routine
3708 -- calls Fix_Error (see spec of that procedure for details).
3710 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3711 pragma No_Return (Error_Pragma_Arg);
3712 -- Similar to above form of Error_Pragma_Arg except that two messages
3713 -- are provided, the second is a continuation comment starting with \.
3715 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3716 pragma No_Return (Error_Pragma_Arg_Ident);
3717 -- Outputs error message for current pragma. The message may contain a %
3718 -- that will be replaced with the pragma name. The parameter Arg must be
3719 -- a pragma argument association with a non-empty identifier (i.e. its
3720 -- Chars field must be set), and the error message is placed on the
3721 -- identifier. The message is placed using Error_Msg_N so the message
3722 -- may also contain an & insertion character which will reference
3723 -- the identifier. After placing the message, Pragma_Exit is raised.
3724 -- Note: this routine calls Fix_Error (see spec of that procedure for
3725 -- details).
3727 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3728 pragma No_Return (Error_Pragma_Ref);
3729 -- Outputs error message for current pragma. The message may contain
3730 -- a % that will be replaced with the pragma name. The parameter Ref
3731 -- must be an entity whose name can be referenced by & and sloc by #.
3732 -- After placing the message, Pragma_Exit is raised. Note: this routine
3733 -- calls Fix_Error (see spec of that procedure for details).
3735 function Find_Lib_Unit_Name return Entity_Id;
3736 -- Used for a library unit pragma to find the entity to which the
3737 -- library unit pragma applies, returns the entity found.
3739 procedure Find_Program_Unit_Name (Id : Node_Id);
3740 -- If the pragma is a compilation unit pragma, the id must denote the
3741 -- compilation unit in the same compilation, and the pragma must appear
3742 -- in the list of preceding or trailing pragmas. If it is a program
3743 -- unit pragma that is not a compilation unit pragma, then the
3744 -- identifier must be visible.
3746 function Find_Unique_Parameterless_Procedure
3747 (Name : Entity_Id;
3748 Arg : Node_Id) return Entity_Id;
3749 -- Used for a procedure pragma to find the unique parameterless
3750 -- procedure identified by Name, returns it if it exists, otherwise
3751 -- errors out and uses Arg as the pragma argument for the message.
3753 function Fix_Error (Msg : String) return String;
3754 -- This is called prior to issuing an error message. Msg is the normal
3755 -- error message issued in the pragma case. This routine checks for the
3756 -- case of a pragma coming from an aspect in the source, and returns a
3757 -- message suitable for the aspect case as follows:
3759 -- Each substring "pragma" is replaced by "aspect"
3761 -- If "argument of" is at the start of the error message text, it is
3762 -- replaced by "entity for".
3764 -- If "argument" is at the start of the error message text, it is
3765 -- replaced by "entity".
3767 -- So for example, "argument of pragma X must be discrete type"
3768 -- returns "entity for aspect X must be a discrete type".
3770 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3771 -- be different from the pragma name). If the current pragma results
3772 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3773 -- original pragma name.
3775 procedure Gather_Associations
3776 (Names : Name_List;
3777 Args : out Args_List);
3778 -- This procedure is used to gather the arguments for a pragma that
3779 -- permits arbitrary ordering of parameters using the normal rules
3780 -- for named and positional parameters. The Names argument is a list
3781 -- of Name_Id values that corresponds to the allowed pragma argument
3782 -- association identifiers in order. The result returned in Args is
3783 -- a list of corresponding expressions that are the pragma arguments.
3784 -- Note that this is a list of expressions, not of pragma argument
3785 -- associations (Gather_Associations has completely checked all the
3786 -- optional identifiers when it returns). An entry in Args is Empty
3787 -- on return if the corresponding argument is not present.
3789 procedure GNAT_Pragma;
3790 -- Called for all GNAT defined pragmas to check the relevant restriction
3791 -- (No_Implementation_Pragmas).
3793 function Is_Before_First_Decl
3794 (Pragma_Node : Node_Id;
3795 Decls : List_Id) return Boolean;
3796 -- Return True if Pragma_Node is before the first declarative item in
3797 -- Decls where Decls is the list of declarative items.
3799 function Is_Configuration_Pragma return Boolean;
3800 -- Determines if the placement of the current pragma is appropriate
3801 -- for a configuration pragma.
3803 function Is_In_Context_Clause return Boolean;
3804 -- Returns True if pragma appears within the context clause of a unit,
3805 -- and False for any other placement (does not generate any messages).
3807 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3808 -- Analyzes the argument, and determines if it is a static string
3809 -- expression, returns True if so, False if non-static or not String.
3810 -- A special case is that a string literal returns True in Ada 83 mode
3811 -- (which has no such thing as static string expressions). Note that
3812 -- the call analyzes its argument, so this cannot be used for the case
3813 -- where an identifier might not be declared.
3815 procedure Pragma_Misplaced;
3816 pragma No_Return (Pragma_Misplaced);
3817 -- Issue fatal error message for misplaced pragma
3819 procedure Process_Atomic_Independent_Shared_Volatile;
3820 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3821 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3822 -- and treated as being identical in effect to pragma Atomic.
3824 procedure Process_Compile_Time_Warning_Or_Error;
3825 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3827 procedure Process_Convention
3828 (C : out Convention_Id;
3829 Ent : out Entity_Id);
3830 -- Common processing for Convention, Interface, Import and Export.
3831 -- Checks first two arguments of pragma, and sets the appropriate
3832 -- convention value in the specified entity or entities. On return
3833 -- C is the convention, Ent is the referenced entity.
3835 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3836 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3837 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3839 procedure Process_Extended_Import_Export_Object_Pragma
3840 (Arg_Internal : Node_Id;
3841 Arg_External : Node_Id;
3842 Arg_Size : Node_Id);
3843 -- Common processing for the pragmas Import/Export_Object. The three
3844 -- arguments correspond to the three named parameters of the pragmas. An
3845 -- argument is empty if the corresponding parameter is not present in
3846 -- the pragma.
3848 procedure Process_Extended_Import_Export_Internal_Arg
3849 (Arg_Internal : Node_Id := Empty);
3850 -- Common processing for all extended Import and Export pragmas. The
3851 -- argument is the pragma parameter for the Internal argument. If
3852 -- Arg_Internal is empty or inappropriate, an error message is posted.
3853 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3854 -- set to identify the referenced entity.
3856 procedure Process_Extended_Import_Export_Subprogram_Pragma
3857 (Arg_Internal : Node_Id;
3858 Arg_External : Node_Id;
3859 Arg_Parameter_Types : Node_Id;
3860 Arg_Result_Type : Node_Id := Empty;
3861 Arg_Mechanism : Node_Id;
3862 Arg_Result_Mechanism : Node_Id := Empty);
3863 -- Common processing for all extended Import and Export pragmas applying
3864 -- to subprograms. The caller omits any arguments that do not apply to
3865 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3866 -- only in the Import_Function and Export_Function cases). The argument
3867 -- names correspond to the allowed pragma association identifiers.
3869 procedure Process_Generic_List;
3870 -- Common processing for Share_Generic and Inline_Generic
3872 procedure Process_Import_Or_Interface;
3873 -- Common processing for Import or Interface
3875 procedure Process_Import_Predefined_Type;
3876 -- Processing for completing a type with pragma Import. This is used
3877 -- to declare types that match predefined C types, especially for cases
3878 -- without corresponding Ada predefined type.
3880 type Inline_Status is (Suppressed, Disabled, Enabled);
3881 -- Inline status of a subprogram, indicated as follows:
3882 -- Suppressed: inlining is suppressed for the subprogram
3883 -- Disabled: no inlining is requested for the subprogram
3884 -- Enabled: inlining is requested/required for the subprogram
3886 procedure Process_Inline (Status : Inline_Status);
3887 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3888 -- indicates the inline status specified by the pragma.
3890 procedure Process_Interface_Name
3891 (Subprogram_Def : Entity_Id;
3892 Ext_Arg : Node_Id;
3893 Link_Arg : Node_Id);
3894 -- Given the last two arguments of pragma Import, pragma Export, or
3895 -- pragma Interface_Name, performs validity checks and sets the
3896 -- Interface_Name field of the given subprogram entity to the
3897 -- appropriate external or link name, depending on the arguments given.
3898 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3899 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3900 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3901 -- nor Link_Arg is present, the interface name is set to the default
3902 -- from the subprogram name.
3904 procedure Process_Interrupt_Or_Attach_Handler;
3905 -- Common processing for Interrupt and Attach_Handler pragmas
3907 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3908 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3909 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3910 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3911 -- is not set in the Restrictions case.
3913 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3914 -- Common processing for Suppress and Unsuppress. The boolean parameter
3915 -- Suppress_Case is True for the Suppress case, and False for the
3916 -- Unsuppress case.
3918 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3919 -- Subsidiary to the analysis of pragmas Independent[_Components].
3920 -- Record such a pragma N applied to entity E for future checks.
3922 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3923 -- This procedure sets the Is_Exported flag for the given entity,
3924 -- checking that the entity was not previously imported. Arg is
3925 -- the argument that specified the entity. A check is also made
3926 -- for exporting inappropriate entities.
3928 procedure Set_Extended_Import_Export_External_Name
3929 (Internal_Ent : Entity_Id;
3930 Arg_External : Node_Id);
3931 -- Common processing for all extended import export pragmas. The first
3932 -- argument, Internal_Ent, is the internal entity, which has already
3933 -- been checked for validity by the caller. Arg_External is from the
3934 -- Import or Export pragma, and may be null if no External parameter
3935 -- was present. If Arg_External is present and is a non-null string
3936 -- (a null string is treated as the default), then the Interface_Name
3937 -- field of Internal_Ent is set appropriately.
3939 procedure Set_Imported (E : Entity_Id);
3940 -- This procedure sets the Is_Imported flag for the given entity,
3941 -- checking that it is not previously exported or imported.
3943 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3944 -- Mech is a parameter passing mechanism (see Import_Function syntax
3945 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3946 -- has the right form, and if not issues an error message. If the
3947 -- argument has the right form then the Mechanism field of Ent is
3948 -- set appropriately.
3950 procedure Set_Rational_Profile;
3951 -- Activate the set of configuration pragmas and permissions that make
3952 -- up the Rational profile.
3954 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
3955 -- Activate the set of configuration pragmas and restrictions that make
3956 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
3957 -- Ravenscar. N is the corresponding pragma node, which is used for
3958 -- error messages on any constructs violating the profile.
3960 ----------------------------------
3961 -- Acquire_Warning_Match_String --
3962 ----------------------------------
3964 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
3965 begin
3966 String_To_Name_Buffer
3967 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
3969 -- Add asterisk at start if not already there
3971 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
3972 Name_Buffer (2 .. Name_Len + 1) :=
3973 Name_Buffer (1 .. Name_Len);
3974 Name_Buffer (1) := '*';
3975 Name_Len := Name_Len + 1;
3976 end if;
3978 -- Add asterisk at end if not already there
3980 if Name_Buffer (Name_Len) /= '*' then
3981 Name_Len := Name_Len + 1;
3982 Name_Buffer (Name_Len) := '*';
3983 end if;
3984 end Acquire_Warning_Match_String;
3986 ---------------------
3987 -- Ada_2005_Pragma --
3988 ---------------------
3990 procedure Ada_2005_Pragma is
3991 begin
3992 if Ada_Version <= Ada_95 then
3993 Check_Restriction (No_Implementation_Pragmas, N);
3994 end if;
3995 end Ada_2005_Pragma;
3997 ---------------------
3998 -- Ada_2012_Pragma --
3999 ---------------------
4001 procedure Ada_2012_Pragma is
4002 begin
4003 if Ada_Version <= Ada_2005 then
4004 Check_Restriction (No_Implementation_Pragmas, N);
4005 end if;
4006 end Ada_2012_Pragma;
4008 ----------------------------
4009 -- Analyze_Depends_Global --
4010 ----------------------------
4012 procedure Analyze_Depends_Global
4013 (Spec_Id : out Entity_Id;
4014 Subp_Decl : out Node_Id;
4015 Legal : out Boolean)
4017 begin
4018 -- Assume that the pragma is illegal
4020 Spec_Id := Empty;
4021 Subp_Decl := Empty;
4022 Legal := False;
4024 GNAT_Pragma;
4025 Check_Arg_Count (1);
4027 -- Ensure the proper placement of the pragma. Depends/Global must be
4028 -- associated with a subprogram declaration or a body that acts as a
4029 -- spec.
4031 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4033 -- Entry
4035 if Nkind (Subp_Decl) = N_Entry_Declaration then
4036 null;
4038 -- Generic subprogram
4040 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4041 null;
4043 -- Object declaration of a single concurrent type
4045 elsif Nkind (Subp_Decl) = N_Object_Declaration then
4046 null;
4048 -- Single task type
4050 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4051 null;
4053 -- Subprogram body acts as spec
4055 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4056 and then No (Corresponding_Spec (Subp_Decl))
4057 then
4058 null;
4060 -- Subprogram body stub acts as spec
4062 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4063 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4064 then
4065 null;
4067 -- Subprogram declaration
4069 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4070 null;
4072 -- Task type
4074 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4075 null;
4077 else
4078 Pragma_Misplaced;
4079 return;
4080 end if;
4082 -- If we get here, then the pragma is legal
4084 Legal := True;
4085 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4087 -- When the related context is an entry, the entry must belong to a
4088 -- protected unit (SPARK RM 6.1.4(6)).
4090 if Is_Entry_Declaration (Spec_Id)
4091 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4092 then
4093 Pragma_Misplaced;
4094 return;
4096 -- When the related context is an anonymous object created for a
4097 -- simple concurrent type, the type must be a task
4098 -- (SPARK RM 6.1.4(6)).
4100 elsif Is_Single_Concurrent_Object (Spec_Id)
4101 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4102 then
4103 Pragma_Misplaced;
4104 return;
4105 end if;
4107 -- A pragma that applies to a Ghost entity becomes Ghost for the
4108 -- purposes of legality checks and removal of ignored Ghost code.
4110 Mark_Pragma_As_Ghost (N, Spec_Id);
4111 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4112 end Analyze_Depends_Global;
4114 ------------------------
4115 -- Analyze_If_Present --
4116 ------------------------
4118 procedure Analyze_If_Present (Id : Pragma_Id) is
4119 Stmt : Node_Id;
4121 begin
4122 pragma Assert (Is_List_Member (N));
4124 -- Inspect the declarations or statements following pragma N looking
4125 -- for another pragma whose Id matches the caller's request. If it is
4126 -- available, analyze it.
4128 Stmt := Next (N);
4129 while Present (Stmt) loop
4130 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4131 Analyze_Pragma (Stmt);
4132 exit;
4134 -- The first source declaration or statement immediately following
4135 -- N ends the region where a pragma may appear.
4137 elsif Comes_From_Source (Stmt) then
4138 exit;
4139 end if;
4141 Next (Stmt);
4142 end loop;
4143 end Analyze_If_Present;
4145 --------------------------------
4146 -- Analyze_Pre_Post_Condition --
4147 --------------------------------
4149 procedure Analyze_Pre_Post_Condition is
4150 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4151 Subp_Decl : Node_Id;
4152 Subp_Id : Entity_Id;
4154 Duplicates_OK : Boolean := False;
4155 -- Flag set when a pre/postcondition allows multiple pragmas of the
4156 -- same kind.
4158 In_Body_OK : Boolean := False;
4159 -- Flag set when a pre/postcondition is allowed to appear on a body
4160 -- even though the subprogram may have a spec.
4162 Is_Pre_Post : Boolean := False;
4163 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4164 -- Post_Class.
4166 begin
4167 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4168 -- offer uniformity among the various kinds of pre/postconditions by
4169 -- rewriting the pragma identifier. This allows the retrieval of the
4170 -- original pragma name by routine Original_Aspect_Pragma_Name.
4172 if Comes_From_Source (N) then
4173 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4174 Is_Pre_Post := True;
4175 Set_Class_Present (N, Pname = Name_Pre_Class);
4176 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4178 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4179 Is_Pre_Post := True;
4180 Set_Class_Present (N, Pname = Name_Post_Class);
4181 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4182 end if;
4183 end if;
4185 -- Determine the semantics with respect to duplicates and placement
4186 -- in a body. Pragmas Precondition and Postcondition were introduced
4187 -- before aspects and are not subject to the same aspect-like rules.
4189 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4190 Duplicates_OK := True;
4191 In_Body_OK := True;
4192 end if;
4194 GNAT_Pragma;
4196 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4197 -- argument without an identifier.
4199 if Is_Pre_Post then
4200 Check_Arg_Count (1);
4201 Check_No_Identifiers;
4203 -- Pragmas Precondition and Postcondition have complex argument
4204 -- profile.
4206 else
4207 Check_At_Least_N_Arguments (1);
4208 Check_At_Most_N_Arguments (2);
4209 Check_Optional_Identifier (Arg1, Name_Check);
4211 if Present (Arg2) then
4212 Check_Optional_Identifier (Arg2, Name_Message);
4213 Preanalyze_Spec_Expression
4214 (Get_Pragma_Arg (Arg2), Standard_String);
4215 end if;
4216 end if;
4218 -- For a pragma PPC in the extended main source unit, record enabled
4219 -- status in SCO.
4220 -- ??? nothing checks that the pragma is in the main source unit
4222 if Is_Checked (N) and then not Split_PPC (N) then
4223 Set_SCO_Pragma_Enabled (Loc);
4224 end if;
4226 -- Ensure the proper placement of the pragma
4228 Subp_Decl :=
4229 Find_Related_Declaration_Or_Body
4230 (N, Do_Checks => not Duplicates_OK);
4232 -- When a pre/postcondition pragma applies to an abstract subprogram,
4233 -- its original form must be an aspect with 'Class.
4235 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4236 if not From_Aspect_Specification (N) then
4237 Error_Pragma
4238 ("pragma % cannot be applied to abstract subprogram");
4240 elsif not Class_Present (N) then
4241 Error_Pragma
4242 ("aspect % requires ''Class for abstract subprogram");
4243 end if;
4245 -- Entry declaration
4247 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4248 null;
4250 -- Generic subprogram declaration
4252 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4253 null;
4255 -- Subprogram body
4257 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4258 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4259 then
4260 null;
4262 -- Subprogram body stub
4264 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4265 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4266 then
4267 null;
4269 -- Subprogram declaration
4271 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4273 -- AI05-0230: When a pre/postcondition pragma applies to a null
4274 -- procedure, its original form must be an aspect with 'Class.
4276 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4277 and then Null_Present (Specification (Subp_Decl))
4278 and then From_Aspect_Specification (N)
4279 and then not Class_Present (N)
4280 then
4281 Error_Pragma ("aspect % requires ''Class for null procedure");
4282 end if;
4284 -- Otherwise the placement is illegal
4286 else
4287 Pragma_Misplaced;
4288 return;
4289 end if;
4291 Subp_Id := Defining_Entity (Subp_Decl);
4293 -- Chain the pragma on the contract for further processing by
4294 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4296 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4298 -- A pragma that applies to a Ghost entity becomes Ghost for the
4299 -- purposes of legality checks and removal of ignored Ghost code.
4301 Mark_Pragma_As_Ghost (N, Subp_Id);
4303 -- Fully analyze the pragma when it appears inside an entry or
4304 -- subprogram body because it cannot benefit from forward references.
4306 if Nkind_In (Subp_Decl, N_Entry_Body,
4307 N_Subprogram_Body,
4308 N_Subprogram_Body_Stub)
4309 then
4310 -- The legality checks of pragmas Precondition and Postcondition
4311 -- are affected by the SPARK mode in effect and the volatility of
4312 -- the context. Analyze all pragmas in a specific order.
4314 Analyze_If_Present (Pragma_SPARK_Mode);
4315 Analyze_If_Present (Pragma_Volatile_Function);
4316 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4317 end if;
4318 end Analyze_Pre_Post_Condition;
4320 -----------------------------------------
4321 -- Analyze_Refined_Depends_Global_Post --
4322 -----------------------------------------
4324 procedure Analyze_Refined_Depends_Global_Post
4325 (Spec_Id : out Entity_Id;
4326 Body_Id : out Entity_Id;
4327 Legal : out Boolean)
4329 Body_Decl : Node_Id;
4330 Spec_Decl : Node_Id;
4332 begin
4333 -- Assume that the pragma is illegal
4335 Spec_Id := Empty;
4336 Body_Id := Empty;
4337 Legal := False;
4339 GNAT_Pragma;
4340 Check_Arg_Count (1);
4341 Check_No_Identifiers;
4343 -- Verify the placement of the pragma and check for duplicates. The
4344 -- pragma must apply to a subprogram body [stub].
4346 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4348 -- Entry body
4350 if Nkind (Body_Decl) = N_Entry_Body then
4351 null;
4353 -- Subprogram body
4355 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4356 null;
4358 -- Subprogram body stub
4360 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4361 null;
4363 -- Task body
4365 elsif Nkind (Body_Decl) = N_Task_Body then
4366 null;
4368 else
4369 Pragma_Misplaced;
4370 return;
4371 end if;
4373 Body_Id := Defining_Entity (Body_Decl);
4374 Spec_Id := Unique_Defining_Entity (Body_Decl);
4376 -- The pragma must apply to the second declaration of a subprogram.
4377 -- In other words, the body [stub] cannot acts as a spec.
4379 if No (Spec_Id) then
4380 Error_Pragma ("pragma % cannot apply to a stand alone body");
4381 return;
4383 -- Catch the case where the subprogram body is a subunit and acts as
4384 -- the third declaration of the subprogram.
4386 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4387 Error_Pragma ("pragma % cannot apply to a subunit");
4388 return;
4389 end if;
4391 -- A refined pragma can only apply to the body [stub] of a subprogram
4392 -- declared in the visible part of a package. Retrieve the context of
4393 -- the subprogram declaration.
4395 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4397 -- When dealing with protected entries or protected subprograms, use
4398 -- the enclosing protected type as the proper context.
4400 if Ekind_In (Spec_Id, E_Entry,
4401 E_Entry_Family,
4402 E_Function,
4403 E_Procedure)
4404 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4405 then
4406 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4407 end if;
4409 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4410 Error_Pragma
4411 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4412 & "subprogram declared in a package specification"));
4413 return;
4414 end if;
4416 -- If we get here, then the pragma is legal
4418 Legal := True;
4420 -- A pragma that applies to a Ghost entity becomes Ghost for the
4421 -- purposes of legality checks and removal of ignored Ghost code.
4423 Mark_Pragma_As_Ghost (N, Spec_Id);
4425 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4426 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4427 end if;
4428 end Analyze_Refined_Depends_Global_Post;
4430 --------------------------
4431 -- Check_Ada_83_Warning --
4432 --------------------------
4434 procedure Check_Ada_83_Warning is
4435 begin
4436 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4437 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4438 end if;
4439 end Check_Ada_83_Warning;
4441 ---------------------
4442 -- Check_Arg_Count --
4443 ---------------------
4445 procedure Check_Arg_Count (Required : Nat) is
4446 begin
4447 if Arg_Count /= Required then
4448 Error_Pragma ("wrong number of arguments for pragma%");
4449 end if;
4450 end Check_Arg_Count;
4452 --------------------------------
4453 -- Check_Arg_Is_External_Name --
4454 --------------------------------
4456 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4457 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4459 begin
4460 if Nkind (Argx) = N_Identifier then
4461 return;
4463 else
4464 Analyze_And_Resolve (Argx, Standard_String);
4466 if Is_OK_Static_Expression (Argx) then
4467 return;
4469 elsif Etype (Argx) = Any_Type then
4470 raise Pragma_Exit;
4472 -- An interesting special case, if we have a string literal and
4473 -- we are in Ada 83 mode, then we allow it even though it will
4474 -- not be flagged as static. This allows expected Ada 83 mode
4475 -- use of external names which are string literals, even though
4476 -- technically these are not static in Ada 83.
4478 elsif Ada_Version = Ada_83
4479 and then Nkind (Argx) = N_String_Literal
4480 then
4481 return;
4483 -- Static expression that raises Constraint_Error. This has
4484 -- already been flagged, so just exit from pragma processing.
4486 elsif Is_OK_Static_Expression (Argx) then
4487 raise Pragma_Exit;
4489 -- Here we have a real error (non-static expression)
4491 else
4492 Error_Msg_Name_1 := Pname;
4494 declare
4495 Msg : constant String :=
4496 "argument for pragma% must be a identifier or "
4497 & "static string expression!";
4498 begin
4499 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4500 raise Pragma_Exit;
4501 end;
4502 end if;
4503 end if;
4504 end Check_Arg_Is_External_Name;
4506 -----------------------------
4507 -- Check_Arg_Is_Identifier --
4508 -----------------------------
4510 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4511 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4512 begin
4513 if Nkind (Argx) /= N_Identifier then
4514 Error_Pragma_Arg
4515 ("argument for pragma% must be identifier", Argx);
4516 end if;
4517 end Check_Arg_Is_Identifier;
4519 ----------------------------------
4520 -- Check_Arg_Is_Integer_Literal --
4521 ----------------------------------
4523 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4524 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4525 begin
4526 if Nkind (Argx) /= N_Integer_Literal then
4527 Error_Pragma_Arg
4528 ("argument for pragma% must be integer literal", Argx);
4529 end if;
4530 end Check_Arg_Is_Integer_Literal;
4532 -------------------------------------------
4533 -- Check_Arg_Is_Library_Level_Local_Name --
4534 -------------------------------------------
4536 -- LOCAL_NAME ::=
4537 -- DIRECT_NAME
4538 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4539 -- | library_unit_NAME
4541 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4542 begin
4543 Check_Arg_Is_Local_Name (Arg);
4545 -- If it came from an aspect, we want to give the error just as if it
4546 -- came from source.
4548 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4549 and then (Comes_From_Source (N)
4550 or else Present (Corresponding_Aspect (Parent (Arg))))
4551 then
4552 Error_Pragma_Arg
4553 ("argument for pragma% must be library level entity", Arg);
4554 end if;
4555 end Check_Arg_Is_Library_Level_Local_Name;
4557 -----------------------------
4558 -- Check_Arg_Is_Local_Name --
4559 -----------------------------
4561 -- LOCAL_NAME ::=
4562 -- DIRECT_NAME
4563 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4564 -- | library_unit_NAME
4566 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4567 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4569 begin
4570 -- If this pragma came from an aspect specification, we don't want to
4571 -- check for this error, because that would cause spurious errors, in
4572 -- case a type is frozen in a scope more nested than the type. The
4573 -- aspect itself of course can't be anywhere but on the declaration
4574 -- itself.
4576 if Nkind (Arg) = N_Pragma_Argument_Association then
4577 if From_Aspect_Specification (Parent (Arg)) then
4578 return;
4579 end if;
4581 -- Arg is the Expression of an N_Pragma_Argument_Association
4583 else
4584 if From_Aspect_Specification (Parent (Parent (Arg))) then
4585 return;
4586 end if;
4587 end if;
4589 Analyze (Argx);
4591 if Nkind (Argx) not in N_Direct_Name
4592 and then (Nkind (Argx) /= N_Attribute_Reference
4593 or else Present (Expressions (Argx))
4594 or else Nkind (Prefix (Argx)) /= N_Identifier)
4595 and then (not Is_Entity_Name (Argx)
4596 or else not Is_Compilation_Unit (Entity (Argx)))
4597 then
4598 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
4599 end if;
4601 -- No further check required if not an entity name
4603 if not Is_Entity_Name (Argx) then
4604 null;
4606 else
4607 declare
4608 OK : Boolean;
4609 Ent : constant Entity_Id := Entity (Argx);
4610 Scop : constant Entity_Id := Scope (Ent);
4612 begin
4613 -- Case of a pragma applied to a compilation unit: pragma must
4614 -- occur immediately after the program unit in the compilation.
4616 if Is_Compilation_Unit (Ent) then
4617 declare
4618 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
4620 begin
4621 -- Case of pragma placed immediately after spec
4623 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
4624 OK := True;
4626 -- Case of pragma placed immediately after body
4628 elsif Nkind (Decl) = N_Subprogram_Declaration
4629 and then Present (Corresponding_Body (Decl))
4630 then
4631 OK := Parent (N) =
4632 Aux_Decls_Node
4633 (Parent (Unit_Declaration_Node
4634 (Corresponding_Body (Decl))));
4636 -- All other cases are illegal
4638 else
4639 OK := False;
4640 end if;
4641 end;
4643 -- Special restricted placement rule from 10.2.1(11.8/2)
4645 elsif Is_Generic_Formal (Ent)
4646 and then Prag_Id = Pragma_Preelaborable_Initialization
4647 then
4648 OK := List_Containing (N) =
4649 Generic_Formal_Declarations
4650 (Unit_Declaration_Node (Scop));
4652 -- If this is an aspect applied to a subprogram body, the
4653 -- pragma is inserted in its declarative part.
4655 elsif From_Aspect_Specification (N)
4656 and then Ent = Current_Scope
4657 and then
4658 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
4659 then
4660 OK := True;
4662 -- If the aspect is a predicate (possibly others ???) and the
4663 -- context is a record type, this is a discriminant expression
4664 -- within a type declaration, that freezes the predicated
4665 -- subtype.
4667 elsif From_Aspect_Specification (N)
4668 and then Prag_Id = Pragma_Predicate
4669 and then Ekind (Current_Scope) = E_Record_Type
4670 and then Scop = Scope (Current_Scope)
4671 then
4672 OK := True;
4674 -- Default case, just check that the pragma occurs in the scope
4675 -- of the entity denoted by the name.
4677 else
4678 OK := Current_Scope = Scop;
4679 end if;
4681 if not OK then
4682 Error_Pragma_Arg
4683 ("pragma% argument must be in same declarative part", Arg);
4684 end if;
4685 end;
4686 end if;
4687 end Check_Arg_Is_Local_Name;
4689 ---------------------------------
4690 -- Check_Arg_Is_Locking_Policy --
4691 ---------------------------------
4693 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
4694 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4696 begin
4697 Check_Arg_Is_Identifier (Argx);
4699 if not Is_Locking_Policy_Name (Chars (Argx)) then
4700 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
4701 end if;
4702 end Check_Arg_Is_Locking_Policy;
4704 -----------------------------------------------
4705 -- Check_Arg_Is_Partition_Elaboration_Policy --
4706 -----------------------------------------------
4708 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
4709 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4711 begin
4712 Check_Arg_Is_Identifier (Argx);
4714 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
4715 Error_Pragma_Arg
4716 ("& is not a valid partition elaboration policy name", Argx);
4717 end if;
4718 end Check_Arg_Is_Partition_Elaboration_Policy;
4720 -------------------------
4721 -- Check_Arg_Is_One_Of --
4722 -------------------------
4724 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4725 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4727 begin
4728 Check_Arg_Is_Identifier (Argx);
4730 if not Nam_In (Chars (Argx), N1, N2) then
4731 Error_Msg_Name_2 := N1;
4732 Error_Msg_Name_3 := N2;
4733 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
4734 end if;
4735 end Check_Arg_Is_One_Of;
4737 procedure Check_Arg_Is_One_Of
4738 (Arg : Node_Id;
4739 N1, N2, N3 : Name_Id)
4741 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4743 begin
4744 Check_Arg_Is_Identifier (Argx);
4746 if not Nam_In (Chars (Argx), N1, N2, N3) then
4747 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4748 end if;
4749 end Check_Arg_Is_One_Of;
4751 procedure Check_Arg_Is_One_Of
4752 (Arg : Node_Id;
4753 N1, N2, N3, N4 : Name_Id)
4755 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4757 begin
4758 Check_Arg_Is_Identifier (Argx);
4760 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
4761 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4762 end if;
4763 end Check_Arg_Is_One_Of;
4765 procedure Check_Arg_Is_One_Of
4766 (Arg : Node_Id;
4767 N1, N2, N3, N4, N5 : Name_Id)
4769 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4771 begin
4772 Check_Arg_Is_Identifier (Argx);
4774 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
4775 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4776 end if;
4777 end Check_Arg_Is_One_Of;
4779 ---------------------------------
4780 -- Check_Arg_Is_Queuing_Policy --
4781 ---------------------------------
4783 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
4784 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4786 begin
4787 Check_Arg_Is_Identifier (Argx);
4789 if not Is_Queuing_Policy_Name (Chars (Argx)) then
4790 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
4791 end if;
4792 end Check_Arg_Is_Queuing_Policy;
4794 ---------------------------------------
4795 -- Check_Arg_Is_OK_Static_Expression --
4796 ---------------------------------------
4798 procedure Check_Arg_Is_OK_Static_Expression
4799 (Arg : Node_Id;
4800 Typ : Entity_Id := Empty)
4802 begin
4803 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
4804 end Check_Arg_Is_OK_Static_Expression;
4806 ------------------------------------------
4807 -- Check_Arg_Is_Task_Dispatching_Policy --
4808 ------------------------------------------
4810 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
4811 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4813 begin
4814 Check_Arg_Is_Identifier (Argx);
4816 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
4817 Error_Pragma_Arg
4818 ("& is not an allowed task dispatching policy name", Argx);
4819 end if;
4820 end Check_Arg_Is_Task_Dispatching_Policy;
4822 ---------------------
4823 -- Check_Arg_Order --
4824 ---------------------
4826 procedure Check_Arg_Order (Names : Name_List) is
4827 Arg : Node_Id;
4829 Highest_So_Far : Natural := 0;
4830 -- Highest index in Names seen do far
4832 begin
4833 Arg := Arg1;
4834 for J in 1 .. Arg_Count loop
4835 if Chars (Arg) /= No_Name then
4836 for K in Names'Range loop
4837 if Chars (Arg) = Names (K) then
4838 if K < Highest_So_Far then
4839 Error_Msg_Name_1 := Pname;
4840 Error_Msg_N
4841 ("parameters out of order for pragma%", Arg);
4842 Error_Msg_Name_1 := Names (K);
4843 Error_Msg_Name_2 := Names (Highest_So_Far);
4844 Error_Msg_N ("\% must appear before %", Arg);
4845 raise Pragma_Exit;
4847 else
4848 Highest_So_Far := K;
4849 end if;
4850 end if;
4851 end loop;
4852 end if;
4854 Arg := Next (Arg);
4855 end loop;
4856 end Check_Arg_Order;
4858 --------------------------------
4859 -- Check_At_Least_N_Arguments --
4860 --------------------------------
4862 procedure Check_At_Least_N_Arguments (N : Nat) is
4863 begin
4864 if Arg_Count < N then
4865 Error_Pragma ("too few arguments for pragma%");
4866 end if;
4867 end Check_At_Least_N_Arguments;
4869 -------------------------------
4870 -- Check_At_Most_N_Arguments --
4871 -------------------------------
4873 procedure Check_At_Most_N_Arguments (N : Nat) is
4874 Arg : Node_Id;
4875 begin
4876 if Arg_Count > N then
4877 Arg := Arg1;
4878 for J in 1 .. N loop
4879 Next (Arg);
4880 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
4881 end loop;
4882 end if;
4883 end Check_At_Most_N_Arguments;
4885 ---------------------
4886 -- Check_Component --
4887 ---------------------
4889 procedure Check_Component
4890 (Comp : Node_Id;
4891 UU_Typ : Entity_Id;
4892 In_Variant_Part : Boolean := False)
4894 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
4895 Sindic : constant Node_Id :=
4896 Subtype_Indication (Component_Definition (Comp));
4897 Typ : constant Entity_Id := Etype (Comp_Id);
4899 begin
4900 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4901 -- object constraint, then the component type shall be an Unchecked_
4902 -- Union.
4904 if Nkind (Sindic) = N_Subtype_Indication
4905 and then Has_Per_Object_Constraint (Comp_Id)
4906 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
4907 then
4908 Error_Msg_N
4909 ("component subtype subject to per-object constraint "
4910 & "must be an Unchecked_Union", Comp);
4912 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4913 -- the body of a generic unit, or within the body of any of its
4914 -- descendant library units, no part of the type of a component
4915 -- declared in a variant_part of the unchecked union type shall be of
4916 -- a formal private type or formal private extension declared within
4917 -- the formal part of the generic unit.
4919 elsif Ada_Version >= Ada_2012
4920 and then In_Generic_Body (UU_Typ)
4921 and then In_Variant_Part
4922 and then Is_Private_Type (Typ)
4923 and then Is_Generic_Type (Typ)
4924 then
4925 Error_Msg_N
4926 ("component of unchecked union cannot be of generic type", Comp);
4928 elsif Needs_Finalization (Typ) then
4929 Error_Msg_N
4930 ("component of unchecked union cannot be controlled", Comp);
4932 elsif Has_Task (Typ) then
4933 Error_Msg_N
4934 ("component of unchecked union cannot have tasks", Comp);
4935 end if;
4936 end Check_Component;
4938 ----------------------------
4939 -- Check_Duplicate_Pragma --
4940 ----------------------------
4942 procedure Check_Duplicate_Pragma (E : Entity_Id) is
4943 Id : Entity_Id := E;
4944 P : Node_Id;
4946 begin
4947 -- Nothing to do if this pragma comes from an aspect specification,
4948 -- since we could not be duplicating a pragma, and we dealt with the
4949 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4951 if From_Aspect_Specification (N) then
4952 return;
4953 end if;
4955 -- Otherwise current pragma may duplicate previous pragma or a
4956 -- previously given aspect specification or attribute definition
4957 -- clause for the same pragma.
4959 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
4961 if Present (P) then
4963 -- If the entity is a type, then we have to make sure that the
4964 -- ostensible duplicate is not for a parent type from which this
4965 -- type is derived.
4967 if Is_Type (E) then
4968 if Nkind (P) = N_Pragma then
4969 declare
4970 Args : constant List_Id :=
4971 Pragma_Argument_Associations (P);
4972 begin
4973 if Present (Args)
4974 and then Is_Entity_Name (Expression (First (Args)))
4975 and then Is_Type (Entity (Expression (First (Args))))
4976 and then Entity (Expression (First (Args))) /= E
4977 then
4978 return;
4979 end if;
4980 end;
4982 elsif Nkind (P) = N_Aspect_Specification
4983 and then Is_Type (Entity (P))
4984 and then Entity (P) /= E
4985 then
4986 return;
4987 end if;
4988 end if;
4990 -- Here we have a definite duplicate
4992 Error_Msg_Name_1 := Pragma_Name (N);
4993 Error_Msg_Sloc := Sloc (P);
4995 -- For a single protected or a single task object, the error is
4996 -- issued on the original entity.
4998 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
4999 Id := Defining_Identifier (Original_Node (Parent (Id)));
5000 end if;
5002 if Nkind (P) = N_Aspect_Specification
5003 or else From_Aspect_Specification (P)
5004 then
5005 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5006 else
5007 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5008 end if;
5010 raise Pragma_Exit;
5011 end if;
5012 end Check_Duplicate_Pragma;
5014 ----------------------------------
5015 -- Check_Duplicated_Export_Name --
5016 ----------------------------------
5018 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5019 String_Val : constant String_Id := Strval (Nam);
5021 begin
5022 -- We are only interested in the export case, and in the case of
5023 -- generics, it is the instance, not the template, that is the
5024 -- problem (the template will generate a warning in any case).
5026 if not Inside_A_Generic
5027 and then (Prag_Id = Pragma_Export
5028 or else
5029 Prag_Id = Pragma_Export_Procedure
5030 or else
5031 Prag_Id = Pragma_Export_Valued_Procedure
5032 or else
5033 Prag_Id = Pragma_Export_Function)
5034 then
5035 for J in Externals.First .. Externals.Last loop
5036 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5037 Error_Msg_Sloc := Sloc (Externals.Table (J));
5038 Error_Msg_N ("external name duplicates name given#", Nam);
5039 exit;
5040 end if;
5041 end loop;
5043 Externals.Append (Nam);
5044 end if;
5045 end Check_Duplicated_Export_Name;
5047 ----------------------------------------
5048 -- Check_Expr_Is_OK_Static_Expression --
5049 ----------------------------------------
5051 procedure Check_Expr_Is_OK_Static_Expression
5052 (Expr : Node_Id;
5053 Typ : Entity_Id := Empty)
5055 begin
5056 if Present (Typ) then
5057 Analyze_And_Resolve (Expr, Typ);
5058 else
5059 Analyze_And_Resolve (Expr);
5060 end if;
5062 if Is_OK_Static_Expression (Expr) then
5063 return;
5065 elsif Etype (Expr) = Any_Type then
5066 raise Pragma_Exit;
5068 -- An interesting special case, if we have a string literal and we
5069 -- are in Ada 83 mode, then we allow it even though it will not be
5070 -- flagged as static. This allows the use of Ada 95 pragmas like
5071 -- Import in Ada 83 mode. They will of course be flagged with
5072 -- warnings as usual, but will not cause errors.
5074 elsif Ada_Version = Ada_83
5075 and then Nkind (Expr) = N_String_Literal
5076 then
5077 return;
5079 -- Static expression that raises Constraint_Error. This has already
5080 -- been flagged, so just exit from pragma processing.
5082 elsif Is_OK_Static_Expression (Expr) then
5083 raise Pragma_Exit;
5085 -- Finally, we have a real error
5087 else
5088 Error_Msg_Name_1 := Pname;
5089 Flag_Non_Static_Expr
5090 (Fix_Error ("argument for pragma% must be a static expression!"),
5091 Expr);
5092 raise Pragma_Exit;
5093 end if;
5094 end Check_Expr_Is_OK_Static_Expression;
5096 -------------------------
5097 -- Check_First_Subtype --
5098 -------------------------
5100 procedure Check_First_Subtype (Arg : Node_Id) is
5101 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5102 Ent : constant Entity_Id := Entity (Argx);
5104 begin
5105 if Is_First_Subtype (Ent) then
5106 null;
5108 elsif Is_Type (Ent) then
5109 Error_Pragma_Arg
5110 ("pragma% cannot apply to subtype", Argx);
5112 elsif Is_Object (Ent) then
5113 Error_Pragma_Arg
5114 ("pragma% cannot apply to object, requires a type", Argx);
5116 else
5117 Error_Pragma_Arg
5118 ("pragma% cannot apply to&, requires a type", Argx);
5119 end if;
5120 end Check_First_Subtype;
5122 ----------------------
5123 -- Check_Identifier --
5124 ----------------------
5126 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5127 begin
5128 if Present (Arg)
5129 and then Nkind (Arg) = N_Pragma_Argument_Association
5130 then
5131 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5132 Error_Msg_Name_1 := Pname;
5133 Error_Msg_Name_2 := Id;
5134 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5135 raise Pragma_Exit;
5136 end if;
5137 end if;
5138 end Check_Identifier;
5140 --------------------------------
5141 -- Check_Identifier_Is_One_Of --
5142 --------------------------------
5144 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5145 begin
5146 if Present (Arg)
5147 and then Nkind (Arg) = N_Pragma_Argument_Association
5148 then
5149 if Chars (Arg) = No_Name then
5150 Error_Msg_Name_1 := Pname;
5151 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5152 raise Pragma_Exit;
5154 elsif Chars (Arg) /= N1
5155 and then Chars (Arg) /= N2
5156 then
5157 Error_Msg_Name_1 := Pname;
5158 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5159 raise Pragma_Exit;
5160 end if;
5161 end if;
5162 end Check_Identifier_Is_One_Of;
5164 ---------------------------
5165 -- Check_In_Main_Program --
5166 ---------------------------
5168 procedure Check_In_Main_Program is
5169 P : constant Node_Id := Parent (N);
5171 begin
5172 -- Must be in subprogram body
5174 if Nkind (P) /= N_Subprogram_Body then
5175 Error_Pragma ("% pragma allowed only in subprogram");
5177 -- Otherwise warn if obviously not main program
5179 elsif Present (Parameter_Specifications (Specification (P)))
5180 or else not Is_Compilation_Unit (Defining_Entity (P))
5181 then
5182 Error_Msg_Name_1 := Pname;
5183 Error_Msg_N
5184 ("??pragma% is only effective in main program", N);
5185 end if;
5186 end Check_In_Main_Program;
5188 ---------------------------------------
5189 -- Check_Interrupt_Or_Attach_Handler --
5190 ---------------------------------------
5192 procedure Check_Interrupt_Or_Attach_Handler is
5193 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5194 Handler_Proc, Proc_Scope : Entity_Id;
5196 begin
5197 Analyze (Arg1_X);
5199 if Prag_Id = Pragma_Interrupt_Handler then
5200 Check_Restriction (No_Dynamic_Attachment, N);
5201 end if;
5203 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5204 Proc_Scope := Scope (Handler_Proc);
5206 if Ekind (Proc_Scope) /= E_Protected_Type then
5207 Error_Pragma_Arg
5208 ("argument of pragma% must be protected procedure", Arg1);
5209 end if;
5211 -- For pragma case (as opposed to access case), check placement.
5212 -- We don't need to do that for aspects, because we have the
5213 -- check that they aspect applies an appropriate procedure.
5215 if not From_Aspect_Specification (N)
5216 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5217 then
5218 Error_Pragma ("pragma% must be in protected definition");
5219 end if;
5221 if not Is_Library_Level_Entity (Proc_Scope) then
5222 Error_Pragma_Arg
5223 ("argument for pragma% must be library level entity", Arg1);
5224 end if;
5226 -- AI05-0033: A pragma cannot appear within a generic body, because
5227 -- instance can be in a nested scope. The check that protected type
5228 -- is itself a library-level declaration is done elsewhere.
5230 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5231 -- handle code prior to AI-0033. Analysis tools typically are not
5232 -- interested in this pragma in any case, so no need to worry too
5233 -- much about its placement.
5235 if Inside_A_Generic then
5236 if Ekind (Scope (Current_Scope)) = E_Generic_Package
5237 and then In_Package_Body (Scope (Current_Scope))
5238 and then not Relaxed_RM_Semantics
5239 then
5240 Error_Pragma ("pragma% cannot be used inside a generic");
5241 end if;
5242 end if;
5243 end Check_Interrupt_Or_Attach_Handler;
5245 ---------------------------------
5246 -- Check_Loop_Pragma_Placement --
5247 ---------------------------------
5249 procedure Check_Loop_Pragma_Placement is
5250 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5251 -- Verify whether the current pragma is properly grouped with other
5252 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5253 -- related loop where the pragma appears.
5255 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5256 -- Determine whether an arbitrary statement Stmt denotes pragma
5257 -- Loop_Invariant or Loop_Variant.
5259 procedure Placement_Error (Constr : Node_Id);
5260 pragma No_Return (Placement_Error);
5261 -- Node Constr denotes the last loop restricted construct before we
5262 -- encountered an illegal relation between enclosing constructs. Emit
5263 -- an error depending on what Constr was.
5265 --------------------------------
5266 -- Check_Loop_Pragma_Grouping --
5267 --------------------------------
5269 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5270 Stop_Search : exception;
5271 -- This exception is used to terminate the recursive descent of
5272 -- routine Check_Grouping.
5274 procedure Check_Grouping (L : List_Id);
5275 -- Find the first group of pragmas in list L and if successful,
5276 -- ensure that the current pragma is part of that group. The
5277 -- routine raises Stop_Search once such a check is performed to
5278 -- halt the recursive descent.
5280 procedure Grouping_Error (Prag : Node_Id);
5281 pragma No_Return (Grouping_Error);
5282 -- Emit an error concerning the current pragma indicating that it
5283 -- should be placed after pragma Prag.
5285 --------------------
5286 -- Check_Grouping --
5287 --------------------
5289 procedure Check_Grouping (L : List_Id) is
5290 HSS : Node_Id;
5291 Prag : Node_Id;
5292 Stmt : Node_Id;
5294 begin
5295 -- Inspect the list of declarations or statements looking for
5296 -- the first grouping of pragmas:
5298 -- loop
5299 -- pragma Loop_Invariant ...;
5300 -- pragma Loop_Variant ...;
5301 -- . . . -- (1)
5302 -- pragma Loop_Variant ...; -- current pragma
5304 -- If the current pragma is not in the grouping, then it must
5305 -- either appear in a different declarative or statement list
5306 -- or the construct at (1) is separating the pragma from the
5307 -- grouping.
5309 Stmt := First (L);
5310 while Present (Stmt) loop
5312 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5313 -- inside a loop or a block housed inside a loop. Inspect
5314 -- the declarations and statements of the block as they may
5315 -- contain the first grouping.
5317 if Nkind (Stmt) = N_Block_Statement then
5318 HSS := Handled_Statement_Sequence (Stmt);
5320 Check_Grouping (Declarations (Stmt));
5322 if Present (HSS) then
5323 Check_Grouping (Statements (HSS));
5324 end if;
5326 -- First pragma of the first topmost grouping has been found
5328 elsif Is_Loop_Pragma (Stmt) then
5330 -- The group and the current pragma are not in the same
5331 -- declarative or statement list.
5333 if List_Containing (Stmt) /= List_Containing (N) then
5334 Grouping_Error (Stmt);
5336 -- Try to reach the current pragma from the first pragma
5337 -- of the grouping while skipping other members:
5339 -- pragma Loop_Invariant ...; -- first pragma
5340 -- pragma Loop_Variant ...; -- member
5341 -- . . .
5342 -- pragma Loop_Variant ...; -- current pragma
5344 else
5345 while Present (Stmt) loop
5347 -- The current pragma is either the first pragma
5348 -- of the group or is a member of the group. Stop
5349 -- the search as the placement is legal.
5351 if Stmt = N then
5352 raise Stop_Search;
5354 -- Skip group members, but keep track of the last
5355 -- pragma in the group.
5357 elsif Is_Loop_Pragma (Stmt) then
5358 Prag := Stmt;
5360 -- Skip declarations and statements generated by
5361 -- the compiler during expansion.
5363 elsif not Comes_From_Source (Stmt) then
5364 null;
5366 -- A non-pragma is separating the group from the
5367 -- current pragma, the placement is illegal.
5369 else
5370 Grouping_Error (Prag);
5371 end if;
5373 Next (Stmt);
5374 end loop;
5376 -- If the traversal did not reach the current pragma,
5377 -- then the list must be malformed.
5379 raise Program_Error;
5380 end if;
5381 end if;
5383 Next (Stmt);
5384 end loop;
5385 end Check_Grouping;
5387 --------------------
5388 -- Grouping_Error --
5389 --------------------
5391 procedure Grouping_Error (Prag : Node_Id) is
5392 begin
5393 Error_Msg_Sloc := Sloc (Prag);
5394 Error_Pragma ("pragma% must appear next to pragma#");
5395 end Grouping_Error;
5397 -- Start of processing for Check_Loop_Pragma_Grouping
5399 begin
5400 -- Inspect the statements of the loop or nested blocks housed
5401 -- within to determine whether the current pragma is part of the
5402 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5404 Check_Grouping (Statements (Loop_Stmt));
5406 exception
5407 when Stop_Search => null;
5408 end Check_Loop_Pragma_Grouping;
5410 --------------------
5411 -- Is_Loop_Pragma --
5412 --------------------
5414 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5415 begin
5416 -- Inspect the original node as Loop_Invariant and Loop_Variant
5417 -- pragmas are rewritten to null when assertions are disabled.
5419 if Nkind (Original_Node (Stmt)) = N_Pragma then
5420 return
5421 Nam_In (Pragma_Name (Original_Node (Stmt)),
5422 Name_Loop_Invariant,
5423 Name_Loop_Variant);
5424 else
5425 return False;
5426 end if;
5427 end Is_Loop_Pragma;
5429 ---------------------
5430 -- Placement_Error --
5431 ---------------------
5433 procedure Placement_Error (Constr : Node_Id) is
5434 LA : constant String := " with Loop_Entry";
5436 begin
5437 if Prag_Id = Pragma_Assert then
5438 Error_Msg_String (1 .. LA'Length) := LA;
5439 Error_Msg_Strlen := LA'Length;
5440 else
5441 Error_Msg_Strlen := 0;
5442 end if;
5444 if Nkind (Constr) = N_Pragma then
5445 Error_Pragma
5446 ("pragma %~ must appear immediately within the statements "
5447 & "of a loop");
5448 else
5449 Error_Pragma_Arg
5450 ("block containing pragma %~ must appear immediately within "
5451 & "the statements of a loop", Constr);
5452 end if;
5453 end Placement_Error;
5455 -- Local declarations
5457 Prev : Node_Id;
5458 Stmt : Node_Id;
5460 -- Start of processing for Check_Loop_Pragma_Placement
5462 begin
5463 -- Check that pragma appears immediately within a loop statement,
5464 -- ignoring intervening block statements.
5466 Prev := N;
5467 Stmt := Parent (N);
5468 while Present (Stmt) loop
5470 -- The pragma or previous block must appear immediately within the
5471 -- current block's declarative or statement part.
5473 if Nkind (Stmt) = N_Block_Statement then
5474 if (No (Declarations (Stmt))
5475 or else List_Containing (Prev) /= Declarations (Stmt))
5476 and then
5477 List_Containing (Prev) /=
5478 Statements (Handled_Statement_Sequence (Stmt))
5479 then
5480 Placement_Error (Prev);
5481 return;
5483 -- Keep inspecting the parents because we are now within a
5484 -- chain of nested blocks.
5486 else
5487 Prev := Stmt;
5488 Stmt := Parent (Stmt);
5489 end if;
5491 -- The pragma or previous block must appear immediately within the
5492 -- statements of the loop.
5494 elsif Nkind (Stmt) = N_Loop_Statement then
5495 if List_Containing (Prev) /= Statements (Stmt) then
5496 Placement_Error (Prev);
5497 end if;
5499 -- Stop the traversal because we reached the innermost loop
5500 -- regardless of whether we encountered an error or not.
5502 exit;
5504 -- Ignore a handled statement sequence. Note that this node may
5505 -- be related to a subprogram body in which case we will emit an
5506 -- error on the next iteration of the search.
5508 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5509 Stmt := Parent (Stmt);
5511 -- Any other statement breaks the chain from the pragma to the
5512 -- loop.
5514 else
5515 Placement_Error (Prev);
5516 return;
5517 end if;
5518 end loop;
5520 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5521 -- grouped together with other such pragmas.
5523 if Is_Loop_Pragma (N) then
5525 -- The previous check should have located the related loop
5527 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5528 Check_Loop_Pragma_Grouping (Stmt);
5529 end if;
5530 end Check_Loop_Pragma_Placement;
5532 -------------------------------------------
5533 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5534 -------------------------------------------
5536 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5537 P : Node_Id;
5539 begin
5540 P := Parent (N);
5541 loop
5542 if No (P) then
5543 exit;
5545 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5546 exit;
5548 elsif Nkind_In (P, N_Package_Specification,
5549 N_Block_Statement)
5550 then
5551 return;
5553 -- Note: the following tests seem a little peculiar, because
5554 -- they test for bodies, but if we were in the statement part
5555 -- of the body, we would already have hit the handled statement
5556 -- sequence, so the only way we get here is by being in the
5557 -- declarative part of the body.
5559 elsif Nkind_In (P, N_Subprogram_Body,
5560 N_Package_Body,
5561 N_Task_Body,
5562 N_Entry_Body)
5563 then
5564 return;
5565 end if;
5567 P := Parent (P);
5568 end loop;
5570 Error_Pragma ("pragma% is not in declarative part or package spec");
5571 end Check_Is_In_Decl_Part_Or_Package_Spec;
5573 -------------------------
5574 -- Check_No_Identifier --
5575 -------------------------
5577 procedure Check_No_Identifier (Arg : Node_Id) is
5578 begin
5579 if Nkind (Arg) = N_Pragma_Argument_Association
5580 and then Chars (Arg) /= No_Name
5581 then
5582 Error_Pragma_Arg_Ident
5583 ("pragma% does not permit identifier& here", Arg);
5584 end if;
5585 end Check_No_Identifier;
5587 --------------------------
5588 -- Check_No_Identifiers --
5589 --------------------------
5591 procedure Check_No_Identifiers is
5592 Arg_Node : Node_Id;
5593 begin
5594 Arg_Node := Arg1;
5595 for J in 1 .. Arg_Count loop
5596 Check_No_Identifier (Arg_Node);
5597 Next (Arg_Node);
5598 end loop;
5599 end Check_No_Identifiers;
5601 ------------------------
5602 -- Check_No_Link_Name --
5603 ------------------------
5605 procedure Check_No_Link_Name is
5606 begin
5607 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
5608 Arg4 := Arg3;
5609 end if;
5611 if Present (Arg4) then
5612 Error_Pragma_Arg
5613 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
5614 end if;
5615 end Check_No_Link_Name;
5617 -------------------------------
5618 -- Check_Optional_Identifier --
5619 -------------------------------
5621 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
5622 begin
5623 if Present (Arg)
5624 and then Nkind (Arg) = N_Pragma_Argument_Association
5625 and then Chars (Arg) /= No_Name
5626 then
5627 if Chars (Arg) /= Id then
5628 Error_Msg_Name_1 := Pname;
5629 Error_Msg_Name_2 := Id;
5630 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5631 raise Pragma_Exit;
5632 end if;
5633 end if;
5634 end Check_Optional_Identifier;
5636 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
5637 begin
5638 Name_Buffer (1 .. Id'Length) := Id;
5639 Name_Len := Id'Length;
5640 Check_Optional_Identifier (Arg, Name_Find);
5641 end Check_Optional_Identifier;
5643 -------------------------------------
5644 -- Check_Static_Boolean_Expression --
5645 -------------------------------------
5647 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
5648 begin
5649 if Present (Expr) then
5650 Analyze_And_Resolve (Expr, Standard_Boolean);
5652 if not Is_OK_Static_Expression (Expr) then
5653 Error_Pragma_Arg
5654 ("expression of pragma % must be static", Expr);
5655 end if;
5656 end if;
5657 end Check_Static_Boolean_Expression;
5659 -----------------------------
5660 -- Check_Static_Constraint --
5661 -----------------------------
5663 -- Note: for convenience in writing this procedure, in addition to
5664 -- the officially (i.e. by spec) allowed argument which is always a
5665 -- constraint, it also allows ranges and discriminant associations.
5666 -- Above is not clear ???
5668 procedure Check_Static_Constraint (Constr : Node_Id) is
5670 procedure Require_Static (E : Node_Id);
5671 -- Require given expression to be static expression
5673 --------------------
5674 -- Require_Static --
5675 --------------------
5677 procedure Require_Static (E : Node_Id) is
5678 begin
5679 if not Is_OK_Static_Expression (E) then
5680 Flag_Non_Static_Expr
5681 ("non-static constraint not allowed in Unchecked_Union!", E);
5682 raise Pragma_Exit;
5683 end if;
5684 end Require_Static;
5686 -- Start of processing for Check_Static_Constraint
5688 begin
5689 case Nkind (Constr) is
5690 when N_Discriminant_Association =>
5691 Require_Static (Expression (Constr));
5693 when N_Range =>
5694 Require_Static (Low_Bound (Constr));
5695 Require_Static (High_Bound (Constr));
5697 when N_Attribute_Reference =>
5698 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
5699 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
5701 when N_Range_Constraint =>
5702 Check_Static_Constraint (Range_Expression (Constr));
5704 when N_Index_Or_Discriminant_Constraint =>
5705 declare
5706 IDC : Entity_Id;
5707 begin
5708 IDC := First (Constraints (Constr));
5709 while Present (IDC) loop
5710 Check_Static_Constraint (IDC);
5711 Next (IDC);
5712 end loop;
5713 end;
5715 when others =>
5716 null;
5717 end case;
5718 end Check_Static_Constraint;
5720 --------------------------------------
5721 -- Check_Valid_Configuration_Pragma --
5722 --------------------------------------
5724 -- A configuration pragma must appear in the context clause of a
5725 -- compilation unit, and only other pragmas may precede it. Note that
5726 -- the test also allows use in a configuration pragma file.
5728 procedure Check_Valid_Configuration_Pragma is
5729 begin
5730 if not Is_Configuration_Pragma then
5731 Error_Pragma ("incorrect placement for configuration pragma%");
5732 end if;
5733 end Check_Valid_Configuration_Pragma;
5735 -------------------------------------
5736 -- Check_Valid_Library_Unit_Pragma --
5737 -------------------------------------
5739 procedure Check_Valid_Library_Unit_Pragma is
5740 Plist : List_Id;
5741 Parent_Node : Node_Id;
5742 Unit_Name : Entity_Id;
5743 Unit_Kind : Node_Kind;
5744 Unit_Node : Node_Id;
5745 Sindex : Source_File_Index;
5747 begin
5748 if not Is_List_Member (N) then
5749 Pragma_Misplaced;
5751 else
5752 Plist := List_Containing (N);
5753 Parent_Node := Parent (Plist);
5755 if Parent_Node = Empty then
5756 Pragma_Misplaced;
5758 -- Case of pragma appearing after a compilation unit. In this case
5759 -- it must have an argument with the corresponding name and must
5760 -- be part of the following pragmas of its parent.
5762 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
5763 if Plist /= Pragmas_After (Parent_Node) then
5764 Pragma_Misplaced;
5766 elsif Arg_Count = 0 then
5767 Error_Pragma
5768 ("argument required if outside compilation unit");
5770 else
5771 Check_No_Identifiers;
5772 Check_Arg_Count (1);
5773 Unit_Node := Unit (Parent (Parent_Node));
5774 Unit_Kind := Nkind (Unit_Node);
5776 Analyze (Get_Pragma_Arg (Arg1));
5778 if Unit_Kind = N_Generic_Subprogram_Declaration
5779 or else Unit_Kind = N_Subprogram_Declaration
5780 then
5781 Unit_Name := Defining_Entity (Unit_Node);
5783 elsif Unit_Kind in N_Generic_Instantiation then
5784 Unit_Name := Defining_Entity (Unit_Node);
5786 else
5787 Unit_Name := Cunit_Entity (Current_Sem_Unit);
5788 end if;
5790 if Chars (Unit_Name) /=
5791 Chars (Entity (Get_Pragma_Arg (Arg1)))
5792 then
5793 Error_Pragma_Arg
5794 ("pragma% argument is not current unit name", Arg1);
5795 end if;
5797 if Ekind (Unit_Name) = E_Package
5798 and then Present (Renamed_Entity (Unit_Name))
5799 then
5800 Error_Pragma ("pragma% not allowed for renamed package");
5801 end if;
5802 end if;
5804 -- Pragma appears other than after a compilation unit
5806 else
5807 -- Here we check for the generic instantiation case and also
5808 -- for the case of processing a generic formal package. We
5809 -- detect these cases by noting that the Sloc on the node
5810 -- does not belong to the current compilation unit.
5812 Sindex := Source_Index (Current_Sem_Unit);
5814 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
5815 Rewrite (N, Make_Null_Statement (Loc));
5816 return;
5818 -- If before first declaration, the pragma applies to the
5819 -- enclosing unit, and the name if present must be this name.
5821 elsif Is_Before_First_Decl (N, Plist) then
5822 Unit_Node := Unit_Declaration_Node (Current_Scope);
5823 Unit_Kind := Nkind (Unit_Node);
5825 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
5826 Pragma_Misplaced;
5828 elsif Unit_Kind = N_Subprogram_Body
5829 and then not Acts_As_Spec (Unit_Node)
5830 then
5831 Pragma_Misplaced;
5833 elsif Nkind (Parent_Node) = N_Package_Body then
5834 Pragma_Misplaced;
5836 elsif Nkind (Parent_Node) = N_Package_Specification
5837 and then Plist = Private_Declarations (Parent_Node)
5838 then
5839 Pragma_Misplaced;
5841 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
5842 or else Nkind (Parent_Node) =
5843 N_Generic_Subprogram_Declaration)
5844 and then Plist = Generic_Formal_Declarations (Parent_Node)
5845 then
5846 Pragma_Misplaced;
5848 elsif Arg_Count > 0 then
5849 Analyze (Get_Pragma_Arg (Arg1));
5851 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
5852 Error_Pragma_Arg
5853 ("name in pragma% must be enclosing unit", Arg1);
5854 end if;
5856 -- It is legal to have no argument in this context
5858 else
5859 return;
5860 end if;
5862 -- Error if not before first declaration. This is because a
5863 -- library unit pragma argument must be the name of a library
5864 -- unit (RM 10.1.5(7)), but the only names permitted in this
5865 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5866 -- generic subprogram declarations or generic instantiations.
5868 else
5869 Error_Pragma
5870 ("pragma% misplaced, must be before first declaration");
5871 end if;
5872 end if;
5873 end if;
5874 end Check_Valid_Library_Unit_Pragma;
5876 -------------------
5877 -- Check_Variant --
5878 -------------------
5880 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5881 Clist : constant Node_Id := Component_List (Variant);
5882 Comp : Node_Id;
5884 begin
5885 Comp := First (Component_Items (Clist));
5886 while Present (Comp) loop
5887 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5888 Next (Comp);
5889 end loop;
5890 end Check_Variant;
5892 ---------------------------
5893 -- Ensure_Aggregate_Form --
5894 ---------------------------
5896 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
5897 CFSD : constant Boolean := Get_Comes_From_Source_Default;
5898 Expr : constant Node_Id := Expression (Arg);
5899 Loc : constant Source_Ptr := Sloc (Expr);
5900 Comps : List_Id := No_List;
5901 Exprs : List_Id := No_List;
5902 Nam : Name_Id := No_Name;
5903 Nam_Loc : Source_Ptr;
5905 begin
5906 -- The pragma argument is in positional form:
5908 -- pragma Depends (Nam => ...)
5909 -- ^
5910 -- Chars field
5912 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5913 -- argument association.
5915 if Nkind (Arg) = N_Pragma_Argument_Association then
5916 Nam := Chars (Arg);
5917 Nam_Loc := Sloc (Arg);
5919 -- Remove the pragma argument name as this will be captured in the
5920 -- aggregate.
5922 Set_Chars (Arg, No_Name);
5923 end if;
5925 -- The argument is already in aggregate form, but the presence of a
5926 -- name causes this to be interpreted as named association which in
5927 -- turn must be converted into an aggregate.
5929 -- pragma Global (In_Out => (A, B, C))
5930 -- ^ ^
5931 -- name aggregate
5933 -- pragma Global ((In_Out => (A, B, C)))
5934 -- ^ ^
5935 -- aggregate aggregate
5937 if Nkind (Expr) = N_Aggregate then
5938 if Nam = No_Name then
5939 return;
5940 end if;
5942 -- Do not transform a null argument into an aggregate as N_Null has
5943 -- special meaning in formal verification pragmas.
5945 elsif Nkind (Expr) = N_Null then
5946 return;
5947 end if;
5949 -- Everything comes from source if the original comes from source
5951 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
5953 -- Positional argument is transformed into an aggregate with an
5954 -- Expressions list.
5956 if Nam = No_Name then
5957 Exprs := New_List (Relocate_Node (Expr));
5959 -- An associative argument is transformed into an aggregate with
5960 -- Component_Associations.
5962 else
5963 Comps := New_List (
5964 Make_Component_Association (Loc,
5965 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
5966 Expression => Relocate_Node (Expr)));
5967 end if;
5969 Set_Expression (Arg,
5970 Make_Aggregate (Loc,
5971 Component_Associations => Comps,
5972 Expressions => Exprs));
5974 -- Restore Comes_From_Source default
5976 Set_Comes_From_Source_Default (CFSD);
5977 end Ensure_Aggregate_Form;
5979 ------------------
5980 -- Error_Pragma --
5981 ------------------
5983 procedure Error_Pragma (Msg : String) is
5984 begin
5985 Error_Msg_Name_1 := Pname;
5986 Error_Msg_N (Fix_Error (Msg), N);
5987 raise Pragma_Exit;
5988 end Error_Pragma;
5990 ----------------------
5991 -- Error_Pragma_Arg --
5992 ----------------------
5994 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5995 begin
5996 Error_Msg_Name_1 := Pname;
5997 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
5998 raise Pragma_Exit;
5999 end Error_Pragma_Arg;
6001 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6002 begin
6003 Error_Msg_Name_1 := Pname;
6004 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6005 Error_Pragma_Arg (Msg2, Arg);
6006 end Error_Pragma_Arg;
6008 ----------------------------
6009 -- Error_Pragma_Arg_Ident --
6010 ----------------------------
6012 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6013 begin
6014 Error_Msg_Name_1 := Pname;
6015 Error_Msg_N (Fix_Error (Msg), Arg);
6016 raise Pragma_Exit;
6017 end Error_Pragma_Arg_Ident;
6019 ----------------------
6020 -- Error_Pragma_Ref --
6021 ----------------------
6023 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6024 begin
6025 Error_Msg_Name_1 := Pname;
6026 Error_Msg_Sloc := Sloc (Ref);
6027 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6028 raise Pragma_Exit;
6029 end Error_Pragma_Ref;
6031 ------------------------
6032 -- Find_Lib_Unit_Name --
6033 ------------------------
6035 function Find_Lib_Unit_Name return Entity_Id is
6036 begin
6037 -- Return inner compilation unit entity, for case of nested
6038 -- categorization pragmas. This happens in generic unit.
6040 if Nkind (Parent (N)) = N_Package_Specification
6041 and then Defining_Entity (Parent (N)) /= Current_Scope
6042 then
6043 return Defining_Entity (Parent (N));
6044 else
6045 return Current_Scope;
6046 end if;
6047 end Find_Lib_Unit_Name;
6049 ----------------------------
6050 -- Find_Program_Unit_Name --
6051 ----------------------------
6053 procedure Find_Program_Unit_Name (Id : Node_Id) is
6054 Unit_Name : Entity_Id;
6055 Unit_Kind : Node_Kind;
6056 P : constant Node_Id := Parent (N);
6058 begin
6059 if Nkind (P) = N_Compilation_Unit then
6060 Unit_Kind := Nkind (Unit (P));
6062 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6063 N_Package_Declaration)
6064 or else Unit_Kind in N_Generic_Declaration
6065 then
6066 Unit_Name := Defining_Entity (Unit (P));
6068 if Chars (Id) = Chars (Unit_Name) then
6069 Set_Entity (Id, Unit_Name);
6070 Set_Etype (Id, Etype (Unit_Name));
6071 else
6072 Set_Etype (Id, Any_Type);
6073 Error_Pragma
6074 ("cannot find program unit referenced by pragma%");
6075 end if;
6077 else
6078 Set_Etype (Id, Any_Type);
6079 Error_Pragma ("pragma% inapplicable to this unit");
6080 end if;
6082 else
6083 Analyze (Id);
6084 end if;
6085 end Find_Program_Unit_Name;
6087 -----------------------------------------
6088 -- Find_Unique_Parameterless_Procedure --
6089 -----------------------------------------
6091 function Find_Unique_Parameterless_Procedure
6092 (Name : Entity_Id;
6093 Arg : Node_Id) return Entity_Id
6095 Proc : Entity_Id := Empty;
6097 begin
6098 -- The body of this procedure needs some comments ???
6100 if not Is_Entity_Name (Name) then
6101 Error_Pragma_Arg
6102 ("argument of pragma% must be entity name", Arg);
6104 elsif not Is_Overloaded (Name) then
6105 Proc := Entity (Name);
6107 if Ekind (Proc) /= E_Procedure
6108 or else Present (First_Formal (Proc))
6109 then
6110 Error_Pragma_Arg
6111 ("argument of pragma% must be parameterless procedure", Arg);
6112 end if;
6114 else
6115 declare
6116 Found : Boolean := False;
6117 It : Interp;
6118 Index : Interp_Index;
6120 begin
6121 Get_First_Interp (Name, Index, It);
6122 while Present (It.Nam) loop
6123 Proc := It.Nam;
6125 if Ekind (Proc) = E_Procedure
6126 and then No (First_Formal (Proc))
6127 then
6128 if not Found then
6129 Found := True;
6130 Set_Entity (Name, Proc);
6131 Set_Is_Overloaded (Name, False);
6132 else
6133 Error_Pragma_Arg
6134 ("ambiguous handler name for pragma% ", Arg);
6135 end if;
6136 end if;
6138 Get_Next_Interp (Index, It);
6139 end loop;
6141 if not Found then
6142 Error_Pragma_Arg
6143 ("argument of pragma% must be parameterless procedure",
6144 Arg);
6145 else
6146 Proc := Entity (Name);
6147 end if;
6148 end;
6149 end if;
6151 return Proc;
6152 end Find_Unique_Parameterless_Procedure;
6154 ---------------
6155 -- Fix_Error --
6156 ---------------
6158 function Fix_Error (Msg : String) return String is
6159 Res : String (Msg'Range) := Msg;
6160 Res_Last : Natural := Msg'Last;
6161 J : Natural;
6163 begin
6164 -- If we have a rewriting of another pragma, go to that pragma
6166 if Is_Rewrite_Substitution (N)
6167 and then Nkind (Original_Node (N)) = N_Pragma
6168 then
6169 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6170 end if;
6172 -- Case where pragma comes from an aspect specification
6174 if From_Aspect_Specification (N) then
6176 -- Change appearence of "pragma" in message to "aspect"
6178 J := Res'First;
6179 while J <= Res_Last - 5 loop
6180 if Res (J .. J + 5) = "pragma" then
6181 Res (J .. J + 5) := "aspect";
6182 J := J + 6;
6184 else
6185 J := J + 1;
6186 end if;
6187 end loop;
6189 -- Change "argument of" at start of message to "entity for"
6191 if Res'Length > 11
6192 and then Res (Res'First .. Res'First + 10) = "argument of"
6193 then
6194 Res (Res'First .. Res'First + 9) := "entity for";
6195 Res (Res'First + 10 .. Res_Last - 1) :=
6196 Res (Res'First + 11 .. Res_Last);
6197 Res_Last := Res_Last - 1;
6198 end if;
6200 -- Change "argument" at start of message to "entity"
6202 if Res'Length > 8
6203 and then Res (Res'First .. Res'First + 7) = "argument"
6204 then
6205 Res (Res'First .. Res'First + 5) := "entity";
6206 Res (Res'First + 6 .. Res_Last - 2) :=
6207 Res (Res'First + 8 .. Res_Last);
6208 Res_Last := Res_Last - 2;
6209 end if;
6211 -- Get name from corresponding aspect
6213 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6214 end if;
6216 -- Return possibly modified message
6218 return Res (Res'First .. Res_Last);
6219 end Fix_Error;
6221 -------------------------
6222 -- Gather_Associations --
6223 -------------------------
6225 procedure Gather_Associations
6226 (Names : Name_List;
6227 Args : out Args_List)
6229 Arg : Node_Id;
6231 begin
6232 -- Initialize all parameters to Empty
6234 for J in Args'Range loop
6235 Args (J) := Empty;
6236 end loop;
6238 -- That's all we have to do if there are no argument associations
6240 if No (Pragma_Argument_Associations (N)) then
6241 return;
6242 end if;
6244 -- Otherwise first deal with any positional parameters present
6246 Arg := First (Pragma_Argument_Associations (N));
6247 for Index in Args'Range loop
6248 exit when No (Arg) or else Chars (Arg) /= No_Name;
6249 Args (Index) := Get_Pragma_Arg (Arg);
6250 Next (Arg);
6251 end loop;
6253 -- Positional parameters all processed, if any left, then we
6254 -- have too many positional parameters.
6256 if Present (Arg) and then Chars (Arg) = No_Name then
6257 Error_Pragma_Arg
6258 ("too many positional associations for pragma%", Arg);
6259 end if;
6261 -- Process named parameters if any are present
6263 while Present (Arg) loop
6264 if Chars (Arg) = No_Name then
6265 Error_Pragma_Arg
6266 ("positional association cannot follow named association",
6267 Arg);
6269 else
6270 for Index in Names'Range loop
6271 if Names (Index) = Chars (Arg) then
6272 if Present (Args (Index)) then
6273 Error_Pragma_Arg
6274 ("duplicate argument association for pragma%", Arg);
6275 else
6276 Args (Index) := Get_Pragma_Arg (Arg);
6277 exit;
6278 end if;
6279 end if;
6281 if Index = Names'Last then
6282 Error_Msg_Name_1 := Pname;
6283 Error_Msg_N ("pragma% does not allow & argument", Arg);
6285 -- Check for possible misspelling
6287 for Index1 in Names'Range loop
6288 if Is_Bad_Spelling_Of
6289 (Chars (Arg), Names (Index1))
6290 then
6291 Error_Msg_Name_1 := Names (Index1);
6292 Error_Msg_N -- CODEFIX
6293 ("\possible misspelling of%", Arg);
6294 exit;
6295 end if;
6296 end loop;
6298 raise Pragma_Exit;
6299 end if;
6300 end loop;
6301 end if;
6303 Next (Arg);
6304 end loop;
6305 end Gather_Associations;
6307 -----------------
6308 -- GNAT_Pragma --
6309 -----------------
6311 procedure GNAT_Pragma is
6312 begin
6313 -- We need to check the No_Implementation_Pragmas restriction for
6314 -- the case of a pragma from source. Note that the case of aspects
6315 -- generating corresponding pragmas marks these pragmas as not being
6316 -- from source, so this test also catches that case.
6318 if Comes_From_Source (N) then
6319 Check_Restriction (No_Implementation_Pragmas, N);
6320 end if;
6321 end GNAT_Pragma;
6323 --------------------------
6324 -- Is_Before_First_Decl --
6325 --------------------------
6327 function Is_Before_First_Decl
6328 (Pragma_Node : Node_Id;
6329 Decls : List_Id) return Boolean
6331 Item : Node_Id := First (Decls);
6333 begin
6334 -- Only other pragmas can come before this pragma
6336 loop
6337 if No (Item) or else Nkind (Item) /= N_Pragma then
6338 return False;
6340 elsif Item = Pragma_Node then
6341 return True;
6342 end if;
6344 Next (Item);
6345 end loop;
6346 end Is_Before_First_Decl;
6348 -----------------------------
6349 -- Is_Configuration_Pragma --
6350 -----------------------------
6352 -- A configuration pragma must appear in the context clause of a
6353 -- compilation unit, and only other pragmas may precede it. Note that
6354 -- the test below also permits use in a configuration pragma file.
6356 function Is_Configuration_Pragma return Boolean is
6357 Lis : constant List_Id := List_Containing (N);
6358 Par : constant Node_Id := Parent (N);
6359 Prg : Node_Id;
6361 begin
6362 -- If no parent, then we are in the configuration pragma file,
6363 -- so the placement is definitely appropriate.
6365 if No (Par) then
6366 return True;
6368 -- Otherwise we must be in the context clause of a compilation unit
6369 -- and the only thing allowed before us in the context list is more
6370 -- configuration pragmas.
6372 elsif Nkind (Par) = N_Compilation_Unit
6373 and then Context_Items (Par) = Lis
6374 then
6375 Prg := First (Lis);
6377 loop
6378 if Prg = N then
6379 return True;
6380 elsif Nkind (Prg) /= N_Pragma then
6381 return False;
6382 end if;
6384 Next (Prg);
6385 end loop;
6387 else
6388 return False;
6389 end if;
6390 end Is_Configuration_Pragma;
6392 --------------------------
6393 -- Is_In_Context_Clause --
6394 --------------------------
6396 function Is_In_Context_Clause return Boolean is
6397 Plist : List_Id;
6398 Parent_Node : Node_Id;
6400 begin
6401 if not Is_List_Member (N) then
6402 return False;
6404 else
6405 Plist := List_Containing (N);
6406 Parent_Node := Parent (Plist);
6408 if Parent_Node = Empty
6409 or else Nkind (Parent_Node) /= N_Compilation_Unit
6410 or else Context_Items (Parent_Node) /= Plist
6411 then
6412 return False;
6413 end if;
6414 end if;
6416 return True;
6417 end Is_In_Context_Clause;
6419 ---------------------------------
6420 -- Is_Static_String_Expression --
6421 ---------------------------------
6423 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6424 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6425 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6427 begin
6428 Analyze_And_Resolve (Argx);
6430 -- Special case Ada 83, where the expression will never be static,
6431 -- but we will return true if we had a string literal to start with.
6433 if Ada_Version = Ada_83 then
6434 return Lit;
6436 -- Normal case, true only if we end up with a string literal that
6437 -- is marked as being the result of evaluating a static expression.
6439 else
6440 return Is_OK_Static_Expression (Argx)
6441 and then Nkind (Argx) = N_String_Literal;
6442 end if;
6444 end Is_Static_String_Expression;
6446 ----------------------
6447 -- Pragma_Misplaced --
6448 ----------------------
6450 procedure Pragma_Misplaced is
6451 begin
6452 Error_Pragma ("incorrect placement of pragma%");
6453 end Pragma_Misplaced;
6455 ------------------------------------------------
6456 -- Process_Atomic_Independent_Shared_Volatile --
6457 ------------------------------------------------
6459 procedure Process_Atomic_Independent_Shared_Volatile is
6460 procedure Set_Atomic_VFA (E : Entity_Id);
6461 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6462 -- no explicit alignment was given, set alignment to unknown, since
6463 -- back end knows what the alignment requirements are for atomic and
6464 -- full access arrays. Note: this is necessary for derived types.
6466 --------------------
6467 -- Set_Atomic_VFA --
6468 --------------------
6470 procedure Set_Atomic_VFA (E : Entity_Id) is
6471 begin
6472 if Prag_Id = Pragma_Volatile_Full_Access then
6473 Set_Is_Volatile_Full_Access (E);
6474 else
6475 Set_Is_Atomic (E);
6476 end if;
6478 if not Has_Alignment_Clause (E) then
6479 Set_Alignment (E, Uint_0);
6480 end if;
6481 end Set_Atomic_VFA;
6483 -- Local variables
6485 Decl : Node_Id;
6486 E : Entity_Id;
6487 E_Arg : Node_Id;
6489 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6491 begin
6492 Check_Ada_83_Warning;
6493 Check_No_Identifiers;
6494 Check_Arg_Count (1);
6495 Check_Arg_Is_Local_Name (Arg1);
6496 E_Arg := Get_Pragma_Arg (Arg1);
6498 if Etype (E_Arg) = Any_Type then
6499 return;
6500 end if;
6502 E := Entity (E_Arg);
6503 Decl := Declaration_Node (E);
6505 -- A pragma that applies to a Ghost entity becomes Ghost for the
6506 -- purposes of legality checks and removal of ignored Ghost code.
6508 Mark_Pragma_As_Ghost (N, E);
6510 -- Check duplicate before we chain ourselves
6512 Check_Duplicate_Pragma (E);
6514 -- Check Atomic and VFA used together
6516 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6517 or else (Is_Volatile_Full_Access (E)
6518 and then (Prag_Id = Pragma_Atomic
6519 or else
6520 Prag_Id = Pragma_Shared))
6521 then
6522 Error_Pragma
6523 ("cannot have Volatile_Full_Access and Atomic for same entity");
6524 end if;
6526 -- Check for applying VFA to an entity which has aliased component
6528 if Prag_Id = Pragma_Volatile_Full_Access then
6529 declare
6530 Comp : Entity_Id;
6531 Aliased_Comp : Boolean := False;
6532 -- Set True if aliased component present
6534 begin
6535 if Is_Array_Type (Etype (E)) then
6536 Aliased_Comp := Has_Aliased_Components (Etype (E));
6538 -- Record case, too bad Has_Aliased_Components is not also
6539 -- set for records, should it be ???
6541 elsif Is_Record_Type (Etype (E)) then
6542 Comp := First_Component_Or_Discriminant (Etype (E));
6543 while Present (Comp) loop
6544 if Is_Aliased (Comp)
6545 or else Is_Aliased (Etype (Comp))
6546 then
6547 Aliased_Comp := True;
6548 exit;
6549 end if;
6551 Next_Component_Or_Discriminant (Comp);
6552 end loop;
6553 end if;
6555 if Aliased_Comp then
6556 Error_Pragma
6557 ("cannot apply Volatile_Full_Access (aliased component "
6558 & "present)");
6559 end if;
6560 end;
6561 end if;
6563 -- Now check appropriateness of the entity
6565 if Is_Type (E) then
6566 if Rep_Item_Too_Early (E, N)
6567 or else
6568 Rep_Item_Too_Late (E, N)
6569 then
6570 return;
6571 else
6572 Check_First_Subtype (Arg1);
6573 end if;
6575 -- Attribute belongs on the base type. If the view of the type is
6576 -- currently private, it also belongs on the underlying type.
6578 if Prag_Id = Pragma_Atomic
6579 or else
6580 Prag_Id = Pragma_Shared
6581 or else
6582 Prag_Id = Pragma_Volatile_Full_Access
6583 then
6584 Set_Atomic_VFA (E);
6585 Set_Atomic_VFA (Base_Type (E));
6586 Set_Atomic_VFA (Underlying_Type (E));
6587 end if;
6589 -- Atomic/Shared/Volatile_Full_Access imply Independent
6591 if Prag_Id /= Pragma_Volatile then
6592 Set_Is_Independent (E);
6593 Set_Is_Independent (Base_Type (E));
6594 Set_Is_Independent (Underlying_Type (E));
6596 if Prag_Id = Pragma_Independent then
6597 Record_Independence_Check (N, Base_Type (E));
6598 end if;
6599 end if;
6601 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6603 if Prag_Id /= Pragma_Independent then
6604 Set_Is_Volatile (E);
6605 Set_Is_Volatile (Base_Type (E));
6606 Set_Is_Volatile (Underlying_Type (E));
6608 Set_Treat_As_Volatile (E);
6609 Set_Treat_As_Volatile (Underlying_Type (E));
6610 end if;
6612 elsif Nkind (Decl) = N_Object_Declaration
6613 or else (Nkind (Decl) = N_Component_Declaration
6614 and then Original_Record_Component (E) = E)
6615 then
6616 if Rep_Item_Too_Late (E, N) then
6617 return;
6618 end if;
6620 if Prag_Id = Pragma_Atomic
6621 or else
6622 Prag_Id = Pragma_Shared
6623 or else
6624 Prag_Id = Pragma_Volatile_Full_Access
6625 then
6626 if Prag_Id = Pragma_Volatile_Full_Access then
6627 Set_Is_Volatile_Full_Access (E);
6628 else
6629 Set_Is_Atomic (E);
6630 end if;
6632 -- If the object declaration has an explicit initialization, a
6633 -- temporary may have to be created to hold the expression, to
6634 -- ensure that access to the object remain atomic.
6636 if Nkind (Parent (E)) = N_Object_Declaration
6637 and then Present (Expression (Parent (E)))
6638 then
6639 Set_Has_Delayed_Freeze (E);
6640 end if;
6641 end if;
6643 -- Atomic/Shared/Volatile_Full_Access imply Independent
6645 if Prag_Id /= Pragma_Volatile then
6646 Set_Is_Independent (E);
6648 if Prag_Id = Pragma_Independent then
6649 Record_Independence_Check (N, E);
6650 end if;
6651 end if;
6653 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6655 if Prag_Id /= Pragma_Independent then
6656 Set_Is_Volatile (E);
6657 Set_Treat_As_Volatile (E);
6658 end if;
6660 else
6661 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6662 end if;
6664 -- The following check is only relevant when SPARK_Mode is on as
6665 -- this is not a standard Ada legality rule. Pragma Volatile can
6666 -- only apply to a full type declaration or an object declaration
6667 -- (SPARK RM C.6(1)). Original_Node is necessary to account for
6668 -- untagged derived types that are rewritten as subtypes of their
6669 -- respective root types.
6671 if SPARK_Mode = On
6672 and then Prag_Id = Pragma_Volatile
6673 and then
6674 not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
6675 N_Object_Declaration)
6676 then
6677 Error_Pragma_Arg
6678 ("argument of pragma % must denote a full type or object "
6679 & "declaration", Arg1);
6680 end if;
6681 end Process_Atomic_Independent_Shared_Volatile;
6683 -------------------------------------------
6684 -- Process_Compile_Time_Warning_Or_Error --
6685 -------------------------------------------
6687 procedure Process_Compile_Time_Warning_Or_Error is
6688 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
6690 begin
6691 Check_Arg_Count (2);
6692 Check_No_Identifiers;
6693 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
6694 Analyze_And_Resolve (Arg1x, Standard_Boolean);
6696 if Compile_Time_Known_Value (Arg1x) then
6697 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
6698 declare
6699 Str : constant String_Id :=
6700 Strval (Get_Pragma_Arg (Arg2));
6701 Len : constant Nat := String_Length (Str);
6702 Cont : Boolean;
6703 Ptr : Nat;
6704 CC : Char_Code;
6705 C : Character;
6706 Cent : constant Entity_Id :=
6707 Cunit_Entity (Current_Sem_Unit);
6709 Force : constant Boolean :=
6710 Prag_Id = Pragma_Compile_Time_Warning
6711 and then
6712 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
6713 and then (Ekind (Cent) /= E_Package
6714 or else not In_Private_Part (Cent));
6715 -- Set True if this is the warning case, and we are in the
6716 -- visible part of a package spec, or in a subprogram spec,
6717 -- in which case we want to force the client to see the
6718 -- warning, even though it is not in the main unit.
6720 begin
6721 -- Loop through segments of message separated by line feeds.
6722 -- We output these segments as separate messages with
6723 -- continuation marks for all but the first.
6725 Cont := False;
6726 Ptr := 1;
6727 loop
6728 Error_Msg_Strlen := 0;
6730 -- Loop to copy characters from argument to error message
6731 -- string buffer.
6733 loop
6734 exit when Ptr > Len;
6735 CC := Get_String_Char (Str, Ptr);
6736 Ptr := Ptr + 1;
6738 -- Ignore wide chars ??? else store character
6740 if In_Character_Range (CC) then
6741 C := Get_Character (CC);
6742 exit when C = ASCII.LF;
6743 Error_Msg_Strlen := Error_Msg_Strlen + 1;
6744 Error_Msg_String (Error_Msg_Strlen) := C;
6745 end if;
6746 end loop;
6748 -- Here with one line ready to go
6750 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
6752 -- If this is a warning in a spec, then we want clients
6753 -- to see the warning, so mark the message with the
6754 -- special sequence !! to force the warning. In the case
6755 -- of a package spec, we do not force this if we are in
6756 -- the private part of the spec.
6758 if Force then
6759 if Cont = False then
6760 Error_Msg_N ("<<~!!", Arg1);
6761 Cont := True;
6762 else
6763 Error_Msg_N ("\<<~!!", Arg1);
6764 end if;
6766 -- Error, rather than warning, or in a body, so we do not
6767 -- need to force visibility for client (error will be
6768 -- output in any case, and this is the situation in which
6769 -- we do not want a client to get a warning, since the
6770 -- warning is in the body or the spec private part).
6772 else
6773 if Cont = False then
6774 Error_Msg_N ("<<~", Arg1);
6775 Cont := True;
6776 else
6777 Error_Msg_N ("\<<~", Arg1);
6778 end if;
6779 end if;
6781 exit when Ptr > Len;
6782 end loop;
6783 end;
6784 end if;
6785 end if;
6786 end Process_Compile_Time_Warning_Or_Error;
6788 ------------------------
6789 -- Process_Convention --
6790 ------------------------
6792 procedure Process_Convention
6793 (C : out Convention_Id;
6794 Ent : out Entity_Id)
6796 Cname : Name_Id;
6798 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
6799 -- Called if we have more than one Export/Import/Convention pragma.
6800 -- This is generally illegal, but we have a special case of allowing
6801 -- Import and Interface to coexist if they specify the convention in
6802 -- a consistent manner. We are allowed to do this, since Interface is
6803 -- an implementation defined pragma, and we choose to do it since we
6804 -- know Rational allows this combination. S is the entity id of the
6805 -- subprogram in question. This procedure also sets the special flag
6806 -- Import_Interface_Present in both pragmas in the case where we do
6807 -- have matching Import and Interface pragmas.
6809 procedure Set_Convention_From_Pragma (E : Entity_Id);
6810 -- Set convention in entity E, and also flag that the entity has a
6811 -- convention pragma. If entity is for a private or incomplete type,
6812 -- also set convention and flag on underlying type. This procedure
6813 -- also deals with the special case of C_Pass_By_Copy convention,
6814 -- and error checks for inappropriate convention specification.
6816 -------------------------------
6817 -- Diagnose_Multiple_Pragmas --
6818 -------------------------------
6820 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
6821 Pdec : constant Node_Id := Declaration_Node (S);
6822 Decl : Node_Id;
6823 Err : Boolean;
6825 function Same_Convention (Decl : Node_Id) return Boolean;
6826 -- Decl is a pragma node. This function returns True if this
6827 -- pragma has a first argument that is an identifier with a
6828 -- Chars field corresponding to the Convention_Id C.
6830 function Same_Name (Decl : Node_Id) return Boolean;
6831 -- Decl is a pragma node. This function returns True if this
6832 -- pragma has a second argument that is an identifier with a
6833 -- Chars field that matches the Chars of the current subprogram.
6835 ---------------------
6836 -- Same_Convention --
6837 ---------------------
6839 function Same_Convention (Decl : Node_Id) return Boolean is
6840 Arg1 : constant Node_Id :=
6841 First (Pragma_Argument_Associations (Decl));
6843 begin
6844 if Present (Arg1) then
6845 declare
6846 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
6847 begin
6848 if Nkind (Arg) = N_Identifier
6849 and then Is_Convention_Name (Chars (Arg))
6850 and then Get_Convention_Id (Chars (Arg)) = C
6851 then
6852 return True;
6853 end if;
6854 end;
6855 end if;
6857 return False;
6858 end Same_Convention;
6860 ---------------
6861 -- Same_Name --
6862 ---------------
6864 function Same_Name (Decl : Node_Id) return Boolean is
6865 Arg1 : constant Node_Id :=
6866 First (Pragma_Argument_Associations (Decl));
6867 Arg2 : Node_Id;
6869 begin
6870 if No (Arg1) then
6871 return False;
6872 end if;
6874 Arg2 := Next (Arg1);
6876 if No (Arg2) then
6877 return False;
6878 end if;
6880 declare
6881 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
6882 begin
6883 if Nkind (Arg) = N_Identifier
6884 and then Chars (Arg) = Chars (S)
6885 then
6886 return True;
6887 end if;
6888 end;
6890 return False;
6891 end Same_Name;
6893 -- Start of processing for Diagnose_Multiple_Pragmas
6895 begin
6896 Err := True;
6898 -- Definitely give message if we have Convention/Export here
6900 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
6901 null;
6903 -- If we have an Import or Export, scan back from pragma to
6904 -- find any previous pragma applying to the same procedure.
6905 -- The scan will be terminated by the start of the list, or
6906 -- hitting the subprogram declaration. This won't allow one
6907 -- pragma to appear in the public part and one in the private
6908 -- part, but that seems very unlikely in practice.
6910 else
6911 Decl := Prev (N);
6912 while Present (Decl) and then Decl /= Pdec loop
6914 -- Look for pragma with same name as us
6916 if Nkind (Decl) = N_Pragma
6917 and then Same_Name (Decl)
6918 then
6919 -- Give error if same as our pragma or Export/Convention
6921 if Nam_In (Pragma_Name (Decl), Name_Export,
6922 Name_Convention,
6923 Pragma_Name (N))
6924 then
6925 exit;
6927 -- Case of Import/Interface or the other way round
6929 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
6930 Name_Import)
6931 then
6932 -- Here we know that we have Import and Interface. It
6933 -- doesn't matter which way round they are. See if
6934 -- they specify the same convention. If so, all OK,
6935 -- and set special flags to stop other messages
6937 if Same_Convention (Decl) then
6938 Set_Import_Interface_Present (N);
6939 Set_Import_Interface_Present (Decl);
6940 Err := False;
6942 -- If different conventions, special message
6944 else
6945 Error_Msg_Sloc := Sloc (Decl);
6946 Error_Pragma_Arg
6947 ("convention differs from that given#", Arg1);
6948 return;
6949 end if;
6950 end if;
6951 end if;
6953 Next (Decl);
6954 end loop;
6955 end if;
6957 -- Give message if needed if we fall through those tests
6958 -- except on Relaxed_RM_Semantics where we let go: either this
6959 -- is a case accepted/ignored by other Ada compilers (e.g.
6960 -- a mix of Convention and Import), or another error will be
6961 -- generated later (e.g. using both Import and Export).
6963 if Err and not Relaxed_RM_Semantics then
6964 Error_Pragma_Arg
6965 ("at most one Convention/Export/Import pragma is allowed",
6966 Arg2);
6967 end if;
6968 end Diagnose_Multiple_Pragmas;
6970 --------------------------------
6971 -- Set_Convention_From_Pragma --
6972 --------------------------------
6974 procedure Set_Convention_From_Pragma (E : Entity_Id) is
6975 begin
6976 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6977 -- for an overridden dispatching operation. Technically this is
6978 -- an amendment and should only be done in Ada 2005 mode. However,
6979 -- this is clearly a mistake, since the problem that is addressed
6980 -- by this AI is that there is a clear gap in the RM.
6982 if Is_Dispatching_Operation (E)
6983 and then Present (Overridden_Operation (E))
6984 and then C /= Convention (Overridden_Operation (E))
6985 then
6986 Error_Pragma_Arg
6987 ("cannot change convention for overridden dispatching "
6988 & "operation", Arg1);
6989 end if;
6991 -- Special checks for Convention_Stdcall
6993 if C = Convention_Stdcall then
6995 -- A dispatching call is not allowed. A dispatching subprogram
6996 -- cannot be used to interface to the Win32 API, so in fact
6997 -- this check does not impose any effective restriction.
6999 if Is_Dispatching_Operation (E) then
7000 Error_Msg_Sloc := Sloc (E);
7002 -- Note: make this unconditional so that if there is more
7003 -- than one call to which the pragma applies, we get a
7004 -- message for each call. Also don't use Error_Pragma,
7005 -- so that we get multiple messages.
7007 Error_Msg_N
7008 ("dispatching subprogram# cannot use Stdcall convention!",
7009 Arg1);
7011 -- Subprograms are not allowed
7013 elsif not Is_Subprogram_Or_Generic_Subprogram (E)
7015 -- A variable is OK
7017 and then Ekind (E) /= E_Variable
7019 -- An access to subprogram is also allowed
7021 and then not
7022 (Is_Access_Type (E)
7023 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7025 -- Allow internal call to set convention of subprogram type
7027 and then not (Ekind (E) = E_Subprogram_Type)
7028 then
7029 Error_Pragma_Arg
7030 ("second argument of pragma% must be subprogram (type)",
7031 Arg2);
7032 end if;
7033 end if;
7035 -- Set the convention
7037 Set_Convention (E, C);
7038 Set_Has_Convention_Pragma (E);
7040 -- For the case of a record base type, also set the convention of
7041 -- any anonymous access types declared in the record which do not
7042 -- currently have a specified convention.
7044 if Is_Record_Type (E) and then Is_Base_Type (E) then
7045 declare
7046 Comp : Node_Id;
7048 begin
7049 Comp := First_Component (E);
7050 while Present (Comp) loop
7051 if Present (Etype (Comp))
7052 and then Ekind_In (Etype (Comp),
7053 E_Anonymous_Access_Type,
7054 E_Anonymous_Access_Subprogram_Type)
7055 and then not Has_Convention_Pragma (Comp)
7056 then
7057 Set_Convention (Comp, C);
7058 end if;
7060 Next_Component (Comp);
7061 end loop;
7062 end;
7063 end if;
7065 -- Deal with incomplete/private type case, where underlying type
7066 -- is available, so set convention of that underlying type.
7068 if Is_Incomplete_Or_Private_Type (E)
7069 and then Present (Underlying_Type (E))
7070 then
7071 Set_Convention (Underlying_Type (E), C);
7072 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7073 end if;
7075 -- A class-wide type should inherit the convention of the specific
7076 -- root type (although this isn't specified clearly by the RM).
7078 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7079 Set_Convention (Class_Wide_Type (E), C);
7080 end if;
7082 -- If the entity is a record type, then check for special case of
7083 -- C_Pass_By_Copy, which is treated the same as C except that the
7084 -- special record flag is set. This convention is only permitted
7085 -- on record types (see AI95-00131).
7087 if Cname = Name_C_Pass_By_Copy then
7088 if Is_Record_Type (E) then
7089 Set_C_Pass_By_Copy (Base_Type (E));
7090 elsif Is_Incomplete_Or_Private_Type (E)
7091 and then Is_Record_Type (Underlying_Type (E))
7092 then
7093 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7094 else
7095 Error_Pragma_Arg
7096 ("C_Pass_By_Copy convention allowed only for record type",
7097 Arg2);
7098 end if;
7099 end if;
7101 -- If the entity is a derived boolean type, check for the special
7102 -- case of convention C, C++, or Fortran, where we consider any
7103 -- nonzero value to represent true.
7105 if Is_Discrete_Type (E)
7106 and then Root_Type (Etype (E)) = Standard_Boolean
7107 and then
7108 (C = Convention_C
7109 or else
7110 C = Convention_CPP
7111 or else
7112 C = Convention_Fortran)
7113 then
7114 Set_Nonzero_Is_True (Base_Type (E));
7115 end if;
7116 end Set_Convention_From_Pragma;
7118 -- Local variables
7120 Comp_Unit : Unit_Number_Type;
7121 E : Entity_Id;
7122 E1 : Entity_Id;
7123 Id : Node_Id;
7125 -- Start of processing for Process_Convention
7127 begin
7128 Check_At_Least_N_Arguments (2);
7129 Check_Optional_Identifier (Arg1, Name_Convention);
7130 Check_Arg_Is_Identifier (Arg1);
7131 Cname := Chars (Get_Pragma_Arg (Arg1));
7133 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7134 -- tested again below to set the critical flag).
7136 if Cname = Name_C_Pass_By_Copy then
7137 C := Convention_C;
7139 -- Otherwise we must have something in the standard convention list
7141 elsif Is_Convention_Name (Cname) then
7142 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7144 -- Otherwise warn on unrecognized convention
7146 else
7147 if Warn_On_Export_Import then
7148 Error_Msg_N
7149 ("??unrecognized convention name, C assumed",
7150 Get_Pragma_Arg (Arg1));
7151 end if;
7153 C := Convention_C;
7154 end if;
7156 Check_Optional_Identifier (Arg2, Name_Entity);
7157 Check_Arg_Is_Local_Name (Arg2);
7159 Id := Get_Pragma_Arg (Arg2);
7160 Analyze (Id);
7162 if not Is_Entity_Name (Id) then
7163 Error_Pragma_Arg ("entity name required", Arg2);
7164 end if;
7166 E := Entity (Id);
7168 -- Set entity to return
7170 Ent := E;
7172 -- Ada_Pass_By_Copy special checking
7174 if C = Convention_Ada_Pass_By_Copy then
7175 if not Is_First_Subtype (E) then
7176 Error_Pragma_Arg
7177 ("convention `Ada_Pass_By_Copy` only allowed for types",
7178 Arg2);
7179 end if;
7181 if Is_By_Reference_Type (E) then
7182 Error_Pragma_Arg
7183 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7184 & "type", Arg1);
7185 end if;
7187 -- Ada_Pass_By_Reference special checking
7189 elsif C = Convention_Ada_Pass_By_Reference then
7190 if not Is_First_Subtype (E) then
7191 Error_Pragma_Arg
7192 ("convention `Ada_Pass_By_Reference` only allowed for types",
7193 Arg2);
7194 end if;
7196 if Is_By_Copy_Type (E) then
7197 Error_Pragma_Arg
7198 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7199 & "type", Arg1);
7200 end if;
7201 end if;
7203 -- Go to renamed subprogram if present, since convention applies to
7204 -- the actual renamed entity, not to the renaming entity. If the
7205 -- subprogram is inherited, go to parent subprogram.
7207 if Is_Subprogram (E)
7208 and then Present (Alias (E))
7209 then
7210 if Nkind (Parent (Declaration_Node (E))) =
7211 N_Subprogram_Renaming_Declaration
7212 then
7213 if Scope (E) /= Scope (Alias (E)) then
7214 Error_Pragma_Ref
7215 ("cannot apply pragma% to non-local entity&#", E);
7216 end if;
7218 E := Alias (E);
7220 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7221 N_Private_Extension_Declaration)
7222 and then Scope (E) = Scope (Alias (E))
7223 then
7224 E := Alias (E);
7226 -- Return the parent subprogram the entity was inherited from
7228 Ent := E;
7229 end if;
7230 end if;
7232 -- Check that we are not applying this to a specless body. Relax this
7233 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7235 if Is_Subprogram (E)
7236 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7237 and then not Relaxed_RM_Semantics
7238 then
7239 Error_Pragma
7240 ("pragma% requires separate spec and must come before body");
7241 end if;
7243 -- Check that we are not applying this to a named constant
7245 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7246 Error_Msg_Name_1 := Pname;
7247 Error_Msg_N
7248 ("cannot apply pragma% to named constant!",
7249 Get_Pragma_Arg (Arg2));
7250 Error_Pragma_Arg
7251 ("\supply appropriate type for&!", Arg2);
7252 end if;
7254 if Ekind (E) = E_Enumeration_Literal then
7255 Error_Pragma ("enumeration literal not allowed for pragma%");
7256 end if;
7258 -- Check for rep item appearing too early or too late
7260 if Etype (E) = Any_Type
7261 or else Rep_Item_Too_Early (E, N)
7262 then
7263 raise Pragma_Exit;
7265 elsif Present (Underlying_Type (E)) then
7266 E := Underlying_Type (E);
7267 end if;
7269 if Rep_Item_Too_Late (E, N) then
7270 raise Pragma_Exit;
7271 end if;
7273 if Has_Convention_Pragma (E) then
7274 Diagnose_Multiple_Pragmas (E);
7276 elsif Convention (E) = Convention_Protected
7277 or else Ekind (Scope (E)) = E_Protected_Type
7278 then
7279 Error_Pragma_Arg
7280 ("a protected operation cannot be given a different convention",
7281 Arg2);
7282 end if;
7284 -- For Intrinsic, a subprogram is required
7286 if C = Convention_Intrinsic
7287 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7288 then
7289 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7291 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7292 Error_Pragma_Arg
7293 ("second argument of pragma% must be a subprogram", Arg2);
7294 end if;
7295 end if;
7297 -- Deal with non-subprogram cases
7299 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7300 Set_Convention_From_Pragma (E);
7302 if Is_Type (E) then
7304 -- The pragma must apply to a first subtype, but it can also
7305 -- apply to a generic type in a generic formal part, in which
7306 -- case it will also appear in the corresponding instance.
7308 if Is_Generic_Type (E) or else In_Instance then
7309 null;
7310 else
7311 Check_First_Subtype (Arg2);
7312 end if;
7314 Set_Convention_From_Pragma (Base_Type (E));
7316 -- For access subprograms, we must set the convention on the
7317 -- internally generated directly designated type as well.
7319 if Ekind (E) = E_Access_Subprogram_Type then
7320 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7321 end if;
7322 end if;
7324 -- For the subprogram case, set proper convention for all homonyms
7325 -- in same scope and the same declarative part, i.e. the same
7326 -- compilation unit.
7328 else
7329 Comp_Unit := Get_Source_Unit (E);
7330 Set_Convention_From_Pragma (E);
7332 -- Treat a pragma Import as an implicit body, and pragma import
7333 -- as implicit reference (for navigation in GPS).
7335 if Prag_Id = Pragma_Import then
7336 Generate_Reference (E, Id, 'b');
7338 -- For exported entities we restrict the generation of references
7339 -- to entities exported to foreign languages since entities
7340 -- exported to Ada do not provide further information to GPS and
7341 -- add undesired references to the output of the gnatxref tool.
7343 elsif Prag_Id = Pragma_Export
7344 and then Convention (E) /= Convention_Ada
7345 then
7346 Generate_Reference (E, Id, 'i');
7347 end if;
7349 -- If the pragma comes from an aspect, it only applies to the
7350 -- given entity, not its homonyms.
7352 if From_Aspect_Specification (N) then
7353 return;
7354 end if;
7356 -- Otherwise Loop through the homonyms of the pragma argument's
7357 -- entity, an apply convention to those in the current scope.
7359 E1 := Ent;
7361 loop
7362 E1 := Homonym (E1);
7363 exit when No (E1) or else Scope (E1) /= Current_Scope;
7365 -- Ignore entry for which convention is already set
7367 if Has_Convention_Pragma (E1) then
7368 goto Continue;
7369 end if;
7371 -- Do not set the pragma on inherited operations or on formal
7372 -- subprograms.
7374 if Comes_From_Source (E1)
7375 and then Comp_Unit = Get_Source_Unit (E1)
7376 and then not Is_Formal_Subprogram (E1)
7377 and then Nkind (Original_Node (Parent (E1))) /=
7378 N_Full_Type_Declaration
7379 then
7380 if Present (Alias (E1))
7381 and then Scope (E1) /= Scope (Alias (E1))
7382 then
7383 Error_Pragma_Ref
7384 ("cannot apply pragma% to non-local entity& declared#",
7385 E1);
7386 end if;
7388 Set_Convention_From_Pragma (E1);
7390 if Prag_Id = Pragma_Import then
7391 Generate_Reference (E1, Id, 'b');
7392 end if;
7393 end if;
7395 <<Continue>>
7396 null;
7397 end loop;
7398 end if;
7399 end Process_Convention;
7401 ----------------------------------------
7402 -- Process_Disable_Enable_Atomic_Sync --
7403 ----------------------------------------
7405 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7406 begin
7407 Check_No_Identifiers;
7408 Check_At_Most_N_Arguments (1);
7410 -- Modeled internally as
7411 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7413 Rewrite (N,
7414 Make_Pragma (Loc,
7415 Pragma_Identifier =>
7416 Make_Identifier (Loc, Nam),
7417 Pragma_Argument_Associations => New_List (
7418 Make_Pragma_Argument_Association (Loc,
7419 Expression =>
7420 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7422 if Present (Arg1) then
7423 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7424 end if;
7426 Analyze (N);
7427 end Process_Disable_Enable_Atomic_Sync;
7429 -------------------------------------------------
7430 -- Process_Extended_Import_Export_Internal_Arg --
7431 -------------------------------------------------
7433 procedure Process_Extended_Import_Export_Internal_Arg
7434 (Arg_Internal : Node_Id := Empty)
7436 begin
7437 if No (Arg_Internal) then
7438 Error_Pragma ("Internal parameter required for pragma%");
7439 end if;
7441 if Nkind (Arg_Internal) = N_Identifier then
7442 null;
7444 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7445 and then (Prag_Id = Pragma_Import_Function
7446 or else
7447 Prag_Id = Pragma_Export_Function)
7448 then
7449 null;
7451 else
7452 Error_Pragma_Arg
7453 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7454 end if;
7456 Check_Arg_Is_Local_Name (Arg_Internal);
7457 end Process_Extended_Import_Export_Internal_Arg;
7459 --------------------------------------------------
7460 -- Process_Extended_Import_Export_Object_Pragma --
7461 --------------------------------------------------
7463 procedure Process_Extended_Import_Export_Object_Pragma
7464 (Arg_Internal : Node_Id;
7465 Arg_External : Node_Id;
7466 Arg_Size : Node_Id)
7468 Def_Id : Entity_Id;
7470 begin
7471 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7472 Def_Id := Entity (Arg_Internal);
7474 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7475 Error_Pragma_Arg
7476 ("pragma% must designate an object", Arg_Internal);
7477 end if;
7479 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7480 or else
7481 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7482 then
7483 Error_Pragma_Arg
7484 ("previous Common/Psect_Object applies, pragma % not permitted",
7485 Arg_Internal);
7486 end if;
7488 if Rep_Item_Too_Late (Def_Id, N) then
7489 raise Pragma_Exit;
7490 end if;
7492 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7494 if Present (Arg_Size) then
7495 Check_Arg_Is_External_Name (Arg_Size);
7496 end if;
7498 -- Export_Object case
7500 if Prag_Id = Pragma_Export_Object then
7501 if not Is_Library_Level_Entity (Def_Id) then
7502 Error_Pragma_Arg
7503 ("argument for pragma% must be library level entity",
7504 Arg_Internal);
7505 end if;
7507 if Ekind (Current_Scope) = E_Generic_Package then
7508 Error_Pragma ("pragma& cannot appear in a generic unit");
7509 end if;
7511 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7512 Error_Pragma_Arg
7513 ("exported object must have compile time known size",
7514 Arg_Internal);
7515 end if;
7517 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7518 Error_Msg_N ("??duplicate Export_Object pragma", N);
7519 else
7520 Set_Exported (Def_Id, Arg_Internal);
7521 end if;
7523 -- Import_Object case
7525 else
7526 if Is_Concurrent_Type (Etype (Def_Id)) then
7527 Error_Pragma_Arg
7528 ("cannot use pragma% for task/protected object",
7529 Arg_Internal);
7530 end if;
7532 if Ekind (Def_Id) = E_Constant then
7533 Error_Pragma_Arg
7534 ("cannot import a constant", Arg_Internal);
7535 end if;
7537 if Warn_On_Export_Import
7538 and then Has_Discriminants (Etype (Def_Id))
7539 then
7540 Error_Msg_N
7541 ("imported value must be initialized??", Arg_Internal);
7542 end if;
7544 if Warn_On_Export_Import
7545 and then Is_Access_Type (Etype (Def_Id))
7546 then
7547 Error_Pragma_Arg
7548 ("cannot import object of an access type??", Arg_Internal);
7549 end if;
7551 if Warn_On_Export_Import
7552 and then Is_Imported (Def_Id)
7553 then
7554 Error_Msg_N ("??duplicate Import_Object pragma", N);
7556 -- Check for explicit initialization present. Note that an
7557 -- initialization generated by the code generator, e.g. for an
7558 -- access type, does not count here.
7560 elsif Present (Expression (Parent (Def_Id)))
7561 and then
7562 Comes_From_Source
7563 (Original_Node (Expression (Parent (Def_Id))))
7564 then
7565 Error_Msg_Sloc := Sloc (Def_Id);
7566 Error_Pragma_Arg
7567 ("imported entities cannot be initialized (RM B.1(24))",
7568 "\no initialization allowed for & declared#", Arg1);
7569 else
7570 Set_Imported (Def_Id);
7571 Note_Possible_Modification (Arg_Internal, Sure => False);
7572 end if;
7573 end if;
7574 end Process_Extended_Import_Export_Object_Pragma;
7576 ------------------------------------------------------
7577 -- Process_Extended_Import_Export_Subprogram_Pragma --
7578 ------------------------------------------------------
7580 procedure Process_Extended_Import_Export_Subprogram_Pragma
7581 (Arg_Internal : Node_Id;
7582 Arg_External : Node_Id;
7583 Arg_Parameter_Types : Node_Id;
7584 Arg_Result_Type : Node_Id := Empty;
7585 Arg_Mechanism : Node_Id;
7586 Arg_Result_Mechanism : Node_Id := Empty)
7588 Ent : Entity_Id;
7589 Def_Id : Entity_Id;
7590 Hom_Id : Entity_Id;
7591 Formal : Entity_Id;
7592 Ambiguous : Boolean;
7593 Match : Boolean;
7595 function Same_Base_Type
7596 (Ptype : Node_Id;
7597 Formal : Entity_Id) return Boolean;
7598 -- Determines if Ptype references the type of Formal. Note that only
7599 -- the base types need to match according to the spec. Ptype here is
7600 -- the argument from the pragma, which is either a type name, or an
7601 -- access attribute.
7603 --------------------
7604 -- Same_Base_Type --
7605 --------------------
7607 function Same_Base_Type
7608 (Ptype : Node_Id;
7609 Formal : Entity_Id) return Boolean
7611 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7612 Pref : Node_Id;
7614 begin
7615 -- Case where pragma argument is typ'Access
7617 if Nkind (Ptype) = N_Attribute_Reference
7618 and then Attribute_Name (Ptype) = Name_Access
7619 then
7620 Pref := Prefix (Ptype);
7621 Find_Type (Pref);
7623 if not Is_Entity_Name (Pref)
7624 or else Entity (Pref) = Any_Type
7625 then
7626 raise Pragma_Exit;
7627 end if;
7629 -- We have a match if the corresponding argument is of an
7630 -- anonymous access type, and its designated type matches the
7631 -- type of the prefix of the access attribute
7633 return Ekind (Ftyp) = E_Anonymous_Access_Type
7634 and then Base_Type (Entity (Pref)) =
7635 Base_Type (Etype (Designated_Type (Ftyp)));
7637 -- Case where pragma argument is a type name
7639 else
7640 Find_Type (Ptype);
7642 if not Is_Entity_Name (Ptype)
7643 or else Entity (Ptype) = Any_Type
7644 then
7645 raise Pragma_Exit;
7646 end if;
7648 -- We have a match if the corresponding argument is of the type
7649 -- given in the pragma (comparing base types)
7651 return Base_Type (Entity (Ptype)) = Ftyp;
7652 end if;
7653 end Same_Base_Type;
7655 -- Start of processing for
7656 -- Process_Extended_Import_Export_Subprogram_Pragma
7658 begin
7659 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7660 Ent := Empty;
7661 Ambiguous := False;
7663 -- Loop through homonyms (overloadings) of the entity
7665 Hom_Id := Entity (Arg_Internal);
7666 while Present (Hom_Id) loop
7667 Def_Id := Get_Base_Subprogram (Hom_Id);
7669 -- We need a subprogram in the current scope
7671 if not Is_Subprogram (Def_Id)
7672 or else Scope (Def_Id) /= Current_Scope
7673 then
7674 null;
7676 else
7677 Match := True;
7679 -- Pragma cannot apply to subprogram body
7681 if Is_Subprogram (Def_Id)
7682 and then Nkind (Parent (Declaration_Node (Def_Id))) =
7683 N_Subprogram_Body
7684 then
7685 Error_Pragma
7686 ("pragma% requires separate spec"
7687 & " and must come before body");
7688 end if;
7690 -- Test result type if given, note that the result type
7691 -- parameter can only be present for the function cases.
7693 if Present (Arg_Result_Type)
7694 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
7695 then
7696 Match := False;
7698 elsif Etype (Def_Id) /= Standard_Void_Type
7699 and then
7700 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
7701 then
7702 Match := False;
7704 -- Test parameter types if given. Note that this parameter
7705 -- has not been analyzed (and must not be, since it is
7706 -- semantic nonsense), so we get it as the parser left it.
7708 elsif Present (Arg_Parameter_Types) then
7709 Check_Matching_Types : declare
7710 Formal : Entity_Id;
7711 Ptype : Node_Id;
7713 begin
7714 Formal := First_Formal (Def_Id);
7716 if Nkind (Arg_Parameter_Types) = N_Null then
7717 if Present (Formal) then
7718 Match := False;
7719 end if;
7721 -- A list of one type, e.g. (List) is parsed as
7722 -- a parenthesized expression.
7724 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
7725 and then Paren_Count (Arg_Parameter_Types) = 1
7726 then
7727 if No (Formal)
7728 or else Present (Next_Formal (Formal))
7729 then
7730 Match := False;
7731 else
7732 Match :=
7733 Same_Base_Type (Arg_Parameter_Types, Formal);
7734 end if;
7736 -- A list of more than one type is parsed as a aggregate
7738 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
7739 and then Paren_Count (Arg_Parameter_Types) = 0
7740 then
7741 Ptype := First (Expressions (Arg_Parameter_Types));
7742 while Present (Ptype) or else Present (Formal) loop
7743 if No (Ptype)
7744 or else No (Formal)
7745 or else not Same_Base_Type (Ptype, Formal)
7746 then
7747 Match := False;
7748 exit;
7749 else
7750 Next_Formal (Formal);
7751 Next (Ptype);
7752 end if;
7753 end loop;
7755 -- Anything else is of the wrong form
7757 else
7758 Error_Pragma_Arg
7759 ("wrong form for Parameter_Types parameter",
7760 Arg_Parameter_Types);
7761 end if;
7762 end Check_Matching_Types;
7763 end if;
7765 -- Match is now False if the entry we found did not match
7766 -- either a supplied Parameter_Types or Result_Types argument
7768 if Match then
7769 if No (Ent) then
7770 Ent := Def_Id;
7772 -- Ambiguous case, the flag Ambiguous shows if we already
7773 -- detected this and output the initial messages.
7775 else
7776 if not Ambiguous then
7777 Ambiguous := True;
7778 Error_Msg_Name_1 := Pname;
7779 Error_Msg_N
7780 ("pragma% does not uniquely identify subprogram!",
7782 Error_Msg_Sloc := Sloc (Ent);
7783 Error_Msg_N ("matching subprogram #!", N);
7784 Ent := Empty;
7785 end if;
7787 Error_Msg_Sloc := Sloc (Def_Id);
7788 Error_Msg_N ("matching subprogram #!", N);
7789 end if;
7790 end if;
7791 end if;
7793 Hom_Id := Homonym (Hom_Id);
7794 end loop;
7796 -- See if we found an entry
7798 if No (Ent) then
7799 if not Ambiguous then
7800 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
7801 Error_Pragma
7802 ("pragma% cannot be given for generic subprogram");
7803 else
7804 Error_Pragma
7805 ("pragma% does not identify local subprogram");
7806 end if;
7807 end if;
7809 return;
7810 end if;
7812 -- Import pragmas must be for imported entities
7814 if Prag_Id = Pragma_Import_Function
7815 or else
7816 Prag_Id = Pragma_Import_Procedure
7817 or else
7818 Prag_Id = Pragma_Import_Valued_Procedure
7819 then
7820 if not Is_Imported (Ent) then
7821 Error_Pragma
7822 ("pragma Import or Interface must precede pragma%");
7823 end if;
7825 -- Here we have the Export case which can set the entity as exported
7827 -- But does not do so if the specified external name is null, since
7828 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7829 -- compatible) to request no external name.
7831 elsif Nkind (Arg_External) = N_String_Literal
7832 and then String_Length (Strval (Arg_External)) = 0
7833 then
7834 null;
7836 -- In all other cases, set entity as exported
7838 else
7839 Set_Exported (Ent, Arg_Internal);
7840 end if;
7842 -- Special processing for Valued_Procedure cases
7844 if Prag_Id = Pragma_Import_Valued_Procedure
7845 or else
7846 Prag_Id = Pragma_Export_Valued_Procedure
7847 then
7848 Formal := First_Formal (Ent);
7850 if No (Formal) then
7851 Error_Pragma ("at least one parameter required for pragma%");
7853 elsif Ekind (Formal) /= E_Out_Parameter then
7854 Error_Pragma ("first parameter must have mode out for pragma%");
7856 else
7857 Set_Is_Valued_Procedure (Ent);
7858 end if;
7859 end if;
7861 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
7863 -- Process Result_Mechanism argument if present. We have already
7864 -- checked that this is only allowed for the function case.
7866 if Present (Arg_Result_Mechanism) then
7867 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
7868 end if;
7870 -- Process Mechanism parameter if present. Note that this parameter
7871 -- is not analyzed, and must not be analyzed since it is semantic
7872 -- nonsense, so we get it in exactly as the parser left it.
7874 if Present (Arg_Mechanism) then
7875 declare
7876 Formal : Entity_Id;
7877 Massoc : Node_Id;
7878 Mname : Node_Id;
7879 Choice : Node_Id;
7881 begin
7882 -- A single mechanism association without a formal parameter
7883 -- name is parsed as a parenthesized expression. All other
7884 -- cases are parsed as aggregates, so we rewrite the single
7885 -- parameter case as an aggregate for consistency.
7887 if Nkind (Arg_Mechanism) /= N_Aggregate
7888 and then Paren_Count (Arg_Mechanism) = 1
7889 then
7890 Rewrite (Arg_Mechanism,
7891 Make_Aggregate (Sloc (Arg_Mechanism),
7892 Expressions => New_List (
7893 Relocate_Node (Arg_Mechanism))));
7894 end if;
7896 -- Case of only mechanism name given, applies to all formals
7898 if Nkind (Arg_Mechanism) /= N_Aggregate then
7899 Formal := First_Formal (Ent);
7900 while Present (Formal) loop
7901 Set_Mechanism_Value (Formal, Arg_Mechanism);
7902 Next_Formal (Formal);
7903 end loop;
7905 -- Case of list of mechanism associations given
7907 else
7908 if Null_Record_Present (Arg_Mechanism) then
7909 Error_Pragma_Arg
7910 ("inappropriate form for Mechanism parameter",
7911 Arg_Mechanism);
7912 end if;
7914 -- Deal with positional ones first
7916 Formal := First_Formal (Ent);
7918 if Present (Expressions (Arg_Mechanism)) then
7919 Mname := First (Expressions (Arg_Mechanism));
7920 while Present (Mname) loop
7921 if No (Formal) then
7922 Error_Pragma_Arg
7923 ("too many mechanism associations", Mname);
7924 end if;
7926 Set_Mechanism_Value (Formal, Mname);
7927 Next_Formal (Formal);
7928 Next (Mname);
7929 end loop;
7930 end if;
7932 -- Deal with named entries
7934 if Present (Component_Associations (Arg_Mechanism)) then
7935 Massoc := First (Component_Associations (Arg_Mechanism));
7936 while Present (Massoc) loop
7937 Choice := First (Choices (Massoc));
7939 if Nkind (Choice) /= N_Identifier
7940 or else Present (Next (Choice))
7941 then
7942 Error_Pragma_Arg
7943 ("incorrect form for mechanism association",
7944 Massoc);
7945 end if;
7947 Formal := First_Formal (Ent);
7948 loop
7949 if No (Formal) then
7950 Error_Pragma_Arg
7951 ("parameter name & not present", Choice);
7952 end if;
7954 if Chars (Choice) = Chars (Formal) then
7955 Set_Mechanism_Value
7956 (Formal, Expression (Massoc));
7958 -- Set entity on identifier (needed by ASIS)
7960 Set_Entity (Choice, Formal);
7962 exit;
7963 end if;
7965 Next_Formal (Formal);
7966 end loop;
7968 Next (Massoc);
7969 end loop;
7970 end if;
7971 end if;
7972 end;
7973 end if;
7974 end Process_Extended_Import_Export_Subprogram_Pragma;
7976 --------------------------
7977 -- Process_Generic_List --
7978 --------------------------
7980 procedure Process_Generic_List is
7981 Arg : Node_Id;
7982 Exp : Node_Id;
7984 begin
7985 Check_No_Identifiers;
7986 Check_At_Least_N_Arguments (1);
7988 -- Check all arguments are names of generic units or instances
7990 Arg := Arg1;
7991 while Present (Arg) loop
7992 Exp := Get_Pragma_Arg (Arg);
7993 Analyze (Exp);
7995 if not Is_Entity_Name (Exp)
7996 or else
7997 (not Is_Generic_Instance (Entity (Exp))
7998 and then
7999 not Is_Generic_Unit (Entity (Exp)))
8000 then
8001 Error_Pragma_Arg
8002 ("pragma% argument must be name of generic unit/instance",
8003 Arg);
8004 end if;
8006 Next (Arg);
8007 end loop;
8008 end Process_Generic_List;
8010 ------------------------------------
8011 -- Process_Import_Predefined_Type --
8012 ------------------------------------
8014 procedure Process_Import_Predefined_Type is
8015 Loc : constant Source_Ptr := Sloc (N);
8016 Elmt : Elmt_Id;
8017 Ftyp : Node_Id := Empty;
8018 Decl : Node_Id;
8019 Def : Node_Id;
8020 Nam : Name_Id;
8022 begin
8023 String_To_Name_Buffer (Strval (Expression (Arg3)));
8024 Nam := Name_Find;
8026 Elmt := First_Elmt (Predefined_Float_Types);
8027 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8028 Next_Elmt (Elmt);
8029 end loop;
8031 Ftyp := Node (Elmt);
8033 if Present (Ftyp) then
8035 -- Don't build a derived type declaration, because predefined C
8036 -- types have no declaration anywhere, so cannot really be named.
8037 -- Instead build a full type declaration, starting with an
8038 -- appropriate type definition is built
8040 if Is_Floating_Point_Type (Ftyp) then
8041 Def := Make_Floating_Point_Definition (Loc,
8042 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8043 Make_Real_Range_Specification (Loc,
8044 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8045 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8047 -- Should never have a predefined type we cannot handle
8049 else
8050 raise Program_Error;
8051 end if;
8053 -- Build and insert a Full_Type_Declaration, which will be
8054 -- analyzed as soon as this list entry has been analyzed.
8056 Decl := Make_Full_Type_Declaration (Loc,
8057 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8058 Type_Definition => Def);
8060 Insert_After (N, Decl);
8061 Mark_Rewrite_Insertion (Decl);
8063 else
8064 Error_Pragma_Arg ("no matching type found for pragma%",
8065 Arg2);
8066 end if;
8067 end Process_Import_Predefined_Type;
8069 ---------------------------------
8070 -- Process_Import_Or_Interface --
8071 ---------------------------------
8073 procedure Process_Import_Or_Interface is
8074 C : Convention_Id;
8075 Def_Id : Entity_Id;
8076 Hom_Id : Entity_Id;
8078 begin
8079 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8080 -- pragma Import (Entity, "external name");
8082 if Relaxed_RM_Semantics
8083 and then Arg_Count = 2
8084 and then Prag_Id = Pragma_Import
8085 and then Nkind (Expression (Arg2)) = N_String_Literal
8086 then
8087 C := Convention_C;
8088 Def_Id := Get_Pragma_Arg (Arg1);
8089 Analyze (Def_Id);
8091 if not Is_Entity_Name (Def_Id) then
8092 Error_Pragma_Arg ("entity name required", Arg1);
8093 end if;
8095 Def_Id := Entity (Def_Id);
8096 Kill_Size_Check_Code (Def_Id);
8097 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8099 else
8100 Process_Convention (C, Def_Id);
8102 -- A pragma that applies to a Ghost entity becomes Ghost for the
8103 -- purposes of legality checks and removal of ignored Ghost code.
8105 Mark_Pragma_As_Ghost (N, Def_Id);
8106 Kill_Size_Check_Code (Def_Id);
8107 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8108 end if;
8110 -- Various error checks
8112 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8114 -- We do not permit Import to apply to a renaming declaration
8116 if Present (Renamed_Object (Def_Id)) then
8117 Error_Pragma_Arg
8118 ("pragma% not allowed for object renaming", Arg2);
8120 -- User initialization is not allowed for imported object, but
8121 -- the object declaration may contain a default initialization,
8122 -- that will be discarded. Note that an explicit initialization
8123 -- only counts if it comes from source, otherwise it is simply
8124 -- the code generator making an implicit initialization explicit.
8126 elsif Present (Expression (Parent (Def_Id)))
8127 and then Comes_From_Source
8128 (Original_Node (Expression (Parent (Def_Id))))
8129 then
8130 -- Set imported flag to prevent cascaded errors
8132 Set_Is_Imported (Def_Id);
8134 Error_Msg_Sloc := Sloc (Def_Id);
8135 Error_Pragma_Arg
8136 ("no initialization allowed for declaration of& #",
8137 "\imported entities cannot be initialized (RM B.1(24))",
8138 Arg2);
8140 else
8141 -- If the pragma comes from an aspect specification the
8142 -- Is_Imported flag has already been set.
8144 if not From_Aspect_Specification (N) then
8145 Set_Imported (Def_Id);
8146 end if;
8148 Process_Interface_Name (Def_Id, Arg3, Arg4);
8150 -- Note that we do not set Is_Public here. That's because we
8151 -- only want to set it if there is no address clause, and we
8152 -- don't know that yet, so we delay that processing till
8153 -- freeze time.
8155 -- pragma Import completes deferred constants
8157 if Ekind (Def_Id) = E_Constant then
8158 Set_Has_Completion (Def_Id);
8159 end if;
8161 -- It is not possible to import a constant of an unconstrained
8162 -- array type (e.g. string) because there is no simple way to
8163 -- write a meaningful subtype for it.
8165 if Is_Array_Type (Etype (Def_Id))
8166 and then not Is_Constrained (Etype (Def_Id))
8167 then
8168 Error_Msg_NE
8169 ("imported constant& must have a constrained subtype",
8170 N, Def_Id);
8171 end if;
8172 end if;
8174 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8176 -- If the name is overloaded, pragma applies to all of the denoted
8177 -- entities in the same declarative part, unless the pragma comes
8178 -- from an aspect specification or was generated by the compiler
8179 -- (such as for pragma Provide_Shift_Operators).
8181 Hom_Id := Def_Id;
8182 while Present (Hom_Id) loop
8184 Def_Id := Get_Base_Subprogram (Hom_Id);
8186 -- Ignore inherited subprograms because the pragma will apply
8187 -- to the parent operation, which is the one called.
8189 if Is_Overloadable (Def_Id)
8190 and then Present (Alias (Def_Id))
8191 then
8192 null;
8194 -- If it is not a subprogram, it must be in an outer scope and
8195 -- pragma does not apply.
8197 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8198 null;
8200 -- The pragma does not apply to primitives of interfaces
8202 elsif Is_Dispatching_Operation (Def_Id)
8203 and then Present (Find_Dispatching_Type (Def_Id))
8204 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8205 then
8206 null;
8208 -- Verify that the homonym is in the same declarative part (not
8209 -- just the same scope). If the pragma comes from an aspect
8210 -- specification we know that it is part of the declaration.
8212 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8213 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8214 and then not From_Aspect_Specification (N)
8215 then
8216 exit;
8218 else
8219 -- If the pragma comes from an aspect specification the
8220 -- Is_Imported flag has already been set.
8222 if not From_Aspect_Specification (N) then
8223 Set_Imported (Def_Id);
8224 end if;
8226 -- Reject an Import applied to an abstract subprogram
8228 if Is_Subprogram (Def_Id)
8229 and then Is_Abstract_Subprogram (Def_Id)
8230 then
8231 Error_Msg_Sloc := Sloc (Def_Id);
8232 Error_Msg_NE
8233 ("cannot import abstract subprogram& declared#",
8234 Arg2, Def_Id);
8235 end if;
8237 -- Special processing for Convention_Intrinsic
8239 if C = Convention_Intrinsic then
8241 -- Link_Name argument not allowed for intrinsic
8243 Check_No_Link_Name;
8245 Set_Is_Intrinsic_Subprogram (Def_Id);
8247 -- If no external name is present, then check that this
8248 -- is a valid intrinsic subprogram. If an external name
8249 -- is present, then this is handled by the back end.
8251 if No (Arg3) then
8252 Check_Intrinsic_Subprogram
8253 (Def_Id, Get_Pragma_Arg (Arg2));
8254 end if;
8255 end if;
8257 -- Verify that the subprogram does not have a completion
8258 -- through a renaming declaration. For other completions the
8259 -- pragma appears as a too late representation.
8261 declare
8262 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8264 begin
8265 if Present (Decl)
8266 and then Nkind (Decl) = N_Subprogram_Declaration
8267 and then Present (Corresponding_Body (Decl))
8268 and then Nkind (Unit_Declaration_Node
8269 (Corresponding_Body (Decl))) =
8270 N_Subprogram_Renaming_Declaration
8271 then
8272 Error_Msg_Sloc := Sloc (Def_Id);
8273 Error_Msg_NE
8274 ("cannot import&, renaming already provided for "
8275 & "declaration #", N, Def_Id);
8276 end if;
8277 end;
8279 -- If the pragma comes from an aspect specification, there
8280 -- must be an Import aspect specified as well. In the rare
8281 -- case where Import is set to False, the suprogram needs to
8282 -- have a local completion.
8284 declare
8285 Imp_Aspect : constant Node_Id :=
8286 Find_Aspect (Def_Id, Aspect_Import);
8287 Expr : Node_Id;
8289 begin
8290 if Present (Imp_Aspect)
8291 and then Present (Expression (Imp_Aspect))
8292 then
8293 Expr := Expression (Imp_Aspect);
8294 Analyze_And_Resolve (Expr, Standard_Boolean);
8296 if Is_Entity_Name (Expr)
8297 and then Entity (Expr) = Standard_True
8298 then
8299 Set_Has_Completion (Def_Id);
8300 end if;
8302 -- If there is no expression, the default is True, as for
8303 -- all boolean aspects. Same for the older pragma.
8305 else
8306 Set_Has_Completion (Def_Id);
8307 end if;
8308 end;
8310 Process_Interface_Name (Def_Id, Arg3, Arg4);
8311 end if;
8313 if Is_Compilation_Unit (Hom_Id) then
8315 -- Its possible homonyms are not affected by the pragma.
8316 -- Such homonyms might be present in the context of other
8317 -- units being compiled.
8319 exit;
8321 elsif From_Aspect_Specification (N) then
8322 exit;
8324 -- If the pragma was created by the compiler, then we don't
8325 -- want it to apply to other homonyms. This kind of case can
8326 -- occur when using pragma Provide_Shift_Operators, which
8327 -- generates implicit shift and rotate operators with Import
8328 -- pragmas that might apply to earlier explicit or implicit
8329 -- declarations marked with Import (for example, coming from
8330 -- an earlier pragma Provide_Shift_Operators for another type),
8331 -- and we don't generally want other homonyms being treated
8332 -- as imported or the pragma flagged as an illegal duplicate.
8334 elsif not Comes_From_Source (N) then
8335 exit;
8337 else
8338 Hom_Id := Homonym (Hom_Id);
8339 end if;
8340 end loop;
8342 -- Import a CPP class
8344 elsif C = Convention_CPP
8345 and then (Is_Record_Type (Def_Id)
8346 or else Ekind (Def_Id) = E_Incomplete_Type)
8347 then
8348 if Ekind (Def_Id) = E_Incomplete_Type then
8349 if Present (Full_View (Def_Id)) then
8350 Def_Id := Full_View (Def_Id);
8352 else
8353 Error_Msg_N
8354 ("cannot import 'C'P'P type before full declaration seen",
8355 Get_Pragma_Arg (Arg2));
8357 -- Although we have reported the error we decorate it as
8358 -- CPP_Class to avoid reporting spurious errors
8360 Set_Is_CPP_Class (Def_Id);
8361 return;
8362 end if;
8363 end if;
8365 -- Types treated as CPP classes must be declared limited (note:
8366 -- this used to be a warning but there is no real benefit to it
8367 -- since we did effectively intend to treat the type as limited
8368 -- anyway).
8370 if not Is_Limited_Type (Def_Id) then
8371 Error_Msg_N
8372 ("imported 'C'P'P type must be limited",
8373 Get_Pragma_Arg (Arg2));
8374 end if;
8376 if Etype (Def_Id) /= Def_Id
8377 and then not Is_CPP_Class (Root_Type (Def_Id))
8378 then
8379 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8380 end if;
8382 Set_Is_CPP_Class (Def_Id);
8384 -- Imported CPP types must not have discriminants (because C++
8385 -- classes do not have discriminants).
8387 if Has_Discriminants (Def_Id) then
8388 Error_Msg_N
8389 ("imported 'C'P'P type cannot have discriminants",
8390 First (Discriminant_Specifications
8391 (Declaration_Node (Def_Id))));
8392 end if;
8394 -- Check that components of imported CPP types do not have default
8395 -- expressions. For private types this check is performed when the
8396 -- full view is analyzed (see Process_Full_View).
8398 if not Is_Private_Type (Def_Id) then
8399 Check_CPP_Type_Has_No_Defaults (Def_Id);
8400 end if;
8402 -- Import a CPP exception
8404 elsif C = Convention_CPP
8405 and then Ekind (Def_Id) = E_Exception
8406 then
8407 if No (Arg3) then
8408 Error_Pragma_Arg
8409 ("'External_'Name arguments is required for 'Cpp exception",
8410 Arg3);
8411 else
8412 -- As only a string is allowed, Check_Arg_Is_External_Name
8413 -- isn't called.
8415 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8416 end if;
8418 if Present (Arg4) then
8419 Error_Pragma_Arg
8420 ("Link_Name argument not allowed for imported Cpp exception",
8421 Arg4);
8422 end if;
8424 -- Do not call Set_Interface_Name as the name of the exception
8425 -- shouldn't be modified (and in particular it shouldn't be
8426 -- the External_Name). For exceptions, the External_Name is the
8427 -- name of the RTTI structure.
8429 -- ??? Emit an error if pragma Import/Export_Exception is present
8431 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8432 Check_No_Link_Name;
8433 Check_Arg_Count (3);
8434 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8436 Process_Import_Predefined_Type;
8438 else
8439 Error_Pragma_Arg
8440 ("second argument of pragma% must be object, subprogram "
8441 & "or incomplete type",
8442 Arg2);
8443 end if;
8445 -- If this pragma applies to a compilation unit, then the unit, which
8446 -- is a subprogram, does not require (or allow) a body. We also do
8447 -- not need to elaborate imported procedures.
8449 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8450 declare
8451 Cunit : constant Node_Id := Parent (Parent (N));
8452 begin
8453 Set_Body_Required (Cunit, False);
8454 end;
8455 end if;
8456 end Process_Import_Or_Interface;
8458 --------------------
8459 -- Process_Inline --
8460 --------------------
8462 procedure Process_Inline (Status : Inline_Status) is
8463 Applies : Boolean;
8464 Assoc : Node_Id;
8465 Decl : Node_Id;
8466 Subp : Entity_Id;
8467 Subp_Id : Node_Id;
8469 Ghost_Error_Posted : Boolean := False;
8470 -- Flag set when an error concerning the illegal mix of Ghost and
8471 -- non-Ghost subprograms is emitted.
8473 Ghost_Id : Entity_Id := Empty;
8474 -- The entity of the first Ghost subprogram encountered while
8475 -- processing the arguments of the pragma.
8477 procedure Make_Inline (Subp : Entity_Id);
8478 -- Subp is the defining unit name of the subprogram declaration. Set
8479 -- the flag, as well as the flag in the corresponding body, if there
8480 -- is one present.
8482 procedure Set_Inline_Flags (Subp : Entity_Id);
8483 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8484 -- Has_Pragma_Inline_Always for the Inline_Always case.
8486 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8487 -- Returns True if it can be determined at this stage that inlining
8488 -- is not possible, for example if the body is available and contains
8489 -- exception handlers, we prevent inlining, since otherwise we can
8490 -- get undefined symbols at link time. This function also emits a
8491 -- warning if front-end inlining is enabled and the pragma appears
8492 -- too late.
8494 -- ??? is business with link symbols still valid, or does it relate
8495 -- to front end ZCX which is being phased out ???
8497 ---------------------------
8498 -- Inlining_Not_Possible --
8499 ---------------------------
8501 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8502 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8503 Stats : Node_Id;
8505 begin
8506 if Nkind (Decl) = N_Subprogram_Body then
8507 Stats := Handled_Statement_Sequence (Decl);
8508 return Present (Exception_Handlers (Stats))
8509 or else Present (At_End_Proc (Stats));
8511 elsif Nkind (Decl) = N_Subprogram_Declaration
8512 and then Present (Corresponding_Body (Decl))
8513 then
8514 if Front_End_Inlining
8515 and then Analyzed (Corresponding_Body (Decl))
8516 then
8517 Error_Msg_N ("pragma appears too late, ignored??", N);
8518 return True;
8520 -- If the subprogram is a renaming as body, the body is just a
8521 -- call to the renamed subprogram, and inlining is trivially
8522 -- possible.
8524 elsif
8525 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8526 N_Subprogram_Renaming_Declaration
8527 then
8528 return False;
8530 else
8531 Stats :=
8532 Handled_Statement_Sequence
8533 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8535 return
8536 Present (Exception_Handlers (Stats))
8537 or else Present (At_End_Proc (Stats));
8538 end if;
8540 else
8541 -- If body is not available, assume the best, the check is
8542 -- performed again when compiling enclosing package bodies.
8544 return False;
8545 end if;
8546 end Inlining_Not_Possible;
8548 -----------------
8549 -- Make_Inline --
8550 -----------------
8552 procedure Make_Inline (Subp : Entity_Id) is
8553 Kind : constant Entity_Kind := Ekind (Subp);
8554 Inner_Subp : Entity_Id := Subp;
8556 begin
8557 -- Ignore if bad type, avoid cascaded error
8559 if Etype (Subp) = Any_Type then
8560 Applies := True;
8561 return;
8563 -- If inlining is not possible, for now do not treat as an error
8565 elsif Status /= Suppressed
8566 and then Inlining_Not_Possible (Subp)
8567 then
8568 Applies := True;
8569 return;
8571 -- Here we have a candidate for inlining, but we must exclude
8572 -- derived operations. Otherwise we would end up trying to inline
8573 -- a phantom declaration, and the result would be to drag in a
8574 -- body which has no direct inlining associated with it. That
8575 -- would not only be inefficient but would also result in the
8576 -- backend doing cross-unit inlining in cases where it was
8577 -- definitely inappropriate to do so.
8579 -- However, a simple Comes_From_Source test is insufficient, since
8580 -- we do want to allow inlining of generic instances which also do
8581 -- not come from source. We also need to recognize specs generated
8582 -- by the front-end for bodies that carry the pragma. Finally,
8583 -- predefined operators do not come from source but are not
8584 -- inlineable either.
8586 elsif Is_Generic_Instance (Subp)
8587 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8588 then
8589 null;
8591 elsif not Comes_From_Source (Subp)
8592 and then Scope (Subp) /= Standard_Standard
8593 then
8594 Applies := True;
8595 return;
8596 end if;
8598 -- The referenced entity must either be the enclosing entity, or
8599 -- an entity declared within the current open scope.
8601 if Present (Scope (Subp))
8602 and then Scope (Subp) /= Current_Scope
8603 and then Subp /= Current_Scope
8604 then
8605 Error_Pragma_Arg
8606 ("argument of% must be entity in current scope", Assoc);
8607 return;
8608 end if;
8610 -- Processing for procedure, operator or function. If subprogram
8611 -- is aliased (as for an instance) indicate that the renamed
8612 -- entity (if declared in the same unit) is inlined.
8613 -- If this is the anonymous subprogram created for a subprogram
8614 -- instance, the inlining applies to it directly. Otherwise we
8615 -- retrieve it as the alias of the visible subprogram instance.
8617 if Is_Subprogram (Subp) then
8618 if Is_Wrapper_Package (Scope (Subp)) then
8619 Inner_Subp := Subp;
8620 else
8621 Inner_Subp := Ultimate_Alias (Inner_Subp);
8622 end if;
8624 if In_Same_Source_Unit (Subp, Inner_Subp) then
8625 Set_Inline_Flags (Inner_Subp);
8627 Decl := Parent (Parent (Inner_Subp));
8629 if Nkind (Decl) = N_Subprogram_Declaration
8630 and then Present (Corresponding_Body (Decl))
8631 then
8632 Set_Inline_Flags (Corresponding_Body (Decl));
8634 elsif Is_Generic_Instance (Subp)
8635 and then Comes_From_Source (Subp)
8636 then
8637 -- Indicate that the body needs to be created for
8638 -- inlining subsequent calls. The instantiation node
8639 -- follows the declaration of the wrapper package
8640 -- created for it. The subprogram that requires the
8641 -- body is the anonymous one in the wrapper package.
8643 if Scope (Subp) /= Standard_Standard
8644 and then
8645 Need_Subprogram_Instance_Body
8646 (Next (Unit_Declaration_Node
8647 (Scope (Alias (Subp)))), Subp)
8648 then
8649 null;
8650 end if;
8652 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8653 -- appear in a formal part to apply to a formal subprogram.
8654 -- Do not apply check within an instance or a formal package
8655 -- the test will have been applied to the original generic.
8657 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8658 and then List_Containing (Decl) = List_Containing (N)
8659 and then not In_Instance
8660 then
8661 Error_Msg_N
8662 ("Inline cannot apply to a formal subprogram", N);
8664 -- If Subp is a renaming, it is the renamed entity that
8665 -- will appear in any call, and be inlined. However, for
8666 -- ASIS uses it is convenient to indicate that the renaming
8667 -- itself is an inlined subprogram, so that some gnatcheck
8668 -- rules can be applied in the absence of expansion.
8670 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8671 Set_Inline_Flags (Subp);
8672 end if;
8673 end if;
8675 Applies := True;
8677 -- For a generic subprogram set flag as well, for use at the point
8678 -- of instantiation, to determine whether the body should be
8679 -- generated.
8681 elsif Is_Generic_Subprogram (Subp) then
8682 Set_Inline_Flags (Subp);
8683 Applies := True;
8685 -- Literals are by definition inlined
8687 elsif Kind = E_Enumeration_Literal then
8688 null;
8690 -- Anything else is an error
8692 else
8693 Error_Pragma_Arg
8694 ("expect subprogram name for pragma%", Assoc);
8695 end if;
8696 end Make_Inline;
8698 ----------------------
8699 -- Set_Inline_Flags --
8700 ----------------------
8702 procedure Set_Inline_Flags (Subp : Entity_Id) is
8703 begin
8704 -- First set the Has_Pragma_XXX flags and issue the appropriate
8705 -- errors and warnings for suspicious combinations.
8707 if Prag_Id = Pragma_No_Inline then
8708 if Has_Pragma_Inline_Always (Subp) then
8709 Error_Msg_N
8710 ("Inline_Always and No_Inline are mutually exclusive", N);
8711 elsif Has_Pragma_Inline (Subp) then
8712 Error_Msg_NE
8713 ("Inline and No_Inline both specified for& ??",
8714 N, Entity (Subp_Id));
8715 end if;
8717 Set_Has_Pragma_No_Inline (Subp);
8718 else
8719 if Prag_Id = Pragma_Inline_Always then
8720 if Has_Pragma_No_Inline (Subp) then
8721 Error_Msg_N
8722 ("Inline_Always and No_Inline are mutually exclusive",
8724 end if;
8726 Set_Has_Pragma_Inline_Always (Subp);
8727 else
8728 if Has_Pragma_No_Inline (Subp) then
8729 Error_Msg_NE
8730 ("Inline and No_Inline both specified for& ??",
8731 N, Entity (Subp_Id));
8732 end if;
8733 end if;
8735 if not Has_Pragma_Inline (Subp) then
8736 Set_Has_Pragma_Inline (Subp);
8737 end if;
8738 end if;
8740 -- Then adjust the Is_Inlined flag. It can never be set if the
8741 -- subprogram is subject to pragma No_Inline.
8743 case Status is
8744 when Suppressed =>
8745 Set_Is_Inlined (Subp, False);
8746 when Disabled =>
8747 null;
8748 when Enabled =>
8749 if not Has_Pragma_No_Inline (Subp) then
8750 Set_Is_Inlined (Subp, True);
8751 end if;
8752 end case;
8754 -- A pragma that applies to a Ghost entity becomes Ghost for the
8755 -- purposes of legality checks and removal of ignored Ghost code.
8757 Mark_Pragma_As_Ghost (N, Subp);
8759 -- Capture the entity of the first Ghost subprogram being
8760 -- processed for error detection purposes.
8762 if Is_Ghost_Entity (Subp) then
8763 if No (Ghost_Id) then
8764 Ghost_Id := Subp;
8765 end if;
8767 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
8768 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
8770 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
8771 Ghost_Error_Posted := True;
8773 Error_Msg_Name_1 := Pname;
8774 Error_Msg_N
8775 ("pragma % cannot mention ghost and non-ghost subprograms",
8778 Error_Msg_Sloc := Sloc (Ghost_Id);
8779 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
8781 Error_Msg_Sloc := Sloc (Subp);
8782 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
8783 end if;
8784 end Set_Inline_Flags;
8786 -- Start of processing for Process_Inline
8788 begin
8789 Check_No_Identifiers;
8790 Check_At_Least_N_Arguments (1);
8792 if Status = Enabled then
8793 Inline_Processing_Required := True;
8794 end if;
8796 Assoc := Arg1;
8797 while Present (Assoc) loop
8798 Subp_Id := Get_Pragma_Arg (Assoc);
8799 Analyze (Subp_Id);
8800 Applies := False;
8802 if Is_Entity_Name (Subp_Id) then
8803 Subp := Entity (Subp_Id);
8805 if Subp = Any_Id then
8807 -- If previous error, avoid cascaded errors
8809 Check_Error_Detected;
8810 Applies := True;
8812 else
8813 Make_Inline (Subp);
8815 -- For the pragma case, climb homonym chain. This is
8816 -- what implements allowing the pragma in the renaming
8817 -- case, with the result applying to the ancestors, and
8818 -- also allows Inline to apply to all previous homonyms.
8820 if not From_Aspect_Specification (N) then
8821 while Present (Homonym (Subp))
8822 and then Scope (Homonym (Subp)) = Current_Scope
8823 loop
8824 Make_Inline (Homonym (Subp));
8825 Subp := Homonym (Subp);
8826 end loop;
8827 end if;
8828 end if;
8829 end if;
8831 if not Applies then
8832 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
8833 end if;
8835 Next (Assoc);
8836 end loop;
8837 end Process_Inline;
8839 ----------------------------
8840 -- Process_Interface_Name --
8841 ----------------------------
8843 procedure Process_Interface_Name
8844 (Subprogram_Def : Entity_Id;
8845 Ext_Arg : Node_Id;
8846 Link_Arg : Node_Id)
8848 Ext_Nam : Node_Id;
8849 Link_Nam : Node_Id;
8850 String_Val : String_Id;
8852 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
8853 -- SN is a string literal node for an interface name. This routine
8854 -- performs some minimal checks that the name is reasonable. In
8855 -- particular that no spaces or other obviously incorrect characters
8856 -- appear. This is only a warning, since any characters are allowed.
8858 ----------------------------------
8859 -- Check_Form_Of_Interface_Name --
8860 ----------------------------------
8862 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
8863 S : constant String_Id := Strval (Expr_Value_S (SN));
8864 SL : constant Nat := String_Length (S);
8865 C : Char_Code;
8867 begin
8868 if SL = 0 then
8869 Error_Msg_N ("interface name cannot be null string", SN);
8870 end if;
8872 for J in 1 .. SL loop
8873 C := Get_String_Char (S, J);
8875 -- Look for dubious character and issue unconditional warning.
8876 -- Definitely dubious if not in character range.
8878 if not In_Character_Range (C)
8880 -- Commas, spaces and (back)slashes are dubious
8882 or else Get_Character (C) = ','
8883 or else Get_Character (C) = '\'
8884 or else Get_Character (C) = ' '
8885 or else Get_Character (C) = '/'
8886 then
8887 Error_Msg
8888 ("??interface name contains illegal character",
8889 Sloc (SN) + Source_Ptr (J));
8890 end if;
8891 end loop;
8892 end Check_Form_Of_Interface_Name;
8894 -- Start of processing for Process_Interface_Name
8896 begin
8897 if No (Link_Arg) then
8898 if No (Ext_Arg) then
8899 return;
8901 elsif Chars (Ext_Arg) = Name_Link_Name then
8902 Ext_Nam := Empty;
8903 Link_Nam := Expression (Ext_Arg);
8905 else
8906 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8907 Ext_Nam := Expression (Ext_Arg);
8908 Link_Nam := Empty;
8909 end if;
8911 else
8912 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8913 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
8914 Ext_Nam := Expression (Ext_Arg);
8915 Link_Nam := Expression (Link_Arg);
8916 end if;
8918 -- Check expressions for external name and link name are static
8920 if Present (Ext_Nam) then
8921 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
8922 Check_Form_Of_Interface_Name (Ext_Nam);
8924 -- Verify that external name is not the name of a local entity,
8925 -- which would hide the imported one and could lead to run-time
8926 -- surprises. The problem can only arise for entities declared in
8927 -- a package body (otherwise the external name is fully qualified
8928 -- and will not conflict).
8930 declare
8931 Nam : Name_Id;
8932 E : Entity_Id;
8933 Par : Node_Id;
8935 begin
8936 if Prag_Id = Pragma_Import then
8937 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
8938 Nam := Name_Find;
8939 E := Entity_Id (Get_Name_Table_Int (Nam));
8941 if Nam /= Chars (Subprogram_Def)
8942 and then Present (E)
8943 and then not Is_Overloadable (E)
8944 and then Is_Immediately_Visible (E)
8945 and then not Is_Imported (E)
8946 and then Ekind (Scope (E)) = E_Package
8947 then
8948 Par := Parent (E);
8949 while Present (Par) loop
8950 if Nkind (Par) = N_Package_Body then
8951 Error_Msg_Sloc := Sloc (E);
8952 Error_Msg_NE
8953 ("imported entity is hidden by & declared#",
8954 Ext_Arg, E);
8955 exit;
8956 end if;
8958 Par := Parent (Par);
8959 end loop;
8960 end if;
8961 end if;
8962 end;
8963 end if;
8965 if Present (Link_Nam) then
8966 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
8967 Check_Form_Of_Interface_Name (Link_Nam);
8968 end if;
8970 -- If there is no link name, just set the external name
8972 if No (Link_Nam) then
8973 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
8975 -- For the Link_Name case, the given literal is preceded by an
8976 -- asterisk, which indicates to GCC that the given name should be
8977 -- taken literally, and in particular that no prepending of
8978 -- underlines should occur, even in systems where this is the
8979 -- normal default.
8981 else
8982 Start_String;
8983 Store_String_Char (Get_Char_Code ('*'));
8984 String_Val := Strval (Expr_Value_S (Link_Nam));
8985 Store_String_Chars (String_Val);
8986 Link_Nam :=
8987 Make_String_Literal (Sloc (Link_Nam),
8988 Strval => End_String);
8989 end if;
8991 -- Set the interface name. If the entity is a generic instance, use
8992 -- its alias, which is the callable entity.
8994 if Is_Generic_Instance (Subprogram_Def) then
8995 Set_Encoded_Interface_Name
8996 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
8997 else
8998 Set_Encoded_Interface_Name
8999 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9000 end if;
9002 Check_Duplicated_Export_Name (Link_Nam);
9003 end Process_Interface_Name;
9005 -----------------------------------------
9006 -- Process_Interrupt_Or_Attach_Handler --
9007 -----------------------------------------
9009 procedure Process_Interrupt_Or_Attach_Handler is
9010 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9011 Prot_Typ : constant Entity_Id := Scope (Handler);
9013 begin
9014 -- A pragma that applies to a Ghost entity becomes Ghost for the
9015 -- purposes of legality checks and removal of ignored Ghost code.
9017 Mark_Pragma_As_Ghost (N, Handler);
9018 Set_Is_Interrupt_Handler (Handler);
9020 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9022 Record_Rep_Item (Prot_Typ, N);
9024 -- Chain the pragma on the contract for completeness
9026 Add_Contract_Item (N, Handler);
9027 end Process_Interrupt_Or_Attach_Handler;
9029 --------------------------------------------------
9030 -- Process_Restrictions_Or_Restriction_Warnings --
9031 --------------------------------------------------
9033 -- Note: some of the simple identifier cases were handled in par-prag,
9034 -- but it is harmless (and more straightforward) to simply handle all
9035 -- cases here, even if it means we repeat a bit of work in some cases.
9037 procedure Process_Restrictions_Or_Restriction_Warnings
9038 (Warn : Boolean)
9040 Arg : Node_Id;
9041 R_Id : Restriction_Id;
9042 Id : Name_Id;
9043 Expr : Node_Id;
9044 Val : Uint;
9046 begin
9047 -- Ignore all Restrictions pragmas in CodePeer mode
9049 if CodePeer_Mode then
9050 return;
9051 end if;
9053 Check_Ada_83_Warning;
9054 Check_At_Least_N_Arguments (1);
9055 Check_Valid_Configuration_Pragma;
9057 Arg := Arg1;
9058 while Present (Arg) loop
9059 Id := Chars (Arg);
9060 Expr := Get_Pragma_Arg (Arg);
9062 -- Case of no restriction identifier present
9064 if Id = No_Name then
9065 if Nkind (Expr) /= N_Identifier then
9066 Error_Pragma_Arg
9067 ("invalid form for restriction", Arg);
9068 end if;
9070 R_Id :=
9071 Get_Restriction_Id
9072 (Process_Restriction_Synonyms (Expr));
9074 if R_Id not in All_Boolean_Restrictions then
9075 Error_Msg_Name_1 := Pname;
9076 Error_Msg_N
9077 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9079 -- Check for possible misspelling
9081 for J in Restriction_Id loop
9082 declare
9083 Rnm : constant String := Restriction_Id'Image (J);
9085 begin
9086 Name_Buffer (1 .. Rnm'Length) := Rnm;
9087 Name_Len := Rnm'Length;
9088 Set_Casing (All_Lower_Case);
9090 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9091 Set_Casing
9092 (Identifier_Casing (Current_Source_File));
9093 Error_Msg_String (1 .. Rnm'Length) :=
9094 Name_Buffer (1 .. Name_Len);
9095 Error_Msg_Strlen := Rnm'Length;
9096 Error_Msg_N -- CODEFIX
9097 ("\possible misspelling of ""~""",
9098 Get_Pragma_Arg (Arg));
9099 exit;
9100 end if;
9101 end;
9102 end loop;
9104 raise Pragma_Exit;
9105 end if;
9107 if Implementation_Restriction (R_Id) then
9108 Check_Restriction (No_Implementation_Restrictions, Arg);
9109 end if;
9111 -- Special processing for No_Elaboration_Code restriction
9113 if R_Id = No_Elaboration_Code then
9115 -- Restriction is only recognized within a configuration
9116 -- pragma file, or within a unit of the main extended
9117 -- program. Note: the test for Main_Unit is needed to
9118 -- properly include the case of configuration pragma files.
9120 if not (Current_Sem_Unit = Main_Unit
9121 or else In_Extended_Main_Source_Unit (N))
9122 then
9123 return;
9125 -- Don't allow in a subunit unless already specified in
9126 -- body or spec.
9128 elsif Nkind (Parent (N)) = N_Compilation_Unit
9129 and then Nkind (Unit (Parent (N))) = N_Subunit
9130 and then not Restriction_Active (No_Elaboration_Code)
9131 then
9132 Error_Msg_N
9133 ("invalid specification of ""No_Elaboration_Code""",
9135 Error_Msg_N
9136 ("\restriction cannot be specified in a subunit", N);
9137 Error_Msg_N
9138 ("\unless also specified in body or spec", N);
9139 return;
9141 -- If we accept a No_Elaboration_Code restriction, then it
9142 -- needs to be added to the configuration restriction set so
9143 -- that we get proper application to other units in the main
9144 -- extended source as required.
9146 else
9147 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9148 end if;
9149 end if;
9151 -- If this is a warning, then set the warning unless we already
9152 -- have a real restriction active (we never want a warning to
9153 -- override a real restriction).
9155 if Warn then
9156 if not Restriction_Active (R_Id) then
9157 Set_Restriction (R_Id, N);
9158 Restriction_Warnings (R_Id) := True;
9159 end if;
9161 -- If real restriction case, then set it and make sure that the
9162 -- restriction warning flag is off, since a real restriction
9163 -- always overrides a warning.
9165 else
9166 Set_Restriction (R_Id, N);
9167 Restriction_Warnings (R_Id) := False;
9168 end if;
9170 -- Check for obsolescent restrictions in Ada 2005 mode
9172 if not Warn
9173 and then Ada_Version >= Ada_2005
9174 and then (R_Id = No_Asynchronous_Control
9175 or else
9176 R_Id = No_Unchecked_Deallocation
9177 or else
9178 R_Id = No_Unchecked_Conversion)
9179 then
9180 Check_Restriction (No_Obsolescent_Features, N);
9181 end if;
9183 -- A very special case that must be processed here: pragma
9184 -- Restrictions (No_Exceptions) turns off all run-time
9185 -- checking. This is a bit dubious in terms of the formal
9186 -- language definition, but it is what is intended by RM
9187 -- H.4(12). Restriction_Warnings never affects generated code
9188 -- so this is done only in the real restriction case.
9190 -- Atomic_Synchronization is not a real check, so it is not
9191 -- affected by this processing).
9193 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9194 -- run-time checks in CodePeer and GNATprove modes: we want to
9195 -- generate checks for analysis purposes, as set respectively
9196 -- by -gnatC and -gnatd.F
9198 if not Warn
9199 and then not (CodePeer_Mode or GNATprove_Mode)
9200 and then R_Id = No_Exceptions
9201 then
9202 for J in Scope_Suppress.Suppress'Range loop
9203 if J /= Atomic_Synchronization then
9204 Scope_Suppress.Suppress (J) := True;
9205 end if;
9206 end loop;
9207 end if;
9209 -- Case of No_Dependence => unit-name. Note that the parser
9210 -- already made the necessary entry in the No_Dependence table.
9212 elsif Id = Name_No_Dependence then
9213 if not OK_No_Dependence_Unit_Name (Expr) then
9214 raise Pragma_Exit;
9215 end if;
9217 -- Case of No_Specification_Of_Aspect => aspect-identifier
9219 elsif Id = Name_No_Specification_Of_Aspect then
9220 declare
9221 A_Id : Aspect_Id;
9223 begin
9224 if Nkind (Expr) /= N_Identifier then
9225 A_Id := No_Aspect;
9226 else
9227 A_Id := Get_Aspect_Id (Chars (Expr));
9228 end if;
9230 if A_Id = No_Aspect then
9231 Error_Pragma_Arg ("invalid restriction name", Arg);
9232 else
9233 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9234 end if;
9235 end;
9237 -- Case of No_Use_Of_Attribute => attribute-identifier
9239 elsif Id = Name_No_Use_Of_Attribute then
9240 if Nkind (Expr) /= N_Identifier
9241 or else not Is_Attribute_Name (Chars (Expr))
9242 then
9243 Error_Msg_N ("unknown attribute name??", Expr);
9245 else
9246 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9247 end if;
9249 -- Case of No_Use_Of_Entity => fully-qualified-name
9251 elsif Id = Name_No_Use_Of_Entity then
9253 -- Restriction is only recognized within a configuration
9254 -- pragma file, or within a unit of the main extended
9255 -- program. Note: the test for Main_Unit is needed to
9256 -- properly include the case of configuration pragma files.
9258 if Current_Sem_Unit = Main_Unit
9259 or else In_Extended_Main_Source_Unit (N)
9260 then
9261 if not OK_No_Dependence_Unit_Name (Expr) then
9262 Error_Msg_N ("wrong form for entity name", Expr);
9263 else
9264 Set_Restriction_No_Use_Of_Entity
9265 (Expr, Warn, No_Profile);
9266 end if;
9267 end if;
9269 -- Case of No_Use_Of_Pragma => pragma-identifier
9271 elsif Id = Name_No_Use_Of_Pragma then
9272 if Nkind (Expr) /= N_Identifier
9273 or else not Is_Pragma_Name (Chars (Expr))
9274 then
9275 Error_Msg_N ("unknown pragma name??", Expr);
9276 else
9277 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9278 end if;
9280 -- All other cases of restriction identifier present
9282 else
9283 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9284 Analyze_And_Resolve (Expr, Any_Integer);
9286 if R_Id not in All_Parameter_Restrictions then
9287 Error_Pragma_Arg
9288 ("invalid restriction parameter identifier", Arg);
9290 elsif not Is_OK_Static_Expression (Expr) then
9291 Flag_Non_Static_Expr
9292 ("value must be static expression!", Expr);
9293 raise Pragma_Exit;
9295 elsif not Is_Integer_Type (Etype (Expr))
9296 or else Expr_Value (Expr) < 0
9297 then
9298 Error_Pragma_Arg
9299 ("value must be non-negative integer", Arg);
9300 end if;
9302 -- Restriction pragma is active
9304 Val := Expr_Value (Expr);
9306 if not UI_Is_In_Int_Range (Val) then
9307 Error_Pragma_Arg
9308 ("pragma ignored, value too large??", Arg);
9309 end if;
9311 -- Warning case. If the real restriction is active, then we
9312 -- ignore the request, since warning never overrides a real
9313 -- restriction. Otherwise we set the proper warning. Note that
9314 -- this circuit sets the warning again if it is already set,
9315 -- which is what we want, since the constant may have changed.
9317 if Warn then
9318 if not Restriction_Active (R_Id) then
9319 Set_Restriction
9320 (R_Id, N, Integer (UI_To_Int (Val)));
9321 Restriction_Warnings (R_Id) := True;
9322 end if;
9324 -- Real restriction case, set restriction and make sure warning
9325 -- flag is off since real restriction always overrides warning.
9327 else
9328 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9329 Restriction_Warnings (R_Id) := False;
9330 end if;
9331 end if;
9333 Next (Arg);
9334 end loop;
9335 end Process_Restrictions_Or_Restriction_Warnings;
9337 ---------------------------------
9338 -- Process_Suppress_Unsuppress --
9339 ---------------------------------
9341 -- Note: this procedure makes entries in the check suppress data
9342 -- structures managed by Sem. See spec of package Sem for full
9343 -- details on how we handle recording of check suppression.
9345 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9346 C : Check_Id;
9347 E : Entity_Id;
9348 E_Id : Node_Id;
9350 In_Package_Spec : constant Boolean :=
9351 Is_Package_Or_Generic_Package (Current_Scope)
9352 and then not In_Package_Body (Current_Scope);
9354 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9355 -- Used to suppress a single check on the given entity
9357 --------------------------------
9358 -- Suppress_Unsuppress_Echeck --
9359 --------------------------------
9361 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9362 begin
9363 -- Check for error of trying to set atomic synchronization for
9364 -- a non-atomic variable.
9366 if C = Atomic_Synchronization
9367 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9368 then
9369 Error_Msg_N
9370 ("pragma & requires atomic type or variable",
9371 Pragma_Identifier (Original_Node (N)));
9372 end if;
9374 Set_Checks_May_Be_Suppressed (E);
9376 if In_Package_Spec then
9377 Push_Global_Suppress_Stack_Entry
9378 (Entity => E,
9379 Check => C,
9380 Suppress => Suppress_Case);
9381 else
9382 Push_Local_Suppress_Stack_Entry
9383 (Entity => E,
9384 Check => C,
9385 Suppress => Suppress_Case);
9386 end if;
9388 -- If this is a first subtype, and the base type is distinct,
9389 -- then also set the suppress flags on the base type.
9391 if Is_First_Subtype (E) and then Etype (E) /= E then
9392 Suppress_Unsuppress_Echeck (Etype (E), C);
9393 end if;
9394 end Suppress_Unsuppress_Echeck;
9396 -- Start of processing for Process_Suppress_Unsuppress
9398 begin
9399 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9400 -- on user code: we want to generate checks for analysis purposes, as
9401 -- set respectively by -gnatC and -gnatd.F
9403 if Comes_From_Source (N)
9404 and then (CodePeer_Mode or GNATprove_Mode)
9405 then
9406 return;
9407 end if;
9409 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9410 -- declarative part or a package spec (RM 11.5(5)).
9412 if not Is_Configuration_Pragma then
9413 Check_Is_In_Decl_Part_Or_Package_Spec;
9414 end if;
9416 Check_At_Least_N_Arguments (1);
9417 Check_At_Most_N_Arguments (2);
9418 Check_No_Identifier (Arg1);
9419 Check_Arg_Is_Identifier (Arg1);
9421 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9423 if C = No_Check_Id then
9424 Error_Pragma_Arg
9425 ("argument of pragma% is not valid check name", Arg1);
9426 end if;
9428 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9430 if C = Elaboration_Check and then SPARK_Mode = On then
9431 Error_Pragma_Arg
9432 ("Suppress of Elaboration_Check ignored in SPARK??",
9433 "\elaboration checking rules are statically enforced "
9434 & "(SPARK RM 7.7)", Arg1);
9435 end if;
9437 -- One-argument case
9439 if Arg_Count = 1 then
9441 -- Make an entry in the local scope suppress table. This is the
9442 -- table that directly shows the current value of the scope
9443 -- suppress check for any check id value.
9445 if C = All_Checks then
9447 -- For All_Checks, we set all specific predefined checks with
9448 -- the exception of Elaboration_Check, which is handled
9449 -- specially because of not wanting All_Checks to have the
9450 -- effect of deactivating static elaboration order processing.
9451 -- Atomic_Synchronization is also not affected, since this is
9452 -- not a real check.
9454 for J in Scope_Suppress.Suppress'Range loop
9455 if J /= Elaboration_Check
9456 and then
9457 J /= Atomic_Synchronization
9458 then
9459 Scope_Suppress.Suppress (J) := Suppress_Case;
9460 end if;
9461 end loop;
9463 -- If not All_Checks, and predefined check, then set appropriate
9464 -- scope entry. Note that we will set Elaboration_Check if this
9465 -- is explicitly specified. Atomic_Synchronization is allowed
9466 -- only if internally generated and entity is atomic.
9468 elsif C in Predefined_Check_Id
9469 and then (not Comes_From_Source (N)
9470 or else C /= Atomic_Synchronization)
9471 then
9472 Scope_Suppress.Suppress (C) := Suppress_Case;
9473 end if;
9475 -- Also make an entry in the Local_Entity_Suppress table
9477 Push_Local_Suppress_Stack_Entry
9478 (Entity => Empty,
9479 Check => C,
9480 Suppress => Suppress_Case);
9482 -- Case of two arguments present, where the check is suppressed for
9483 -- a specified entity (given as the second argument of the pragma)
9485 else
9486 -- This is obsolescent in Ada 2005 mode
9488 if Ada_Version >= Ada_2005 then
9489 Check_Restriction (No_Obsolescent_Features, Arg2);
9490 end if;
9492 Check_Optional_Identifier (Arg2, Name_On);
9493 E_Id := Get_Pragma_Arg (Arg2);
9494 Analyze (E_Id);
9496 if not Is_Entity_Name (E_Id) then
9497 Error_Pragma_Arg
9498 ("second argument of pragma% must be entity name", Arg2);
9499 end if;
9501 E := Entity (E_Id);
9503 if E = Any_Id then
9504 return;
9505 end if;
9507 -- A pragma that applies to a Ghost entity becomes Ghost for the
9508 -- purposes of legality checks and removal of ignored Ghost code.
9510 Mark_Pragma_As_Ghost (N, E);
9512 -- Enforce RM 11.5(7) which requires that for a pragma that
9513 -- appears within a package spec, the named entity must be
9514 -- within the package spec. We allow the package name itself
9515 -- to be mentioned since that makes sense, although it is not
9516 -- strictly allowed by 11.5(7).
9518 if In_Package_Spec
9519 and then E /= Current_Scope
9520 and then Scope (E) /= Current_Scope
9521 then
9522 Error_Pragma_Arg
9523 ("entity in pragma% is not in package spec (RM 11.5(7))",
9524 Arg2);
9525 end if;
9527 -- Loop through homonyms. As noted below, in the case of a package
9528 -- spec, only homonyms within the package spec are considered.
9530 loop
9531 Suppress_Unsuppress_Echeck (E, C);
9533 if Is_Generic_Instance (E)
9534 and then Is_Subprogram (E)
9535 and then Present (Alias (E))
9536 then
9537 Suppress_Unsuppress_Echeck (Alias (E), C);
9538 end if;
9540 -- Move to next homonym if not aspect spec case
9542 exit when From_Aspect_Specification (N);
9543 E := Homonym (E);
9544 exit when No (E);
9546 -- If we are within a package specification, the pragma only
9547 -- applies to homonyms in the same scope.
9549 exit when In_Package_Spec
9550 and then Scope (E) /= Current_Scope;
9551 end loop;
9552 end if;
9553 end Process_Suppress_Unsuppress;
9555 -------------------------------
9556 -- Record_Independence_Check --
9557 -------------------------------
9559 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9560 begin
9561 -- For GCC back ends the validation is done a priori
9563 if not AAMP_On_Target then
9564 return;
9565 end if;
9567 Independence_Checks.Append ((N, E));
9568 end Record_Independence_Check;
9570 ------------------
9571 -- Set_Exported --
9572 ------------------
9574 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9575 begin
9576 if Is_Imported (E) then
9577 Error_Pragma_Arg
9578 ("cannot export entity& that was previously imported", Arg);
9580 elsif Present (Address_Clause (E))
9581 and then not Relaxed_RM_Semantics
9582 then
9583 Error_Pragma_Arg
9584 ("cannot export entity& that has an address clause", Arg);
9585 end if;
9587 Set_Is_Exported (E);
9589 -- Generate a reference for entity explicitly, because the
9590 -- identifier may be overloaded and name resolution will not
9591 -- generate one.
9593 Generate_Reference (E, Arg);
9595 -- Deal with exporting non-library level entity
9597 if not Is_Library_Level_Entity (E) then
9599 -- Not allowed at all for subprograms
9601 if Is_Subprogram (E) then
9602 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9604 -- Otherwise set public and statically allocated
9606 else
9607 Set_Is_Public (E);
9608 Set_Is_Statically_Allocated (E);
9610 -- Warn if the corresponding W flag is set
9612 if Warn_On_Export_Import
9614 -- Only do this for something that was in the source. Not
9615 -- clear if this can be False now (there used for sure to be
9616 -- cases on some systems where it was False), but anyway the
9617 -- test is harmless if not needed, so it is retained.
9619 and then Comes_From_Source (Arg)
9620 then
9621 Error_Msg_NE
9622 ("?x?& has been made static as a result of Export",
9623 Arg, E);
9624 Error_Msg_N
9625 ("\?x?this usage is non-standard and non-portable",
9626 Arg);
9627 end if;
9628 end if;
9629 end if;
9631 if Warn_On_Export_Import and then Is_Type (E) then
9632 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9633 end if;
9635 if Warn_On_Export_Import and Inside_A_Generic then
9636 Error_Msg_NE
9637 ("all instances of& will have the same external name?x?",
9638 Arg, E);
9639 end if;
9640 end Set_Exported;
9642 ----------------------------------------------
9643 -- Set_Extended_Import_Export_External_Name --
9644 ----------------------------------------------
9646 procedure Set_Extended_Import_Export_External_Name
9647 (Internal_Ent : Entity_Id;
9648 Arg_External : Node_Id)
9650 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9651 New_Name : Node_Id;
9653 begin
9654 if No (Arg_External) then
9655 return;
9656 end if;
9658 Check_Arg_Is_External_Name (Arg_External);
9660 if Nkind (Arg_External) = N_String_Literal then
9661 if String_Length (Strval (Arg_External)) = 0 then
9662 return;
9663 else
9664 New_Name := Adjust_External_Name_Case (Arg_External);
9665 end if;
9667 elsif Nkind (Arg_External) = N_Identifier then
9668 New_Name := Get_Default_External_Name (Arg_External);
9670 -- Check_Arg_Is_External_Name should let through only identifiers and
9671 -- string literals or static string expressions (which are folded to
9672 -- string literals).
9674 else
9675 raise Program_Error;
9676 end if;
9678 -- If we already have an external name set (by a prior normal Import
9679 -- or Export pragma), then the external names must match
9681 if Present (Interface_Name (Internal_Ent)) then
9683 -- Ignore mismatching names in CodePeer mode, to support some
9684 -- old compilers which would export the same procedure under
9685 -- different names, e.g:
9686 -- procedure P;
9687 -- pragma Export_Procedure (P, "a");
9688 -- pragma Export_Procedure (P, "b");
9690 if CodePeer_Mode then
9691 return;
9692 end if;
9694 Check_Matching_Internal_Names : declare
9695 S1 : constant String_Id := Strval (Old_Name);
9696 S2 : constant String_Id := Strval (New_Name);
9698 procedure Mismatch;
9699 pragma No_Return (Mismatch);
9700 -- Called if names do not match
9702 --------------
9703 -- Mismatch --
9704 --------------
9706 procedure Mismatch is
9707 begin
9708 Error_Msg_Sloc := Sloc (Old_Name);
9709 Error_Pragma_Arg
9710 ("external name does not match that given #",
9711 Arg_External);
9712 end Mismatch;
9714 -- Start of processing for Check_Matching_Internal_Names
9716 begin
9717 if String_Length (S1) /= String_Length (S2) then
9718 Mismatch;
9720 else
9721 for J in 1 .. String_Length (S1) loop
9722 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
9723 Mismatch;
9724 end if;
9725 end loop;
9726 end if;
9727 end Check_Matching_Internal_Names;
9729 -- Otherwise set the given name
9731 else
9732 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
9733 Check_Duplicated_Export_Name (New_Name);
9734 end if;
9735 end Set_Extended_Import_Export_External_Name;
9737 ------------------
9738 -- Set_Imported --
9739 ------------------
9741 procedure Set_Imported (E : Entity_Id) is
9742 begin
9743 -- Error message if already imported or exported
9745 if Is_Exported (E) or else Is_Imported (E) then
9747 -- Error if being set Exported twice
9749 if Is_Exported (E) then
9750 Error_Msg_NE ("entity& was previously exported", N, E);
9752 -- Ignore error in CodePeer mode where we treat all imported
9753 -- subprograms as unknown.
9755 elsif CodePeer_Mode then
9756 goto OK;
9758 -- OK if Import/Interface case
9760 elsif Import_Interface_Present (N) then
9761 goto OK;
9763 -- Error if being set Imported twice
9765 else
9766 Error_Msg_NE ("entity& was previously imported", N, E);
9767 end if;
9769 Error_Msg_Name_1 := Pname;
9770 Error_Msg_N
9771 ("\(pragma% applies to all previous entities)", N);
9773 Error_Msg_Sloc := Sloc (E);
9774 Error_Msg_NE ("\import not allowed for& declared#", N, E);
9776 -- Here if not previously imported or exported, OK to import
9778 else
9779 Set_Is_Imported (E);
9781 -- For subprogram, set Import_Pragma field
9783 if Is_Subprogram (E) then
9784 Set_Import_Pragma (E, N);
9785 end if;
9787 -- If the entity is an object that is not at the library level,
9788 -- then it is statically allocated. We do not worry about objects
9789 -- with address clauses in this context since they are not really
9790 -- imported in the linker sense.
9792 if Is_Object (E)
9793 and then not Is_Library_Level_Entity (E)
9794 and then No (Address_Clause (E))
9795 then
9796 Set_Is_Statically_Allocated (E);
9797 end if;
9798 end if;
9800 <<OK>> null;
9801 end Set_Imported;
9803 -------------------------
9804 -- Set_Mechanism_Value --
9805 -------------------------
9807 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9808 -- analyzed, since it is semantic nonsense), so we get it in the exact
9809 -- form created by the parser.
9811 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
9812 procedure Bad_Mechanism;
9813 pragma No_Return (Bad_Mechanism);
9814 -- Signal bad mechanism name
9816 -------------------------
9817 -- Bad_Mechanism_Value --
9818 -------------------------
9820 procedure Bad_Mechanism is
9821 begin
9822 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
9823 end Bad_Mechanism;
9825 -- Start of processing for Set_Mechanism_Value
9827 begin
9828 if Mechanism (Ent) /= Default_Mechanism then
9829 Error_Msg_NE
9830 ("mechanism for & has already been set", Mech_Name, Ent);
9831 end if;
9833 -- MECHANISM_NAME ::= value | reference
9835 if Nkind (Mech_Name) = N_Identifier then
9836 if Chars (Mech_Name) = Name_Value then
9837 Set_Mechanism (Ent, By_Copy);
9838 return;
9840 elsif Chars (Mech_Name) = Name_Reference then
9841 Set_Mechanism (Ent, By_Reference);
9842 return;
9844 elsif Chars (Mech_Name) = Name_Copy then
9845 Error_Pragma_Arg
9846 ("bad mechanism name, Value assumed", Mech_Name);
9848 else
9849 Bad_Mechanism;
9850 end if;
9852 else
9853 Bad_Mechanism;
9854 end if;
9855 end Set_Mechanism_Value;
9857 --------------------------
9858 -- Set_Rational_Profile --
9859 --------------------------
9861 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9862 -- extension to the semantics of renaming declarations.
9864 procedure Set_Rational_Profile is
9865 begin
9866 Implicit_Packing := True;
9867 Overriding_Renamings := True;
9868 Use_VADS_Size := True;
9869 end Set_Rational_Profile;
9871 ---------------------------
9872 -- Set_Ravenscar_Profile --
9873 ---------------------------
9875 -- The tasks to be done here are
9877 -- Set required policies
9879 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9880 -- pragma Locking_Policy (Ceiling_Locking)
9882 -- Set Detect_Blocking mode
9884 -- Set required restrictions (see System.Rident for detailed list)
9886 -- Set the No_Dependence rules
9887 -- No_Dependence => Ada.Asynchronous_Task_Control
9888 -- No_Dependence => Ada.Calendar
9889 -- No_Dependence => Ada.Execution_Time.Group_Budget
9890 -- No_Dependence => Ada.Execution_Time.Timers
9891 -- No_Dependence => Ada.Task_Attributes
9892 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9894 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
9895 procedure Set_Error_Msg_To_Profile_Name;
9896 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
9897 -- profile.
9899 -----------------------------------
9900 -- Set_Error_Msg_To_Profile_Name --
9901 -----------------------------------
9903 procedure Set_Error_Msg_To_Profile_Name is
9904 Prof_Nam : constant Node_Id :=
9905 Get_Pragma_Arg
9906 (First (Pragma_Argument_Associations (N)));
9908 begin
9909 Get_Name_String (Chars (Prof_Nam));
9910 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
9911 Error_Msg_Strlen := Name_Len;
9912 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
9913 end Set_Error_Msg_To_Profile_Name;
9915 -- Local variables
9917 Nod : Node_Id;
9918 Pref : Node_Id;
9919 Pref_Id : Node_Id;
9920 Sel_Id : Node_Id;
9922 -- Start of processing for Set_Ravenscar_Profile
9924 begin
9925 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9927 if Task_Dispatching_Policy /= ' '
9928 and then Task_Dispatching_Policy /= 'F'
9929 then
9930 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
9931 Set_Error_Msg_To_Profile_Name;
9932 Error_Pragma ("Profile (~) incompatible with policy#");
9934 -- Set the FIFO_Within_Priorities policy, but always preserve
9935 -- System_Location since we like the error message with the run time
9936 -- name.
9938 else
9939 Task_Dispatching_Policy := 'F';
9941 if Task_Dispatching_Policy_Sloc /= System_Location then
9942 Task_Dispatching_Policy_Sloc := Loc;
9943 end if;
9944 end if;
9946 -- pragma Locking_Policy (Ceiling_Locking)
9948 if Locking_Policy /= ' '
9949 and then Locking_Policy /= 'C'
9950 then
9951 Error_Msg_Sloc := Locking_Policy_Sloc;
9952 Set_Error_Msg_To_Profile_Name;
9953 Error_Pragma ("Profile (~) incompatible with policy#");
9955 -- Set the Ceiling_Locking policy, but preserve System_Location since
9956 -- we like the error message with the run time name.
9958 else
9959 Locking_Policy := 'C';
9961 if Locking_Policy_Sloc /= System_Location then
9962 Locking_Policy_Sloc := Loc;
9963 end if;
9964 end if;
9966 -- pragma Detect_Blocking
9968 Detect_Blocking := True;
9970 -- Set the corresponding restrictions
9972 Set_Profile_Restrictions
9973 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
9975 -- Set the No_Dependence restrictions
9977 -- The following No_Dependence restrictions:
9978 -- No_Dependence => Ada.Asynchronous_Task_Control
9979 -- No_Dependence => Ada.Calendar
9980 -- No_Dependence => Ada.Task_Attributes
9981 -- are already set by previous call to Set_Profile_Restrictions.
9983 -- Set the following restrictions which were added to Ada 2005:
9984 -- No_Dependence => Ada.Execution_Time.Group_Budget
9985 -- No_Dependence => Ada.Execution_Time.Timers
9987 -- ??? The use of Name_Buffer here is suspicious. The names should
9988 -- be registered in snames.ads-tmpl and used to build the qualified
9989 -- names of units.
9991 if Ada_Version >= Ada_2005 then
9992 Name_Buffer (1 .. 3) := "ada";
9993 Name_Len := 3;
9995 Pref_Id := Make_Identifier (Loc, Name_Find);
9997 Name_Buffer (1 .. 14) := "execution_time";
9998 Name_Len := 14;
10000 Sel_Id := Make_Identifier (Loc, Name_Find);
10002 Pref :=
10003 Make_Selected_Component
10004 (Sloc => Loc,
10005 Prefix => Pref_Id,
10006 Selector_Name => Sel_Id);
10008 Name_Buffer (1 .. 13) := "group_budgets";
10009 Name_Len := 13;
10011 Sel_Id := Make_Identifier (Loc, Name_Find);
10013 Nod :=
10014 Make_Selected_Component
10015 (Sloc => Loc,
10016 Prefix => Pref,
10017 Selector_Name => Sel_Id);
10019 Set_Restriction_No_Dependence
10020 (Unit => Nod,
10021 Warn => Treat_Restrictions_As_Warnings,
10022 Profile => Ravenscar);
10024 Name_Buffer (1 .. 6) := "timers";
10025 Name_Len := 6;
10027 Sel_Id := Make_Identifier (Loc, Name_Find);
10029 Nod :=
10030 Make_Selected_Component
10031 (Sloc => Loc,
10032 Prefix => Pref,
10033 Selector_Name => Sel_Id);
10035 Set_Restriction_No_Dependence
10036 (Unit => Nod,
10037 Warn => Treat_Restrictions_As_Warnings,
10038 Profile => Ravenscar);
10039 end if;
10041 -- Set the following restriction which was added to Ada 2012 (see
10042 -- AI-0171):
10043 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10045 if Ada_Version >= Ada_2012 then
10046 Name_Buffer (1 .. 6) := "system";
10047 Name_Len := 6;
10049 Pref_Id := Make_Identifier (Loc, Name_Find);
10051 Name_Buffer (1 .. 15) := "multiprocessors";
10052 Name_Len := 15;
10054 Sel_Id := Make_Identifier (Loc, Name_Find);
10056 Pref :=
10057 Make_Selected_Component
10058 (Sloc => Loc,
10059 Prefix => Pref_Id,
10060 Selector_Name => Sel_Id);
10062 Name_Buffer (1 .. 19) := "dispatching_domains";
10063 Name_Len := 19;
10065 Sel_Id := Make_Identifier (Loc, Name_Find);
10067 Nod :=
10068 Make_Selected_Component
10069 (Sloc => Loc,
10070 Prefix => Pref,
10071 Selector_Name => Sel_Id);
10073 Set_Restriction_No_Dependence
10074 (Unit => Nod,
10075 Warn => Treat_Restrictions_As_Warnings,
10076 Profile => Ravenscar);
10077 end if;
10078 end Set_Ravenscar_Profile;
10080 -- Start of processing for Analyze_Pragma
10082 begin
10083 -- The following code is a defense against recursion. Not clear that
10084 -- this can happen legitimately, but perhaps some error situations can
10085 -- cause it, and we did see this recursion during testing.
10087 if Analyzed (N) then
10088 return;
10089 else
10090 Set_Analyzed (N);
10091 end if;
10093 Check_Restriction_No_Use_Of_Pragma (N);
10095 -- Deal with unrecognized pragma
10097 Pname := Pragma_Name (N);
10099 if not Is_Pragma_Name (Pname) then
10100 if Warn_On_Unrecognized_Pragma then
10101 Error_Msg_Name_1 := Pname;
10102 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10104 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10105 if Is_Bad_Spelling_Of (Pname, PN) then
10106 Error_Msg_Name_1 := PN;
10107 Error_Msg_N -- CODEFIX
10108 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10109 exit;
10110 end if;
10111 end loop;
10112 end if;
10114 return;
10115 end if;
10117 -- Ignore pragma if Ignore_Pragma applies
10119 if Get_Name_Table_Boolean3 (Pname) then
10120 return;
10121 end if;
10123 -- Here to start processing for recognized pragma
10125 Prag_Id := Get_Pragma_Id (Pname);
10126 Pname := Original_Aspect_Pragma_Name (N);
10128 -- Capture setting of Opt.Uneval_Old
10130 case Opt.Uneval_Old is
10131 when 'A' =>
10132 Set_Uneval_Old_Accept (N);
10133 when 'E' =>
10134 null;
10135 when 'W' =>
10136 Set_Uneval_Old_Warn (N);
10137 when others =>
10138 raise Program_Error;
10139 end case;
10141 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10142 -- is already set, indicating that we have already checked the policy
10143 -- at the right point. This happens for example in the case of a pragma
10144 -- that is derived from an Aspect.
10146 if Is_Ignored (N) or else Is_Checked (N) then
10147 null;
10149 -- For a pragma that is a rewriting of another pragma, copy the
10150 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10152 elsif Is_Rewrite_Substitution (N)
10153 and then Nkind (Original_Node (N)) = N_Pragma
10154 and then Original_Node (N) /= N
10155 then
10156 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10157 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10159 -- Otherwise query the applicable policy at this point
10161 else
10162 Check_Applicable_Policy (N);
10164 -- If pragma is disabled, rewrite as NULL and skip analysis
10166 if Is_Disabled (N) then
10167 Rewrite (N, Make_Null_Statement (Loc));
10168 Analyze (N);
10169 raise Pragma_Exit;
10170 end if;
10171 end if;
10173 -- Preset arguments
10175 Arg_Count := 0;
10176 Arg1 := Empty;
10177 Arg2 := Empty;
10178 Arg3 := Empty;
10179 Arg4 := Empty;
10181 if Present (Pragma_Argument_Associations (N)) then
10182 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10183 Arg1 := First (Pragma_Argument_Associations (N));
10185 if Present (Arg1) then
10186 Arg2 := Next (Arg1);
10188 if Present (Arg2) then
10189 Arg3 := Next (Arg2);
10191 if Present (Arg3) then
10192 Arg4 := Next (Arg3);
10193 end if;
10194 end if;
10195 end if;
10196 end if;
10198 -- An enumeration type defines the pragmas that are supported by the
10199 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10200 -- into the corresponding enumeration value for the following case.
10202 case Prag_Id is
10204 -----------------
10205 -- Abort_Defer --
10206 -----------------
10208 -- pragma Abort_Defer;
10210 when Pragma_Abort_Defer =>
10211 GNAT_Pragma;
10212 Check_Arg_Count (0);
10214 -- The only required semantic processing is to check the
10215 -- placement. This pragma must appear at the start of the
10216 -- statement sequence of a handled sequence of statements.
10218 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10219 or else N /= First (Statements (Parent (N)))
10220 then
10221 Pragma_Misplaced;
10222 end if;
10224 --------------------
10225 -- Abstract_State --
10226 --------------------
10228 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10230 -- ABSTRACT_STATE_LIST ::=
10231 -- null
10232 -- | STATE_NAME_WITH_OPTIONS
10233 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10235 -- STATE_NAME_WITH_OPTIONS ::=
10236 -- STATE_NAME
10237 -- | (STATE_NAME with OPTION_LIST)
10239 -- OPTION_LIST ::= OPTION {, OPTION}
10241 -- OPTION ::=
10242 -- SIMPLE_OPTION
10243 -- | NAME_VALUE_OPTION
10245 -- SIMPLE_OPTION ::= Ghost | Synchronous
10247 -- NAME_VALUE_OPTION ::=
10248 -- Part_Of => ABSTRACT_STATE
10249 -- | External [=> EXTERNAL_PROPERTY_LIST]
10251 -- EXTERNAL_PROPERTY_LIST ::=
10252 -- EXTERNAL_PROPERTY
10253 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10255 -- EXTERNAL_PROPERTY ::=
10256 -- Async_Readers [=> boolean_EXPRESSION]
10257 -- | Async_Writers [=> boolean_EXPRESSION]
10258 -- | Effective_Reads [=> boolean_EXPRESSION]
10259 -- | Effective_Writes [=> boolean_EXPRESSION]
10260 -- others => boolean_EXPRESSION
10262 -- STATE_NAME ::= defining_identifier
10264 -- ABSTRACT_STATE ::= name
10266 -- Characteristics:
10268 -- * Analysis - The annotation is fully analyzed immediately upon
10269 -- elaboration as it cannot forward reference entities.
10271 -- * Expansion - None.
10273 -- * Template - The annotation utilizes the generic template of the
10274 -- related package declaration.
10276 -- * Globals - The annotation cannot reference global entities.
10278 -- * Instance - The annotation is instantiated automatically when
10279 -- the related generic package is instantiated.
10281 when Pragma_Abstract_State => Abstract_State : declare
10282 Missing_Parentheses : Boolean := False;
10283 -- Flag set when a state declaration with options is not properly
10284 -- parenthesized.
10286 -- Flags used to verify the consistency of states
10288 Non_Null_Seen : Boolean := False;
10289 Null_Seen : Boolean := False;
10291 procedure Analyze_Abstract_State
10292 (State : Node_Id;
10293 Pack_Id : Entity_Id);
10294 -- Verify the legality of a single state declaration. Create and
10295 -- decorate a state abstraction entity and introduce it into the
10296 -- visibility chain. Pack_Id denotes the entity or the related
10297 -- package where pragma Abstract_State appears.
10299 procedure Malformed_State_Error (State : Node_Id);
10300 -- Emit an error concerning the illegal declaration of abstract
10301 -- state State. This routine diagnoses syntax errors that lead to
10302 -- a different parse tree. The error is issued regardless of the
10303 -- SPARK mode in effect.
10305 ----------------------------
10306 -- Analyze_Abstract_State --
10307 ----------------------------
10309 procedure Analyze_Abstract_State
10310 (State : Node_Id;
10311 Pack_Id : Entity_Id)
10313 -- Flags used to verify the consistency of options
10315 AR_Seen : Boolean := False;
10316 AW_Seen : Boolean := False;
10317 ER_Seen : Boolean := False;
10318 EW_Seen : Boolean := False;
10319 External_Seen : Boolean := False;
10320 Ghost_Seen : Boolean := False;
10321 Others_Seen : Boolean := False;
10322 Part_Of_Seen : Boolean := False;
10323 Synchronous_Seen : Boolean := False;
10325 -- Flags used to store the static value of all external states'
10326 -- expressions.
10328 AR_Val : Boolean := False;
10329 AW_Val : Boolean := False;
10330 ER_Val : Boolean := False;
10331 EW_Val : Boolean := False;
10333 State_Id : Entity_Id := Empty;
10334 -- The entity to be generated for the current state declaration
10336 procedure Analyze_External_Option (Opt : Node_Id);
10337 -- Verify the legality of option External
10339 procedure Analyze_External_Property
10340 (Prop : Node_Id;
10341 Expr : Node_Id := Empty);
10342 -- Verify the legailty of a single external property. Prop
10343 -- denotes the external property. Expr is the expression used
10344 -- to set the property.
10346 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10347 -- Verify the legality of option Part_Of
10349 procedure Check_Duplicate_Option
10350 (Opt : Node_Id;
10351 Status : in out Boolean);
10352 -- Flag Status denotes whether a particular option has been
10353 -- seen while processing a state. This routine verifies that
10354 -- Opt is not a duplicate option and sets the flag Status
10355 -- (SPARK RM 7.1.4(1)).
10357 procedure Check_Duplicate_Property
10358 (Prop : Node_Id;
10359 Status : in out Boolean);
10360 -- Flag Status denotes whether a particular property has been
10361 -- seen while processing option External. This routine verifies
10362 -- that Prop is not a duplicate property and sets flag Status.
10363 -- Opt is not a duplicate property and sets the flag Status.
10364 -- (SPARK RM 7.1.4(2))
10366 procedure Check_Ghost_Synchronous;
10367 -- Ensure that the abstract state is not subject to both Ghost
10368 -- and Synchronous simple options. Emit an error if this is the
10369 -- case.
10371 procedure Create_Abstract_State
10372 (Nam : Name_Id;
10373 Decl : Node_Id;
10374 Loc : Source_Ptr;
10375 Is_Null : Boolean);
10376 -- Generate an abstract state entity with name Nam and enter it
10377 -- into visibility. Decl is the "declaration" of the state as
10378 -- it appears in pragma Abstract_State. Loc is the location of
10379 -- the related state "declaration". Flag Is_Null should be set
10380 -- when the associated Abstract_State pragma defines a null
10381 -- state.
10383 -----------------------------
10384 -- Analyze_External_Option --
10385 -----------------------------
10387 procedure Analyze_External_Option (Opt : Node_Id) is
10388 Errors : constant Nat := Serious_Errors_Detected;
10389 Prop : Node_Id;
10390 Props : Node_Id := Empty;
10392 begin
10393 if Nkind (Opt) = N_Component_Association then
10394 Props := Expression (Opt);
10395 end if;
10397 -- External state with properties
10399 if Present (Props) then
10401 -- Multiple properties appear as an aggregate
10403 if Nkind (Props) = N_Aggregate then
10405 -- Simple property form
10407 Prop := First (Expressions (Props));
10408 while Present (Prop) loop
10409 Analyze_External_Property (Prop);
10410 Next (Prop);
10411 end loop;
10413 -- Property with expression form
10415 Prop := First (Component_Associations (Props));
10416 while Present (Prop) loop
10417 Analyze_External_Property
10418 (Prop => First (Choices (Prop)),
10419 Expr => Expression (Prop));
10421 Next (Prop);
10422 end loop;
10424 -- Single property
10426 else
10427 Analyze_External_Property (Props);
10428 end if;
10430 -- An external state defined without any properties defaults
10431 -- all properties to True.
10433 else
10434 AR_Val := True;
10435 AW_Val := True;
10436 ER_Val := True;
10437 EW_Val := True;
10438 end if;
10440 -- Once all external properties have been processed, verify
10441 -- their mutual interaction. Do not perform the check when
10442 -- at least one of the properties is illegal as this will
10443 -- produce a bogus error.
10445 if Errors = Serious_Errors_Detected then
10446 Check_External_Properties
10447 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10448 end if;
10449 end Analyze_External_Option;
10451 -------------------------------
10452 -- Analyze_External_Property --
10453 -------------------------------
10455 procedure Analyze_External_Property
10456 (Prop : Node_Id;
10457 Expr : Node_Id := Empty)
10459 Expr_Val : Boolean;
10461 begin
10462 -- Check the placement of "others" (if available)
10464 if Nkind (Prop) = N_Others_Choice then
10465 if Others_Seen then
10466 SPARK_Msg_N
10467 ("only one others choice allowed in option External",
10468 Prop);
10469 else
10470 Others_Seen := True;
10471 end if;
10473 elsif Others_Seen then
10474 SPARK_Msg_N
10475 ("others must be the last property in option External",
10476 Prop);
10478 -- The only remaining legal options are the four predefined
10479 -- external properties.
10481 elsif Nkind (Prop) = N_Identifier
10482 and then Nam_In (Chars (Prop), Name_Async_Readers,
10483 Name_Async_Writers,
10484 Name_Effective_Reads,
10485 Name_Effective_Writes)
10486 then
10487 null;
10489 -- Otherwise the construct is not a valid property
10491 else
10492 SPARK_Msg_N ("invalid external state property", Prop);
10493 return;
10494 end if;
10496 -- Ensure that the expression of the external state property
10497 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10499 if Present (Expr) then
10500 Analyze_And_Resolve (Expr, Standard_Boolean);
10502 if Is_OK_Static_Expression (Expr) then
10503 Expr_Val := Is_True (Expr_Value (Expr));
10504 else
10505 SPARK_Msg_N
10506 ("expression of external state property must be "
10507 & "static", Expr);
10508 end if;
10510 -- The lack of expression defaults the property to True
10512 else
10513 Expr_Val := True;
10514 end if;
10516 -- Named properties
10518 if Nkind (Prop) = N_Identifier then
10519 if Chars (Prop) = Name_Async_Readers then
10520 Check_Duplicate_Property (Prop, AR_Seen);
10521 AR_Val := Expr_Val;
10523 elsif Chars (Prop) = Name_Async_Writers then
10524 Check_Duplicate_Property (Prop, AW_Seen);
10525 AW_Val := Expr_Val;
10527 elsif Chars (Prop) = Name_Effective_Reads then
10528 Check_Duplicate_Property (Prop, ER_Seen);
10529 ER_Val := Expr_Val;
10531 else
10532 Check_Duplicate_Property (Prop, EW_Seen);
10533 EW_Val := Expr_Val;
10534 end if;
10536 -- The handling of property "others" must take into account
10537 -- all other named properties that have been encountered so
10538 -- far. Only those that have not been seen are affected by
10539 -- "others".
10541 else
10542 if not AR_Seen then
10543 AR_Val := Expr_Val;
10544 end if;
10546 if not AW_Seen then
10547 AW_Val := Expr_Val;
10548 end if;
10550 if not ER_Seen then
10551 ER_Val := Expr_Val;
10552 end if;
10554 if not EW_Seen then
10555 EW_Val := Expr_Val;
10556 end if;
10557 end if;
10558 end Analyze_External_Property;
10560 ----------------------------
10561 -- Analyze_Part_Of_Option --
10562 ----------------------------
10564 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10565 Encap : constant Node_Id := Expression (Opt);
10566 Constits : Elist_Id;
10567 Encap_Id : Entity_Id;
10568 Legal : Boolean;
10570 begin
10571 Check_Duplicate_Option (Opt, Part_Of_Seen);
10573 Analyze_Part_Of
10574 (Indic => First (Choices (Opt)),
10575 Item_Id => State_Id,
10576 Encap => Encap,
10577 Encap_Id => Encap_Id,
10578 Legal => Legal);
10580 -- The Part_Of indicator transforms the abstract state into
10581 -- a constituent of the encapsulating state or single
10582 -- concurrent type.
10584 if Legal then
10585 pragma Assert (Present (Encap_Id));
10586 Constits := Part_Of_Constituents (Encap_Id);
10588 if No (Constits) then
10589 Constits := New_Elmt_List;
10590 Set_Part_Of_Constituents (Encap_Id, Constits);
10591 end if;
10593 Append_Elmt (State_Id, Constits);
10594 Set_Encapsulating_State (State_Id, Encap_Id);
10595 end if;
10596 end Analyze_Part_Of_Option;
10598 ----------------------------
10599 -- Check_Duplicate_Option --
10600 ----------------------------
10602 procedure Check_Duplicate_Option
10603 (Opt : Node_Id;
10604 Status : in out Boolean)
10606 begin
10607 if Status then
10608 SPARK_Msg_N ("duplicate state option", Opt);
10609 end if;
10611 Status := True;
10612 end Check_Duplicate_Option;
10614 ------------------------------
10615 -- Check_Duplicate_Property --
10616 ------------------------------
10618 procedure Check_Duplicate_Property
10619 (Prop : Node_Id;
10620 Status : in out Boolean)
10622 begin
10623 if Status then
10624 SPARK_Msg_N ("duplicate external property", Prop);
10625 end if;
10627 Status := True;
10628 end Check_Duplicate_Property;
10630 -----------------------------
10631 -- Check_Ghost_Synchronous --
10632 -----------------------------
10634 procedure Check_Ghost_Synchronous is
10635 begin
10636 -- A synchronized abstract state cannot be Ghost and vice
10637 -- versa (SPARK RM 6.9(19)).
10639 if Ghost_Seen and Synchronous_Seen then
10640 SPARK_Msg_N ("synchronized state cannot be ghost", State);
10641 end if;
10642 end Check_Ghost_Synchronous;
10644 ---------------------------
10645 -- Create_Abstract_State --
10646 ---------------------------
10648 procedure Create_Abstract_State
10649 (Nam : Name_Id;
10650 Decl : Node_Id;
10651 Loc : Source_Ptr;
10652 Is_Null : Boolean)
10654 begin
10655 -- The abstract state may be semi-declared when the related
10656 -- package was withed through a limited with clause. In that
10657 -- case reuse the entity to fully declare the state.
10659 if Present (Decl) and then Present (Entity (Decl)) then
10660 State_Id := Entity (Decl);
10662 -- Otherwise the elaboration of pragma Abstract_State
10663 -- declares the state.
10665 else
10666 State_Id := Make_Defining_Identifier (Loc, Nam);
10668 if Present (Decl) then
10669 Set_Entity (Decl, State_Id);
10670 end if;
10671 end if;
10673 -- Null states never come from source
10675 Set_Comes_From_Source (State_Id, not Is_Null);
10676 Set_Parent (State_Id, State);
10677 Set_Ekind (State_Id, E_Abstract_State);
10678 Set_Etype (State_Id, Standard_Void_Type);
10679 Set_Encapsulating_State (State_Id, Empty);
10681 -- An abstract state declared within a Ghost region becomes
10682 -- Ghost (SPARK RM 6.9(2)).
10684 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
10685 Set_Is_Ghost_Entity (State_Id);
10686 end if;
10688 -- Establish a link between the state declaration and the
10689 -- abstract state entity. Note that a null state remains as
10690 -- N_Null and does not carry any linkages.
10692 if not Is_Null then
10693 if Present (Decl) then
10694 Set_Entity (Decl, State_Id);
10695 Set_Etype (Decl, Standard_Void_Type);
10696 end if;
10698 -- Every non-null state must be defined, nameable and
10699 -- resolvable.
10701 Push_Scope (Pack_Id);
10702 Generate_Definition (State_Id);
10703 Enter_Name (State_Id);
10704 Pop_Scope;
10705 end if;
10706 end Create_Abstract_State;
10708 -- Local variables
10710 Opt : Node_Id;
10711 Opt_Nam : Node_Id;
10713 -- Start of processing for Analyze_Abstract_State
10715 begin
10716 -- A package with a null abstract state is not allowed to
10717 -- declare additional states.
10719 if Null_Seen then
10720 SPARK_Msg_NE
10721 ("package & has null abstract state", State, Pack_Id);
10723 -- Null states appear as internally generated entities
10725 elsif Nkind (State) = N_Null then
10726 Create_Abstract_State
10727 (Nam => New_Internal_Name ('S'),
10728 Decl => Empty,
10729 Loc => Sloc (State),
10730 Is_Null => True);
10731 Null_Seen := True;
10733 -- Catch a case where a null state appears in a list of
10734 -- non-null states.
10736 if Non_Null_Seen then
10737 SPARK_Msg_NE
10738 ("package & has non-null abstract state",
10739 State, Pack_Id);
10740 end if;
10742 -- Simple state declaration
10744 elsif Nkind (State) = N_Identifier then
10745 Create_Abstract_State
10746 (Nam => Chars (State),
10747 Decl => State,
10748 Loc => Sloc (State),
10749 Is_Null => False);
10750 Non_Null_Seen := True;
10752 -- State declaration with various options. This construct
10753 -- appears as an extension aggregate in the tree.
10755 elsif Nkind (State) = N_Extension_Aggregate then
10756 if Nkind (Ancestor_Part (State)) = N_Identifier then
10757 Create_Abstract_State
10758 (Nam => Chars (Ancestor_Part (State)),
10759 Decl => Ancestor_Part (State),
10760 Loc => Sloc (Ancestor_Part (State)),
10761 Is_Null => False);
10762 Non_Null_Seen := True;
10763 else
10764 SPARK_Msg_N
10765 ("state name must be an identifier",
10766 Ancestor_Part (State));
10767 end if;
10769 -- Options External, Ghost and Synchronous appear as
10770 -- expressions.
10772 Opt := First (Expressions (State));
10773 while Present (Opt) loop
10774 if Nkind (Opt) = N_Identifier then
10776 -- External
10778 if Chars (Opt) = Name_External then
10779 Check_Duplicate_Option (Opt, External_Seen);
10780 Analyze_External_Option (Opt);
10782 -- Ghost
10784 elsif Chars (Opt) = Name_Ghost then
10785 Check_Duplicate_Option (Opt, Ghost_Seen);
10786 Check_Ghost_Synchronous;
10788 if Present (State_Id) then
10789 Set_Is_Ghost_Entity (State_Id);
10790 end if;
10792 -- Synchronous
10794 elsif Chars (Opt) = Name_Synchronous then
10795 Check_Duplicate_Option (Opt, Synchronous_Seen);
10796 Check_Ghost_Synchronous;
10798 -- Option Part_Of without an encapsulating state is
10799 -- illegal (SPARK RM 7.1.4(9)).
10801 elsif Chars (Opt) = Name_Part_Of then
10802 SPARK_Msg_N
10803 ("indicator Part_Of must denote abstract state, "
10804 & "single protected type or single task type",
10805 Opt);
10807 -- Do not emit an error message when a previous state
10808 -- declaration with options was not parenthesized as
10809 -- the option is actually another state declaration.
10811 -- with Abstract_State
10812 -- (State_1 with ..., -- missing parentheses
10813 -- (State_2 with ...),
10814 -- State_3) -- ok state declaration
10816 elsif Missing_Parentheses then
10817 null;
10819 -- Otherwise the option is not allowed. Note that it
10820 -- is not possible to distinguish between an option
10821 -- and a state declaration when a previous state with
10822 -- options not properly parentheses.
10824 -- with Abstract_State
10825 -- (State_1 with ..., -- missing parentheses
10826 -- State_2); -- could be an option
10828 else
10829 SPARK_Msg_N
10830 ("simple option not allowed in state declaration",
10831 Opt);
10832 end if;
10834 -- Catch a case where missing parentheses around a state
10835 -- declaration with options cause a subsequent state
10836 -- declaration with options to be treated as an option.
10838 -- with Abstract_State
10839 -- (State_1 with ..., -- missing parentheses
10840 -- (State_2 with ...))
10842 elsif Nkind (Opt) = N_Extension_Aggregate then
10843 Missing_Parentheses := True;
10844 SPARK_Msg_N
10845 ("state declaration must be parenthesized",
10846 Ancestor_Part (State));
10848 -- Otherwise the option is malformed
10850 else
10851 SPARK_Msg_N ("malformed option", Opt);
10852 end if;
10854 Next (Opt);
10855 end loop;
10857 -- Options External and Part_Of appear as component
10858 -- associations.
10860 Opt := First (Component_Associations (State));
10861 while Present (Opt) loop
10862 Opt_Nam := First (Choices (Opt));
10864 if Nkind (Opt_Nam) = N_Identifier then
10865 if Chars (Opt_Nam) = Name_External then
10866 Analyze_External_Option (Opt);
10868 elsif Chars (Opt_Nam) = Name_Part_Of then
10869 Analyze_Part_Of_Option (Opt);
10871 else
10872 SPARK_Msg_N ("invalid state option", Opt);
10873 end if;
10874 else
10875 SPARK_Msg_N ("invalid state option", Opt);
10876 end if;
10878 Next (Opt);
10879 end loop;
10881 -- Any other attempt to declare a state is illegal
10883 else
10884 Malformed_State_Error (State);
10885 return;
10886 end if;
10888 -- Guard against a junk state. In such cases no entity is
10889 -- generated and the subsequent checks cannot be applied.
10891 if Present (State_Id) then
10893 -- Verify whether the state does not introduce an illegal
10894 -- hidden state within a package subject to a null abstract
10895 -- state.
10897 Check_No_Hidden_State (State_Id);
10899 -- Check whether the lack of option Part_Of agrees with the
10900 -- placement of the abstract state with respect to the state
10901 -- space.
10903 if not Part_Of_Seen then
10904 Check_Missing_Part_Of (State_Id);
10905 end if;
10907 -- Associate the state with its related package
10909 if No (Abstract_States (Pack_Id)) then
10910 Set_Abstract_States (Pack_Id, New_Elmt_List);
10911 end if;
10913 Append_Elmt (State_Id, Abstract_States (Pack_Id));
10914 end if;
10915 end Analyze_Abstract_State;
10917 ---------------------------
10918 -- Malformed_State_Error --
10919 ---------------------------
10921 procedure Malformed_State_Error (State : Node_Id) is
10922 begin
10923 Error_Msg_N ("malformed abstract state declaration", State);
10925 -- An abstract state with a simple option is being declared
10926 -- with "=>" rather than the legal "with". The state appears
10927 -- as a component association.
10929 if Nkind (State) = N_Component_Association then
10930 Error_Msg_N ("\use WITH to specify simple option", State);
10931 end if;
10932 end Malformed_State_Error;
10934 -- Local variables
10936 Pack_Decl : Node_Id;
10937 Pack_Id : Entity_Id;
10938 State : Node_Id;
10939 States : Node_Id;
10941 -- Start of processing for Abstract_State
10943 begin
10944 GNAT_Pragma;
10945 Check_No_Identifiers;
10946 Check_Arg_Count (1);
10948 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
10950 -- Ensure the proper placement of the pragma. Abstract states must
10951 -- be associated with a package declaration.
10953 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
10954 N_Package_Declaration)
10955 then
10956 null;
10958 -- Otherwise the pragma is associated with an illegal construct
10960 else
10961 Pragma_Misplaced;
10962 return;
10963 end if;
10965 Pack_Id := Defining_Entity (Pack_Decl);
10967 -- Chain the pragma on the contract for completeness
10969 Add_Contract_Item (N, Pack_Id);
10971 -- The legality checks of pragmas Abstract_State, Initializes, and
10972 -- Initial_Condition are affected by the SPARK mode in effect. In
10973 -- addition, these three pragmas are subject to an inherent order:
10975 -- 1) Abstract_State
10976 -- 2) Initializes
10977 -- 3) Initial_Condition
10979 -- Analyze all these pragmas in the order outlined above
10981 Analyze_If_Present (Pragma_SPARK_Mode);
10983 -- A pragma that applies to a Ghost entity becomes Ghost for the
10984 -- purposes of legality checks and removal of ignored Ghost code.
10986 Mark_Pragma_As_Ghost (N, Pack_Id);
10987 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
10989 States := Expression (Get_Argument (N, Pack_Id));
10991 -- Multiple non-null abstract states appear as an aggregate
10993 if Nkind (States) = N_Aggregate then
10994 State := First (Expressions (States));
10995 while Present (State) loop
10996 Analyze_Abstract_State (State, Pack_Id);
10997 Next (State);
10998 end loop;
11000 -- An abstract state with a simple option is being illegaly
11001 -- declared with "=>" rather than "with". In this case the
11002 -- state declaration appears as a component association.
11004 if Present (Component_Associations (States)) then
11005 State := First (Component_Associations (States));
11006 while Present (State) loop
11007 Malformed_State_Error (State);
11008 Next (State);
11009 end loop;
11010 end if;
11012 -- Various forms of a single abstract state. Note that these may
11013 -- include malformed state declarations.
11015 else
11016 Analyze_Abstract_State (States, Pack_Id);
11017 end if;
11019 Analyze_If_Present (Pragma_Initializes);
11020 Analyze_If_Present (Pragma_Initial_Condition);
11021 end Abstract_State;
11023 ------------
11024 -- Ada_83 --
11025 ------------
11027 -- pragma Ada_83;
11029 -- Note: this pragma also has some specific processing in Par.Prag
11030 -- because we want to set the Ada version mode during parsing.
11032 when Pragma_Ada_83 =>
11033 GNAT_Pragma;
11034 Check_Arg_Count (0);
11036 -- We really should check unconditionally for proper configuration
11037 -- pragma placement, since we really don't want mixed Ada modes
11038 -- within a single unit, and the GNAT reference manual has always
11039 -- said this was a configuration pragma, but we did not check and
11040 -- are hesitant to add the check now.
11042 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11043 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11044 -- or Ada 2012 mode.
11046 if Ada_Version >= Ada_2005 then
11047 Check_Valid_Configuration_Pragma;
11048 end if;
11050 -- Now set Ada 83 mode
11052 if not Latest_Ada_Only then
11053 Ada_Version := Ada_83;
11054 Ada_Version_Explicit := Ada_83;
11055 Ada_Version_Pragma := N;
11056 end if;
11058 ------------
11059 -- Ada_95 --
11060 ------------
11062 -- pragma Ada_95;
11064 -- Note: this pragma also has some specific processing in Par.Prag
11065 -- because we want to set the Ada 83 version mode during parsing.
11067 when Pragma_Ada_95 =>
11068 GNAT_Pragma;
11069 Check_Arg_Count (0);
11071 -- We really should check unconditionally for proper configuration
11072 -- pragma placement, since we really don't want mixed Ada modes
11073 -- within a single unit, and the GNAT reference manual has always
11074 -- said this was a configuration pragma, but we did not check and
11075 -- are hesitant to add the check now.
11077 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11078 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11080 if Ada_Version >= Ada_2005 then
11081 Check_Valid_Configuration_Pragma;
11082 end if;
11084 -- Now set Ada 95 mode
11086 if not Latest_Ada_Only then
11087 Ada_Version := Ada_95;
11088 Ada_Version_Explicit := Ada_95;
11089 Ada_Version_Pragma := N;
11090 end if;
11092 ---------------------
11093 -- Ada_05/Ada_2005 --
11094 ---------------------
11096 -- pragma Ada_05;
11097 -- pragma Ada_05 (LOCAL_NAME);
11099 -- pragma Ada_2005;
11100 -- pragma Ada_2005 (LOCAL_NAME):
11102 -- Note: these pragmas also have some specific processing in Par.Prag
11103 -- because we want to set the Ada 2005 version mode during parsing.
11105 -- The one argument form is used for managing the transition from
11106 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11107 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11108 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11109 -- mode, a preference rule is established which does not choose
11110 -- such an entity unless it is unambiguously specified. This avoids
11111 -- extra subprograms marked this way from generating ambiguities in
11112 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11113 -- intended for exclusive use in the GNAT run-time library.
11115 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
11116 E_Id : Node_Id;
11118 begin
11119 GNAT_Pragma;
11121 if Arg_Count = 1 then
11122 Check_Arg_Is_Local_Name (Arg1);
11123 E_Id := Get_Pragma_Arg (Arg1);
11125 if Etype (E_Id) = Any_Type then
11126 return;
11127 end if;
11129 Set_Is_Ada_2005_Only (Entity (E_Id));
11130 Record_Rep_Item (Entity (E_Id), N);
11132 else
11133 Check_Arg_Count (0);
11135 -- For Ada_2005 we unconditionally enforce the documented
11136 -- configuration pragma placement, since we do not want to
11137 -- tolerate mixed modes in a unit involving Ada 2005. That
11138 -- would cause real difficulties for those cases where there
11139 -- are incompatibilities between Ada 95 and Ada 2005.
11141 Check_Valid_Configuration_Pragma;
11143 -- Now set appropriate Ada mode
11145 if not Latest_Ada_Only then
11146 Ada_Version := Ada_2005;
11147 Ada_Version_Explicit := Ada_2005;
11148 Ada_Version_Pragma := N;
11149 end if;
11150 end if;
11151 end;
11153 ---------------------
11154 -- Ada_12/Ada_2012 --
11155 ---------------------
11157 -- pragma Ada_12;
11158 -- pragma Ada_12 (LOCAL_NAME);
11160 -- pragma Ada_2012;
11161 -- pragma Ada_2012 (LOCAL_NAME):
11163 -- Note: these pragmas also have some specific processing in Par.Prag
11164 -- because we want to set the Ada 2012 version mode during parsing.
11166 -- The one argument form is used for managing the transition from Ada
11167 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11168 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11169 -- mode will generate a warning. In addition, in any pre-Ada_2012
11170 -- mode, a preference rule is established which does not choose
11171 -- such an entity unless it is unambiguously specified. This avoids
11172 -- extra subprograms marked this way from generating ambiguities in
11173 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11174 -- intended for exclusive use in the GNAT run-time library.
11176 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
11177 E_Id : Node_Id;
11179 begin
11180 GNAT_Pragma;
11182 if Arg_Count = 1 then
11183 Check_Arg_Is_Local_Name (Arg1);
11184 E_Id := Get_Pragma_Arg (Arg1);
11186 if Etype (E_Id) = Any_Type then
11187 return;
11188 end if;
11190 Set_Is_Ada_2012_Only (Entity (E_Id));
11191 Record_Rep_Item (Entity (E_Id), N);
11193 else
11194 Check_Arg_Count (0);
11196 -- For Ada_2012 we unconditionally enforce the documented
11197 -- configuration pragma placement, since we do not want to
11198 -- tolerate mixed modes in a unit involving Ada 2012. That
11199 -- would cause real difficulties for those cases where there
11200 -- are incompatibilities between Ada 95 and Ada 2012. We could
11201 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11203 Check_Valid_Configuration_Pragma;
11205 -- Now set appropriate Ada mode
11207 Ada_Version := Ada_2012;
11208 Ada_Version_Explicit := Ada_2012;
11209 Ada_Version_Pragma := N;
11210 end if;
11211 end;
11213 ----------------------
11214 -- All_Calls_Remote --
11215 ----------------------
11217 -- pragma All_Calls_Remote [(library_package_NAME)];
11219 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11220 Lib_Entity : Entity_Id;
11222 begin
11223 Check_Ada_83_Warning;
11224 Check_Valid_Library_Unit_Pragma;
11226 if Nkind (N) = N_Null_Statement then
11227 return;
11228 end if;
11230 Lib_Entity := Find_Lib_Unit_Name;
11232 -- A pragma that applies to a Ghost entity becomes Ghost for the
11233 -- purposes of legality checks and removal of ignored Ghost code.
11235 Mark_Pragma_As_Ghost (N, Lib_Entity);
11237 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11239 if Present (Lib_Entity) and then not Debug_Flag_U then
11240 if not Is_Remote_Call_Interface (Lib_Entity) then
11241 Error_Pragma ("pragma% only apply to rci unit");
11243 -- Set flag for entity of the library unit
11245 else
11246 Set_Has_All_Calls_Remote (Lib_Entity);
11247 end if;
11248 end if;
11249 end All_Calls_Remote;
11251 ---------------------------
11252 -- Allow_Integer_Address --
11253 ---------------------------
11255 -- pragma Allow_Integer_Address;
11257 when Pragma_Allow_Integer_Address =>
11258 GNAT_Pragma;
11259 Check_Valid_Configuration_Pragma;
11260 Check_Arg_Count (0);
11262 -- If Address is a private type, then set the flag to allow
11263 -- integer address values. If Address is not private, then this
11264 -- pragma has no purpose, so it is simply ignored. Not clear if
11265 -- there are any such targets now.
11267 if Opt.Address_Is_Private then
11268 Opt.Allow_Integer_Address := True;
11269 end if;
11271 --------------
11272 -- Annotate --
11273 --------------
11275 -- pragma Annotate
11276 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11277 -- ARG ::= NAME | EXPRESSION
11279 -- The first two arguments are by convention intended to refer to an
11280 -- external tool and a tool-specific function. These arguments are
11281 -- not analyzed.
11283 when Pragma_Annotate => Annotate : declare
11284 Arg : Node_Id;
11285 Expr : Node_Id;
11286 Nam_Arg : Node_Id;
11288 begin
11289 GNAT_Pragma;
11290 Check_At_Least_N_Arguments (1);
11292 Nam_Arg := Last (Pragma_Argument_Associations (N));
11294 -- Determine whether the last argument is "Entity => local_NAME"
11295 -- and if it is, perform the required semantic checks. Remove the
11296 -- argument from further processing.
11298 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11299 and then Chars (Nam_Arg) = Name_Entity
11300 then
11301 Check_Arg_Is_Local_Name (Nam_Arg);
11302 Arg_Count := Arg_Count - 1;
11304 -- A pragma that applies to a Ghost entity becomes Ghost for
11305 -- the purposes of legality checks and removal of ignored Ghost
11306 -- code.
11308 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11309 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11310 then
11311 Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11312 end if;
11314 -- Not allowed in compiler units (bootstrap issues)
11316 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11317 end if;
11319 -- Continue the processing with last argument removed for now
11321 Check_Arg_Is_Identifier (Arg1);
11322 Check_No_Identifiers;
11323 Store_Note (N);
11325 -- The second parameter is optional, it is never analyzed
11327 if No (Arg2) then
11328 null;
11330 -- Otherwise there is a second parameter
11332 else
11333 -- The second parameter must be an identifier
11335 Check_Arg_Is_Identifier (Arg2);
11337 -- Process the remaining parameters (if any)
11339 Arg := Next (Arg2);
11340 while Present (Arg) loop
11341 Expr := Get_Pragma_Arg (Arg);
11342 Analyze (Expr);
11344 if Is_Entity_Name (Expr) then
11345 null;
11347 -- For string literals, we assume Standard_String as the
11348 -- type, unless the string contains wide or wide_wide
11349 -- characters.
11351 elsif Nkind (Expr) = N_String_Literal then
11352 if Has_Wide_Wide_Character (Expr) then
11353 Resolve (Expr, Standard_Wide_Wide_String);
11354 elsif Has_Wide_Character (Expr) then
11355 Resolve (Expr, Standard_Wide_String);
11356 else
11357 Resolve (Expr, Standard_String);
11358 end if;
11360 elsif Is_Overloaded (Expr) then
11361 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11363 else
11364 Resolve (Expr);
11365 end if;
11367 Next (Arg);
11368 end loop;
11369 end if;
11370 end Annotate;
11372 -------------------------------------------------
11373 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11374 -------------------------------------------------
11376 -- pragma Assert
11377 -- ( [Check => ] Boolean_EXPRESSION
11378 -- [, [Message =>] Static_String_EXPRESSION]);
11380 -- pragma Assert_And_Cut
11381 -- ( [Check => ] Boolean_EXPRESSION
11382 -- [, [Message =>] Static_String_EXPRESSION]);
11384 -- pragma Assume
11385 -- ( [Check => ] Boolean_EXPRESSION
11386 -- [, [Message =>] Static_String_EXPRESSION]);
11388 -- pragma Loop_Invariant
11389 -- ( [Check => ] Boolean_EXPRESSION
11390 -- [, [Message =>] Static_String_EXPRESSION]);
11392 when Pragma_Assert |
11393 Pragma_Assert_And_Cut |
11394 Pragma_Assume |
11395 Pragma_Loop_Invariant =>
11396 Assert : declare
11397 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11398 -- Determine whether expression Expr contains a Loop_Entry
11399 -- attribute reference.
11401 -------------------------
11402 -- Contains_Loop_Entry --
11403 -------------------------
11405 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11406 Has_Loop_Entry : Boolean := False;
11408 function Process (N : Node_Id) return Traverse_Result;
11409 -- Process function for traversal to look for Loop_Entry
11411 -------------
11412 -- Process --
11413 -------------
11415 function Process (N : Node_Id) return Traverse_Result is
11416 begin
11417 if Nkind (N) = N_Attribute_Reference
11418 and then Attribute_Name (N) = Name_Loop_Entry
11419 then
11420 Has_Loop_Entry := True;
11421 return Abandon;
11422 else
11423 return OK;
11424 end if;
11425 end Process;
11427 procedure Traverse is new Traverse_Proc (Process);
11429 -- Start of processing for Contains_Loop_Entry
11431 begin
11432 Traverse (Expr);
11433 return Has_Loop_Entry;
11434 end Contains_Loop_Entry;
11436 -- Local variables
11438 Expr : Node_Id;
11439 New_Args : List_Id;
11441 -- Start of processing for Assert
11443 begin
11444 -- Assert is an Ada 2005 RM-defined pragma
11446 if Prag_Id = Pragma_Assert then
11447 Ada_2005_Pragma;
11449 -- The remaining ones are GNAT pragmas
11451 else
11452 GNAT_Pragma;
11453 end if;
11455 Check_At_Least_N_Arguments (1);
11456 Check_At_Most_N_Arguments (2);
11457 Check_Arg_Order ((Name_Check, Name_Message));
11458 Check_Optional_Identifier (Arg1, Name_Check);
11459 Expr := Get_Pragma_Arg (Arg1);
11461 -- Special processing for Loop_Invariant, Loop_Variant or for
11462 -- other cases where a Loop_Entry attribute is present. If the
11463 -- assertion pragma contains attribute Loop_Entry, ensure that
11464 -- the related pragma is within a loop.
11466 if Prag_Id = Pragma_Loop_Invariant
11467 or else Prag_Id = Pragma_Loop_Variant
11468 or else Contains_Loop_Entry (Expr)
11469 then
11470 Check_Loop_Pragma_Placement;
11472 -- Perform preanalysis to deal with embedded Loop_Entry
11473 -- attributes.
11475 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11476 end if;
11478 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11479 -- a corresponding Check pragma:
11481 -- pragma Check (name, condition [, msg]);
11483 -- Where name is the identifier matching the pragma name. So
11484 -- rewrite pragma in this manner, transfer the message argument
11485 -- if present, and analyze the result
11487 -- Note: When dealing with a semantically analyzed tree, the
11488 -- information that a Check node N corresponds to a source Assert,
11489 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11490 -- pragma kind of Original_Node(N).
11492 New_Args := New_List (
11493 Make_Pragma_Argument_Association (Loc,
11494 Expression => Make_Identifier (Loc, Pname)),
11495 Make_Pragma_Argument_Association (Sloc (Expr),
11496 Expression => Expr));
11498 if Arg_Count > 1 then
11499 Check_Optional_Identifier (Arg2, Name_Message);
11501 -- Provide semantic annnotations for optional argument, for
11502 -- ASIS use, before rewriting.
11504 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11505 Append_To (New_Args, New_Copy_Tree (Arg2));
11506 end if;
11508 -- Rewrite as Check pragma
11510 Rewrite (N,
11511 Make_Pragma (Loc,
11512 Chars => Name_Check,
11513 Pragma_Argument_Associations => New_Args));
11515 Analyze (N);
11516 end Assert;
11518 ----------------------
11519 -- Assertion_Policy --
11520 ----------------------
11522 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11524 -- The following form is Ada 2012 only, but we allow it in all modes
11526 -- Pragma Assertion_Policy (
11527 -- ASSERTION_KIND => POLICY_IDENTIFIER
11528 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11530 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11532 -- RM_ASSERTION_KIND ::= Assert |
11533 -- Static_Predicate |
11534 -- Dynamic_Predicate |
11535 -- Pre |
11536 -- Pre'Class |
11537 -- Post |
11538 -- Post'Class |
11539 -- Type_Invariant |
11540 -- Type_Invariant'Class
11542 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11543 -- Assume |
11544 -- Contract_Cases |
11545 -- Debug |
11546 -- Default_Initial_Condition |
11547 -- Ghost |
11548 -- Initial_Condition |
11549 -- Loop_Invariant |
11550 -- Loop_Variant |
11551 -- Postcondition |
11552 -- Precondition |
11553 -- Predicate |
11554 -- Refined_Post |
11555 -- Statement_Assertions
11557 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11558 -- ID_ASSERTION_KIND list contains implementation-defined additions
11559 -- recognized by GNAT. The effect is to control the behavior of
11560 -- identically named aspects and pragmas, depending on the specified
11561 -- policy identifier:
11563 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11565 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11566 -- implementation-defined addition that results in totally ignoring
11567 -- the corresponding assertion. If Disable is specified, then the
11568 -- argument of the assertion is not even analyzed. This is useful
11569 -- when the aspect/pragma argument references entities in a with'ed
11570 -- package that is replaced by a dummy package in the final build.
11572 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11573 -- and Type_Invariant'Class were recognized by the parser and
11574 -- transformed into references to the special internal identifiers
11575 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11576 -- processing is required here.
11578 when Pragma_Assertion_Policy => Assertion_Policy : declare
11579 Arg : Node_Id;
11580 Kind : Name_Id;
11581 LocP : Source_Ptr;
11582 Policy : Node_Id;
11584 begin
11585 Ada_2005_Pragma;
11587 -- This can always appear as a configuration pragma
11589 if Is_Configuration_Pragma then
11590 null;
11592 -- It can also appear in a declarative part or package spec in Ada
11593 -- 2012 mode. We allow this in other modes, but in that case we
11594 -- consider that we have an Ada 2012 pragma on our hands.
11596 else
11597 Check_Is_In_Decl_Part_Or_Package_Spec;
11598 Ada_2012_Pragma;
11599 end if;
11601 -- One argument case with no identifier (first form above)
11603 if Arg_Count = 1
11604 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11605 or else Chars (Arg1) = No_Name)
11606 then
11607 Check_Arg_Is_One_Of
11608 (Arg1, Name_Check, Name_Disable, Name_Ignore);
11610 -- Treat one argument Assertion_Policy as equivalent to:
11612 -- pragma Check_Policy (Assertion, policy)
11614 -- So rewrite pragma in that manner and link on to the chain
11615 -- of Check_Policy pragmas, marking the pragma as analyzed.
11617 Policy := Get_Pragma_Arg (Arg1);
11619 Rewrite (N,
11620 Make_Pragma (Loc,
11621 Chars => Name_Check_Policy,
11622 Pragma_Argument_Associations => New_List (
11623 Make_Pragma_Argument_Association (Loc,
11624 Expression => Make_Identifier (Loc, Name_Assertion)),
11626 Make_Pragma_Argument_Association (Loc,
11627 Expression =>
11628 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11629 Analyze (N);
11631 -- Here if we have two or more arguments
11633 else
11634 Check_At_Least_N_Arguments (1);
11635 Ada_2012_Pragma;
11637 -- Loop through arguments
11639 Arg := Arg1;
11640 while Present (Arg) loop
11641 LocP := Sloc (Arg);
11643 -- Kind must be specified
11645 if Nkind (Arg) /= N_Pragma_Argument_Association
11646 or else Chars (Arg) = No_Name
11647 then
11648 Error_Pragma_Arg
11649 ("missing assertion kind for pragma%", Arg);
11650 end if;
11652 -- Check Kind and Policy have allowed forms
11654 Kind := Chars (Arg);
11655 Policy := Get_Pragma_Arg (Arg);
11657 if not Is_Valid_Assertion_Kind (Kind) then
11658 Error_Pragma_Arg
11659 ("invalid assertion kind for pragma%", Arg);
11660 end if;
11662 Check_Arg_Is_One_Of
11663 (Arg, Name_Check, Name_Disable, Name_Ignore);
11665 if Kind = Name_Ghost then
11667 -- The Ghost policy must be either Check or Ignore
11668 -- (SPARK RM 6.9(6)).
11670 if not Nam_In (Chars (Policy), Name_Check,
11671 Name_Ignore)
11672 then
11673 Error_Pragma_Arg
11674 ("argument of pragma % Ghost must be Check or "
11675 & "Ignore", Policy);
11676 end if;
11678 -- Pragma Assertion_Policy specifying a Ghost policy
11679 -- cannot occur within a Ghost subprogram or package
11680 -- (SPARK RM 6.9(14)).
11682 if Ghost_Mode > None then
11683 Error_Pragma
11684 ("pragma % cannot appear within ghost subprogram or "
11685 & "package");
11686 end if;
11687 end if;
11689 -- Rewrite the Assertion_Policy pragma as a series of
11690 -- Check_Policy pragmas of the form:
11692 -- Check_Policy (Kind, Policy);
11694 -- Note: the insertion of the pragmas cannot be done with
11695 -- Insert_Action because in the configuration case, there
11696 -- are no scopes on the scope stack and the mechanism will
11697 -- fail.
11699 Insert_Before_And_Analyze (N,
11700 Make_Pragma (LocP,
11701 Chars => Name_Check_Policy,
11702 Pragma_Argument_Associations => New_List (
11703 Make_Pragma_Argument_Association (LocP,
11704 Expression => Make_Identifier (LocP, Kind)),
11705 Make_Pragma_Argument_Association (LocP,
11706 Expression => Policy))));
11708 Arg := Next (Arg);
11709 end loop;
11711 -- Rewrite the Assertion_Policy pragma as null since we have
11712 -- now inserted all the equivalent Check pragmas.
11714 Rewrite (N, Make_Null_Statement (Loc));
11715 Analyze (N);
11716 end if;
11717 end Assertion_Policy;
11719 ------------------------------
11720 -- Assume_No_Invalid_Values --
11721 ------------------------------
11723 -- pragma Assume_No_Invalid_Values (On | Off);
11725 when Pragma_Assume_No_Invalid_Values =>
11726 GNAT_Pragma;
11727 Check_Valid_Configuration_Pragma;
11728 Check_Arg_Count (1);
11729 Check_No_Identifiers;
11730 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11732 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
11733 Assume_No_Invalid_Values := True;
11734 else
11735 Assume_No_Invalid_Values := False;
11736 end if;
11738 --------------------------
11739 -- Attribute_Definition --
11740 --------------------------
11742 -- pragma Attribute_Definition
11743 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11744 -- [Entity =>] LOCAL_NAME,
11745 -- [Expression =>] EXPRESSION | NAME);
11747 when Pragma_Attribute_Definition => Attribute_Definition : declare
11748 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
11749 Aname : Name_Id;
11751 begin
11752 GNAT_Pragma;
11753 Check_Arg_Count (3);
11754 Check_Optional_Identifier (Arg1, "attribute");
11755 Check_Optional_Identifier (Arg2, "entity");
11756 Check_Optional_Identifier (Arg3, "expression");
11758 if Nkind (Attribute_Designator) /= N_Identifier then
11759 Error_Msg_N ("attribute name expected", Attribute_Designator);
11760 return;
11761 end if;
11763 Check_Arg_Is_Local_Name (Arg2);
11765 -- If the attribute is not recognized, then issue a warning (not
11766 -- an error), and ignore the pragma.
11768 Aname := Chars (Attribute_Designator);
11770 if not Is_Attribute_Name (Aname) then
11771 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
11772 return;
11773 end if;
11775 -- Otherwise, rewrite the pragma as an attribute definition clause
11777 Rewrite (N,
11778 Make_Attribute_Definition_Clause (Loc,
11779 Name => Get_Pragma_Arg (Arg2),
11780 Chars => Aname,
11781 Expression => Get_Pragma_Arg (Arg3)));
11782 Analyze (N);
11783 end Attribute_Definition;
11785 ------------------------------------------------------------------
11786 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11787 ------------------------------------------------------------------
11789 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
11790 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
11791 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
11792 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
11794 when Pragma_Async_Readers |
11795 Pragma_Async_Writers |
11796 Pragma_Effective_Reads |
11797 Pragma_Effective_Writes =>
11798 Async_Effective : declare
11799 Obj_Decl : Node_Id;
11800 Obj_Id : Entity_Id;
11802 begin
11803 GNAT_Pragma;
11804 Check_No_Identifiers;
11805 Check_At_Most_N_Arguments (1);
11807 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
11809 -- Object declaration
11811 if Nkind (Obj_Decl) = N_Object_Declaration then
11812 null;
11814 -- Otherwise the pragma is associated with an illegal construact
11816 else
11817 Pragma_Misplaced;
11818 return;
11819 end if;
11821 Obj_Id := Defining_Entity (Obj_Decl);
11823 -- Perform minimal verification to ensure that the argument is at
11824 -- least a variable. Subsequent finer grained checks will be done
11825 -- at the end of the declarative region the contains the pragma.
11827 if Ekind (Obj_Id) = E_Variable then
11829 -- Chain the pragma on the contract for further processing by
11830 -- Analyze_External_Property_In_Decl_Part.
11832 Add_Contract_Item (N, Obj_Id);
11834 -- A pragma that applies to a Ghost entity becomes Ghost for
11835 -- the purposes of legality checks and removal of ignored Ghost
11836 -- code.
11838 Mark_Pragma_As_Ghost (N, Obj_Id);
11840 -- Analyze the Boolean expression (if any)
11842 if Present (Arg1) then
11843 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
11844 end if;
11846 -- Otherwise the external property applies to a constant
11848 else
11849 Error_Pragma ("pragma % must apply to a volatile object");
11850 end if;
11851 end Async_Effective;
11853 ------------------
11854 -- Asynchronous --
11855 ------------------
11857 -- pragma Asynchronous (LOCAL_NAME);
11859 when Pragma_Asynchronous => Asynchronous : declare
11860 C_Ent : Entity_Id;
11861 Decl : Node_Id;
11862 Formal : Entity_Id;
11863 L : List_Id;
11864 Nm : Entity_Id;
11865 S : Node_Id;
11867 procedure Process_Async_Pragma;
11868 -- Common processing for procedure and access-to-procedure case
11870 --------------------------
11871 -- Process_Async_Pragma --
11872 --------------------------
11874 procedure Process_Async_Pragma is
11875 begin
11876 if No (L) then
11877 Set_Is_Asynchronous (Nm);
11878 return;
11879 end if;
11881 -- The formals should be of mode IN (RM E.4.1(6))
11883 S := First (L);
11884 while Present (S) loop
11885 Formal := Defining_Identifier (S);
11887 if Nkind (Formal) = N_Defining_Identifier
11888 and then Ekind (Formal) /= E_In_Parameter
11889 then
11890 Error_Pragma_Arg
11891 ("pragma% procedure can only have IN parameter",
11892 Arg1);
11893 end if;
11895 Next (S);
11896 end loop;
11898 Set_Is_Asynchronous (Nm);
11899 end Process_Async_Pragma;
11901 -- Start of processing for pragma Asynchronous
11903 begin
11904 Check_Ada_83_Warning;
11905 Check_No_Identifiers;
11906 Check_Arg_Count (1);
11907 Check_Arg_Is_Local_Name (Arg1);
11909 if Debug_Flag_U then
11910 return;
11911 end if;
11913 C_Ent := Cunit_Entity (Current_Sem_Unit);
11914 Analyze (Get_Pragma_Arg (Arg1));
11915 Nm := Entity (Get_Pragma_Arg (Arg1));
11917 -- A pragma that applies to a Ghost entity becomes Ghost for the
11918 -- purposes of legality checks and removal of ignored Ghost code.
11920 Mark_Pragma_As_Ghost (N, Nm);
11922 if not Is_Remote_Call_Interface (C_Ent)
11923 and then not Is_Remote_Types (C_Ent)
11924 then
11925 -- This pragma should only appear in an RCI or Remote Types
11926 -- unit (RM E.4.1(4)).
11928 Error_Pragma
11929 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11930 end if;
11932 if Ekind (Nm) = E_Procedure
11933 and then Nkind (Parent (Nm)) = N_Procedure_Specification
11934 then
11935 if not Is_Remote_Call_Interface (Nm) then
11936 Error_Pragma_Arg
11937 ("pragma% cannot be applied on non-remote procedure",
11938 Arg1);
11939 end if;
11941 L := Parameter_Specifications (Parent (Nm));
11942 Process_Async_Pragma;
11943 return;
11945 elsif Ekind (Nm) = E_Function then
11946 Error_Pragma_Arg
11947 ("pragma% cannot be applied to function", Arg1);
11949 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
11950 if Is_Record_Type (Nm) then
11952 -- A record type that is the Equivalent_Type for a remote
11953 -- access-to-subprogram type.
11955 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
11957 else
11958 -- A non-expanded RAS type (distribution is not enabled)
11960 Decl := Declaration_Node (Nm);
11961 end if;
11963 if Nkind (Decl) = N_Full_Type_Declaration
11964 and then Nkind (Type_Definition (Decl)) =
11965 N_Access_Procedure_Definition
11966 then
11967 L := Parameter_Specifications (Type_Definition (Decl));
11968 Process_Async_Pragma;
11970 if Is_Asynchronous (Nm)
11971 and then Expander_Active
11972 and then Get_PCS_Name /= Name_No_DSA
11973 then
11974 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
11975 end if;
11977 else
11978 Error_Pragma_Arg
11979 ("pragma% cannot reference access-to-function type",
11980 Arg1);
11981 end if;
11983 -- Only other possibility is Access-to-class-wide type
11985 elsif Is_Access_Type (Nm)
11986 and then Is_Class_Wide_Type (Designated_Type (Nm))
11987 then
11988 Check_First_Subtype (Arg1);
11989 Set_Is_Asynchronous (Nm);
11990 if Expander_Active then
11991 RACW_Type_Is_Asynchronous (Nm);
11992 end if;
11994 else
11995 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
11996 end if;
11997 end Asynchronous;
11999 ------------
12000 -- Atomic --
12001 ------------
12003 -- pragma Atomic (LOCAL_NAME);
12005 when Pragma_Atomic =>
12006 Process_Atomic_Independent_Shared_Volatile;
12008 -----------------------
12009 -- Atomic_Components --
12010 -----------------------
12012 -- pragma Atomic_Components (array_LOCAL_NAME);
12014 -- This processing is shared by Volatile_Components
12016 when Pragma_Atomic_Components |
12017 Pragma_Volatile_Components =>
12018 Atomic_Components : declare
12019 D : Node_Id;
12020 E : Entity_Id;
12021 E_Id : Node_Id;
12022 K : Node_Kind;
12024 begin
12025 Check_Ada_83_Warning;
12026 Check_No_Identifiers;
12027 Check_Arg_Count (1);
12028 Check_Arg_Is_Local_Name (Arg1);
12029 E_Id := Get_Pragma_Arg (Arg1);
12031 if Etype (E_Id) = Any_Type then
12032 return;
12033 end if;
12035 E := Entity (E_Id);
12037 -- A pragma that applies to a Ghost entity becomes Ghost for the
12038 -- purposes of legality checks and removal of ignored Ghost code.
12040 Mark_Pragma_As_Ghost (N, E);
12041 Check_Duplicate_Pragma (E);
12043 if Rep_Item_Too_Early (E, N)
12044 or else
12045 Rep_Item_Too_Late (E, N)
12046 then
12047 return;
12048 end if;
12050 D := Declaration_Node (E);
12051 K := Nkind (D);
12053 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12054 or else
12055 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12056 and then Nkind (D) = N_Object_Declaration
12057 and then Nkind (Object_Definition (D)) =
12058 N_Constrained_Array_Definition)
12059 then
12060 -- The flag is set on the object, or on the base type
12062 if Nkind (D) /= N_Object_Declaration then
12063 E := Base_Type (E);
12064 end if;
12066 -- Atomic implies both Independent and Volatile
12068 if Prag_Id = Pragma_Atomic_Components then
12069 Set_Has_Atomic_Components (E);
12070 Set_Has_Independent_Components (E);
12071 end if;
12073 Set_Has_Volatile_Components (E);
12075 else
12076 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12077 end if;
12078 end Atomic_Components;
12080 --------------------
12081 -- Attach_Handler --
12082 --------------------
12084 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12086 when Pragma_Attach_Handler =>
12087 Check_Ada_83_Warning;
12088 Check_No_Identifiers;
12089 Check_Arg_Count (2);
12091 if No_Run_Time_Mode then
12092 Error_Msg_CRT ("Attach_Handler pragma", N);
12093 else
12094 Check_Interrupt_Or_Attach_Handler;
12096 -- The expression that designates the attribute may depend on a
12097 -- discriminant, and is therefore a per-object expression, to
12098 -- be expanded in the init proc. If expansion is enabled, then
12099 -- perform semantic checks on a copy only.
12101 declare
12102 Temp : Node_Id;
12103 Typ : Node_Id;
12104 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12106 begin
12107 -- In Relaxed_RM_Semantics mode, we allow any static
12108 -- integer value, for compatibility with other compilers.
12110 if Relaxed_RM_Semantics
12111 and then Nkind (Parg2) = N_Integer_Literal
12112 then
12113 Typ := Standard_Integer;
12114 else
12115 Typ := RTE (RE_Interrupt_ID);
12116 end if;
12118 if Expander_Active then
12119 Temp := New_Copy_Tree (Parg2);
12120 Set_Parent (Temp, N);
12121 Preanalyze_And_Resolve (Temp, Typ);
12122 else
12123 Analyze (Parg2);
12124 Resolve (Parg2, Typ);
12125 end if;
12126 end;
12128 Process_Interrupt_Or_Attach_Handler;
12129 end if;
12131 --------------------
12132 -- C_Pass_By_Copy --
12133 --------------------
12135 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12137 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12138 Arg : Node_Id;
12139 Val : Uint;
12141 begin
12142 GNAT_Pragma;
12143 Check_Valid_Configuration_Pragma;
12144 Check_Arg_Count (1);
12145 Check_Optional_Identifier (Arg1, "max_size");
12147 Arg := Get_Pragma_Arg (Arg1);
12148 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12150 Val := Expr_Value (Arg);
12152 if Val <= 0 then
12153 Error_Pragma_Arg
12154 ("maximum size for pragma% must be positive", Arg1);
12156 elsif UI_Is_In_Int_Range (Val) then
12157 Default_C_Record_Mechanism := UI_To_Int (Val);
12159 -- If a giant value is given, Int'Last will do well enough.
12160 -- If sometime someone complains that a record larger than
12161 -- two gigabytes is not copied, we will worry about it then.
12163 else
12164 Default_C_Record_Mechanism := Mechanism_Type'Last;
12165 end if;
12166 end C_Pass_By_Copy;
12168 -----------
12169 -- Check --
12170 -----------
12172 -- pragma Check ([Name =>] CHECK_KIND,
12173 -- [Check =>] Boolean_EXPRESSION
12174 -- [,[Message =>] String_EXPRESSION]);
12176 -- CHECK_KIND ::= IDENTIFIER |
12177 -- Pre'Class |
12178 -- Post'Class |
12179 -- Invariant'Class |
12180 -- Type_Invariant'Class
12182 -- The identifiers Assertions and Statement_Assertions are not
12183 -- allowed, since they have special meaning for Check_Policy.
12185 when Pragma_Check => Check : declare
12186 Cname : Name_Id;
12187 Eloc : Source_Ptr;
12188 Expr : Node_Id;
12189 Str : Node_Id;
12191 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
12193 begin
12194 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12195 -- the mode now to ensure that any nodes generated during analysis
12196 -- and expansion are marked as Ghost.
12198 Set_Ghost_Mode (N);
12200 GNAT_Pragma;
12201 Check_At_Least_N_Arguments (2);
12202 Check_At_Most_N_Arguments (3);
12203 Check_Optional_Identifier (Arg1, Name_Name);
12204 Check_Optional_Identifier (Arg2, Name_Check);
12206 if Arg_Count = 3 then
12207 Check_Optional_Identifier (Arg3, Name_Message);
12208 Str := Get_Pragma_Arg (Arg3);
12209 end if;
12211 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12212 Check_Arg_Is_Identifier (Arg1);
12213 Cname := Chars (Get_Pragma_Arg (Arg1));
12215 -- Check forbidden name Assertions or Statement_Assertions
12217 case Cname is
12218 when Name_Assertions =>
12219 Error_Pragma_Arg
12220 ("""Assertions"" is not allowed as a check kind for "
12221 & "pragma%", Arg1);
12223 when Name_Statement_Assertions =>
12224 Error_Pragma_Arg
12225 ("""Statement_Assertions"" is not allowed as a check kind "
12226 & "for pragma%", Arg1);
12228 when others =>
12229 null;
12230 end case;
12232 -- Check applicable policy. We skip this if Checked/Ignored status
12233 -- is already set (e.g. in the case of a pragma from an aspect).
12235 if Is_Checked (N) or else Is_Ignored (N) then
12236 null;
12238 -- For a non-source pragma that is a rewriting of another pragma,
12239 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12241 elsif Is_Rewrite_Substitution (N)
12242 and then Nkind (Original_Node (N)) = N_Pragma
12243 and then Original_Node (N) /= N
12244 then
12245 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12246 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12248 -- Otherwise query the applicable policy at this point
12250 else
12251 case Check_Kind (Cname) is
12252 when Name_Ignore =>
12253 Set_Is_Ignored (N, True);
12254 Set_Is_Checked (N, False);
12256 when Name_Check =>
12257 Set_Is_Ignored (N, False);
12258 Set_Is_Checked (N, True);
12260 -- For disable, rewrite pragma as null statement and skip
12261 -- rest of the analysis of the pragma.
12263 when Name_Disable =>
12264 Rewrite (N, Make_Null_Statement (Loc));
12265 Analyze (N);
12266 raise Pragma_Exit;
12268 -- No other possibilities
12270 when others =>
12271 raise Program_Error;
12272 end case;
12273 end if;
12275 -- If check kind was not Disable, then continue pragma analysis
12277 Expr := Get_Pragma_Arg (Arg2);
12279 -- Deal with SCO generation
12281 case Cname is
12283 -- Nothing to do for predicates as the checks occur in the
12284 -- client units. The SCO for the aspect in the declaration
12285 -- unit is conservatively always enabled.
12287 when Name_Predicate =>
12288 null;
12290 -- Otherwise mark aspect/pragma SCO as enabled
12292 when others =>
12293 if Is_Checked (N) and then not Split_PPC (N) then
12294 Set_SCO_Pragma_Enabled (Loc);
12295 end if;
12296 end case;
12298 -- Deal with analyzing the string argument
12300 if Arg_Count = 3 then
12302 -- If checks are not on we don't want any expansion (since
12303 -- such expansion would not get properly deleted) but
12304 -- we do want to analyze (to get proper references).
12305 -- The Preanalyze_And_Resolve routine does just what we want
12307 if Is_Ignored (N) then
12308 Preanalyze_And_Resolve (Str, Standard_String);
12310 -- Otherwise we need a proper analysis and expansion
12312 else
12313 Analyze_And_Resolve (Str, Standard_String);
12314 end if;
12315 end if;
12317 -- Now you might think we could just do the same with the Boolean
12318 -- expression if checks are off (and expansion is on) and then
12319 -- rewrite the check as a null statement. This would work but we
12320 -- would lose the useful warnings about an assertion being bound
12321 -- to fail even if assertions are turned off.
12323 -- So instead we wrap the boolean expression in an if statement
12324 -- that looks like:
12326 -- if False and then condition then
12327 -- null;
12328 -- end if;
12330 -- The reason we do this rewriting during semantic analysis rather
12331 -- than as part of normal expansion is that we cannot analyze and
12332 -- expand the code for the boolean expression directly, or it may
12333 -- cause insertion of actions that would escape the attempt to
12334 -- suppress the check code.
12336 -- Note that the Sloc for the if statement corresponds to the
12337 -- argument condition, not the pragma itself. The reason for
12338 -- this is that we may generate a warning if the condition is
12339 -- False at compile time, and we do not want to delete this
12340 -- warning when we delete the if statement.
12342 if Expander_Active and Is_Ignored (N) then
12343 Eloc := Sloc (Expr);
12345 Rewrite (N,
12346 Make_If_Statement (Eloc,
12347 Condition =>
12348 Make_And_Then (Eloc,
12349 Left_Opnd => Make_Identifier (Eloc, Name_False),
12350 Right_Opnd => Expr),
12351 Then_Statements => New_List (
12352 Make_Null_Statement (Eloc))));
12354 -- Now go ahead and analyze the if statement
12356 In_Assertion_Expr := In_Assertion_Expr + 1;
12358 -- One rather special treatment. If we are now in Eliminated
12359 -- overflow mode, then suppress overflow checking since we do
12360 -- not want to drag in the bignum stuff if we are in Ignore
12361 -- mode anyway. This is particularly important if we are using
12362 -- a configurable run time that does not support bignum ops.
12364 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12365 declare
12366 Svo : constant Boolean :=
12367 Scope_Suppress.Suppress (Overflow_Check);
12368 begin
12369 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12370 Scope_Suppress.Suppress (Overflow_Check) := True;
12371 Analyze (N);
12372 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12373 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12374 end;
12376 -- Not that special case
12378 else
12379 Analyze (N);
12380 end if;
12382 -- All done with this check
12384 In_Assertion_Expr := In_Assertion_Expr - 1;
12386 -- Check is active or expansion not active. In these cases we can
12387 -- just go ahead and analyze the boolean with no worries.
12389 else
12390 In_Assertion_Expr := In_Assertion_Expr + 1;
12391 Analyze_And_Resolve (Expr, Any_Boolean);
12392 In_Assertion_Expr := In_Assertion_Expr - 1;
12393 end if;
12395 Ghost_Mode := Save_Ghost_Mode;
12396 end Check;
12398 --------------------------
12399 -- Check_Float_Overflow --
12400 --------------------------
12402 -- pragma Check_Float_Overflow;
12404 when Pragma_Check_Float_Overflow =>
12405 GNAT_Pragma;
12406 Check_Valid_Configuration_Pragma;
12407 Check_Arg_Count (0);
12408 Check_Float_Overflow := not Machine_Overflows_On_Target;
12410 ----------------
12411 -- Check_Name --
12412 ----------------
12414 -- pragma Check_Name (check_IDENTIFIER);
12416 when Pragma_Check_Name =>
12417 GNAT_Pragma;
12418 Check_No_Identifiers;
12419 Check_Valid_Configuration_Pragma;
12420 Check_Arg_Count (1);
12421 Check_Arg_Is_Identifier (Arg1);
12423 declare
12424 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12426 begin
12427 for J in Check_Names.First .. Check_Names.Last loop
12428 if Check_Names.Table (J) = Nam then
12429 return;
12430 end if;
12431 end loop;
12433 Check_Names.Append (Nam);
12434 end;
12436 ------------------
12437 -- Check_Policy --
12438 ------------------
12440 -- This is the old style syntax, which is still allowed in all modes:
12442 -- pragma Check_Policy ([Name =>] CHECK_KIND
12443 -- [Policy =>] POLICY_IDENTIFIER);
12445 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12447 -- CHECK_KIND ::= IDENTIFIER |
12448 -- Pre'Class |
12449 -- Post'Class |
12450 -- Type_Invariant'Class |
12451 -- Invariant'Class
12453 -- This is the new style syntax, compatible with Assertion_Policy
12454 -- and also allowed in all modes.
12456 -- Pragma Check_Policy (
12457 -- CHECK_KIND => POLICY_IDENTIFIER
12458 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12460 -- Note: the identifiers Name and Policy are not allowed as
12461 -- Check_Kind values. This avoids ambiguities between the old and
12462 -- new form syntax.
12464 when Pragma_Check_Policy => Check_Policy : declare
12465 Kind : Node_Id;
12467 begin
12468 GNAT_Pragma;
12469 Check_At_Least_N_Arguments (1);
12471 -- A Check_Policy pragma can appear either as a configuration
12472 -- pragma, or in a declarative part or a package spec (see RM
12473 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12474 -- followed for Check_Policy).
12476 if not Is_Configuration_Pragma then
12477 Check_Is_In_Decl_Part_Or_Package_Spec;
12478 end if;
12480 -- Figure out if we have the old or new syntax. We have the
12481 -- old syntax if the first argument has no identifier, or the
12482 -- identifier is Name.
12484 if Nkind (Arg1) /= N_Pragma_Argument_Association
12485 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12486 then
12487 -- Old syntax
12489 Check_Arg_Count (2);
12490 Check_Optional_Identifier (Arg1, Name_Name);
12491 Kind := Get_Pragma_Arg (Arg1);
12492 Rewrite_Assertion_Kind (Kind);
12493 Check_Arg_Is_Identifier (Arg1);
12495 -- Check forbidden check kind
12497 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12498 Error_Msg_Name_2 := Chars (Kind);
12499 Error_Pragma_Arg
12500 ("pragma% does not allow% as check name", Arg1);
12501 end if;
12503 -- Check policy
12505 Check_Optional_Identifier (Arg2, Name_Policy);
12506 Check_Arg_Is_One_Of
12507 (Arg2,
12508 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12510 -- And chain pragma on the Check_Policy_List for search
12512 Set_Next_Pragma (N, Opt.Check_Policy_List);
12513 Opt.Check_Policy_List := N;
12515 -- For the new syntax, what we do is to convert each argument to
12516 -- an old syntax equivalent. We do that because we want to chain
12517 -- old style Check_Policy pragmas for the search (we don't want
12518 -- to have to deal with multiple arguments in the search).
12520 else
12521 declare
12522 Arg : Node_Id;
12523 Argx : Node_Id;
12524 LocP : Source_Ptr;
12525 New_P : Node_Id;
12527 begin
12528 Arg := Arg1;
12529 while Present (Arg) loop
12530 LocP := Sloc (Arg);
12531 Argx := Get_Pragma_Arg (Arg);
12533 -- Kind must be specified
12535 if Nkind (Arg) /= N_Pragma_Argument_Association
12536 or else Chars (Arg) = No_Name
12537 then
12538 Error_Pragma_Arg
12539 ("missing assertion kind for pragma%", Arg);
12540 end if;
12542 -- Construct equivalent old form syntax Check_Policy
12543 -- pragma and insert it to get remaining checks.
12545 New_P :=
12546 Make_Pragma (LocP,
12547 Chars => Name_Check_Policy,
12548 Pragma_Argument_Associations => New_List (
12549 Make_Pragma_Argument_Association (LocP,
12550 Expression =>
12551 Make_Identifier (LocP, Chars (Arg))),
12552 Make_Pragma_Argument_Association (Sloc (Argx),
12553 Expression => Argx)));
12555 Arg := Next (Arg);
12557 -- For a configuration pragma, insert old form in
12558 -- the corresponding file.
12560 if Is_Configuration_Pragma then
12561 Insert_After (N, New_P);
12562 Analyze (New_P);
12564 else
12565 Insert_Action (N, New_P);
12566 end if;
12567 end loop;
12569 -- Rewrite original Check_Policy pragma to null, since we
12570 -- have converted it into a series of old syntax pragmas.
12572 Rewrite (N, Make_Null_Statement (Loc));
12573 Analyze (N);
12574 end;
12575 end if;
12576 end Check_Policy;
12578 -------------
12579 -- Comment --
12580 -------------
12582 -- pragma Comment (static_string_EXPRESSION)
12584 -- Processing for pragma Comment shares the circuitry for pragma
12585 -- Ident. The only differences are that Ident enforces a limit of 31
12586 -- characters on its argument, and also enforces limitations on
12587 -- placement for DEC compatibility. Pragma Comment shares neither of
12588 -- these restrictions.
12590 -------------------
12591 -- Common_Object --
12592 -------------------
12594 -- pragma Common_Object (
12595 -- [Internal =>] LOCAL_NAME
12596 -- [, [External =>] EXTERNAL_SYMBOL]
12597 -- [, [Size =>] EXTERNAL_SYMBOL]);
12599 -- Processing for this pragma is shared with Psect_Object
12601 ------------------------
12602 -- Compile_Time_Error --
12603 ------------------------
12605 -- pragma Compile_Time_Error
12606 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12608 when Pragma_Compile_Time_Error =>
12609 GNAT_Pragma;
12610 Process_Compile_Time_Warning_Or_Error;
12612 --------------------------
12613 -- Compile_Time_Warning --
12614 --------------------------
12616 -- pragma Compile_Time_Warning
12617 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12619 when Pragma_Compile_Time_Warning =>
12620 GNAT_Pragma;
12621 Process_Compile_Time_Warning_Or_Error;
12623 ---------------------------
12624 -- Compiler_Unit_Warning --
12625 ---------------------------
12627 -- pragma Compiler_Unit_Warning;
12629 -- Historical note
12631 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12632 -- errors not warnings. This means that we had introduced a big extra
12633 -- inertia to compiler changes, since even if we implemented a new
12634 -- feature, and even if all versions to be used for bootstrapping
12635 -- implemented this new feature, we could not use it, since old
12636 -- compilers would give errors for using this feature in units
12637 -- having Compiler_Unit pragmas.
12639 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12640 -- problem. We no longer have any units mentioning Compiler_Unit,
12641 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12642 -- and thus generates a warning which can be ignored. So that deals
12643 -- with the problem of old compilers not implementing the newer form
12644 -- of the pragma.
12646 -- Newer compilers recognize the new pragma, but generate warning
12647 -- messages instead of errors, which again can be ignored in the
12648 -- case of an old compiler which implements a wanted new feature
12649 -- but at the time felt like warning about it for older compilers.
12651 -- We retain Compiler_Unit so that new compilers can be used to build
12652 -- older run-times that use this pragma. That's an unusual case, but
12653 -- it's easy enough to handle, so why not?
12655 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12656 GNAT_Pragma;
12657 Check_Arg_Count (0);
12659 -- Only recognized in main unit
12661 if Current_Sem_Unit = Main_Unit then
12662 Compiler_Unit := True;
12663 end if;
12665 -----------------------------
12666 -- Complete_Representation --
12667 -----------------------------
12669 -- pragma Complete_Representation;
12671 when Pragma_Complete_Representation =>
12672 GNAT_Pragma;
12673 Check_Arg_Count (0);
12675 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12676 Error_Pragma
12677 ("pragma & must appear within record representation clause");
12678 end if;
12680 ----------------------------
12681 -- Complex_Representation --
12682 ----------------------------
12684 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12686 when Pragma_Complex_Representation => Complex_Representation : declare
12687 E_Id : Entity_Id;
12688 E : Entity_Id;
12689 Ent : Entity_Id;
12691 begin
12692 GNAT_Pragma;
12693 Check_Arg_Count (1);
12694 Check_Optional_Identifier (Arg1, Name_Entity);
12695 Check_Arg_Is_Local_Name (Arg1);
12696 E_Id := Get_Pragma_Arg (Arg1);
12698 if Etype (E_Id) = Any_Type then
12699 return;
12700 end if;
12702 E := Entity (E_Id);
12704 if not Is_Record_Type (E) then
12705 Error_Pragma_Arg
12706 ("argument for pragma% must be record type", Arg1);
12707 end if;
12709 Ent := First_Entity (E);
12711 if No (Ent)
12712 or else No (Next_Entity (Ent))
12713 or else Present (Next_Entity (Next_Entity (Ent)))
12714 or else not Is_Floating_Point_Type (Etype (Ent))
12715 or else Etype (Ent) /= Etype (Next_Entity (Ent))
12716 then
12717 Error_Pragma_Arg
12718 ("record for pragma% must have two fields of the same "
12719 & "floating-point type", Arg1);
12721 else
12722 Set_Has_Complex_Representation (Base_Type (E));
12724 -- We need to treat the type has having a non-standard
12725 -- representation, for back-end purposes, even though in
12726 -- general a complex will have the default representation
12727 -- of a record with two real components.
12729 Set_Has_Non_Standard_Rep (Base_Type (E));
12730 end if;
12731 end Complex_Representation;
12733 -------------------------
12734 -- Component_Alignment --
12735 -------------------------
12737 -- pragma Component_Alignment (
12738 -- [Form =>] ALIGNMENT_CHOICE
12739 -- [, [Name =>] type_LOCAL_NAME]);
12741 -- ALIGNMENT_CHOICE ::=
12742 -- Component_Size
12743 -- | Component_Size_4
12744 -- | Storage_Unit
12745 -- | Default
12747 when Pragma_Component_Alignment => Component_AlignmentP : declare
12748 Args : Args_List (1 .. 2);
12749 Names : constant Name_List (1 .. 2) := (
12750 Name_Form,
12751 Name_Name);
12753 Form : Node_Id renames Args (1);
12754 Name : Node_Id renames Args (2);
12756 Atype : Component_Alignment_Kind;
12757 Typ : Entity_Id;
12759 begin
12760 GNAT_Pragma;
12761 Gather_Associations (Names, Args);
12763 if No (Form) then
12764 Error_Pragma ("missing Form argument for pragma%");
12765 end if;
12767 Check_Arg_Is_Identifier (Form);
12769 -- Get proper alignment, note that Default = Component_Size on all
12770 -- machines we have so far, and we want to set this value rather
12771 -- than the default value to indicate that it has been explicitly
12772 -- set (and thus will not get overridden by the default component
12773 -- alignment for the current scope)
12775 if Chars (Form) = Name_Component_Size then
12776 Atype := Calign_Component_Size;
12778 elsif Chars (Form) = Name_Component_Size_4 then
12779 Atype := Calign_Component_Size_4;
12781 elsif Chars (Form) = Name_Default then
12782 Atype := Calign_Component_Size;
12784 elsif Chars (Form) = Name_Storage_Unit then
12785 Atype := Calign_Storage_Unit;
12787 else
12788 Error_Pragma_Arg
12789 ("invalid Form parameter for pragma%", Form);
12790 end if;
12792 -- Case with no name, supplied, affects scope table entry
12794 if No (Name) then
12795 Scope_Stack.Table
12796 (Scope_Stack.Last).Component_Alignment_Default := Atype;
12798 -- Case of name supplied
12800 else
12801 Check_Arg_Is_Local_Name (Name);
12802 Find_Type (Name);
12803 Typ := Entity (Name);
12805 if Typ = Any_Type
12806 or else Rep_Item_Too_Early (Typ, N)
12807 then
12808 return;
12809 else
12810 Typ := Underlying_Type (Typ);
12811 end if;
12813 if not Is_Record_Type (Typ)
12814 and then not Is_Array_Type (Typ)
12815 then
12816 Error_Pragma_Arg
12817 ("Name parameter of pragma% must identify record or "
12818 & "array type", Name);
12819 end if;
12821 -- An explicit Component_Alignment pragma overrides an
12822 -- implicit pragma Pack, but not an explicit one.
12824 if not Has_Pragma_Pack (Base_Type (Typ)) then
12825 Set_Is_Packed (Base_Type (Typ), False);
12826 Set_Component_Alignment (Base_Type (Typ), Atype);
12827 end if;
12828 end if;
12829 end Component_AlignmentP;
12831 --------------------------------
12832 -- Constant_After_Elaboration --
12833 --------------------------------
12835 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
12837 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
12838 declare
12839 Obj_Decl : Node_Id;
12840 Obj_Id : Entity_Id;
12842 begin
12843 GNAT_Pragma;
12844 Check_No_Identifiers;
12845 Check_At_Most_N_Arguments (1);
12847 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12849 -- Object declaration
12851 if Nkind (Obj_Decl) = N_Object_Declaration then
12852 null;
12854 -- Otherwise the pragma is associated with an illegal construct
12856 else
12857 Pragma_Misplaced;
12858 return;
12859 end if;
12861 Obj_Id := Defining_Entity (Obj_Decl);
12863 -- The object declaration must be a library-level variable which
12864 -- is either explicitly initialized or obtains a value during the
12865 -- elaboration of a package body (SPARK RM 3.3.1).
12867 if Ekind (Obj_Id) = E_Variable then
12868 if not Is_Library_Level_Entity (Obj_Id) then
12869 Error_Pragma
12870 ("pragma % must apply to a library level variable");
12871 return;
12872 end if;
12874 -- Otherwise the pragma applies to a constant, which is illegal
12876 else
12877 Error_Pragma ("pragma % must apply to a variable declaration");
12878 return;
12879 end if;
12881 -- Chain the pragma on the contract for completeness
12883 Add_Contract_Item (N, Obj_Id);
12885 -- A pragma that applies to a Ghost entity becomes Ghost for the
12886 -- purposes of legality checks and removal of ignored Ghost code.
12888 Mark_Pragma_As_Ghost (N, Obj_Id);
12890 -- Analyze the Boolean expression (if any)
12892 if Present (Arg1) then
12893 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12894 end if;
12895 end Constant_After_Elaboration;
12897 --------------------
12898 -- Contract_Cases --
12899 --------------------
12901 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12903 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12905 -- CASE_GUARD ::= boolean_EXPRESSION | others
12907 -- CONSEQUENCE ::= boolean_EXPRESSION
12909 -- Characteristics:
12911 -- * Analysis - The annotation undergoes initial checks to verify
12912 -- the legal placement and context. Secondary checks preanalyze the
12913 -- expressions in:
12915 -- Analyze_Contract_Cases_In_Decl_Part
12917 -- * Expansion - The annotation is expanded during the expansion of
12918 -- the related subprogram [body] contract as performed in:
12920 -- Expand_Subprogram_Contract
12922 -- * Template - The annotation utilizes the generic template of the
12923 -- related subprogram [body] when it is:
12925 -- aspect on subprogram declaration
12926 -- aspect on stand alone subprogram body
12927 -- pragma on stand alone subprogram body
12929 -- The annotation must prepare its own template when it is:
12931 -- pragma on subprogram declaration
12933 -- * Globals - Capture of global references must occur after full
12934 -- analysis.
12936 -- * Instance - The annotation is instantiated automatically when
12937 -- the related generic subprogram [body] is instantiated except for
12938 -- the "pragma on subprogram declaration" case. In that scenario
12939 -- the annotation must instantiate itself.
12941 when Pragma_Contract_Cases => Contract_Cases : declare
12942 Spec_Id : Entity_Id;
12943 Subp_Decl : Node_Id;
12945 begin
12946 GNAT_Pragma;
12947 Check_No_Identifiers;
12948 Check_Arg_Count (1);
12950 -- Ensure the proper placement of the pragma. Contract_Cases must
12951 -- be associated with a subprogram declaration or a body that acts
12952 -- as a spec.
12954 Subp_Decl :=
12955 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
12957 -- Entry
12959 if Nkind (Subp_Decl) = N_Entry_Declaration then
12960 null;
12962 -- Generic subprogram
12964 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
12965 null;
12967 -- Body acts as spec
12969 elsif Nkind (Subp_Decl) = N_Subprogram_Body
12970 and then No (Corresponding_Spec (Subp_Decl))
12971 then
12972 null;
12974 -- Body stub acts as spec
12976 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
12977 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
12978 then
12979 null;
12981 -- Subprogram
12983 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
12984 null;
12986 else
12987 Pragma_Misplaced;
12988 return;
12989 end if;
12991 Spec_Id := Unique_Defining_Entity (Subp_Decl);
12993 -- Chain the pragma on the contract for further processing by
12994 -- Analyze_Contract_Cases_In_Decl_Part.
12996 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12998 -- A pragma that applies to a Ghost entity becomes Ghost for the
12999 -- purposes of legality checks and removal of ignored Ghost code.
13001 Mark_Pragma_As_Ghost (N, Spec_Id);
13002 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13004 -- Fully analyze the pragma when it appears inside an entry
13005 -- or subprogram body because it cannot benefit from forward
13006 -- references.
13008 if Nkind_In (Subp_Decl, N_Entry_Body,
13009 N_Subprogram_Body,
13010 N_Subprogram_Body_Stub)
13011 then
13012 -- The legality checks of pragma Contract_Cases are affected by
13013 -- the SPARK mode in effect and the volatility of the context.
13014 -- Analyze all pragmas in a specific order.
13016 Analyze_If_Present (Pragma_SPARK_Mode);
13017 Analyze_If_Present (Pragma_Volatile_Function);
13018 Analyze_Contract_Cases_In_Decl_Part (N);
13019 end if;
13020 end Contract_Cases;
13022 ----------------
13023 -- Controlled --
13024 ----------------
13026 -- pragma Controlled (first_subtype_LOCAL_NAME);
13028 when Pragma_Controlled => Controlled : declare
13029 Arg : Node_Id;
13031 begin
13032 Check_No_Identifiers;
13033 Check_Arg_Count (1);
13034 Check_Arg_Is_Local_Name (Arg1);
13035 Arg := Get_Pragma_Arg (Arg1);
13037 if not Is_Entity_Name (Arg)
13038 or else not Is_Access_Type (Entity (Arg))
13039 then
13040 Error_Pragma_Arg ("pragma% requires access type", Arg1);
13041 else
13042 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13043 end if;
13044 end Controlled;
13046 ----------------
13047 -- Convention --
13048 ----------------
13050 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13051 -- [Entity =>] LOCAL_NAME);
13053 when Pragma_Convention => Convention : declare
13054 C : Convention_Id;
13055 E : Entity_Id;
13056 pragma Warnings (Off, C);
13057 pragma Warnings (Off, E);
13058 begin
13059 Check_Arg_Order ((Name_Convention, Name_Entity));
13060 Check_Ada_83_Warning;
13061 Check_Arg_Count (2);
13062 Process_Convention (C, E);
13064 -- A pragma that applies to a Ghost entity becomes Ghost for the
13065 -- purposes of legality checks and removal of ignored Ghost code.
13067 Mark_Pragma_As_Ghost (N, E);
13068 end Convention;
13070 ---------------------------
13071 -- Convention_Identifier --
13072 ---------------------------
13074 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13075 -- [Convention =>] convention_IDENTIFIER);
13077 when Pragma_Convention_Identifier => Convention_Identifier : declare
13078 Idnam : Name_Id;
13079 Cname : Name_Id;
13081 begin
13082 GNAT_Pragma;
13083 Check_Arg_Order ((Name_Name, Name_Convention));
13084 Check_Arg_Count (2);
13085 Check_Optional_Identifier (Arg1, Name_Name);
13086 Check_Optional_Identifier (Arg2, Name_Convention);
13087 Check_Arg_Is_Identifier (Arg1);
13088 Check_Arg_Is_Identifier (Arg2);
13089 Idnam := Chars (Get_Pragma_Arg (Arg1));
13090 Cname := Chars (Get_Pragma_Arg (Arg2));
13092 if Is_Convention_Name (Cname) then
13093 Record_Convention_Identifier
13094 (Idnam, Get_Convention_Id (Cname));
13095 else
13096 Error_Pragma_Arg
13097 ("second arg for % pragma must be convention", Arg2);
13098 end if;
13099 end Convention_Identifier;
13101 ---------------
13102 -- CPP_Class --
13103 ---------------
13105 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13107 when Pragma_CPP_Class => CPP_Class : declare
13108 begin
13109 GNAT_Pragma;
13111 if Warn_On_Obsolescent_Feature then
13112 Error_Msg_N
13113 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13114 & "effect; replace it by pragma import?j?", N);
13115 end if;
13117 Check_Arg_Count (1);
13119 Rewrite (N,
13120 Make_Pragma (Loc,
13121 Chars => Name_Import,
13122 Pragma_Argument_Associations => New_List (
13123 Make_Pragma_Argument_Association (Loc,
13124 Expression => Make_Identifier (Loc, Name_CPP)),
13125 New_Copy (First (Pragma_Argument_Associations (N))))));
13126 Analyze (N);
13127 end CPP_Class;
13129 ---------------------
13130 -- CPP_Constructor --
13131 ---------------------
13133 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13134 -- [, [External_Name =>] static_string_EXPRESSION ]
13135 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13137 when Pragma_CPP_Constructor => CPP_Constructor : declare
13138 Elmt : Elmt_Id;
13139 Id : Entity_Id;
13140 Def_Id : Entity_Id;
13141 Tag_Typ : Entity_Id;
13143 begin
13144 GNAT_Pragma;
13145 Check_At_Least_N_Arguments (1);
13146 Check_At_Most_N_Arguments (3);
13147 Check_Optional_Identifier (Arg1, Name_Entity);
13148 Check_Arg_Is_Local_Name (Arg1);
13150 Id := Get_Pragma_Arg (Arg1);
13151 Find_Program_Unit_Name (Id);
13153 -- If we did not find the name, we are done
13155 if Etype (Id) = Any_Type then
13156 return;
13157 end if;
13159 Def_Id := Entity (Id);
13161 -- Check if already defined as constructor
13163 if Is_Constructor (Def_Id) then
13164 Error_Msg_N
13165 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13166 return;
13167 end if;
13169 if Ekind (Def_Id) = E_Function
13170 and then (Is_CPP_Class (Etype (Def_Id))
13171 or else (Is_Class_Wide_Type (Etype (Def_Id))
13172 and then
13173 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13174 then
13175 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13176 Error_Msg_N
13177 ("'C'P'P constructor must be defined in the scope of "
13178 & "its returned type", Arg1);
13179 end if;
13181 if Arg_Count >= 2 then
13182 Set_Imported (Def_Id);
13183 Set_Is_Public (Def_Id);
13184 Process_Interface_Name (Def_Id, Arg2, Arg3);
13185 end if;
13187 Set_Has_Completion (Def_Id);
13188 Set_Is_Constructor (Def_Id);
13189 Set_Convention (Def_Id, Convention_CPP);
13191 -- Imported C++ constructors are not dispatching primitives
13192 -- because in C++ they don't have a dispatch table slot.
13193 -- However, in Ada the constructor has the profile of a
13194 -- function that returns a tagged type and therefore it has
13195 -- been treated as a primitive operation during semantic
13196 -- analysis. We now remove it from the list of primitive
13197 -- operations of the type.
13199 if Is_Tagged_Type (Etype (Def_Id))
13200 and then not Is_Class_Wide_Type (Etype (Def_Id))
13201 and then Is_Dispatching_Operation (Def_Id)
13202 then
13203 Tag_Typ := Etype (Def_Id);
13205 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13206 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13207 Next_Elmt (Elmt);
13208 end loop;
13210 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13211 Set_Is_Dispatching_Operation (Def_Id, False);
13212 end if;
13214 -- For backward compatibility, if the constructor returns a
13215 -- class wide type, and we internally change the return type to
13216 -- the corresponding root type.
13218 if Is_Class_Wide_Type (Etype (Def_Id)) then
13219 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13220 end if;
13221 else
13222 Error_Pragma_Arg
13223 ("pragma% requires function returning a 'C'P'P_Class type",
13224 Arg1);
13225 end if;
13226 end CPP_Constructor;
13228 -----------------
13229 -- CPP_Virtual --
13230 -----------------
13232 when Pragma_CPP_Virtual => CPP_Virtual : declare
13233 begin
13234 GNAT_Pragma;
13236 if Warn_On_Obsolescent_Feature then
13237 Error_Msg_N
13238 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13239 & "effect?j?", N);
13240 end if;
13241 end CPP_Virtual;
13243 ----------------
13244 -- CPP_Vtable --
13245 ----------------
13247 when Pragma_CPP_Vtable => CPP_Vtable : declare
13248 begin
13249 GNAT_Pragma;
13251 if Warn_On_Obsolescent_Feature then
13252 Error_Msg_N
13253 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13254 & "effect?j?", N);
13255 end if;
13256 end CPP_Vtable;
13258 ---------
13259 -- CPU --
13260 ---------
13262 -- pragma CPU (EXPRESSION);
13264 when Pragma_CPU => CPU : declare
13265 P : constant Node_Id := Parent (N);
13266 Arg : Node_Id;
13267 Ent : Entity_Id;
13269 begin
13270 Ada_2012_Pragma;
13271 Check_No_Identifiers;
13272 Check_Arg_Count (1);
13274 -- Subprogram case
13276 if Nkind (P) = N_Subprogram_Body then
13277 Check_In_Main_Program;
13279 Arg := Get_Pragma_Arg (Arg1);
13280 Analyze_And_Resolve (Arg, Any_Integer);
13282 Ent := Defining_Unit_Name (Specification (P));
13284 if Nkind (Ent) = N_Defining_Program_Unit_Name then
13285 Ent := Defining_Identifier (Ent);
13286 end if;
13288 -- Must be static
13290 if not Is_OK_Static_Expression (Arg) then
13291 Flag_Non_Static_Expr
13292 ("main subprogram affinity is not static!", Arg);
13293 raise Pragma_Exit;
13295 -- If constraint error, then we already signalled an error
13297 elsif Raises_Constraint_Error (Arg) then
13298 null;
13300 -- Otherwise check in range
13302 else
13303 declare
13304 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13305 -- This is the entity System.Multiprocessors.CPU_Range;
13307 Val : constant Uint := Expr_Value (Arg);
13309 begin
13310 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13311 or else
13312 Val > Expr_Value (Type_High_Bound (CPU_Id))
13313 then
13314 Error_Pragma_Arg
13315 ("main subprogram CPU is out of range", Arg1);
13316 end if;
13317 end;
13318 end if;
13320 Set_Main_CPU
13321 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13323 -- Task case
13325 elsif Nkind (P) = N_Task_Definition then
13326 Arg := Get_Pragma_Arg (Arg1);
13327 Ent := Defining_Identifier (Parent (P));
13329 -- The expression must be analyzed in the special manner
13330 -- described in "Handling of Default and Per-Object
13331 -- Expressions" in sem.ads.
13333 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13335 -- Anything else is incorrect
13337 else
13338 Pragma_Misplaced;
13339 end if;
13341 -- Check duplicate pragma before we chain the pragma in the Rep
13342 -- Item chain of Ent.
13344 Check_Duplicate_Pragma (Ent);
13345 Record_Rep_Item (Ent, N);
13346 end CPU;
13348 -----------
13349 -- Debug --
13350 -----------
13352 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13354 when Pragma_Debug => Debug : declare
13355 Cond : Node_Id;
13356 Call : Node_Id;
13358 begin
13359 GNAT_Pragma;
13361 -- The condition for executing the call is that the expander
13362 -- is active and that we are not ignoring this debug pragma.
13364 Cond :=
13365 New_Occurrence_Of
13366 (Boolean_Literals
13367 (Expander_Active and then not Is_Ignored (N)),
13368 Loc);
13370 if not Is_Ignored (N) then
13371 Set_SCO_Pragma_Enabled (Loc);
13372 end if;
13374 if Arg_Count = 2 then
13375 Cond :=
13376 Make_And_Then (Loc,
13377 Left_Opnd => Relocate_Node (Cond),
13378 Right_Opnd => Get_Pragma_Arg (Arg1));
13379 Call := Get_Pragma_Arg (Arg2);
13380 else
13381 Call := Get_Pragma_Arg (Arg1);
13382 end if;
13384 if Nkind_In (Call,
13385 N_Indexed_Component,
13386 N_Function_Call,
13387 N_Identifier,
13388 N_Expanded_Name,
13389 N_Selected_Component)
13390 then
13391 -- If this pragma Debug comes from source, its argument was
13392 -- parsed as a name form (which is syntactically identical).
13393 -- In a generic context a parameterless call will be left as
13394 -- an expanded name (if global) or selected_component if local.
13395 -- Change it to a procedure call statement now.
13397 Change_Name_To_Procedure_Call_Statement (Call);
13399 elsif Nkind (Call) = N_Procedure_Call_Statement then
13401 -- Already in the form of a procedure call statement: nothing
13402 -- to do (could happen in case of an internally generated
13403 -- pragma Debug).
13405 null;
13407 else
13408 -- All other cases: diagnose error
13410 Error_Msg
13411 ("argument of pragma ""Debug"" is not procedure call",
13412 Sloc (Call));
13413 return;
13414 end if;
13416 -- Rewrite into a conditional with an appropriate condition. We
13417 -- wrap the procedure call in a block so that overhead from e.g.
13418 -- use of the secondary stack does not generate execution overhead
13419 -- for suppressed conditions.
13421 -- Normally the analysis that follows will freeze the subprogram
13422 -- being called. However, if the call is to a null procedure,
13423 -- we want to freeze it before creating the block, because the
13424 -- analysis that follows may be done with expansion disabled, in
13425 -- which case the body will not be generated, leading to spurious
13426 -- errors.
13428 if Nkind (Call) = N_Procedure_Call_Statement
13429 and then Is_Entity_Name (Name (Call))
13430 then
13431 Analyze (Name (Call));
13432 Freeze_Before (N, Entity (Name (Call)));
13433 end if;
13435 Rewrite (N,
13436 Make_Implicit_If_Statement (N,
13437 Condition => Cond,
13438 Then_Statements => New_List (
13439 Make_Block_Statement (Loc,
13440 Handled_Statement_Sequence =>
13441 Make_Handled_Sequence_Of_Statements (Loc,
13442 Statements => New_List (Relocate_Node (Call)))))));
13443 Analyze (N);
13445 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13446 -- after analysis of the normally rewritten node, to capture all
13447 -- references to entities, which avoids issuing wrong warnings
13448 -- about unused entities.
13450 if GNATprove_Mode then
13451 Rewrite (N, Make_Null_Statement (Loc));
13452 end if;
13453 end Debug;
13455 ------------------
13456 -- Debug_Policy --
13457 ------------------
13459 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13461 when Pragma_Debug_Policy =>
13462 GNAT_Pragma;
13463 Check_Arg_Count (1);
13464 Check_No_Identifiers;
13465 Check_Arg_Is_Identifier (Arg1);
13467 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13468 -- rewrite it that way, and let the rest of the checking come
13469 -- from analyzing the rewritten pragma.
13471 Rewrite (N,
13472 Make_Pragma (Loc,
13473 Chars => Name_Check_Policy,
13474 Pragma_Argument_Associations => New_List (
13475 Make_Pragma_Argument_Association (Loc,
13476 Expression => Make_Identifier (Loc, Name_Debug)),
13478 Make_Pragma_Argument_Association (Loc,
13479 Expression => Get_Pragma_Arg (Arg1)))));
13480 Analyze (N);
13482 -------------------------------
13483 -- Default_Initial_Condition --
13484 -------------------------------
13486 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13488 when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
13489 Discard : Boolean;
13490 Stmt : Node_Id;
13491 Typ : Entity_Id;
13493 begin
13494 GNAT_Pragma;
13495 Check_No_Identifiers;
13496 Check_At_Most_N_Arguments (1);
13498 Stmt := Prev (N);
13499 while Present (Stmt) loop
13501 -- Skip prior pragmas, but check for duplicates
13503 if Nkind (Stmt) = N_Pragma then
13504 if Pragma_Name (Stmt) = Pname then
13505 Error_Msg_Name_1 := Pname;
13506 Error_Msg_Sloc := Sloc (Stmt);
13507 Error_Msg_N ("pragma % duplicates pragma declared#", N);
13508 end if;
13510 -- Skip internally generated code
13512 elsif not Comes_From_Source (Stmt) then
13513 null;
13515 -- The associated private type [extension] has been found, stop
13516 -- the search.
13518 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
13519 N_Private_Type_Declaration)
13520 then
13521 Typ := Defining_Entity (Stmt);
13522 exit;
13524 -- The pragma does not apply to a legal construct, issue an
13525 -- error and stop the analysis.
13527 else
13528 Pragma_Misplaced;
13529 return;
13530 end if;
13532 Stmt := Prev (Stmt);
13533 end loop;
13535 -- A pragma that applies to a Ghost entity becomes Ghost for the
13536 -- purposes of legality checks and removal of ignored Ghost code.
13538 Mark_Pragma_As_Ghost (N, Typ);
13539 Set_Has_Default_Init_Cond (Typ);
13540 Set_Has_Inherited_Default_Init_Cond (Typ, False);
13542 -- Chain the pragma on the rep item chain for further processing
13544 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13545 end Default_Init_Cond;
13547 ----------------------------------
13548 -- Default_Scalar_Storage_Order --
13549 ----------------------------------
13551 -- pragma Default_Scalar_Storage_Order
13552 -- (High_Order_First | Low_Order_First);
13554 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
13555 Default : Character;
13557 begin
13558 GNAT_Pragma;
13559 Check_Arg_Count (1);
13561 -- Default_Scalar_Storage_Order can appear as a configuration
13562 -- pragma, or in a declarative part of a package spec.
13564 if not Is_Configuration_Pragma then
13565 Check_Is_In_Decl_Part_Or_Package_Spec;
13566 end if;
13568 Check_No_Identifiers;
13569 Check_Arg_Is_One_Of
13570 (Arg1, Name_High_Order_First, Name_Low_Order_First);
13571 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13572 Default := Fold_Upper (Name_Buffer (1));
13574 if not Support_Nondefault_SSO_On_Target
13575 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
13576 then
13577 if Warn_On_Unrecognized_Pragma then
13578 Error_Msg_N
13579 ("non-default Scalar_Storage_Order not supported "
13580 & "on target?g?", N);
13581 Error_Msg_N
13582 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
13583 end if;
13585 -- Here set the specified default
13587 else
13588 Opt.Default_SSO := Default;
13589 end if;
13590 end DSSO;
13592 --------------------------
13593 -- Default_Storage_Pool --
13594 --------------------------
13596 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13598 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
13599 Pool : Node_Id;
13601 begin
13602 Ada_2012_Pragma;
13603 Check_Arg_Count (1);
13605 -- Default_Storage_Pool can appear as a configuration pragma, or
13606 -- in a declarative part of a package spec.
13608 if not Is_Configuration_Pragma then
13609 Check_Is_In_Decl_Part_Or_Package_Spec;
13610 end if;
13612 if From_Aspect_Specification (N) then
13613 declare
13614 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
13615 begin
13616 if not In_Open_Scopes (E) then
13617 Error_Msg_N
13618 ("aspect must apply to package or subprogram", N);
13619 end if;
13620 end;
13621 end if;
13623 if Present (Arg1) then
13624 Pool := Get_Pragma_Arg (Arg1);
13626 -- Case of Default_Storage_Pool (null);
13628 if Nkind (Pool) = N_Null then
13629 Analyze (Pool);
13631 -- This is an odd case, this is not really an expression,
13632 -- so we don't have a type for it. So just set the type to
13633 -- Empty.
13635 Set_Etype (Pool, Empty);
13637 -- Case of Default_Storage_Pool (storage_pool_NAME);
13639 else
13640 -- If it's a configuration pragma, then the only allowed
13641 -- argument is "null".
13643 if Is_Configuration_Pragma then
13644 Error_Pragma_Arg ("NULL expected", Arg1);
13645 end if;
13647 -- The expected type for a non-"null" argument is
13648 -- Root_Storage_Pool'Class, and the pool must be a variable.
13650 Analyze_And_Resolve
13651 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13653 if Is_Variable (Pool) then
13655 -- A pragma that applies to a Ghost entity becomes Ghost
13656 -- for the purposes of legality checks and removal of
13657 -- ignored Ghost code.
13659 Mark_Pragma_As_Ghost (N, Entity (Pool));
13661 else
13662 Error_Pragma_Arg
13663 ("default storage pool must be a variable", Arg1);
13664 end if;
13665 end if;
13667 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13668 -- access type will use this information to set the appropriate
13669 -- attributes of the access type.
13671 Default_Pool := Pool;
13672 end if;
13673 end Default_Storage_Pool;
13675 -------------
13676 -- Depends --
13677 -------------
13679 -- pragma Depends (DEPENDENCY_RELATION);
13681 -- DEPENDENCY_RELATION ::=
13682 -- null
13683 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
13685 -- DEPENDENCY_CLAUSE ::=
13686 -- OUTPUT_LIST =>[+] INPUT_LIST
13687 -- | NULL_DEPENDENCY_CLAUSE
13689 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13691 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13693 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13695 -- OUTPUT ::= NAME | FUNCTION_RESULT
13696 -- INPUT ::= NAME
13698 -- where FUNCTION_RESULT is a function Result attribute_reference
13700 -- Characteristics:
13702 -- * Analysis - The annotation undergoes initial checks to verify
13703 -- the legal placement and context. Secondary checks fully analyze
13704 -- the dependency clauses in:
13706 -- Analyze_Depends_In_Decl_Part
13708 -- * Expansion - None.
13710 -- * Template - The annotation utilizes the generic template of the
13711 -- related subprogram [body] when it is:
13713 -- aspect on subprogram declaration
13714 -- aspect on stand alone subprogram body
13715 -- pragma on stand alone subprogram body
13717 -- The annotation must prepare its own template when it is:
13719 -- pragma on subprogram declaration
13721 -- * Globals - Capture of global references must occur after full
13722 -- analysis.
13724 -- * Instance - The annotation is instantiated automatically when
13725 -- the related generic subprogram [body] is instantiated except for
13726 -- the "pragma on subprogram declaration" case. In that scenario
13727 -- the annotation must instantiate itself.
13729 when Pragma_Depends => Depends : declare
13730 Legal : Boolean;
13731 Spec_Id : Entity_Id;
13732 Subp_Decl : Node_Id;
13734 begin
13735 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
13737 if Legal then
13739 -- Chain the pragma on the contract for further processing by
13740 -- Analyze_Depends_In_Decl_Part.
13742 Add_Contract_Item (N, Spec_Id);
13744 -- Fully analyze the pragma when it appears inside an entry
13745 -- or subprogram body because it cannot benefit from forward
13746 -- references.
13748 if Nkind_In (Subp_Decl, N_Entry_Body,
13749 N_Subprogram_Body,
13750 N_Subprogram_Body_Stub)
13751 then
13752 -- The legality checks of pragmas Depends and Global are
13753 -- affected by the SPARK mode in effect and the volatility
13754 -- of the context. In addition these two pragmas are subject
13755 -- to an inherent order:
13757 -- 1) Global
13758 -- 2) Depends
13760 -- Analyze all these pragmas in the order outlined above
13762 Analyze_If_Present (Pragma_SPARK_Mode);
13763 Analyze_If_Present (Pragma_Volatile_Function);
13764 Analyze_If_Present (Pragma_Global);
13765 Analyze_Depends_In_Decl_Part (N);
13766 end if;
13767 end if;
13768 end Depends;
13770 ---------------------
13771 -- Detect_Blocking --
13772 ---------------------
13774 -- pragma Detect_Blocking;
13776 when Pragma_Detect_Blocking =>
13777 Ada_2005_Pragma;
13778 Check_Arg_Count (0);
13779 Check_Valid_Configuration_Pragma;
13780 Detect_Blocking := True;
13782 ------------------------------------
13783 -- Disable_Atomic_Synchronization --
13784 ------------------------------------
13786 -- pragma Disable_Atomic_Synchronization [(Entity)];
13788 when Pragma_Disable_Atomic_Synchronization =>
13789 GNAT_Pragma;
13790 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
13792 -------------------
13793 -- Discard_Names --
13794 -------------------
13796 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13798 when Pragma_Discard_Names => Discard_Names : declare
13799 E : Entity_Id;
13800 E_Id : Node_Id;
13802 begin
13803 Check_Ada_83_Warning;
13805 -- Deal with configuration pragma case
13807 if Arg_Count = 0 and then Is_Configuration_Pragma then
13808 Global_Discard_Names := True;
13809 return;
13811 -- Otherwise, check correct appropriate context
13813 else
13814 Check_Is_In_Decl_Part_Or_Package_Spec;
13816 if Arg_Count = 0 then
13818 -- If there is no parameter, then from now on this pragma
13819 -- applies to any enumeration, exception or tagged type
13820 -- defined in the current declarative part, and recursively
13821 -- to any nested scope.
13823 Set_Discard_Names (Current_Scope);
13824 return;
13826 else
13827 Check_Arg_Count (1);
13828 Check_Optional_Identifier (Arg1, Name_On);
13829 Check_Arg_Is_Local_Name (Arg1);
13831 E_Id := Get_Pragma_Arg (Arg1);
13833 if Etype (E_Id) = Any_Type then
13834 return;
13835 else
13836 E := Entity (E_Id);
13837 end if;
13839 -- A pragma that applies to a Ghost entity becomes Ghost for
13840 -- the purposes of legality checks and removal of ignored
13841 -- Ghost code.
13843 Mark_Pragma_As_Ghost (N, E);
13845 if (Is_First_Subtype (E)
13846 and then
13847 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
13848 or else Ekind (E) = E_Exception
13849 then
13850 Set_Discard_Names (E);
13851 Record_Rep_Item (E, N);
13853 else
13854 Error_Pragma_Arg
13855 ("inappropriate entity for pragma%", Arg1);
13856 end if;
13857 end if;
13858 end if;
13859 end Discard_Names;
13861 ------------------------
13862 -- Dispatching_Domain --
13863 ------------------------
13865 -- pragma Dispatching_Domain (EXPRESSION);
13867 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
13868 P : constant Node_Id := Parent (N);
13869 Arg : Node_Id;
13870 Ent : Entity_Id;
13872 begin
13873 Ada_2012_Pragma;
13874 Check_No_Identifiers;
13875 Check_Arg_Count (1);
13877 -- This pragma is born obsolete, but not the aspect
13879 if not From_Aspect_Specification (N) then
13880 Check_Restriction
13881 (No_Obsolescent_Features, Pragma_Identifier (N));
13882 end if;
13884 if Nkind (P) = N_Task_Definition then
13885 Arg := Get_Pragma_Arg (Arg1);
13886 Ent := Defining_Identifier (Parent (P));
13888 -- A pragma that applies to a Ghost entity becomes Ghost for
13889 -- the purposes of legality checks and removal of ignored Ghost
13890 -- code.
13892 Mark_Pragma_As_Ghost (N, Ent);
13894 -- The expression must be analyzed in the special manner
13895 -- described in "Handling of Default and Per-Object
13896 -- Expressions" in sem.ads.
13898 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
13900 -- Check duplicate pragma before we chain the pragma in the Rep
13901 -- Item chain of Ent.
13903 Check_Duplicate_Pragma (Ent);
13904 Record_Rep_Item (Ent, N);
13906 -- Anything else is incorrect
13908 else
13909 Pragma_Misplaced;
13910 end if;
13911 end Dispatching_Domain;
13913 ---------------
13914 -- Elaborate --
13915 ---------------
13917 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13919 when Pragma_Elaborate => Elaborate : declare
13920 Arg : Node_Id;
13921 Citem : Node_Id;
13923 begin
13924 -- Pragma must be in context items list of a compilation unit
13926 if not Is_In_Context_Clause then
13927 Pragma_Misplaced;
13928 end if;
13930 -- Must be at least one argument
13932 if Arg_Count = 0 then
13933 Error_Pragma ("pragma% requires at least one argument");
13934 end if;
13936 -- In Ada 83 mode, there can be no items following it in the
13937 -- context list except other pragmas and implicit with clauses
13938 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13939 -- placement rule does not apply.
13941 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
13942 Citem := Next (N);
13943 while Present (Citem) loop
13944 if Nkind (Citem) = N_Pragma
13945 or else (Nkind (Citem) = N_With_Clause
13946 and then Implicit_With (Citem))
13947 then
13948 null;
13949 else
13950 Error_Pragma
13951 ("(Ada 83) pragma% must be at end of context clause");
13952 end if;
13954 Next (Citem);
13955 end loop;
13956 end if;
13958 -- Finally, the arguments must all be units mentioned in a with
13959 -- clause in the same context clause. Note we already checked (in
13960 -- Par.Prag) that the arguments are all identifiers or selected
13961 -- components.
13963 Arg := Arg1;
13964 Outer : while Present (Arg) loop
13965 Citem := First (List_Containing (N));
13966 Inner : while Citem /= N loop
13967 if Nkind (Citem) = N_With_Clause
13968 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13969 then
13970 Set_Elaborate_Present (Citem, True);
13971 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13973 -- With the pragma present, elaboration calls on
13974 -- subprograms from the named unit need no further
13975 -- checks, as long as the pragma appears in the current
13976 -- compilation unit. If the pragma appears in some unit
13977 -- in the context, there might still be a need for an
13978 -- Elaborate_All_Desirable from the current compilation
13979 -- to the named unit, so we keep the check enabled.
13981 if In_Extended_Main_Source_Unit (N) then
13983 -- This does not apply in SPARK mode, where we allow
13984 -- pragma Elaborate, but we don't trust it to be right
13985 -- so we will still insist on the Elaborate_All.
13987 if SPARK_Mode /= On then
13988 Set_Suppress_Elaboration_Warnings
13989 (Entity (Name (Citem)));
13990 end if;
13991 end if;
13993 exit Inner;
13994 end if;
13996 Next (Citem);
13997 end loop Inner;
13999 if Citem = N then
14000 Error_Pragma_Arg
14001 ("argument of pragma% is not withed unit", Arg);
14002 end if;
14004 Next (Arg);
14005 end loop Outer;
14007 -- Give a warning if operating in static mode with one of the
14008 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14010 if Elab_Warnings
14011 and not Dynamic_Elaboration_Checks
14013 -- pragma Elaborate not allowed in SPARK mode anyway. We
14014 -- already complained about it, no point in generating any
14015 -- further complaint.
14017 and SPARK_Mode /= On
14018 then
14019 Error_Msg_N
14020 ("?l?use of pragma Elaborate may not be safe", N);
14021 Error_Msg_N
14022 ("?l?use pragma Elaborate_All instead if possible", N);
14023 end if;
14024 end Elaborate;
14026 -------------------
14027 -- Elaborate_All --
14028 -------------------
14030 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14032 when Pragma_Elaborate_All => Elaborate_All : declare
14033 Arg : Node_Id;
14034 Citem : Node_Id;
14036 begin
14037 Check_Ada_83_Warning;
14039 -- Pragma must be in context items list of a compilation unit
14041 if not Is_In_Context_Clause then
14042 Pragma_Misplaced;
14043 end if;
14045 -- Must be at least one argument
14047 if Arg_Count = 0 then
14048 Error_Pragma ("pragma% requires at least one argument");
14049 end if;
14051 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14052 -- have to appear at the end of the context clause, but may
14053 -- appear mixed in with other items, even in Ada 83 mode.
14055 -- Final check: the arguments must all be units mentioned in
14056 -- a with clause in the same context clause. Note that we
14057 -- already checked (in Par.Prag) that all the arguments are
14058 -- either identifiers or selected components.
14060 Arg := Arg1;
14061 Outr : while Present (Arg) loop
14062 Citem := First (List_Containing (N));
14063 Innr : while Citem /= N loop
14064 if Nkind (Citem) = N_With_Clause
14065 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14066 then
14067 Set_Elaborate_All_Present (Citem, True);
14068 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14070 -- Suppress warnings and elaboration checks on the named
14071 -- unit if the pragma is in the current compilation, as
14072 -- for pragma Elaborate.
14074 if In_Extended_Main_Source_Unit (N) then
14075 Set_Suppress_Elaboration_Warnings
14076 (Entity (Name (Citem)));
14077 end if;
14078 exit Innr;
14079 end if;
14081 Next (Citem);
14082 end loop Innr;
14084 if Citem = N then
14085 Set_Error_Posted (N);
14086 Error_Pragma_Arg
14087 ("argument of pragma% is not withed unit", Arg);
14088 end if;
14090 Next (Arg);
14091 end loop Outr;
14092 end Elaborate_All;
14094 --------------------
14095 -- Elaborate_Body --
14096 --------------------
14098 -- pragma Elaborate_Body [( library_unit_NAME )];
14100 when Pragma_Elaborate_Body => Elaborate_Body : declare
14101 Cunit_Node : Node_Id;
14102 Cunit_Ent : Entity_Id;
14104 begin
14105 Check_Ada_83_Warning;
14106 Check_Valid_Library_Unit_Pragma;
14108 if Nkind (N) = N_Null_Statement then
14109 return;
14110 end if;
14112 Cunit_Node := Cunit (Current_Sem_Unit);
14113 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
14115 -- A pragma that applies to a Ghost entity becomes Ghost for the
14116 -- purposes of legality checks and removal of ignored Ghost code.
14118 Mark_Pragma_As_Ghost (N, Cunit_Ent);
14120 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14121 N_Subprogram_Body)
14122 then
14123 Error_Pragma ("pragma% must refer to a spec, not a body");
14124 else
14125 Set_Body_Required (Cunit_Node, True);
14126 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14128 -- If we are in dynamic elaboration mode, then we suppress
14129 -- elaboration warnings for the unit, since it is definitely
14130 -- fine NOT to do dynamic checks at the first level (and such
14131 -- checks will be suppressed because no elaboration boolean
14132 -- is created for Elaborate_Body packages).
14134 -- But in the static model of elaboration, Elaborate_Body is
14135 -- definitely NOT good enough to ensure elaboration safety on
14136 -- its own, since the body may WITH other units that are not
14137 -- safe from an elaboration point of view, so a client must
14138 -- still do an Elaborate_All on such units.
14140 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14141 -- Elaborate_Body always suppressed elab warnings.
14143 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14144 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14145 end if;
14146 end if;
14147 end Elaborate_Body;
14149 ------------------------
14150 -- Elaboration_Checks --
14151 ------------------------
14153 -- pragma Elaboration_Checks (Static | Dynamic);
14155 when Pragma_Elaboration_Checks =>
14156 GNAT_Pragma;
14157 Check_Arg_Count (1);
14158 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14160 -- Set flag accordingly (ignore attempt at dynamic elaboration
14161 -- checks in SPARK mode).
14163 Dynamic_Elaboration_Checks :=
14164 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic)
14165 and then SPARK_Mode /= On;
14167 ---------------
14168 -- Eliminate --
14169 ---------------
14171 -- pragma Eliminate (
14172 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14173 -- [,[Entity =>] IDENTIFIER |
14174 -- SELECTED_COMPONENT |
14175 -- STRING_LITERAL]
14176 -- [, OVERLOADING_RESOLUTION]);
14178 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14179 -- SOURCE_LOCATION
14181 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14182 -- FUNCTION_PROFILE
14184 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14186 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14187 -- Result_Type => result_SUBTYPE_NAME]
14189 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14190 -- SUBTYPE_NAME ::= STRING_LITERAL
14192 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14193 -- SOURCE_TRACE ::= STRING_LITERAL
14195 when Pragma_Eliminate => Eliminate : declare
14196 Args : Args_List (1 .. 5);
14197 Names : constant Name_List (1 .. 5) := (
14198 Name_Unit_Name,
14199 Name_Entity,
14200 Name_Parameter_Types,
14201 Name_Result_Type,
14202 Name_Source_Location);
14204 Unit_Name : Node_Id renames Args (1);
14205 Entity : Node_Id renames Args (2);
14206 Parameter_Types : Node_Id renames Args (3);
14207 Result_Type : Node_Id renames Args (4);
14208 Source_Location : Node_Id renames Args (5);
14210 begin
14211 GNAT_Pragma;
14212 Check_Valid_Configuration_Pragma;
14213 Gather_Associations (Names, Args);
14215 if No (Unit_Name) then
14216 Error_Pragma ("missing Unit_Name argument for pragma%");
14217 end if;
14219 if No (Entity)
14220 and then (Present (Parameter_Types)
14221 or else
14222 Present (Result_Type)
14223 or else
14224 Present (Source_Location))
14225 then
14226 Error_Pragma ("missing Entity argument for pragma%");
14227 end if;
14229 if (Present (Parameter_Types)
14230 or else
14231 Present (Result_Type))
14232 and then
14233 Present (Source_Location)
14234 then
14235 Error_Pragma
14236 ("parameter profile and source location cannot be used "
14237 & "together in pragma%");
14238 end if;
14240 Process_Eliminate_Pragma
14242 Unit_Name,
14243 Entity,
14244 Parameter_Types,
14245 Result_Type,
14246 Source_Location);
14247 end Eliminate;
14249 -----------------------------------
14250 -- Enable_Atomic_Synchronization --
14251 -----------------------------------
14253 -- pragma Enable_Atomic_Synchronization [(Entity)];
14255 when Pragma_Enable_Atomic_Synchronization =>
14256 GNAT_Pragma;
14257 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14259 ------------
14260 -- Export --
14261 ------------
14263 -- pragma Export (
14264 -- [ Convention =>] convention_IDENTIFIER,
14265 -- [ Entity =>] LOCAL_NAME
14266 -- [, [External_Name =>] static_string_EXPRESSION ]
14267 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14269 when Pragma_Export => Export : declare
14270 C : Convention_Id;
14271 Def_Id : Entity_Id;
14273 pragma Warnings (Off, C);
14275 begin
14276 Check_Ada_83_Warning;
14277 Check_Arg_Order
14278 ((Name_Convention,
14279 Name_Entity,
14280 Name_External_Name,
14281 Name_Link_Name));
14283 Check_At_Least_N_Arguments (2);
14284 Check_At_Most_N_Arguments (4);
14286 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14287 -- pragma Export (Entity, "external name");
14289 if Relaxed_RM_Semantics
14290 and then Arg_Count = 2
14291 and then Nkind (Expression (Arg2)) = N_String_Literal
14292 then
14293 C := Convention_C;
14294 Def_Id := Get_Pragma_Arg (Arg1);
14295 Analyze (Def_Id);
14297 if not Is_Entity_Name (Def_Id) then
14298 Error_Pragma_Arg ("entity name required", Arg1);
14299 end if;
14301 Def_Id := Entity (Def_Id);
14302 Set_Exported (Def_Id, Arg1);
14304 else
14305 Process_Convention (C, Def_Id);
14307 -- A pragma that applies to a Ghost entity becomes Ghost for
14308 -- the purposes of legality checks and removal of ignored Ghost
14309 -- code.
14311 Mark_Pragma_As_Ghost (N, Def_Id);
14313 if Ekind (Def_Id) /= E_Constant then
14314 Note_Possible_Modification
14315 (Get_Pragma_Arg (Arg2), Sure => False);
14316 end if;
14318 Process_Interface_Name (Def_Id, Arg3, Arg4);
14319 Set_Exported (Def_Id, Arg2);
14320 end if;
14322 -- If the entity is a deferred constant, propagate the information
14323 -- to the full view, because gigi elaborates the full view only.
14325 if Ekind (Def_Id) = E_Constant
14326 and then Present (Full_View (Def_Id))
14327 then
14328 declare
14329 Id2 : constant Entity_Id := Full_View (Def_Id);
14330 begin
14331 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14332 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14333 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14334 end;
14335 end if;
14336 end Export;
14338 ---------------------
14339 -- Export_Function --
14340 ---------------------
14342 -- pragma Export_Function (
14343 -- [Internal =>] LOCAL_NAME
14344 -- [, [External =>] EXTERNAL_SYMBOL]
14345 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14346 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14347 -- [, [Mechanism =>] MECHANISM]
14348 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14350 -- EXTERNAL_SYMBOL ::=
14351 -- IDENTIFIER
14352 -- | static_string_EXPRESSION
14354 -- PARAMETER_TYPES ::=
14355 -- null
14356 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14358 -- TYPE_DESIGNATOR ::=
14359 -- subtype_NAME
14360 -- | subtype_Name ' Access
14362 -- MECHANISM ::=
14363 -- MECHANISM_NAME
14364 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14366 -- MECHANISM_ASSOCIATION ::=
14367 -- [formal_parameter_NAME =>] MECHANISM_NAME
14369 -- MECHANISM_NAME ::=
14370 -- Value
14371 -- | Reference
14373 when Pragma_Export_Function => Export_Function : declare
14374 Args : Args_List (1 .. 6);
14375 Names : constant Name_List (1 .. 6) := (
14376 Name_Internal,
14377 Name_External,
14378 Name_Parameter_Types,
14379 Name_Result_Type,
14380 Name_Mechanism,
14381 Name_Result_Mechanism);
14383 Internal : Node_Id renames Args (1);
14384 External : Node_Id renames Args (2);
14385 Parameter_Types : Node_Id renames Args (3);
14386 Result_Type : Node_Id renames Args (4);
14387 Mechanism : Node_Id renames Args (5);
14388 Result_Mechanism : Node_Id renames Args (6);
14390 begin
14391 GNAT_Pragma;
14392 Gather_Associations (Names, Args);
14393 Process_Extended_Import_Export_Subprogram_Pragma (
14394 Arg_Internal => Internal,
14395 Arg_External => External,
14396 Arg_Parameter_Types => Parameter_Types,
14397 Arg_Result_Type => Result_Type,
14398 Arg_Mechanism => Mechanism,
14399 Arg_Result_Mechanism => Result_Mechanism);
14400 end Export_Function;
14402 -------------------
14403 -- Export_Object --
14404 -------------------
14406 -- pragma Export_Object (
14407 -- [Internal =>] LOCAL_NAME
14408 -- [, [External =>] EXTERNAL_SYMBOL]
14409 -- [, [Size =>] EXTERNAL_SYMBOL]);
14411 -- EXTERNAL_SYMBOL ::=
14412 -- IDENTIFIER
14413 -- | static_string_EXPRESSION
14415 -- PARAMETER_TYPES ::=
14416 -- null
14417 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14419 -- TYPE_DESIGNATOR ::=
14420 -- subtype_NAME
14421 -- | subtype_Name ' Access
14423 -- MECHANISM ::=
14424 -- MECHANISM_NAME
14425 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14427 -- MECHANISM_ASSOCIATION ::=
14428 -- [formal_parameter_NAME =>] MECHANISM_NAME
14430 -- MECHANISM_NAME ::=
14431 -- Value
14432 -- | Reference
14434 when Pragma_Export_Object => Export_Object : declare
14435 Args : Args_List (1 .. 3);
14436 Names : constant Name_List (1 .. 3) := (
14437 Name_Internal,
14438 Name_External,
14439 Name_Size);
14441 Internal : Node_Id renames Args (1);
14442 External : Node_Id renames Args (2);
14443 Size : Node_Id renames Args (3);
14445 begin
14446 GNAT_Pragma;
14447 Gather_Associations (Names, Args);
14448 Process_Extended_Import_Export_Object_Pragma (
14449 Arg_Internal => Internal,
14450 Arg_External => External,
14451 Arg_Size => Size);
14452 end Export_Object;
14454 ----------------------
14455 -- Export_Procedure --
14456 ----------------------
14458 -- pragma Export_Procedure (
14459 -- [Internal =>] LOCAL_NAME
14460 -- [, [External =>] EXTERNAL_SYMBOL]
14461 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14462 -- [, [Mechanism =>] MECHANISM]);
14464 -- EXTERNAL_SYMBOL ::=
14465 -- IDENTIFIER
14466 -- | static_string_EXPRESSION
14468 -- PARAMETER_TYPES ::=
14469 -- null
14470 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14472 -- TYPE_DESIGNATOR ::=
14473 -- subtype_NAME
14474 -- | subtype_Name ' Access
14476 -- MECHANISM ::=
14477 -- MECHANISM_NAME
14478 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14480 -- MECHANISM_ASSOCIATION ::=
14481 -- [formal_parameter_NAME =>] MECHANISM_NAME
14483 -- MECHANISM_NAME ::=
14484 -- Value
14485 -- | Reference
14487 when Pragma_Export_Procedure => Export_Procedure : declare
14488 Args : Args_List (1 .. 4);
14489 Names : constant Name_List (1 .. 4) := (
14490 Name_Internal,
14491 Name_External,
14492 Name_Parameter_Types,
14493 Name_Mechanism);
14495 Internal : Node_Id renames Args (1);
14496 External : Node_Id renames Args (2);
14497 Parameter_Types : Node_Id renames Args (3);
14498 Mechanism : Node_Id renames Args (4);
14500 begin
14501 GNAT_Pragma;
14502 Gather_Associations (Names, Args);
14503 Process_Extended_Import_Export_Subprogram_Pragma (
14504 Arg_Internal => Internal,
14505 Arg_External => External,
14506 Arg_Parameter_Types => Parameter_Types,
14507 Arg_Mechanism => Mechanism);
14508 end Export_Procedure;
14510 ------------------
14511 -- Export_Value --
14512 ------------------
14514 -- pragma Export_Value (
14515 -- [Value =>] static_integer_EXPRESSION,
14516 -- [Link_Name =>] static_string_EXPRESSION);
14518 when Pragma_Export_Value =>
14519 GNAT_Pragma;
14520 Check_Arg_Order ((Name_Value, Name_Link_Name));
14521 Check_Arg_Count (2);
14523 Check_Optional_Identifier (Arg1, Name_Value);
14524 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
14526 Check_Optional_Identifier (Arg2, Name_Link_Name);
14527 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
14529 -----------------------------
14530 -- Export_Valued_Procedure --
14531 -----------------------------
14533 -- pragma Export_Valued_Procedure (
14534 -- [Internal =>] LOCAL_NAME
14535 -- [, [External =>] EXTERNAL_SYMBOL,]
14536 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14537 -- [, [Mechanism =>] MECHANISM]);
14539 -- EXTERNAL_SYMBOL ::=
14540 -- IDENTIFIER
14541 -- | static_string_EXPRESSION
14543 -- PARAMETER_TYPES ::=
14544 -- null
14545 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14547 -- TYPE_DESIGNATOR ::=
14548 -- subtype_NAME
14549 -- | subtype_Name ' Access
14551 -- MECHANISM ::=
14552 -- MECHANISM_NAME
14553 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14555 -- MECHANISM_ASSOCIATION ::=
14556 -- [formal_parameter_NAME =>] MECHANISM_NAME
14558 -- MECHANISM_NAME ::=
14559 -- Value
14560 -- | Reference
14562 when Pragma_Export_Valued_Procedure =>
14563 Export_Valued_Procedure : declare
14564 Args : Args_List (1 .. 4);
14565 Names : constant Name_List (1 .. 4) := (
14566 Name_Internal,
14567 Name_External,
14568 Name_Parameter_Types,
14569 Name_Mechanism);
14571 Internal : Node_Id renames Args (1);
14572 External : Node_Id renames Args (2);
14573 Parameter_Types : Node_Id renames Args (3);
14574 Mechanism : Node_Id renames Args (4);
14576 begin
14577 GNAT_Pragma;
14578 Gather_Associations (Names, Args);
14579 Process_Extended_Import_Export_Subprogram_Pragma (
14580 Arg_Internal => Internal,
14581 Arg_External => External,
14582 Arg_Parameter_Types => Parameter_Types,
14583 Arg_Mechanism => Mechanism);
14584 end Export_Valued_Procedure;
14586 -------------------
14587 -- Extend_System --
14588 -------------------
14590 -- pragma Extend_System ([Name =>] Identifier);
14592 when Pragma_Extend_System => Extend_System : declare
14593 begin
14594 GNAT_Pragma;
14595 Check_Valid_Configuration_Pragma;
14596 Check_Arg_Count (1);
14597 Check_Optional_Identifier (Arg1, Name_Name);
14598 Check_Arg_Is_Identifier (Arg1);
14600 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14602 if Name_Len > 4
14603 and then Name_Buffer (1 .. 4) = "aux_"
14604 then
14605 if Present (System_Extend_Pragma_Arg) then
14606 if Chars (Get_Pragma_Arg (Arg1)) =
14607 Chars (Expression (System_Extend_Pragma_Arg))
14608 then
14609 null;
14610 else
14611 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
14612 Error_Pragma ("pragma% conflicts with that #");
14613 end if;
14615 else
14616 System_Extend_Pragma_Arg := Arg1;
14618 if not GNAT_Mode then
14619 System_Extend_Unit := Arg1;
14620 end if;
14621 end if;
14622 else
14623 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14624 end if;
14625 end Extend_System;
14627 ------------------------
14628 -- Extensions_Allowed --
14629 ------------------------
14631 -- pragma Extensions_Allowed (ON | OFF);
14633 when Pragma_Extensions_Allowed =>
14634 GNAT_Pragma;
14635 Check_Arg_Count (1);
14636 Check_No_Identifiers;
14637 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14639 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14640 Extensions_Allowed := True;
14641 Ada_Version := Ada_Version_Type'Last;
14643 else
14644 Extensions_Allowed := False;
14645 Ada_Version := Ada_Version_Explicit;
14646 Ada_Version_Pragma := Empty;
14647 end if;
14649 ------------------------
14650 -- Extensions_Visible --
14651 ------------------------
14653 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14655 -- Characteristics:
14657 -- * Analysis - The annotation is fully analyzed immediately upon
14658 -- elaboration as its expression must be static.
14660 -- * Expansion - None.
14662 -- * Template - The annotation utilizes the generic template of the
14663 -- related subprogram [body] when it is:
14665 -- aspect on subprogram declaration
14666 -- aspect on stand alone subprogram body
14667 -- pragma on stand alone subprogram body
14669 -- The annotation must prepare its own template when it is:
14671 -- pragma on subprogram declaration
14673 -- * Globals - Capture of global references must occur after full
14674 -- analysis.
14676 -- * Instance - The annotation is instantiated automatically when
14677 -- the related generic subprogram [body] is instantiated except for
14678 -- the "pragma on subprogram declaration" case. In that scenario
14679 -- the annotation must instantiate itself.
14681 when Pragma_Extensions_Visible => Extensions_Visible : declare
14682 Formal : Entity_Id;
14683 Has_OK_Formal : Boolean := False;
14684 Spec_Id : Entity_Id;
14685 Subp_Decl : Node_Id;
14687 begin
14688 GNAT_Pragma;
14689 Check_No_Identifiers;
14690 Check_At_Most_N_Arguments (1);
14692 Subp_Decl :=
14693 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14695 -- Abstract subprogram declaration
14697 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
14698 null;
14700 -- Generic subprogram declaration
14702 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14703 null;
14705 -- Body acts as spec
14707 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14708 and then No (Corresponding_Spec (Subp_Decl))
14709 then
14710 null;
14712 -- Body stub acts as spec
14714 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14715 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14716 then
14717 null;
14719 -- Subprogram declaration
14721 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14722 null;
14724 -- Otherwise the pragma is associated with an illegal construct
14726 else
14727 Error_Pragma ("pragma % must apply to a subprogram");
14728 return;
14729 end if;
14731 -- Chain the pragma on the contract for completeness
14733 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14735 -- The legality checks of pragma Extension_Visible are affected
14736 -- by the SPARK mode in effect. Analyze all pragmas in specific
14737 -- order.
14739 Analyze_If_Present (Pragma_SPARK_Mode);
14741 -- Mark the pragma as Ghost if the related subprogram is also
14742 -- Ghost. This also ensures that any expansion performed further
14743 -- below will produce Ghost nodes.
14745 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14746 Mark_Pragma_As_Ghost (N, Spec_Id);
14748 -- Examine the formals of the related subprogram
14750 Formal := First_Formal (Spec_Id);
14751 while Present (Formal) loop
14753 -- At least one of the formals is of a specific tagged type,
14754 -- the pragma is legal.
14756 if Is_Specific_Tagged_Type (Etype (Formal)) then
14757 Has_OK_Formal := True;
14758 exit;
14760 -- A generic subprogram with at least one formal of a private
14761 -- type ensures the legality of the pragma because the actual
14762 -- may be specifically tagged. Note that this is verified by
14763 -- the check above at instantiation time.
14765 elsif Is_Private_Type (Etype (Formal))
14766 and then Is_Generic_Type (Etype (Formal))
14767 then
14768 Has_OK_Formal := True;
14769 exit;
14770 end if;
14772 Next_Formal (Formal);
14773 end loop;
14775 if not Has_OK_Formal then
14776 Error_Msg_Name_1 := Pname;
14777 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
14778 Error_Msg_NE
14779 ("\subprogram & lacks parameter of specific tagged or "
14780 & "generic private type", N, Spec_Id);
14782 return;
14783 end if;
14785 -- Analyze the Boolean expression (if any)
14787 if Present (Arg1) then
14788 Check_Static_Boolean_Expression
14789 (Expression (Get_Argument (N, Spec_Id)));
14790 end if;
14791 end Extensions_Visible;
14793 --------------
14794 -- External --
14795 --------------
14797 -- pragma External (
14798 -- [ Convention =>] convention_IDENTIFIER,
14799 -- [ Entity =>] LOCAL_NAME
14800 -- [, [External_Name =>] static_string_EXPRESSION ]
14801 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14803 when Pragma_External => External : declare
14804 C : Convention_Id;
14805 E : Entity_Id;
14806 pragma Warnings (Off, C);
14808 begin
14809 GNAT_Pragma;
14810 Check_Arg_Order
14811 ((Name_Convention,
14812 Name_Entity,
14813 Name_External_Name,
14814 Name_Link_Name));
14815 Check_At_Least_N_Arguments (2);
14816 Check_At_Most_N_Arguments (4);
14817 Process_Convention (C, E);
14819 -- A pragma that applies to a Ghost entity becomes Ghost for the
14820 -- purposes of legality checks and removal of ignored Ghost code.
14822 Mark_Pragma_As_Ghost (N, E);
14824 Note_Possible_Modification
14825 (Get_Pragma_Arg (Arg2), Sure => False);
14826 Process_Interface_Name (E, Arg3, Arg4);
14827 Set_Exported (E, Arg2);
14828 end External;
14830 --------------------------
14831 -- External_Name_Casing --
14832 --------------------------
14834 -- pragma External_Name_Casing (
14835 -- UPPERCASE | LOWERCASE
14836 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14838 when Pragma_External_Name_Casing => External_Name_Casing : declare
14839 begin
14840 GNAT_Pragma;
14841 Check_No_Identifiers;
14843 if Arg_Count = 2 then
14844 Check_Arg_Is_One_Of
14845 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
14847 case Chars (Get_Pragma_Arg (Arg2)) is
14848 when Name_As_Is =>
14849 Opt.External_Name_Exp_Casing := As_Is;
14851 when Name_Uppercase =>
14852 Opt.External_Name_Exp_Casing := Uppercase;
14854 when Name_Lowercase =>
14855 Opt.External_Name_Exp_Casing := Lowercase;
14857 when others =>
14858 null;
14859 end case;
14861 else
14862 Check_Arg_Count (1);
14863 end if;
14865 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
14867 case Chars (Get_Pragma_Arg (Arg1)) is
14868 when Name_Uppercase =>
14869 Opt.External_Name_Imp_Casing := Uppercase;
14871 when Name_Lowercase =>
14872 Opt.External_Name_Imp_Casing := Lowercase;
14874 when others =>
14875 null;
14876 end case;
14877 end External_Name_Casing;
14879 ---------------
14880 -- Fast_Math --
14881 ---------------
14883 -- pragma Fast_Math;
14885 when Pragma_Fast_Math =>
14886 GNAT_Pragma;
14887 Check_No_Identifiers;
14888 Check_Valid_Configuration_Pragma;
14889 Fast_Math := True;
14891 --------------------------
14892 -- Favor_Top_Level --
14893 --------------------------
14895 -- pragma Favor_Top_Level (type_NAME);
14897 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
14898 Typ : Entity_Id;
14900 begin
14901 GNAT_Pragma;
14902 Check_No_Identifiers;
14903 Check_Arg_Count (1);
14904 Check_Arg_Is_Local_Name (Arg1);
14905 Typ := Entity (Get_Pragma_Arg (Arg1));
14907 -- A pragma that applies to a Ghost entity becomes Ghost for the
14908 -- purposes of legality checks and removal of ignored Ghost code.
14910 Mark_Pragma_As_Ghost (N, Typ);
14912 -- If it's an access-to-subprogram type (in particular, not a
14913 -- subtype), set the flag on that type.
14915 if Is_Access_Subprogram_Type (Typ) then
14916 Set_Can_Use_Internal_Rep (Typ, False);
14918 -- Otherwise it's an error (name denotes the wrong sort of entity)
14920 else
14921 Error_Pragma_Arg
14922 ("access-to-subprogram type expected",
14923 Get_Pragma_Arg (Arg1));
14924 end if;
14925 end Favor_Top_Level;
14927 ---------------------------
14928 -- Finalize_Storage_Only --
14929 ---------------------------
14931 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14933 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
14934 Assoc : constant Node_Id := Arg1;
14935 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
14936 Typ : Entity_Id;
14938 begin
14939 GNAT_Pragma;
14940 Check_No_Identifiers;
14941 Check_Arg_Count (1);
14942 Check_Arg_Is_Local_Name (Arg1);
14944 Find_Type (Type_Id);
14945 Typ := Entity (Type_Id);
14947 if Typ = Any_Type
14948 or else Rep_Item_Too_Early (Typ, N)
14949 then
14950 return;
14951 else
14952 Typ := Underlying_Type (Typ);
14953 end if;
14955 if not Is_Controlled (Typ) then
14956 Error_Pragma ("pragma% must specify controlled type");
14957 end if;
14959 Check_First_Subtype (Arg1);
14961 if Finalize_Storage_Only (Typ) then
14962 Error_Pragma ("duplicate pragma%, only one allowed");
14964 elsif not Rep_Item_Too_Late (Typ, N) then
14965 Set_Finalize_Storage_Only (Base_Type (Typ), True);
14966 end if;
14967 end Finalize_Storage;
14969 -----------
14970 -- Ghost --
14971 -----------
14973 -- pragma Ghost [ (boolean_EXPRESSION) ];
14975 when Pragma_Ghost => Ghost : declare
14976 Context : Node_Id;
14977 Expr : Node_Id;
14978 Id : Entity_Id;
14979 Orig_Stmt : Node_Id;
14980 Prev_Id : Entity_Id;
14981 Stmt : Node_Id;
14983 begin
14984 GNAT_Pragma;
14985 Check_No_Identifiers;
14986 Check_At_Most_N_Arguments (1);
14988 Id := Empty;
14989 Stmt := Prev (N);
14990 while Present (Stmt) loop
14992 -- Skip prior pragmas, but check for duplicates
14994 if Nkind (Stmt) = N_Pragma then
14995 if Pragma_Name (Stmt) = Pname then
14996 Error_Msg_Name_1 := Pname;
14997 Error_Msg_Sloc := Sloc (Stmt);
14998 Error_Msg_N ("pragma % duplicates pragma declared#", N);
14999 end if;
15001 -- Task unit declared without a definition cannot be subject to
15002 -- pragma Ghost (SPARK RM 6.9(19)).
15004 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15005 N_Task_Type_Declaration)
15006 then
15007 Error_Pragma ("pragma % cannot apply to a task type");
15008 return;
15010 -- Skip internally generated code
15012 elsif not Comes_From_Source (Stmt) then
15013 Orig_Stmt := Original_Node (Stmt);
15015 -- When pragma Ghost applies to an untagged derivation, the
15016 -- derivation is transformed into a [sub]type declaration.
15018 if Nkind_In (Stmt, N_Full_Type_Declaration,
15019 N_Subtype_Declaration)
15020 and then Comes_From_Source (Orig_Stmt)
15021 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15022 and then Nkind (Type_Definition (Orig_Stmt)) =
15023 N_Derived_Type_Definition
15024 then
15025 Id := Defining_Entity (Stmt);
15026 exit;
15028 -- When pragma Ghost applies to an object declaration which
15029 -- is initialized by means of a function call that returns
15030 -- on the secondary stack, the object declaration becomes a
15031 -- renaming.
15033 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15034 and then Comes_From_Source (Orig_Stmt)
15035 and then Nkind (Orig_Stmt) = N_Object_Declaration
15036 then
15037 Id := Defining_Entity (Stmt);
15038 exit;
15040 -- When pragma Ghost applies to an expression function, the
15041 -- expression function is transformed into a subprogram.
15043 elsif Nkind (Stmt) = N_Subprogram_Declaration
15044 and then Comes_From_Source (Orig_Stmt)
15045 and then Nkind (Orig_Stmt) = N_Expression_Function
15046 then
15047 Id := Defining_Entity (Stmt);
15048 exit;
15049 end if;
15051 -- The pragma applies to a legal construct, stop the traversal
15053 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15054 N_Full_Type_Declaration,
15055 N_Generic_Subprogram_Declaration,
15056 N_Object_Declaration,
15057 N_Private_Extension_Declaration,
15058 N_Private_Type_Declaration,
15059 N_Subprogram_Declaration,
15060 N_Subtype_Declaration)
15061 then
15062 Id := Defining_Entity (Stmt);
15063 exit;
15065 -- The pragma does not apply to a legal construct, issue an
15066 -- error and stop the analysis.
15068 else
15069 Error_Pragma
15070 ("pragma % must apply to an object, package, subprogram "
15071 & "or type");
15072 return;
15073 end if;
15075 Stmt := Prev (Stmt);
15076 end loop;
15078 Context := Parent (N);
15080 -- Handle compilation units
15082 if Nkind (Context) = N_Compilation_Unit_Aux then
15083 Context := Unit (Parent (Context));
15084 end if;
15086 -- Protected and task types cannot be subject to pragma Ghost
15087 -- (SPARK RM 6.9(19)).
15089 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15090 then
15091 Error_Pragma ("pragma % cannot apply to a protected type");
15092 return;
15094 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15095 Error_Pragma ("pragma % cannot apply to a task type");
15096 return;
15097 end if;
15099 if No (Id) then
15101 -- When pragma Ghost is associated with a [generic] package, it
15102 -- appears in the visible declarations.
15104 if Nkind (Context) = N_Package_Specification
15105 and then Present (Visible_Declarations (Context))
15106 and then List_Containing (N) = Visible_Declarations (Context)
15107 then
15108 Id := Defining_Entity (Context);
15110 -- Pragma Ghost applies to a stand alone subprogram body
15112 elsif Nkind (Context) = N_Subprogram_Body
15113 and then No (Corresponding_Spec (Context))
15114 then
15115 Id := Defining_Entity (Context);
15117 -- Pragma Ghost applies to a subprogram declaration that acts
15118 -- as a compilation unit.
15120 elsif Nkind (Context) = N_Subprogram_Declaration then
15121 Id := Defining_Entity (Context);
15122 end if;
15123 end if;
15125 if No (Id) then
15126 Error_Pragma
15127 ("pragma % must apply to an object, package, subprogram or "
15128 & "type");
15129 return;
15130 end if;
15132 -- Handle completions of types and constants that are subject to
15133 -- pragma Ghost.
15135 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15136 Prev_Id := Incomplete_Or_Partial_View (Id);
15138 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15139 Error_Msg_Name_1 := Pname;
15141 -- The full declaration of a deferred constant cannot be
15142 -- subject to pragma Ghost unless the deferred declaration
15143 -- is also Ghost (SPARK RM 6.9(9)).
15145 if Ekind (Prev_Id) = E_Constant then
15146 Error_Msg_Name_1 := Pname;
15147 Error_Msg_NE (Fix_Error
15148 ("pragma % must apply to declaration of deferred "
15149 & "constant &"), N, Id);
15150 return;
15152 -- Pragma Ghost may appear on the full view of an incomplete
15153 -- type because the incomplete declaration lacks aspects and
15154 -- cannot be subject to pragma Ghost.
15156 elsif Ekind (Prev_Id) = E_Incomplete_Type then
15157 null;
15159 -- The full declaration of a type cannot be subject to
15160 -- pragma Ghost unless the partial view is also Ghost
15161 -- (SPARK RM 6.9(9)).
15163 else
15164 Error_Msg_NE (Fix_Error
15165 ("pragma % must apply to partial view of type &"),
15166 N, Id);
15167 return;
15168 end if;
15169 end if;
15171 -- A synchronized object cannot be subject to pragma Ghost
15172 -- (SPARK RM 6.9(19)).
15174 elsif Ekind (Id) = E_Variable then
15175 if Is_Protected_Type (Etype (Id)) then
15176 Error_Pragma ("pragma % cannot apply to a protected object");
15177 return;
15179 elsif Is_Task_Type (Etype (Id)) then
15180 Error_Pragma ("pragma % cannot apply to a task object");
15181 return;
15182 end if;
15183 end if;
15185 -- Analyze the Boolean expression (if any)
15187 if Present (Arg1) then
15188 Expr := Get_Pragma_Arg (Arg1);
15190 Analyze_And_Resolve (Expr, Standard_Boolean);
15192 if Is_OK_Static_Expression (Expr) then
15194 -- "Ghostness" cannot be turned off once enabled within a
15195 -- region (SPARK RM 6.9(6)).
15197 if Is_False (Expr_Value (Expr))
15198 and then Ghost_Mode > None
15199 then
15200 Error_Pragma
15201 ("pragma % with value False cannot appear in enabled "
15202 & "ghost region");
15203 return;
15204 end if;
15206 -- Otherwie the expression is not static
15208 else
15209 Error_Pragma_Arg
15210 ("expression of pragma % must be static", Expr);
15211 return;
15212 end if;
15213 end if;
15215 Set_Is_Ghost_Entity (Id);
15216 end Ghost;
15218 ------------
15219 -- Global --
15220 ------------
15222 -- pragma Global (GLOBAL_SPECIFICATION);
15224 -- GLOBAL_SPECIFICATION ::=
15225 -- null
15226 -- | (GLOBAL_LIST)
15227 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15229 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15231 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15232 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15233 -- GLOBAL_ITEM ::= NAME
15235 -- Characteristics:
15237 -- * Analysis - The annotation undergoes initial checks to verify
15238 -- the legal placement and context. Secondary checks fully analyze
15239 -- the dependency clauses in:
15241 -- Analyze_Global_In_Decl_Part
15243 -- * Expansion - None.
15245 -- * Template - The annotation utilizes the generic template of the
15246 -- related subprogram [body] when it is:
15248 -- aspect on subprogram declaration
15249 -- aspect on stand alone subprogram body
15250 -- pragma on stand alone subprogram body
15252 -- The annotation must prepare its own template when it is:
15254 -- pragma on subprogram declaration
15256 -- * Globals - Capture of global references must occur after full
15257 -- analysis.
15259 -- * Instance - The annotation is instantiated automatically when
15260 -- the related generic subprogram [body] is instantiated except for
15261 -- the "pragma on subprogram declaration" case. In that scenario
15262 -- the annotation must instantiate itself.
15264 when Pragma_Global => Global : declare
15265 Legal : Boolean;
15266 Spec_Id : Entity_Id;
15267 Subp_Decl : Node_Id;
15269 begin
15270 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15272 if Legal then
15274 -- Chain the pragma on the contract for further processing by
15275 -- Analyze_Global_In_Decl_Part.
15277 Add_Contract_Item (N, Spec_Id);
15279 -- Fully analyze the pragma when it appears inside an entry
15280 -- or subprogram body because it cannot benefit from forward
15281 -- references.
15283 if Nkind_In (Subp_Decl, N_Entry_Body,
15284 N_Subprogram_Body,
15285 N_Subprogram_Body_Stub)
15286 then
15287 -- The legality checks of pragmas Depends and Global are
15288 -- affected by the SPARK mode in effect and the volatility
15289 -- of the context. In addition these two pragmas are subject
15290 -- to an inherent order:
15292 -- 1) Global
15293 -- 2) Depends
15295 -- Analyze all these pragmas in the order outlined above
15297 Analyze_If_Present (Pragma_SPARK_Mode);
15298 Analyze_If_Present (Pragma_Volatile_Function);
15299 Analyze_Global_In_Decl_Part (N);
15300 Analyze_If_Present (Pragma_Depends);
15301 end if;
15302 end if;
15303 end Global;
15305 -----------
15306 -- Ident --
15307 -----------
15309 -- pragma Ident (static_string_EXPRESSION)
15311 -- Note: pragma Comment shares this processing. Pragma Ident is
15312 -- identical in effect to pragma Commment.
15314 when Pragma_Ident | Pragma_Comment => Ident : declare
15315 Str : Node_Id;
15317 begin
15318 GNAT_Pragma;
15319 Check_Arg_Count (1);
15320 Check_No_Identifiers;
15321 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15322 Store_Note (N);
15324 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15326 declare
15327 CS : Node_Id;
15328 GP : Node_Id;
15330 begin
15331 GP := Parent (Parent (N));
15333 if Nkind_In (GP, N_Package_Declaration,
15334 N_Generic_Package_Declaration)
15335 then
15336 GP := Parent (GP);
15337 end if;
15339 -- If we have a compilation unit, then record the ident value,
15340 -- checking for improper duplication.
15342 if Nkind (GP) = N_Compilation_Unit then
15343 CS := Ident_String (Current_Sem_Unit);
15345 if Present (CS) then
15347 -- If we have multiple instances, concatenate them, but
15348 -- not in ASIS, where we want the original tree.
15350 if not ASIS_Mode then
15351 Start_String (Strval (CS));
15352 Store_String_Char (' ');
15353 Store_String_Chars (Strval (Str));
15354 Set_Strval (CS, End_String);
15355 end if;
15357 else
15358 Set_Ident_String (Current_Sem_Unit, Str);
15359 end if;
15361 -- For subunits, we just ignore the Ident, since in GNAT these
15362 -- are not separate object files, and hence not separate units
15363 -- in the unit table.
15365 elsif Nkind (GP) = N_Subunit then
15366 null;
15367 end if;
15368 end;
15369 end Ident;
15371 -------------------
15372 -- Ignore_Pragma --
15373 -------------------
15375 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15377 -- Entirely handled in the parser, nothing to do here
15379 when Pragma_Ignore_Pragma =>
15380 null;
15382 ----------------------------
15383 -- Implementation_Defined --
15384 ----------------------------
15386 -- pragma Implementation_Defined (LOCAL_NAME);
15388 -- Marks previously declared entity as implementation defined. For
15389 -- an overloaded entity, applies to the most recent homonym.
15391 -- pragma Implementation_Defined;
15393 -- The form with no arguments appears anywhere within a scope, most
15394 -- typically a package spec, and indicates that all entities that are
15395 -- defined within the package spec are Implementation_Defined.
15397 when Pragma_Implementation_Defined => Implementation_Defined : declare
15398 Ent : Entity_Id;
15400 begin
15401 GNAT_Pragma;
15402 Check_No_Identifiers;
15404 -- Form with no arguments
15406 if Arg_Count = 0 then
15407 Set_Is_Implementation_Defined (Current_Scope);
15409 -- Form with one argument
15411 else
15412 Check_Arg_Count (1);
15413 Check_Arg_Is_Local_Name (Arg1);
15414 Ent := Entity (Get_Pragma_Arg (Arg1));
15415 Set_Is_Implementation_Defined (Ent);
15416 end if;
15417 end Implementation_Defined;
15419 -----------------
15420 -- Implemented --
15421 -----------------
15423 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15425 -- IMPLEMENTATION_KIND ::=
15426 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15428 -- "By_Any" and "Optional" are treated as synonyms in order to
15429 -- support Ada 2012 aspect Synchronization.
15431 when Pragma_Implemented => Implemented : declare
15432 Proc_Id : Entity_Id;
15433 Typ : Entity_Id;
15435 begin
15436 Ada_2012_Pragma;
15437 Check_Arg_Count (2);
15438 Check_No_Identifiers;
15439 Check_Arg_Is_Identifier (Arg1);
15440 Check_Arg_Is_Local_Name (Arg1);
15441 Check_Arg_Is_One_Of (Arg2,
15442 Name_By_Any,
15443 Name_By_Entry,
15444 Name_By_Protected_Procedure,
15445 Name_Optional);
15447 -- Extract the name of the local procedure
15449 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
15451 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15452 -- primitive procedure of a synchronized tagged type.
15454 if Ekind (Proc_Id) = E_Procedure
15455 and then Is_Primitive (Proc_Id)
15456 and then Present (First_Formal (Proc_Id))
15457 then
15458 Typ := Etype (First_Formal (Proc_Id));
15460 if Is_Tagged_Type (Typ)
15461 and then
15463 -- Check for a protected, a synchronized or a task interface
15465 ((Is_Interface (Typ)
15466 and then Is_Synchronized_Interface (Typ))
15468 -- Check for a protected type or a task type that implements
15469 -- an interface.
15471 or else
15472 (Is_Concurrent_Record_Type (Typ)
15473 and then Present (Interfaces (Typ)))
15475 -- In analysis-only mode, examine original protected type
15477 or else
15478 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
15479 and then Present (Interface_List (Parent (Typ))))
15481 -- Check for a private record extension with keyword
15482 -- "synchronized".
15484 or else
15485 (Ekind_In (Typ, E_Record_Type_With_Private,
15486 E_Record_Subtype_With_Private)
15487 and then Synchronized_Present (Parent (Typ))))
15488 then
15489 null;
15490 else
15491 Error_Pragma_Arg
15492 ("controlling formal must be of synchronized tagged type",
15493 Arg1);
15494 return;
15495 end if;
15497 -- Procedures declared inside a protected type must be accepted
15499 elsif Ekind (Proc_Id) = E_Procedure
15500 and then Is_Protected_Type (Scope (Proc_Id))
15501 then
15502 null;
15504 -- The first argument is not a primitive procedure
15506 else
15507 Error_Pragma_Arg
15508 ("pragma % must be applied to a primitive procedure", Arg1);
15509 return;
15510 end if;
15512 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15513 -- By_Protected_Procedure to the primitive procedure of a task
15514 -- interface.
15516 if Chars (Arg2) = Name_By_Protected_Procedure
15517 and then Is_Interface (Typ)
15518 and then Is_Task_Interface (Typ)
15519 then
15520 Error_Pragma_Arg
15521 ("implementation kind By_Protected_Procedure cannot be "
15522 & "applied to a task interface primitive", Arg2);
15523 return;
15524 end if;
15526 Record_Rep_Item (Proc_Id, N);
15527 end Implemented;
15529 ----------------------
15530 -- Implicit_Packing --
15531 ----------------------
15533 -- pragma Implicit_Packing;
15535 when Pragma_Implicit_Packing =>
15536 GNAT_Pragma;
15537 Check_Arg_Count (0);
15538 Implicit_Packing := True;
15540 ------------
15541 -- Import --
15542 ------------
15544 -- pragma Import (
15545 -- [Convention =>] convention_IDENTIFIER,
15546 -- [Entity =>] LOCAL_NAME
15547 -- [, [External_Name =>] static_string_EXPRESSION ]
15548 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15550 when Pragma_Import =>
15551 Check_Ada_83_Warning;
15552 Check_Arg_Order
15553 ((Name_Convention,
15554 Name_Entity,
15555 Name_External_Name,
15556 Name_Link_Name));
15558 Check_At_Least_N_Arguments (2);
15559 Check_At_Most_N_Arguments (4);
15560 Process_Import_Or_Interface;
15562 ---------------------
15563 -- Import_Function --
15564 ---------------------
15566 -- pragma Import_Function (
15567 -- [Internal =>] LOCAL_NAME,
15568 -- [, [External =>] EXTERNAL_SYMBOL]
15569 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15570 -- [, [Result_Type =>] SUBTYPE_MARK]
15571 -- [, [Mechanism =>] MECHANISM]
15572 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15574 -- EXTERNAL_SYMBOL ::=
15575 -- IDENTIFIER
15576 -- | static_string_EXPRESSION
15578 -- PARAMETER_TYPES ::=
15579 -- null
15580 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15582 -- TYPE_DESIGNATOR ::=
15583 -- subtype_NAME
15584 -- | subtype_Name ' Access
15586 -- MECHANISM ::=
15587 -- MECHANISM_NAME
15588 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15590 -- MECHANISM_ASSOCIATION ::=
15591 -- [formal_parameter_NAME =>] MECHANISM_NAME
15593 -- MECHANISM_NAME ::=
15594 -- Value
15595 -- | Reference
15597 when Pragma_Import_Function => Import_Function : declare
15598 Args : Args_List (1 .. 6);
15599 Names : constant Name_List (1 .. 6) := (
15600 Name_Internal,
15601 Name_External,
15602 Name_Parameter_Types,
15603 Name_Result_Type,
15604 Name_Mechanism,
15605 Name_Result_Mechanism);
15607 Internal : Node_Id renames Args (1);
15608 External : Node_Id renames Args (2);
15609 Parameter_Types : Node_Id renames Args (3);
15610 Result_Type : Node_Id renames Args (4);
15611 Mechanism : Node_Id renames Args (5);
15612 Result_Mechanism : Node_Id renames Args (6);
15614 begin
15615 GNAT_Pragma;
15616 Gather_Associations (Names, Args);
15617 Process_Extended_Import_Export_Subprogram_Pragma (
15618 Arg_Internal => Internal,
15619 Arg_External => External,
15620 Arg_Parameter_Types => Parameter_Types,
15621 Arg_Result_Type => Result_Type,
15622 Arg_Mechanism => Mechanism,
15623 Arg_Result_Mechanism => Result_Mechanism);
15624 end Import_Function;
15626 -------------------
15627 -- Import_Object --
15628 -------------------
15630 -- pragma Import_Object (
15631 -- [Internal =>] LOCAL_NAME
15632 -- [, [External =>] EXTERNAL_SYMBOL]
15633 -- [, [Size =>] EXTERNAL_SYMBOL]);
15635 -- EXTERNAL_SYMBOL ::=
15636 -- IDENTIFIER
15637 -- | static_string_EXPRESSION
15639 when Pragma_Import_Object => Import_Object : declare
15640 Args : Args_List (1 .. 3);
15641 Names : constant Name_List (1 .. 3) := (
15642 Name_Internal,
15643 Name_External,
15644 Name_Size);
15646 Internal : Node_Id renames Args (1);
15647 External : Node_Id renames Args (2);
15648 Size : Node_Id renames Args (3);
15650 begin
15651 GNAT_Pragma;
15652 Gather_Associations (Names, Args);
15653 Process_Extended_Import_Export_Object_Pragma (
15654 Arg_Internal => Internal,
15655 Arg_External => External,
15656 Arg_Size => Size);
15657 end Import_Object;
15659 ----------------------
15660 -- Import_Procedure --
15661 ----------------------
15663 -- pragma Import_Procedure (
15664 -- [Internal =>] LOCAL_NAME
15665 -- [, [External =>] EXTERNAL_SYMBOL]
15666 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15667 -- [, [Mechanism =>] MECHANISM]);
15669 -- EXTERNAL_SYMBOL ::=
15670 -- IDENTIFIER
15671 -- | static_string_EXPRESSION
15673 -- PARAMETER_TYPES ::=
15674 -- null
15675 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15677 -- TYPE_DESIGNATOR ::=
15678 -- subtype_NAME
15679 -- | subtype_Name ' Access
15681 -- MECHANISM ::=
15682 -- MECHANISM_NAME
15683 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15685 -- MECHANISM_ASSOCIATION ::=
15686 -- [formal_parameter_NAME =>] MECHANISM_NAME
15688 -- MECHANISM_NAME ::=
15689 -- Value
15690 -- | Reference
15692 when Pragma_Import_Procedure => Import_Procedure : declare
15693 Args : Args_List (1 .. 4);
15694 Names : constant Name_List (1 .. 4) := (
15695 Name_Internal,
15696 Name_External,
15697 Name_Parameter_Types,
15698 Name_Mechanism);
15700 Internal : Node_Id renames Args (1);
15701 External : Node_Id renames Args (2);
15702 Parameter_Types : Node_Id renames Args (3);
15703 Mechanism : Node_Id renames Args (4);
15705 begin
15706 GNAT_Pragma;
15707 Gather_Associations (Names, Args);
15708 Process_Extended_Import_Export_Subprogram_Pragma (
15709 Arg_Internal => Internal,
15710 Arg_External => External,
15711 Arg_Parameter_Types => Parameter_Types,
15712 Arg_Mechanism => Mechanism);
15713 end Import_Procedure;
15715 -----------------------------
15716 -- Import_Valued_Procedure --
15717 -----------------------------
15719 -- pragma Import_Valued_Procedure (
15720 -- [Internal =>] LOCAL_NAME
15721 -- [, [External =>] EXTERNAL_SYMBOL]
15722 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15723 -- [, [Mechanism =>] MECHANISM]);
15725 -- EXTERNAL_SYMBOL ::=
15726 -- IDENTIFIER
15727 -- | static_string_EXPRESSION
15729 -- PARAMETER_TYPES ::=
15730 -- null
15731 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15733 -- TYPE_DESIGNATOR ::=
15734 -- subtype_NAME
15735 -- | subtype_Name ' Access
15737 -- MECHANISM ::=
15738 -- MECHANISM_NAME
15739 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15741 -- MECHANISM_ASSOCIATION ::=
15742 -- [formal_parameter_NAME =>] MECHANISM_NAME
15744 -- MECHANISM_NAME ::=
15745 -- Value
15746 -- | Reference
15748 when Pragma_Import_Valued_Procedure =>
15749 Import_Valued_Procedure : declare
15750 Args : Args_List (1 .. 4);
15751 Names : constant Name_List (1 .. 4) := (
15752 Name_Internal,
15753 Name_External,
15754 Name_Parameter_Types,
15755 Name_Mechanism);
15757 Internal : Node_Id renames Args (1);
15758 External : Node_Id renames Args (2);
15759 Parameter_Types : Node_Id renames Args (3);
15760 Mechanism : Node_Id renames Args (4);
15762 begin
15763 GNAT_Pragma;
15764 Gather_Associations (Names, Args);
15765 Process_Extended_Import_Export_Subprogram_Pragma (
15766 Arg_Internal => Internal,
15767 Arg_External => External,
15768 Arg_Parameter_Types => Parameter_Types,
15769 Arg_Mechanism => Mechanism);
15770 end Import_Valued_Procedure;
15772 -----------------
15773 -- Independent --
15774 -----------------
15776 -- pragma Independent (LOCAL_NAME);
15778 when Pragma_Independent =>
15779 Process_Atomic_Independent_Shared_Volatile;
15781 ----------------------------
15782 -- Independent_Components --
15783 ----------------------------
15785 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
15787 when Pragma_Independent_Components => Independent_Components : declare
15788 C : Node_Id;
15789 D : Node_Id;
15790 E_Id : Node_Id;
15791 E : Entity_Id;
15792 K : Node_Kind;
15794 begin
15795 Check_Ada_83_Warning;
15796 Ada_2012_Pragma;
15797 Check_No_Identifiers;
15798 Check_Arg_Count (1);
15799 Check_Arg_Is_Local_Name (Arg1);
15800 E_Id := Get_Pragma_Arg (Arg1);
15802 if Etype (E_Id) = Any_Type then
15803 return;
15804 end if;
15806 E := Entity (E_Id);
15808 -- A pragma that applies to a Ghost entity becomes Ghost for the
15809 -- purposes of legality checks and removal of ignored Ghost code.
15811 Mark_Pragma_As_Ghost (N, E);
15813 -- Check duplicate before we chain ourselves
15815 Check_Duplicate_Pragma (E);
15817 -- Check appropriate entity
15819 if Rep_Item_Too_Early (E, N)
15820 or else
15821 Rep_Item_Too_Late (E, N)
15822 then
15823 return;
15824 end if;
15826 D := Declaration_Node (E);
15827 K := Nkind (D);
15829 -- The flag is set on the base type, or on the object
15831 if K = N_Full_Type_Declaration
15832 and then (Is_Array_Type (E) or else Is_Record_Type (E))
15833 then
15834 Set_Has_Independent_Components (Base_Type (E));
15835 Record_Independence_Check (N, Base_Type (E));
15837 -- For record type, set all components independent
15839 if Is_Record_Type (E) then
15840 C := First_Component (E);
15841 while Present (C) loop
15842 Set_Is_Independent (C);
15843 Next_Component (C);
15844 end loop;
15845 end if;
15847 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
15848 and then Nkind (D) = N_Object_Declaration
15849 and then Nkind (Object_Definition (D)) =
15850 N_Constrained_Array_Definition
15851 then
15852 Set_Has_Independent_Components (E);
15853 Record_Independence_Check (N, E);
15855 else
15856 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
15857 end if;
15858 end Independent_Components;
15860 -----------------------
15861 -- Initial_Condition --
15862 -----------------------
15864 -- pragma Initial_Condition (boolean_EXPRESSION);
15866 -- Characteristics:
15868 -- * Analysis - The annotation undergoes initial checks to verify
15869 -- the legal placement and context. Secondary checks preanalyze the
15870 -- expression in:
15872 -- Analyze_Initial_Condition_In_Decl_Part
15874 -- * Expansion - The annotation is expanded during the expansion of
15875 -- the package body whose declaration is subject to the annotation
15876 -- as done in:
15878 -- Expand_Pragma_Initial_Condition
15880 -- * Template - The annotation utilizes the generic template of the
15881 -- related package declaration.
15883 -- * Globals - Capture of global references must occur after full
15884 -- analysis.
15886 -- * Instance - The annotation is instantiated automatically when
15887 -- the related generic package is instantiated.
15889 when Pragma_Initial_Condition => Initial_Condition : declare
15890 Pack_Decl : Node_Id;
15891 Pack_Id : Entity_Id;
15893 begin
15894 GNAT_Pragma;
15895 Check_No_Identifiers;
15896 Check_Arg_Count (1);
15898 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
15900 -- Ensure the proper placement of the pragma. Initial_Condition
15901 -- must be associated with a package declaration.
15903 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
15904 N_Package_Declaration)
15905 then
15906 null;
15908 -- Otherwise the pragma is associated with an illegal context
15910 else
15911 Pragma_Misplaced;
15912 return;
15913 end if;
15915 Pack_Id := Defining_Entity (Pack_Decl);
15917 -- Chain the pragma on the contract for further processing by
15918 -- Analyze_Initial_Condition_In_Decl_Part.
15920 Add_Contract_Item (N, Pack_Id);
15922 -- The legality checks of pragmas Abstract_State, Initializes, and
15923 -- Initial_Condition are affected by the SPARK mode in effect. In
15924 -- addition, these three pragmas are subject to an inherent order:
15926 -- 1) Abstract_State
15927 -- 2) Initializes
15928 -- 3) Initial_Condition
15930 -- Analyze all these pragmas in the order outlined above
15932 Analyze_If_Present (Pragma_SPARK_Mode);
15933 Analyze_If_Present (Pragma_Abstract_State);
15934 Analyze_If_Present (Pragma_Initializes);
15936 -- A pragma that applies to a Ghost entity becomes Ghost for the
15937 -- purposes of legality checks and removal of ignored Ghost code.
15939 Mark_Pragma_As_Ghost (N, Pack_Id);
15940 end Initial_Condition;
15942 ------------------------
15943 -- Initialize_Scalars --
15944 ------------------------
15946 -- pragma Initialize_Scalars;
15948 when Pragma_Initialize_Scalars =>
15949 GNAT_Pragma;
15950 Check_Arg_Count (0);
15951 Check_Valid_Configuration_Pragma;
15952 Check_Restriction (No_Initialize_Scalars, N);
15954 -- Initialize_Scalars creates false positives in CodePeer, and
15955 -- incorrect negative results in GNATprove mode, so ignore this
15956 -- pragma in these modes.
15958 if not Restriction_Active (No_Initialize_Scalars)
15959 and then not (CodePeer_Mode or GNATprove_Mode)
15960 then
15961 Init_Or_Norm_Scalars := True;
15962 Initialize_Scalars := True;
15963 end if;
15965 -----------------
15966 -- Initializes --
15967 -----------------
15969 -- pragma Initializes (INITIALIZATION_LIST);
15971 -- INITIALIZATION_LIST ::=
15972 -- null
15973 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15975 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15977 -- INPUT_LIST ::=
15978 -- null
15979 -- | INPUT
15980 -- | (INPUT {, INPUT})
15982 -- INPUT ::= name
15984 -- Characteristics:
15986 -- * Analysis - The annotation undergoes initial checks to verify
15987 -- the legal placement and context. Secondary checks preanalyze the
15988 -- expression in:
15990 -- Analyze_Initializes_In_Decl_Part
15992 -- * Expansion - None.
15994 -- * Template - The annotation utilizes the generic template of the
15995 -- related package declaration.
15997 -- * Globals - Capture of global references must occur after full
15998 -- analysis.
16000 -- * Instance - The annotation is instantiated automatically when
16001 -- the related generic package is instantiated.
16003 when Pragma_Initializes => Initializes : declare
16004 Pack_Decl : Node_Id;
16005 Pack_Id : Entity_Id;
16007 begin
16008 GNAT_Pragma;
16009 Check_No_Identifiers;
16010 Check_Arg_Count (1);
16012 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16014 -- Ensure the proper placement of the pragma. Initializes must be
16015 -- associated with a package declaration.
16017 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16018 N_Package_Declaration)
16019 then
16020 null;
16022 -- Otherwise the pragma is associated with an illegal construc
16024 else
16025 Pragma_Misplaced;
16026 return;
16027 end if;
16029 Pack_Id := Defining_Entity (Pack_Decl);
16031 -- Chain the pragma on the contract for further processing by
16032 -- Analyze_Initializes_In_Decl_Part.
16034 Add_Contract_Item (N, Pack_Id);
16036 -- The legality checks of pragmas Abstract_State, Initializes, and
16037 -- Initial_Condition are affected by the SPARK mode in effect. In
16038 -- addition, these three pragmas are subject to an inherent order:
16040 -- 1) Abstract_State
16041 -- 2) Initializes
16042 -- 3) Initial_Condition
16044 -- Analyze all these pragmas in the order outlined above
16046 Analyze_If_Present (Pragma_SPARK_Mode);
16047 Analyze_If_Present (Pragma_Abstract_State);
16049 -- A pragma that applies to a Ghost entity becomes Ghost for the
16050 -- purposes of legality checks and removal of ignored Ghost code.
16052 Mark_Pragma_As_Ghost (N, Pack_Id);
16053 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16055 Analyze_If_Present (Pragma_Initial_Condition);
16056 end Initializes;
16058 ------------
16059 -- Inline --
16060 ------------
16062 -- pragma Inline ( NAME {, NAME} );
16064 when Pragma_Inline =>
16066 -- Pragma always active unless in GNATprove mode. It is disabled
16067 -- in GNATprove mode because frontend inlining is applied
16068 -- independently of pragmas Inline and Inline_Always for
16069 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16070 -- in inline.ads.
16072 if not GNATprove_Mode then
16074 -- Inline status is Enabled if inlining option is active
16076 if Inline_Active then
16077 Process_Inline (Enabled);
16078 else
16079 Process_Inline (Disabled);
16080 end if;
16081 end if;
16083 -------------------
16084 -- Inline_Always --
16085 -------------------
16087 -- pragma Inline_Always ( NAME {, NAME} );
16089 when Pragma_Inline_Always =>
16090 GNAT_Pragma;
16092 -- Pragma always active unless in CodePeer mode or GNATprove
16093 -- mode. It is disabled in CodePeer mode because inlining is
16094 -- not helpful, and enabling it caused walk order issues. It
16095 -- is disabled in GNATprove mode because frontend inlining is
16096 -- applied independently of pragmas Inline and Inline_Always for
16097 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16098 -- inline.ads.
16100 if not CodePeer_Mode and not GNATprove_Mode then
16101 Process_Inline (Enabled);
16102 end if;
16104 --------------------
16105 -- Inline_Generic --
16106 --------------------
16108 -- pragma Inline_Generic (NAME {, NAME});
16110 when Pragma_Inline_Generic =>
16111 GNAT_Pragma;
16112 Process_Generic_List;
16114 ----------------------
16115 -- Inspection_Point --
16116 ----------------------
16118 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16120 when Pragma_Inspection_Point => Inspection_Point : declare
16121 Arg : Node_Id;
16122 Exp : Node_Id;
16124 begin
16127 if Arg_Count > 0 then
16128 Arg := Arg1;
16129 loop
16130 Exp := Get_Pragma_Arg (Arg);
16131 Analyze (Exp);
16133 if not Is_Entity_Name (Exp)
16134 or else not Is_Object (Entity (Exp))
16135 then
16136 Error_Pragma_Arg ("object name required", Arg);
16137 end if;
16139 Next (Arg);
16140 exit when No (Arg);
16141 end loop;
16142 end if;
16143 end Inspection_Point;
16145 ---------------
16146 -- Interface --
16147 ---------------
16149 -- pragma Interface (
16150 -- [ Convention =>] convention_IDENTIFIER,
16151 -- [ Entity =>] LOCAL_NAME
16152 -- [, [External_Name =>] static_string_EXPRESSION ]
16153 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16155 when Pragma_Interface =>
16156 GNAT_Pragma;
16157 Check_Arg_Order
16158 ((Name_Convention,
16159 Name_Entity,
16160 Name_External_Name,
16161 Name_Link_Name));
16162 Check_At_Least_N_Arguments (2);
16163 Check_At_Most_N_Arguments (4);
16164 Process_Import_Or_Interface;
16166 -- In Ada 2005, the permission to use Interface (a reserved word)
16167 -- as a pragma name is considered an obsolescent feature, and this
16168 -- pragma was already obsolescent in Ada 95.
16170 if Ada_Version >= Ada_95 then
16171 Check_Restriction
16172 (No_Obsolescent_Features, Pragma_Identifier (N));
16174 if Warn_On_Obsolescent_Feature then
16175 Error_Msg_N
16176 ("pragma Interface is an obsolescent feature?j?", N);
16177 Error_Msg_N
16178 ("|use pragma Import instead?j?", N);
16179 end if;
16180 end if;
16182 --------------------
16183 -- Interface_Name --
16184 --------------------
16186 -- pragma Interface_Name (
16187 -- [ Entity =>] LOCAL_NAME
16188 -- [,[External_Name =>] static_string_EXPRESSION ]
16189 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16191 when Pragma_Interface_Name => Interface_Name : declare
16192 Id : Node_Id;
16193 Def_Id : Entity_Id;
16194 Hom_Id : Entity_Id;
16195 Found : Boolean;
16197 begin
16198 GNAT_Pragma;
16199 Check_Arg_Order
16200 ((Name_Entity, Name_External_Name, Name_Link_Name));
16201 Check_At_Least_N_Arguments (2);
16202 Check_At_Most_N_Arguments (3);
16203 Id := Get_Pragma_Arg (Arg1);
16204 Analyze (Id);
16206 -- This is obsolete from Ada 95 on, but it is an implementation
16207 -- defined pragma, so we do not consider that it violates the
16208 -- restriction (No_Obsolescent_Features).
16210 if Ada_Version >= Ada_95 then
16211 if Warn_On_Obsolescent_Feature then
16212 Error_Msg_N
16213 ("pragma Interface_Name is an obsolescent feature?j?", N);
16214 Error_Msg_N
16215 ("|use pragma Import instead?j?", N);
16216 end if;
16217 end if;
16219 if not Is_Entity_Name (Id) then
16220 Error_Pragma_Arg
16221 ("first argument for pragma% must be entity name", Arg1);
16222 elsif Etype (Id) = Any_Type then
16223 return;
16224 else
16225 Def_Id := Entity (Id);
16226 end if;
16228 -- Special DEC-compatible processing for the object case, forces
16229 -- object to be imported.
16231 if Ekind (Def_Id) = E_Variable then
16232 Kill_Size_Check_Code (Def_Id);
16233 Note_Possible_Modification (Id, Sure => False);
16235 -- Initialization is not allowed for imported variable
16237 if Present (Expression (Parent (Def_Id)))
16238 and then Comes_From_Source (Expression (Parent (Def_Id)))
16239 then
16240 Error_Msg_Sloc := Sloc (Def_Id);
16241 Error_Pragma_Arg
16242 ("no initialization allowed for declaration of& #",
16243 Arg2);
16245 else
16246 -- For compatibility, support VADS usage of providing both
16247 -- pragmas Interface and Interface_Name to obtain the effect
16248 -- of a single Import pragma.
16250 if Is_Imported (Def_Id)
16251 and then Present (First_Rep_Item (Def_Id))
16252 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16253 and then
16254 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
16255 then
16256 null;
16257 else
16258 Set_Imported (Def_Id);
16259 end if;
16261 Set_Is_Public (Def_Id);
16262 Process_Interface_Name (Def_Id, Arg2, Arg3);
16263 end if;
16265 -- Otherwise must be subprogram
16267 elsif not Is_Subprogram (Def_Id) then
16268 Error_Pragma_Arg
16269 ("argument of pragma% is not subprogram", Arg1);
16271 else
16272 Check_At_Most_N_Arguments (3);
16273 Hom_Id := Def_Id;
16274 Found := False;
16276 -- Loop through homonyms
16278 loop
16279 Def_Id := Get_Base_Subprogram (Hom_Id);
16281 if Is_Imported (Def_Id) then
16282 Process_Interface_Name (Def_Id, Arg2, Arg3);
16283 Found := True;
16284 end if;
16286 exit when From_Aspect_Specification (N);
16287 Hom_Id := Homonym (Hom_Id);
16289 exit when No (Hom_Id)
16290 or else Scope (Hom_Id) /= Current_Scope;
16291 end loop;
16293 if not Found then
16294 Error_Pragma_Arg
16295 ("argument of pragma% is not imported subprogram",
16296 Arg1);
16297 end if;
16298 end if;
16299 end Interface_Name;
16301 -----------------------
16302 -- Interrupt_Handler --
16303 -----------------------
16305 -- pragma Interrupt_Handler (handler_NAME);
16307 when Pragma_Interrupt_Handler =>
16308 Check_Ada_83_Warning;
16309 Check_Arg_Count (1);
16310 Check_No_Identifiers;
16312 if No_Run_Time_Mode then
16313 Error_Msg_CRT ("Interrupt_Handler pragma", N);
16314 else
16315 Check_Interrupt_Or_Attach_Handler;
16316 Process_Interrupt_Or_Attach_Handler;
16317 end if;
16319 ------------------------
16320 -- Interrupt_Priority --
16321 ------------------------
16323 -- pragma Interrupt_Priority [(EXPRESSION)];
16325 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16326 P : constant Node_Id := Parent (N);
16327 Arg : Node_Id;
16328 Ent : Entity_Id;
16330 begin
16331 Check_Ada_83_Warning;
16333 if Arg_Count /= 0 then
16334 Arg := Get_Pragma_Arg (Arg1);
16335 Check_Arg_Count (1);
16336 Check_No_Identifiers;
16338 -- The expression must be analyzed in the special manner
16339 -- described in "Handling of Default and Per-Object
16340 -- Expressions" in sem.ads.
16342 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16343 end if;
16345 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16346 Pragma_Misplaced;
16347 return;
16349 else
16350 Ent := Defining_Identifier (Parent (P));
16352 -- Check duplicate pragma before we chain the pragma in the Rep
16353 -- Item chain of Ent.
16355 Check_Duplicate_Pragma (Ent);
16356 Record_Rep_Item (Ent, N);
16358 -- Check the No_Task_At_Interrupt_Priority restriction
16360 if Nkind (P) = N_Task_Definition then
16361 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16362 end if;
16363 end if;
16364 end Interrupt_Priority;
16366 ---------------------
16367 -- Interrupt_State --
16368 ---------------------
16370 -- pragma Interrupt_State (
16371 -- [Name =>] INTERRUPT_ID,
16372 -- [State =>] INTERRUPT_STATE);
16374 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16375 -- INTERRUPT_STATE => System | Runtime | User
16377 -- Note: if the interrupt id is given as an identifier, then it must
16378 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16379 -- given as a static integer expression which must be in the range of
16380 -- Ada.Interrupts.Interrupt_ID.
16382 when Pragma_Interrupt_State => Interrupt_State : declare
16383 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16384 -- This is the entity Ada.Interrupts.Interrupt_ID;
16386 State_Type : Character;
16387 -- Set to 's'/'r'/'u' for System/Runtime/User
16389 IST_Num : Pos;
16390 -- Index to entry in Interrupt_States table
16392 Int_Val : Uint;
16393 -- Value of interrupt
16395 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16396 -- The first argument to the pragma
16398 Int_Ent : Entity_Id;
16399 -- Interrupt entity in Ada.Interrupts.Names
16401 begin
16402 GNAT_Pragma;
16403 Check_Arg_Order ((Name_Name, Name_State));
16404 Check_Arg_Count (2);
16406 Check_Optional_Identifier (Arg1, Name_Name);
16407 Check_Optional_Identifier (Arg2, Name_State);
16408 Check_Arg_Is_Identifier (Arg2);
16410 -- First argument is identifier
16412 if Nkind (Arg1X) = N_Identifier then
16414 -- Search list of names in Ada.Interrupts.Names
16416 Int_Ent := First_Entity (RTE (RE_Names));
16417 loop
16418 if No (Int_Ent) then
16419 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16421 elsif Chars (Int_Ent) = Chars (Arg1X) then
16422 Int_Val := Expr_Value (Constant_Value (Int_Ent));
16423 exit;
16424 end if;
16426 Next_Entity (Int_Ent);
16427 end loop;
16429 -- First argument is not an identifier, so it must be a static
16430 -- expression of type Ada.Interrupts.Interrupt_ID.
16432 else
16433 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16434 Int_Val := Expr_Value (Arg1X);
16436 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
16437 or else
16438 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
16439 then
16440 Error_Pragma_Arg
16441 ("value not in range of type "
16442 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
16443 end if;
16444 end if;
16446 -- Check OK state
16448 case Chars (Get_Pragma_Arg (Arg2)) is
16449 when Name_Runtime => State_Type := 'r';
16450 when Name_System => State_Type := 's';
16451 when Name_User => State_Type := 'u';
16453 when others =>
16454 Error_Pragma_Arg ("invalid interrupt state", Arg2);
16455 end case;
16457 -- Check if entry is already stored
16459 IST_Num := Interrupt_States.First;
16460 loop
16461 -- If entry not found, add it
16463 if IST_Num > Interrupt_States.Last then
16464 Interrupt_States.Append
16465 ((Interrupt_Number => UI_To_Int (Int_Val),
16466 Interrupt_State => State_Type,
16467 Pragma_Loc => Loc));
16468 exit;
16470 -- Case of entry for the same entry
16472 elsif Int_Val = Interrupt_States.Table (IST_Num).
16473 Interrupt_Number
16474 then
16475 -- If state matches, done, no need to make redundant entry
16477 exit when
16478 State_Type = Interrupt_States.Table (IST_Num).
16479 Interrupt_State;
16481 -- Otherwise if state does not match, error
16483 Error_Msg_Sloc :=
16484 Interrupt_States.Table (IST_Num).Pragma_Loc;
16485 Error_Pragma_Arg
16486 ("state conflicts with that given #", Arg2);
16487 exit;
16488 end if;
16490 IST_Num := IST_Num + 1;
16491 end loop;
16492 end Interrupt_State;
16494 ---------------
16495 -- Invariant --
16496 ---------------
16498 -- pragma Invariant
16499 -- ([Entity =>] type_LOCAL_NAME,
16500 -- [Check =>] EXPRESSION
16501 -- [,[Message =>] String_Expression]);
16503 when Pragma_Invariant => Invariant : declare
16504 Discard : Boolean;
16505 Typ : Entity_Id;
16506 Type_Id : Node_Id;
16508 begin
16509 GNAT_Pragma;
16510 Check_At_Least_N_Arguments (2);
16511 Check_At_Most_N_Arguments (3);
16512 Check_Optional_Identifier (Arg1, Name_Entity);
16513 Check_Optional_Identifier (Arg2, Name_Check);
16515 if Arg_Count = 3 then
16516 Check_Optional_Identifier (Arg3, Name_Message);
16517 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
16518 end if;
16520 Check_Arg_Is_Local_Name (Arg1);
16522 Type_Id := Get_Pragma_Arg (Arg1);
16523 Find_Type (Type_Id);
16524 Typ := Entity (Type_Id);
16526 if Typ = Any_Type then
16527 return;
16529 -- Invariants allowed in interface types (RM 7.3.2(3/3))
16531 elsif Is_Interface (Typ) then
16532 null;
16534 -- An invariant must apply to a private type, or appear in the
16535 -- private part of a package spec and apply to a completion.
16536 -- a class-wide invariant can only appear on a private declaration
16537 -- or private extension, not a completion.
16539 elsif Ekind_In (Typ, E_Private_Type,
16540 E_Record_Type_With_Private,
16541 E_Limited_Private_Type)
16542 then
16543 null;
16545 elsif In_Private_Part (Current_Scope)
16546 and then Has_Private_Declaration (Typ)
16547 and then not Class_Present (N)
16548 then
16549 null;
16551 elsif In_Private_Part (Current_Scope) then
16552 Error_Pragma_Arg
16553 ("pragma% only allowed for private type declared in "
16554 & "visible part", Arg1);
16556 else
16557 Error_Pragma_Arg
16558 ("pragma% only allowed for private type", Arg1);
16559 end if;
16561 -- A pragma that applies to a Ghost entity becomes Ghost for the
16562 -- purposes of legality checks and removal of ignored Ghost code.
16564 Mark_Pragma_As_Ghost (N, Typ);
16566 -- Not allowed for abstract type in the non-class case (it is
16567 -- allowed to use Invariant'Class for abstract types).
16569 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
16570 Error_Pragma_Arg
16571 ("pragma% not allowed for abstract type", Arg1);
16572 end if;
16574 -- Link the pragma on to the rep item chain, for processing when
16575 -- the type is frozen.
16577 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16579 -- Note that the type has at least one invariant, and also that
16580 -- it has inheritable invariants if we have Invariant'Class
16581 -- or Type_Invariant'Class. Build the corresponding invariant
16582 -- procedure declaration, so that calls to it can be generated
16583 -- before the body is built (e.g. within an expression function).
16585 -- Interface types have no invariant procedure; their invariants
16586 -- are propagated to the build invariant procedure of all the
16587 -- types covering the interface type.
16589 if not Is_Interface (Typ) then
16590 Insert_After_And_Analyze
16591 (N, Build_Invariant_Procedure_Declaration (Typ));
16592 end if;
16594 if Class_Present (N) then
16595 Set_Has_Inheritable_Invariants (Typ);
16596 end if;
16597 end Invariant;
16599 ----------------
16600 -- Keep_Names --
16601 ----------------
16603 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16605 when Pragma_Keep_Names => Keep_Names : declare
16606 Arg : Node_Id;
16608 begin
16609 GNAT_Pragma;
16610 Check_Arg_Count (1);
16611 Check_Optional_Identifier (Arg1, Name_On);
16612 Check_Arg_Is_Local_Name (Arg1);
16614 Arg := Get_Pragma_Arg (Arg1);
16615 Analyze (Arg);
16617 if Etype (Arg) = Any_Type then
16618 return;
16619 end if;
16621 if not Is_Entity_Name (Arg)
16622 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16623 then
16624 Error_Pragma_Arg
16625 ("pragma% requires a local enumeration type", Arg1);
16626 end if;
16628 Set_Discard_Names (Entity (Arg), False);
16629 end Keep_Names;
16631 -------------
16632 -- License --
16633 -------------
16635 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16637 when Pragma_License =>
16638 GNAT_Pragma;
16640 -- Do not analyze pragma any further in CodePeer mode, to avoid
16641 -- extraneous errors in this implementation-dependent pragma,
16642 -- which has a different profile on other compilers.
16644 if CodePeer_Mode then
16645 return;
16646 end if;
16648 Check_Arg_Count (1);
16649 Check_No_Identifiers;
16650 Check_Valid_Configuration_Pragma;
16651 Check_Arg_Is_Identifier (Arg1);
16653 declare
16654 Sind : constant Source_File_Index :=
16655 Source_Index (Current_Sem_Unit);
16657 begin
16658 case Chars (Get_Pragma_Arg (Arg1)) is
16659 when Name_GPL =>
16660 Set_License (Sind, GPL);
16662 when Name_Modified_GPL =>
16663 Set_License (Sind, Modified_GPL);
16665 when Name_Restricted =>
16666 Set_License (Sind, Restricted);
16668 when Name_Unrestricted =>
16669 Set_License (Sind, Unrestricted);
16671 when others =>
16672 Error_Pragma_Arg ("invalid license name", Arg1);
16673 end case;
16674 end;
16676 ---------------
16677 -- Link_With --
16678 ---------------
16680 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16682 when Pragma_Link_With => Link_With : declare
16683 Arg : Node_Id;
16685 begin
16686 GNAT_Pragma;
16688 if Operating_Mode = Generate_Code
16689 and then In_Extended_Main_Source_Unit (N)
16690 then
16691 Check_At_Least_N_Arguments (1);
16692 Check_No_Identifiers;
16693 Check_Is_In_Decl_Part_Or_Package_Spec;
16694 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16695 Start_String;
16697 Arg := Arg1;
16698 while Present (Arg) loop
16699 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16701 -- Store argument, converting sequences of spaces to a
16702 -- single null character (this is one of the differences
16703 -- in processing between Link_With and Linker_Options).
16705 Arg_Store : declare
16706 C : constant Char_Code := Get_Char_Code (' ');
16707 S : constant String_Id :=
16708 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
16709 L : constant Nat := String_Length (S);
16710 F : Nat := 1;
16712 procedure Skip_Spaces;
16713 -- Advance F past any spaces
16715 -----------------
16716 -- Skip_Spaces --
16717 -----------------
16719 procedure Skip_Spaces is
16720 begin
16721 while F <= L and then Get_String_Char (S, F) = C loop
16722 F := F + 1;
16723 end loop;
16724 end Skip_Spaces;
16726 -- Start of processing for Arg_Store
16728 begin
16729 Skip_Spaces; -- skip leading spaces
16731 -- Loop through characters, changing any embedded
16732 -- sequence of spaces to a single null character (this
16733 -- is how Link_With/Linker_Options differ)
16735 while F <= L loop
16736 if Get_String_Char (S, F) = C then
16737 Skip_Spaces;
16738 exit when F > L;
16739 Store_String_Char (ASCII.NUL);
16741 else
16742 Store_String_Char (Get_String_Char (S, F));
16743 F := F + 1;
16744 end if;
16745 end loop;
16746 end Arg_Store;
16748 Arg := Next (Arg);
16750 if Present (Arg) then
16751 Store_String_Char (ASCII.NUL);
16752 end if;
16753 end loop;
16755 Store_Linker_Option_String (End_String);
16756 end if;
16757 end Link_With;
16759 ------------------
16760 -- Linker_Alias --
16761 ------------------
16763 -- pragma Linker_Alias (
16764 -- [Entity =>] LOCAL_NAME
16765 -- [Target =>] static_string_EXPRESSION);
16767 when Pragma_Linker_Alias =>
16768 GNAT_Pragma;
16769 Check_Arg_Order ((Name_Entity, Name_Target));
16770 Check_Arg_Count (2);
16771 Check_Optional_Identifier (Arg1, Name_Entity);
16772 Check_Optional_Identifier (Arg2, Name_Target);
16773 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16774 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16776 -- The only processing required is to link this item on to the
16777 -- list of rep items for the given entity. This is accomplished
16778 -- by the call to Rep_Item_Too_Late (when no error is detected
16779 -- and False is returned).
16781 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
16782 return;
16783 else
16784 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16785 end if;
16787 ------------------------
16788 -- Linker_Constructor --
16789 ------------------------
16791 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16793 -- Code is shared with Linker_Destructor
16795 -----------------------
16796 -- Linker_Destructor --
16797 -----------------------
16799 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16801 when Pragma_Linker_Constructor |
16802 Pragma_Linker_Destructor =>
16803 Linker_Constructor : declare
16804 Arg1_X : Node_Id;
16805 Proc : Entity_Id;
16807 begin
16808 GNAT_Pragma;
16809 Check_Arg_Count (1);
16810 Check_No_Identifiers;
16811 Check_Arg_Is_Local_Name (Arg1);
16812 Arg1_X := Get_Pragma_Arg (Arg1);
16813 Analyze (Arg1_X);
16814 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
16816 if not Is_Library_Level_Entity (Proc) then
16817 Error_Pragma_Arg
16818 ("argument for pragma% must be library level entity", Arg1);
16819 end if;
16821 -- The only processing required is to link this item on to the
16822 -- list of rep items for the given entity. This is accomplished
16823 -- by the call to Rep_Item_Too_Late (when no error is detected
16824 -- and False is returned).
16826 if Rep_Item_Too_Late (Proc, N) then
16827 return;
16828 else
16829 Set_Has_Gigi_Rep_Item (Proc);
16830 end if;
16831 end Linker_Constructor;
16833 --------------------
16834 -- Linker_Options --
16835 --------------------
16837 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16839 when Pragma_Linker_Options => Linker_Options : declare
16840 Arg : Node_Id;
16842 begin
16843 Check_Ada_83_Warning;
16844 Check_No_Identifiers;
16845 Check_Arg_Count (1);
16846 Check_Is_In_Decl_Part_Or_Package_Spec;
16847 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16848 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
16850 Arg := Arg2;
16851 while Present (Arg) loop
16852 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16853 Store_String_Char (ASCII.NUL);
16854 Store_String_Chars
16855 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
16856 Arg := Next (Arg);
16857 end loop;
16859 if Operating_Mode = Generate_Code
16860 and then In_Extended_Main_Source_Unit (N)
16861 then
16862 Store_Linker_Option_String (End_String);
16863 end if;
16864 end Linker_Options;
16866 --------------------
16867 -- Linker_Section --
16868 --------------------
16870 -- pragma Linker_Section (
16871 -- [Entity =>] LOCAL_NAME
16872 -- [Section =>] static_string_EXPRESSION);
16874 when Pragma_Linker_Section => Linker_Section : declare
16875 Arg : Node_Id;
16876 Ent : Entity_Id;
16877 LPE : Node_Id;
16879 Ghost_Error_Posted : Boolean := False;
16880 -- Flag set when an error concerning the illegal mix of Ghost and
16881 -- non-Ghost subprograms is emitted.
16883 Ghost_Id : Entity_Id := Empty;
16884 -- The entity of the first Ghost subprogram encountered while
16885 -- processing the arguments of the pragma.
16887 begin
16888 GNAT_Pragma;
16889 Check_Arg_Order ((Name_Entity, Name_Section));
16890 Check_Arg_Count (2);
16891 Check_Optional_Identifier (Arg1, Name_Entity);
16892 Check_Optional_Identifier (Arg2, Name_Section);
16893 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16894 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16896 -- Check kind of entity
16898 Arg := Get_Pragma_Arg (Arg1);
16899 Ent := Entity (Arg);
16901 case Ekind (Ent) is
16903 -- Objects (constants and variables) and types. For these cases
16904 -- all we need to do is to set the Linker_Section_pragma field,
16905 -- checking that we do not have a duplicate.
16907 when E_Constant | E_Variable | Type_Kind =>
16908 LPE := Linker_Section_Pragma (Ent);
16910 if Present (LPE) then
16911 Error_Msg_Sloc := Sloc (LPE);
16912 Error_Msg_NE
16913 ("Linker_Section already specified for &#", Arg1, Ent);
16914 end if;
16916 Set_Linker_Section_Pragma (Ent, N);
16918 -- A pragma that applies to a Ghost entity becomes Ghost for
16919 -- the purposes of legality checks and removal of ignored
16920 -- Ghost code.
16922 Mark_Pragma_As_Ghost (N, Ent);
16924 -- Subprograms
16926 when Subprogram_Kind =>
16928 -- Aspect case, entity already set
16930 if From_Aspect_Specification (N) then
16931 Set_Linker_Section_Pragma
16932 (Entity (Corresponding_Aspect (N)), N);
16934 -- Pragma case, we must climb the homonym chain, but skip
16935 -- any for which the linker section is already set.
16937 else
16938 loop
16939 if No (Linker_Section_Pragma (Ent)) then
16940 Set_Linker_Section_Pragma (Ent, N);
16942 -- A pragma that applies to a Ghost entity becomes
16943 -- Ghost for the purposes of legality checks and
16944 -- removal of ignored Ghost code.
16946 Mark_Pragma_As_Ghost (N, Ent);
16948 -- Capture the entity of the first Ghost subprogram
16949 -- being processed for error detection purposes.
16951 if Is_Ghost_Entity (Ent) then
16952 if No (Ghost_Id) then
16953 Ghost_Id := Ent;
16954 end if;
16956 -- Otherwise the subprogram is non-Ghost. It is
16957 -- illegal to mix references to Ghost and non-Ghost
16958 -- entities (SPARK RM 6.9).
16960 elsif Present (Ghost_Id)
16961 and then not Ghost_Error_Posted
16962 then
16963 Ghost_Error_Posted := True;
16965 Error_Msg_Name_1 := Pname;
16966 Error_Msg_N
16967 ("pragma % cannot mention ghost and "
16968 & "non-ghost subprograms", N);
16970 Error_Msg_Sloc := Sloc (Ghost_Id);
16971 Error_Msg_NE
16972 ("\& # declared as ghost", N, Ghost_Id);
16974 Error_Msg_Sloc := Sloc (Ent);
16975 Error_Msg_NE
16976 ("\& # declared as non-ghost", N, Ent);
16977 end if;
16978 end if;
16980 Ent := Homonym (Ent);
16981 exit when No (Ent)
16982 or else Scope (Ent) /= Current_Scope;
16983 end loop;
16984 end if;
16986 -- All other cases are illegal
16988 when others =>
16989 Error_Pragma_Arg
16990 ("pragma% applies only to objects, subprograms, and types",
16991 Arg1);
16992 end case;
16993 end Linker_Section;
16995 ----------
16996 -- List --
16997 ----------
16999 -- pragma List (On | Off)
17001 -- There is nothing to do here, since we did all the processing for
17002 -- this pragma in Par.Prag (so that it works properly even in syntax
17003 -- only mode).
17005 when Pragma_List =>
17006 null;
17008 ---------------
17009 -- Lock_Free --
17010 ---------------
17012 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17014 when Pragma_Lock_Free => Lock_Free : declare
17015 P : constant Node_Id := Parent (N);
17016 Arg : Node_Id;
17017 Ent : Entity_Id;
17018 Val : Boolean;
17020 begin
17021 Check_No_Identifiers;
17022 Check_At_Most_N_Arguments (1);
17024 -- Protected definition case
17026 if Nkind (P) = N_Protected_Definition then
17027 Ent := Defining_Identifier (Parent (P));
17029 -- One argument
17031 if Arg_Count = 1 then
17032 Arg := Get_Pragma_Arg (Arg1);
17033 Val := Is_True (Static_Boolean (Arg));
17035 -- No arguments (expression is considered to be True)
17037 else
17038 Val := True;
17039 end if;
17041 -- Check duplicate pragma before we chain the pragma in the Rep
17042 -- Item chain of Ent.
17044 Check_Duplicate_Pragma (Ent);
17045 Record_Rep_Item (Ent, N);
17046 Set_Uses_Lock_Free (Ent, Val);
17048 -- Anything else is incorrect placement
17050 else
17051 Pragma_Misplaced;
17052 end if;
17053 end Lock_Free;
17055 --------------------
17056 -- Locking_Policy --
17057 --------------------
17059 -- pragma Locking_Policy (policy_IDENTIFIER);
17061 when Pragma_Locking_Policy => declare
17062 subtype LP_Range is Name_Id
17063 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17064 LP_Val : LP_Range;
17065 LP : Character;
17067 begin
17068 Check_Ada_83_Warning;
17069 Check_Arg_Count (1);
17070 Check_No_Identifiers;
17071 Check_Arg_Is_Locking_Policy (Arg1);
17072 Check_Valid_Configuration_Pragma;
17073 LP_Val := Chars (Get_Pragma_Arg (Arg1));
17075 case LP_Val is
17076 when Name_Ceiling_Locking =>
17077 LP := 'C';
17078 when Name_Inheritance_Locking =>
17079 LP := 'I';
17080 when Name_Concurrent_Readers_Locking =>
17081 LP := 'R';
17082 end case;
17084 if Locking_Policy /= ' '
17085 and then Locking_Policy /= LP
17086 then
17087 Error_Msg_Sloc := Locking_Policy_Sloc;
17088 Error_Pragma ("locking policy incompatible with policy#");
17090 -- Set new policy, but always preserve System_Location since we
17091 -- like the error message with the run time name.
17093 else
17094 Locking_Policy := LP;
17096 if Locking_Policy_Sloc /= System_Location then
17097 Locking_Policy_Sloc := Loc;
17098 end if;
17099 end if;
17100 end;
17102 -------------------
17103 -- Loop_Optimize --
17104 -------------------
17106 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17108 -- OPTIMIZATION_HINT ::=
17109 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17111 when Pragma_Loop_Optimize => Loop_Optimize : declare
17112 Hint : Node_Id;
17114 begin
17115 GNAT_Pragma;
17116 Check_At_Least_N_Arguments (1);
17117 Check_No_Identifiers;
17119 Hint := First (Pragma_Argument_Associations (N));
17120 while Present (Hint) loop
17121 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17122 Name_No_Unroll,
17123 Name_Unroll,
17124 Name_No_Vector,
17125 Name_Vector);
17126 Next (Hint);
17127 end loop;
17129 Check_Loop_Pragma_Placement;
17130 end Loop_Optimize;
17132 ------------------
17133 -- Loop_Variant --
17134 ------------------
17136 -- pragma Loop_Variant
17137 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17139 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17141 -- CHANGE_DIRECTION ::= Increases | Decreases
17143 when Pragma_Loop_Variant => Loop_Variant : declare
17144 Variant : Node_Id;
17146 begin
17147 GNAT_Pragma;
17148 Check_At_Least_N_Arguments (1);
17149 Check_Loop_Pragma_Placement;
17151 -- Process all increasing / decreasing expressions
17153 Variant := First (Pragma_Argument_Associations (N));
17154 while Present (Variant) loop
17155 if not Nam_In (Chars (Variant), Name_Decreases,
17156 Name_Increases)
17157 then
17158 Error_Pragma_Arg ("wrong change modifier", Variant);
17159 end if;
17161 Preanalyze_Assert_Expression
17162 (Expression (Variant), Any_Discrete);
17164 Next (Variant);
17165 end loop;
17166 end Loop_Variant;
17168 -----------------------
17169 -- Machine_Attribute --
17170 -----------------------
17172 -- pragma Machine_Attribute (
17173 -- [Entity =>] LOCAL_NAME,
17174 -- [Attribute_Name =>] static_string_EXPRESSION
17175 -- [, [Info =>] static_EXPRESSION] );
17177 when Pragma_Machine_Attribute => Machine_Attribute : declare
17178 Def_Id : Entity_Id;
17180 begin
17181 GNAT_Pragma;
17182 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17184 if Arg_Count = 3 then
17185 Check_Optional_Identifier (Arg3, Name_Info);
17186 Check_Arg_Is_OK_Static_Expression (Arg3);
17187 else
17188 Check_Arg_Count (2);
17189 end if;
17191 Check_Optional_Identifier (Arg1, Name_Entity);
17192 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17193 Check_Arg_Is_Local_Name (Arg1);
17194 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17195 Def_Id := Entity (Get_Pragma_Arg (Arg1));
17197 if Is_Access_Type (Def_Id) then
17198 Def_Id := Designated_Type (Def_Id);
17199 end if;
17201 if Rep_Item_Too_Early (Def_Id, N) then
17202 return;
17203 end if;
17205 Def_Id := Underlying_Type (Def_Id);
17207 -- The only processing required is to link this item on to the
17208 -- list of rep items for the given entity. This is accomplished
17209 -- by the call to Rep_Item_Too_Late (when no error is detected
17210 -- and False is returned).
17212 if Rep_Item_Too_Late (Def_Id, N) then
17213 return;
17214 else
17215 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17216 end if;
17217 end Machine_Attribute;
17219 ----------
17220 -- Main --
17221 ----------
17223 -- pragma Main
17224 -- (MAIN_OPTION [, MAIN_OPTION]);
17226 -- MAIN_OPTION ::=
17227 -- [STACK_SIZE =>] static_integer_EXPRESSION
17228 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17229 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17231 when Pragma_Main => Main : declare
17232 Args : Args_List (1 .. 3);
17233 Names : constant Name_List (1 .. 3) := (
17234 Name_Stack_Size,
17235 Name_Task_Stack_Size_Default,
17236 Name_Time_Slicing_Enabled);
17238 Nod : Node_Id;
17240 begin
17241 GNAT_Pragma;
17242 Gather_Associations (Names, Args);
17244 for J in 1 .. 2 loop
17245 if Present (Args (J)) then
17246 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17247 end if;
17248 end loop;
17250 if Present (Args (3)) then
17251 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17252 end if;
17254 Nod := Next (N);
17255 while Present (Nod) loop
17256 if Nkind (Nod) = N_Pragma
17257 and then Pragma_Name (Nod) = Name_Main
17258 then
17259 Error_Msg_Name_1 := Pname;
17260 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17261 end if;
17263 Next (Nod);
17264 end loop;
17265 end Main;
17267 ------------------
17268 -- Main_Storage --
17269 ------------------
17271 -- pragma Main_Storage
17272 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17274 -- MAIN_STORAGE_OPTION ::=
17275 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17276 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17278 when Pragma_Main_Storage => Main_Storage : declare
17279 Args : Args_List (1 .. 2);
17280 Names : constant Name_List (1 .. 2) := (
17281 Name_Working_Storage,
17282 Name_Top_Guard);
17284 Nod : Node_Id;
17286 begin
17287 GNAT_Pragma;
17288 Gather_Associations (Names, Args);
17290 for J in 1 .. 2 loop
17291 if Present (Args (J)) then
17292 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17293 end if;
17294 end loop;
17296 Check_In_Main_Program;
17298 Nod := Next (N);
17299 while Present (Nod) loop
17300 if Nkind (Nod) = N_Pragma
17301 and then Pragma_Name (Nod) = Name_Main_Storage
17302 then
17303 Error_Msg_Name_1 := Pname;
17304 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17305 end if;
17307 Next (Nod);
17308 end loop;
17309 end Main_Storage;
17311 -----------------
17312 -- Memory_Size --
17313 -----------------
17315 -- pragma Memory_Size (NUMERIC_LITERAL)
17317 when Pragma_Memory_Size =>
17318 GNAT_Pragma;
17320 -- Memory size is simply ignored
17322 Check_No_Identifiers;
17323 Check_Arg_Count (1);
17324 Check_Arg_Is_Integer_Literal (Arg1);
17326 -------------
17327 -- No_Body --
17328 -------------
17330 -- pragma No_Body;
17332 -- The only correct use of this pragma is on its own in a file, in
17333 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17334 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17335 -- check for a file containing nothing but a No_Body pragma). If we
17336 -- attempt to process it during normal semantics processing, it means
17337 -- it was misplaced.
17339 when Pragma_No_Body =>
17340 GNAT_Pragma;
17341 Pragma_Misplaced;
17343 -----------------------------
17344 -- No_Elaboration_Code_All --
17345 -----------------------------
17347 -- pragma No_Elaboration_Code_All;
17349 when Pragma_No_Elaboration_Code_All =>
17350 GNAT_Pragma;
17351 Check_Valid_Library_Unit_Pragma;
17353 if Nkind (N) = N_Null_Statement then
17354 return;
17355 end if;
17357 -- Must appear for a spec or generic spec
17359 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
17360 N_Generic_Package_Declaration,
17361 N_Generic_Subprogram_Declaration,
17362 N_Package_Declaration,
17363 N_Subprogram_Declaration)
17364 then
17365 Error_Pragma
17366 (Fix_Error
17367 ("pragma% can only occur for package "
17368 & "or subprogram spec"));
17369 end if;
17371 -- Set flag in unit table
17373 Set_No_Elab_Code_All (Current_Sem_Unit);
17375 -- Set restriction No_Elaboration_Code if this is the main unit
17377 if Current_Sem_Unit = Main_Unit then
17378 Set_Restriction (No_Elaboration_Code, N);
17379 end if;
17381 -- If we are in the main unit or in an extended main source unit,
17382 -- then we also add it to the configuration restrictions so that
17383 -- it will apply to all units in the extended main source.
17385 if Current_Sem_Unit = Main_Unit
17386 or else In_Extended_Main_Source_Unit (N)
17387 then
17388 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
17389 end if;
17391 -- If in main extended unit, activate transitive with test
17393 if In_Extended_Main_Source_Unit (N) then
17394 Opt.No_Elab_Code_All_Pragma := N;
17395 end if;
17397 ---------------
17398 -- No_Inline --
17399 ---------------
17401 -- pragma No_Inline ( NAME {, NAME} );
17403 when Pragma_No_Inline =>
17404 GNAT_Pragma;
17405 Process_Inline (Suppressed);
17407 ---------------
17408 -- No_Return --
17409 ---------------
17411 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17413 when Pragma_No_Return => No_Return : declare
17414 Arg : Node_Id;
17415 E : Entity_Id;
17416 Found : Boolean;
17417 Id : Node_Id;
17419 Ghost_Error_Posted : Boolean := False;
17420 -- Flag set when an error concerning the illegal mix of Ghost and
17421 -- non-Ghost subprograms is emitted.
17423 Ghost_Id : Entity_Id := Empty;
17424 -- The entity of the first Ghost procedure encountered while
17425 -- processing the arguments of the pragma.
17427 begin
17428 Ada_2005_Pragma;
17429 Check_At_Least_N_Arguments (1);
17431 -- Loop through arguments of pragma
17433 Arg := Arg1;
17434 while Present (Arg) loop
17435 Check_Arg_Is_Local_Name (Arg);
17436 Id := Get_Pragma_Arg (Arg);
17437 Analyze (Id);
17439 if not Is_Entity_Name (Id) then
17440 Error_Pragma_Arg ("entity name required", Arg);
17441 end if;
17443 if Etype (Id) = Any_Type then
17444 raise Pragma_Exit;
17445 end if;
17447 -- Loop to find matching procedures
17449 E := Entity (Id);
17451 Found := False;
17452 while Present (E)
17453 and then Scope (E) = Current_Scope
17454 loop
17455 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
17456 Set_No_Return (E);
17458 -- A pragma that applies to a Ghost entity becomes Ghost
17459 -- for the purposes of legality checks and removal of
17460 -- ignored Ghost code.
17462 Mark_Pragma_As_Ghost (N, E);
17464 -- Capture the entity of the first Ghost procedure being
17465 -- processed for error detection purposes.
17467 if Is_Ghost_Entity (E) then
17468 if No (Ghost_Id) then
17469 Ghost_Id := E;
17470 end if;
17472 -- Otherwise the subprogram is non-Ghost. It is illegal
17473 -- to mix references to Ghost and non-Ghost entities
17474 -- (SPARK RM 6.9).
17476 elsif Present (Ghost_Id)
17477 and then not Ghost_Error_Posted
17478 then
17479 Ghost_Error_Posted := True;
17481 Error_Msg_Name_1 := Pname;
17482 Error_Msg_N
17483 ("pragma % cannot mention ghost and non-ghost "
17484 & "procedures", N);
17486 Error_Msg_Sloc := Sloc (Ghost_Id);
17487 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
17489 Error_Msg_Sloc := Sloc (E);
17490 Error_Msg_NE ("\& # declared as non-ghost", N, E);
17491 end if;
17493 -- Set flag on any alias as well
17495 if Is_Overloadable (E) and then Present (Alias (E)) then
17496 Set_No_Return (Alias (E));
17497 end if;
17499 Found := True;
17500 end if;
17502 exit when From_Aspect_Specification (N);
17503 E := Homonym (E);
17504 end loop;
17506 -- If entity in not in current scope it may be the enclosing
17507 -- suprogram body to which the aspect applies.
17509 if not Found then
17510 if Entity (Id) = Current_Scope
17511 and then From_Aspect_Specification (N)
17512 then
17513 Set_No_Return (Entity (Id));
17514 else
17515 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17516 end if;
17517 end if;
17519 Next (Arg);
17520 end loop;
17521 end No_Return;
17523 -----------------
17524 -- No_Run_Time --
17525 -----------------
17527 -- pragma No_Run_Time;
17529 -- Note: this pragma is retained for backwards compatibility. See
17530 -- body of Rtsfind for full details on its handling.
17532 when Pragma_No_Run_Time =>
17533 GNAT_Pragma;
17534 Check_Valid_Configuration_Pragma;
17535 Check_Arg_Count (0);
17537 No_Run_Time_Mode := True;
17538 Configurable_Run_Time_Mode := True;
17540 -- Set Duration to 32 bits if word size is 32
17542 if Ttypes.System_Word_Size = 32 then
17543 Duration_32_Bits_On_Target := True;
17544 end if;
17546 -- Set appropriate restrictions
17548 Set_Restriction (No_Finalization, N);
17549 Set_Restriction (No_Exception_Handlers, N);
17550 Set_Restriction (Max_Tasks, N, 0);
17551 Set_Restriction (No_Tasking, N);
17553 -----------------------
17554 -- No_Tagged_Streams --
17555 -----------------------
17557 -- pragma No_Tagged_Streams;
17558 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
17560 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
17561 E : Entity_Id;
17562 E_Id : Node_Id;
17564 begin
17565 GNAT_Pragma;
17566 Check_At_Most_N_Arguments (1);
17568 -- One argument case
17570 if Arg_Count = 1 then
17571 Check_Optional_Identifier (Arg1, Name_Entity);
17572 Check_Arg_Is_Local_Name (Arg1);
17573 E_Id := Get_Pragma_Arg (Arg1);
17575 if Etype (E_Id) = Any_Type then
17576 return;
17577 end if;
17579 E := Entity (E_Id);
17581 Check_Duplicate_Pragma (E);
17583 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
17584 Error_Pragma_Arg
17585 ("argument for pragma% must be root tagged type", Arg1);
17586 end if;
17588 if Rep_Item_Too_Early (E, N)
17589 or else
17590 Rep_Item_Too_Late (E, N)
17591 then
17592 return;
17593 else
17594 Set_No_Tagged_Streams_Pragma (E, N);
17595 end if;
17597 -- Zero argument case
17599 else
17600 Check_Is_In_Decl_Part_Or_Package_Spec;
17601 No_Tagged_Streams := N;
17602 end if;
17603 end No_Tagged_Strms;
17605 ------------------------
17606 -- No_Strict_Aliasing --
17607 ------------------------
17609 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17611 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
17612 E_Id : Entity_Id;
17614 begin
17615 GNAT_Pragma;
17616 Check_At_Most_N_Arguments (1);
17618 if Arg_Count = 0 then
17619 Check_Valid_Configuration_Pragma;
17620 Opt.No_Strict_Aliasing := True;
17622 else
17623 Check_Optional_Identifier (Arg2, Name_Entity);
17624 Check_Arg_Is_Local_Name (Arg1);
17625 E_Id := Entity (Get_Pragma_Arg (Arg1));
17627 if E_Id = Any_Type then
17628 return;
17629 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
17630 Error_Pragma_Arg ("pragma% requires access type", Arg1);
17631 end if;
17633 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
17634 end if;
17635 end No_Strict_Aliasing;
17637 -----------------------
17638 -- Normalize_Scalars --
17639 -----------------------
17641 -- pragma Normalize_Scalars;
17643 when Pragma_Normalize_Scalars =>
17644 Check_Ada_83_Warning;
17645 Check_Arg_Count (0);
17646 Check_Valid_Configuration_Pragma;
17648 -- Normalize_Scalars creates false positives in CodePeer, and
17649 -- incorrect negative results in GNATprove mode, so ignore this
17650 -- pragma in these modes.
17652 if not (CodePeer_Mode or GNATprove_Mode) then
17653 Normalize_Scalars := True;
17654 Init_Or_Norm_Scalars := True;
17655 end if;
17657 -----------------
17658 -- Obsolescent --
17659 -----------------
17661 -- pragma Obsolescent;
17663 -- pragma Obsolescent (
17664 -- [Message =>] static_string_EXPRESSION
17665 -- [,[Version =>] Ada_05]]);
17667 -- pragma Obsolescent (
17668 -- [Entity =>] NAME
17669 -- [,[Message =>] static_string_EXPRESSION
17670 -- [,[Version =>] Ada_05]] );
17672 when Pragma_Obsolescent => Obsolescent : declare
17673 Decl : Node_Id;
17674 Ename : Node_Id;
17676 procedure Set_Obsolescent (E : Entity_Id);
17677 -- Given an entity Ent, mark it as obsolescent if appropriate
17679 ---------------------
17680 -- Set_Obsolescent --
17681 ---------------------
17683 procedure Set_Obsolescent (E : Entity_Id) is
17684 Active : Boolean;
17685 Ent : Entity_Id;
17686 S : String_Id;
17688 begin
17689 Active := True;
17690 Ent := E;
17692 -- A pragma that applies to a Ghost entity becomes Ghost for
17693 -- the purposes of legality checks and removal of ignored Ghost
17694 -- code.
17696 Mark_Pragma_As_Ghost (N, E);
17698 -- Entity name was given
17700 if Present (Ename) then
17702 -- If entity name matches, we are fine. Save entity in
17703 -- pragma argument, for ASIS use.
17705 if Chars (Ename) = Chars (Ent) then
17706 Set_Entity (Ename, Ent);
17707 Generate_Reference (Ent, Ename);
17709 -- If entity name does not match, only possibility is an
17710 -- enumeration literal from an enumeration type declaration.
17712 elsif Ekind (Ent) /= E_Enumeration_Type then
17713 Error_Pragma
17714 ("pragma % entity name does not match declaration");
17716 else
17717 Ent := First_Literal (E);
17718 loop
17719 if No (Ent) then
17720 Error_Pragma
17721 ("pragma % entity name does not match any "
17722 & "enumeration literal");
17724 elsif Chars (Ent) = Chars (Ename) then
17725 Set_Entity (Ename, Ent);
17726 Generate_Reference (Ent, Ename);
17727 exit;
17729 else
17730 Ent := Next_Literal (Ent);
17731 end if;
17732 end loop;
17733 end if;
17734 end if;
17736 -- Ent points to entity to be marked
17738 if Arg_Count >= 1 then
17740 -- Deal with static string argument
17742 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17743 S := Strval (Get_Pragma_Arg (Arg1));
17745 for J in 1 .. String_Length (S) loop
17746 if not In_Character_Range (Get_String_Char (S, J)) then
17747 Error_Pragma_Arg
17748 ("pragma% argument does not allow wide characters",
17749 Arg1);
17750 end if;
17751 end loop;
17753 Obsolescent_Warnings.Append
17754 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
17756 -- Check for Ada_05 parameter
17758 if Arg_Count /= 1 then
17759 Check_Arg_Count (2);
17761 declare
17762 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
17764 begin
17765 Check_Arg_Is_Identifier (Argx);
17767 if Chars (Argx) /= Name_Ada_05 then
17768 Error_Msg_Name_2 := Name_Ada_05;
17769 Error_Pragma_Arg
17770 ("only allowed argument for pragma% is %", Argx);
17771 end if;
17773 if Ada_Version_Explicit < Ada_2005
17774 or else not Warn_On_Ada_2005_Compatibility
17775 then
17776 Active := False;
17777 end if;
17778 end;
17779 end if;
17780 end if;
17782 -- Set flag if pragma active
17784 if Active then
17785 Set_Is_Obsolescent (Ent);
17786 end if;
17788 return;
17789 end Set_Obsolescent;
17791 -- Start of processing for pragma Obsolescent
17793 begin
17794 GNAT_Pragma;
17796 Check_At_Most_N_Arguments (3);
17798 -- See if first argument specifies an entity name
17800 if Arg_Count >= 1
17801 and then
17802 (Chars (Arg1) = Name_Entity
17803 or else
17804 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
17805 N_Identifier,
17806 N_Operator_Symbol))
17807 then
17808 Ename := Get_Pragma_Arg (Arg1);
17810 -- Eliminate first argument, so we can share processing
17812 Arg1 := Arg2;
17813 Arg2 := Arg3;
17814 Arg_Count := Arg_Count - 1;
17816 -- No Entity name argument given
17818 else
17819 Ename := Empty;
17820 end if;
17822 if Arg_Count >= 1 then
17823 Check_Optional_Identifier (Arg1, Name_Message);
17825 if Arg_Count = 2 then
17826 Check_Optional_Identifier (Arg2, Name_Version);
17827 end if;
17828 end if;
17830 -- Get immediately preceding declaration
17832 Decl := Prev (N);
17833 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
17834 Prev (Decl);
17835 end loop;
17837 -- Cases where we do not follow anything other than another pragma
17839 if No (Decl) then
17841 -- First case: library level compilation unit declaration with
17842 -- the pragma immediately following the declaration.
17844 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
17845 Set_Obsolescent
17846 (Defining_Entity (Unit (Parent (Parent (N)))));
17847 return;
17849 -- Case 2: library unit placement for package
17851 else
17852 declare
17853 Ent : constant Entity_Id := Find_Lib_Unit_Name;
17854 begin
17855 if Is_Package_Or_Generic_Package (Ent) then
17856 Set_Obsolescent (Ent);
17857 return;
17858 end if;
17859 end;
17860 end if;
17862 -- Cases where we must follow a declaration, including an
17863 -- abstract subprogram declaration, which is not in the
17864 -- other node subtypes.
17866 else
17867 if Nkind (Decl) not in N_Declaration
17868 and then Nkind (Decl) not in N_Later_Decl_Item
17869 and then Nkind (Decl) not in N_Generic_Declaration
17870 and then Nkind (Decl) not in N_Renaming_Declaration
17871 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
17872 then
17873 Error_Pragma
17874 ("pragma% misplaced, "
17875 & "must immediately follow a declaration");
17877 else
17878 Set_Obsolescent (Defining_Entity (Decl));
17879 return;
17880 end if;
17881 end if;
17882 end Obsolescent;
17884 --------------
17885 -- Optimize --
17886 --------------
17888 -- pragma Optimize (Time | Space | Off);
17890 -- The actual check for optimize is done in Gigi. Note that this
17891 -- pragma does not actually change the optimization setting, it
17892 -- simply checks that it is consistent with the pragma.
17894 when Pragma_Optimize =>
17895 Check_No_Identifiers;
17896 Check_Arg_Count (1);
17897 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
17899 ------------------------
17900 -- Optimize_Alignment --
17901 ------------------------
17903 -- pragma Optimize_Alignment (Time | Space | Off);
17905 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
17906 GNAT_Pragma;
17907 Check_No_Identifiers;
17908 Check_Arg_Count (1);
17909 Check_Valid_Configuration_Pragma;
17911 declare
17912 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
17913 begin
17914 case Nam is
17915 when Name_Time =>
17916 Opt.Optimize_Alignment := 'T';
17917 when Name_Space =>
17918 Opt.Optimize_Alignment := 'S';
17919 when Name_Off =>
17920 Opt.Optimize_Alignment := 'O';
17921 when others =>
17922 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
17923 end case;
17924 end;
17926 -- Set indication that mode is set locally. If we are in fact in a
17927 -- configuration pragma file, this setting is harmless since the
17928 -- switch will get reset anyway at the start of each unit.
17930 Optimize_Alignment_Local := True;
17931 end Optimize_Alignment;
17933 -------------
17934 -- Ordered --
17935 -------------
17937 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17939 when Pragma_Ordered => Ordered : declare
17940 Assoc : constant Node_Id := Arg1;
17941 Type_Id : Node_Id;
17942 Typ : Entity_Id;
17944 begin
17945 GNAT_Pragma;
17946 Check_No_Identifiers;
17947 Check_Arg_Count (1);
17948 Check_Arg_Is_Local_Name (Arg1);
17950 Type_Id := Get_Pragma_Arg (Assoc);
17951 Find_Type (Type_Id);
17952 Typ := Entity (Type_Id);
17954 if Typ = Any_Type then
17955 return;
17956 else
17957 Typ := Underlying_Type (Typ);
17958 end if;
17960 if not Is_Enumeration_Type (Typ) then
17961 Error_Pragma ("pragma% must specify enumeration type");
17962 end if;
17964 Check_First_Subtype (Arg1);
17965 Set_Has_Pragma_Ordered (Base_Type (Typ));
17966 end Ordered;
17968 -------------------
17969 -- Overflow_Mode --
17970 -------------------
17972 -- pragma Overflow_Mode
17973 -- ([General => ] MODE [, [Assertions => ] MODE]);
17975 -- MODE := STRICT | MINIMIZED | ELIMINATED
17977 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17978 -- since System.Bignums makes this assumption. This is true of nearly
17979 -- all (all?) targets.
17981 when Pragma_Overflow_Mode => Overflow_Mode : declare
17982 function Get_Overflow_Mode
17983 (Name : Name_Id;
17984 Arg : Node_Id) return Overflow_Mode_Type;
17985 -- Function to process one pragma argument, Arg. If an identifier
17986 -- is present, it must be Name. Mode type is returned if a valid
17987 -- argument exists, otherwise an error is signalled.
17989 -----------------------
17990 -- Get_Overflow_Mode --
17991 -----------------------
17993 function Get_Overflow_Mode
17994 (Name : Name_Id;
17995 Arg : Node_Id) return Overflow_Mode_Type
17997 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
17999 begin
18000 Check_Optional_Identifier (Arg, Name);
18001 Check_Arg_Is_Identifier (Argx);
18003 if Chars (Argx) = Name_Strict then
18004 return Strict;
18006 elsif Chars (Argx) = Name_Minimized then
18007 return Minimized;
18009 elsif Chars (Argx) = Name_Eliminated then
18010 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18011 Error_Pragma_Arg
18012 ("Eliminated not implemented on this target", Argx);
18013 else
18014 return Eliminated;
18015 end if;
18017 else
18018 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18019 end if;
18020 end Get_Overflow_Mode;
18022 -- Start of processing for Overflow_Mode
18024 begin
18025 GNAT_Pragma;
18026 Check_At_Least_N_Arguments (1);
18027 Check_At_Most_N_Arguments (2);
18029 -- Process first argument
18031 Scope_Suppress.Overflow_Mode_General :=
18032 Get_Overflow_Mode (Name_General, Arg1);
18034 -- Case of only one argument
18036 if Arg_Count = 1 then
18037 Scope_Suppress.Overflow_Mode_Assertions :=
18038 Scope_Suppress.Overflow_Mode_General;
18040 -- Case of two arguments present
18042 else
18043 Scope_Suppress.Overflow_Mode_Assertions :=
18044 Get_Overflow_Mode (Name_Assertions, Arg2);
18045 end if;
18046 end Overflow_Mode;
18048 --------------------------
18049 -- Overriding Renamings --
18050 --------------------------
18052 -- pragma Overriding_Renamings;
18054 when Pragma_Overriding_Renamings =>
18055 GNAT_Pragma;
18056 Check_Arg_Count (0);
18057 Check_Valid_Configuration_Pragma;
18058 Overriding_Renamings := True;
18060 ----------
18061 -- Pack --
18062 ----------
18064 -- pragma Pack (first_subtype_LOCAL_NAME);
18066 when Pragma_Pack => Pack : declare
18067 Assoc : constant Node_Id := Arg1;
18068 Ctyp : Entity_Id;
18069 Ignore : Boolean := False;
18070 Typ : Entity_Id;
18071 Type_Id : Node_Id;
18073 begin
18074 Check_No_Identifiers;
18075 Check_Arg_Count (1);
18076 Check_Arg_Is_Local_Name (Arg1);
18077 Type_Id := Get_Pragma_Arg (Assoc);
18079 if not Is_Entity_Name (Type_Id)
18080 or else not Is_Type (Entity (Type_Id))
18081 then
18082 Error_Pragma_Arg
18083 ("argument for pragma% must be type or subtype", Arg1);
18084 end if;
18086 Find_Type (Type_Id);
18087 Typ := Entity (Type_Id);
18089 if Typ = Any_Type
18090 or else Rep_Item_Too_Early (Typ, N)
18091 then
18092 return;
18093 else
18094 Typ := Underlying_Type (Typ);
18095 end if;
18097 -- A pragma that applies to a Ghost entity becomes Ghost for the
18098 -- purposes of legality checks and removal of ignored Ghost code.
18100 Mark_Pragma_As_Ghost (N, Typ);
18102 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18103 Error_Pragma ("pragma% must specify array or record type");
18104 end if;
18106 Check_First_Subtype (Arg1);
18107 Check_Duplicate_Pragma (Typ);
18109 -- Array type
18111 if Is_Array_Type (Typ) then
18112 Ctyp := Component_Type (Typ);
18114 -- Ignore pack that does nothing
18116 if Known_Static_Esize (Ctyp)
18117 and then Known_Static_RM_Size (Ctyp)
18118 and then Esize (Ctyp) = RM_Size (Ctyp)
18119 and then Addressable (Esize (Ctyp))
18120 then
18121 Ignore := True;
18122 end if;
18124 -- Process OK pragma Pack. Note that if there is a separate
18125 -- component clause present, the Pack will be cancelled. This
18126 -- processing is in Freeze.
18128 if not Rep_Item_Too_Late (Typ, N) then
18130 -- In CodePeer mode, we do not need complex front-end
18131 -- expansions related to pragma Pack, so disable handling
18132 -- of pragma Pack.
18134 if CodePeer_Mode then
18135 null;
18137 -- Normal case where we do the pack action
18139 else
18140 if not Ignore then
18141 Set_Is_Packed (Base_Type (Typ));
18142 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18143 end if;
18145 Set_Has_Pragma_Pack (Base_Type (Typ));
18146 end if;
18147 end if;
18149 -- For record types, the pack is always effective
18151 else pragma Assert (Is_Record_Type (Typ));
18152 if not Rep_Item_Too_Late (Typ, N) then
18153 Set_Is_Packed (Base_Type (Typ));
18154 Set_Has_Pragma_Pack (Base_Type (Typ));
18155 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18156 end if;
18157 end if;
18158 end Pack;
18160 ----------
18161 -- Page --
18162 ----------
18164 -- pragma Page;
18166 -- There is nothing to do here, since we did all the processing for
18167 -- this pragma in Par.Prag (so that it works properly even in syntax
18168 -- only mode).
18170 when Pragma_Page =>
18171 null;
18173 -------------
18174 -- Part_Of --
18175 -------------
18177 -- pragma Part_Of (ABSTRACT_STATE);
18179 -- ABSTRACT_STATE ::= NAME
18181 when Pragma_Part_Of => Part_Of : declare
18182 procedure Propagate_Part_Of
18183 (Pack_Id : Entity_Id;
18184 State_Id : Entity_Id;
18185 Instance : Node_Id);
18186 -- Propagate the Part_Of indicator to all abstract states and
18187 -- objects declared in the visible state space of a package
18188 -- denoted by Pack_Id. State_Id is the encapsulating state.
18189 -- Instance is the package instantiation node.
18191 -----------------------
18192 -- Propagate_Part_Of --
18193 -----------------------
18195 procedure Propagate_Part_Of
18196 (Pack_Id : Entity_Id;
18197 State_Id : Entity_Id;
18198 Instance : Node_Id)
18200 Has_Item : Boolean := False;
18201 -- Flag set when the visible state space contains at least one
18202 -- abstract state or variable.
18204 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
18205 -- Propagate the Part_Of indicator to all abstract states and
18206 -- objects declared in the visible state space of a package
18207 -- denoted by Pack_Id.
18209 -----------------------
18210 -- Propagate_Part_Of --
18211 -----------------------
18213 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
18214 Constits : Elist_Id;
18215 Item_Id : Entity_Id;
18217 begin
18218 -- Traverse the entity chain of the package and set relevant
18219 -- attributes of abstract states and objects declared in the
18220 -- visible state space of the package.
18222 Item_Id := First_Entity (Pack_Id);
18223 while Present (Item_Id)
18224 and then not In_Private_Part (Item_Id)
18225 loop
18226 -- Do not consider internally generated items
18228 if not Comes_From_Source (Item_Id) then
18229 null;
18231 -- The Part_Of indicator turns an abstract state or an
18232 -- object into a constituent of the encapsulating state.
18234 elsif Ekind_In (Item_Id, E_Abstract_State,
18235 E_Constant,
18236 E_Variable)
18237 then
18238 Has_Item := True;
18239 Constits := Part_Of_Constituents (State_Id);
18241 if No (Constits) then
18242 Constits := New_Elmt_List;
18243 Set_Part_Of_Constituents (State_Id, Constits);
18244 end if;
18246 Append_Elmt (Item_Id, Constits);
18247 Set_Encapsulating_State (Item_Id, State_Id);
18249 -- Recursively handle nested packages and instantiations
18251 elsif Ekind (Item_Id) = E_Package then
18252 Propagate_Part_Of (Item_Id);
18253 end if;
18255 Next_Entity (Item_Id);
18256 end loop;
18257 end Propagate_Part_Of;
18259 -- Start of processing for Propagate_Part_Of
18261 begin
18262 Propagate_Part_Of (Pack_Id);
18264 -- Detect a package instantiation that is subject to a Part_Of
18265 -- indicator, but has no visible state.
18267 if not Has_Item then
18268 SPARK_Msg_NE
18269 ("package instantiation & has Part_Of indicator but "
18270 & "lacks visible state", Instance, Pack_Id);
18271 end if;
18272 end Propagate_Part_Of;
18274 -- Local variables
18276 Constits : Elist_Id;
18277 Encap : Node_Id;
18278 Encap_Id : Entity_Id;
18279 Item_Id : Entity_Id;
18280 Legal : Boolean;
18281 Stmt : Node_Id;
18283 -- Start of processing for Part_Of
18285 begin
18286 GNAT_Pragma;
18287 Check_No_Identifiers;
18288 Check_Arg_Count (1);
18290 Stmt := Find_Related_Context (N, Do_Checks => True);
18292 -- Object declaration
18294 if Nkind (Stmt) = N_Object_Declaration then
18295 null;
18297 -- Package instantiation
18299 elsif Nkind (Stmt) = N_Package_Instantiation then
18300 null;
18302 -- Single concurrent type declaration
18304 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
18305 null;
18307 -- Otherwise the pragma is associated with an illegal construct
18309 else
18310 Pragma_Misplaced;
18311 return;
18312 end if;
18314 -- Extract the entity of the related object declaration or package
18315 -- instantiation. In the case of the instantiation, use the entity
18316 -- of the instance spec.
18318 if Nkind (Stmt) = N_Package_Instantiation then
18319 Stmt := Instance_Spec (Stmt);
18320 end if;
18322 Item_Id := Defining_Entity (Stmt);
18323 Encap := Get_Pragma_Arg (Arg1);
18325 -- A pragma that applies to a Ghost entity becomes Ghost for the
18326 -- purposes of legality checks and removal of ignored Ghost code.
18328 Mark_Pragma_As_Ghost (N, Item_Id);
18330 -- Chain the pragma on the contract for further processing by
18331 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18333 Add_Contract_Item (N, Item_Id);
18335 -- A variable may act as consituent of a single concurrent type
18336 -- which in turn could be declared after the variable. Due to this
18337 -- discrepancy, the full analysis of indicator Part_Of is delayed
18338 -- until the end of the enclosing declarative region (see routine
18339 -- Analyze_Part_Of_In_Decl_Part).
18341 if Ekind (Item_Id) = E_Variable then
18342 null;
18344 -- Otherwise indicator Part_Of applies to a constant or a package
18345 -- instantiation.
18347 else
18348 -- Detect any discrepancies between the placement of the
18349 -- constant or package instantiation with respect to state
18350 -- space and the encapsulating state.
18352 Analyze_Part_Of
18353 (Indic => N,
18354 Item_Id => Item_Id,
18355 Encap => Encap,
18356 Encap_Id => Encap_Id,
18357 Legal => Legal);
18359 if Legal then
18360 pragma Assert (Present (Encap_Id));
18362 if Ekind (Item_Id) = E_Constant then
18363 Constits := Part_Of_Constituents (Encap_Id);
18365 if No (Constits) then
18366 Constits := New_Elmt_List;
18367 Set_Part_Of_Constituents (Encap_Id, Constits);
18368 end if;
18370 Append_Elmt (Item_Id, Constits);
18371 Set_Encapsulating_State (Item_Id, Encap_Id);
18373 -- Propagate the Part_Of indicator to the visible state
18374 -- space of the package instantiation.
18376 else
18377 Propagate_Part_Of
18378 (Pack_Id => Item_Id,
18379 State_Id => Encap_Id,
18380 Instance => Stmt);
18381 end if;
18382 end if;
18383 end if;
18384 end Part_Of;
18386 ----------------------------------
18387 -- Partition_Elaboration_Policy --
18388 ----------------------------------
18390 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18392 when Pragma_Partition_Elaboration_Policy => declare
18393 subtype PEP_Range is Name_Id
18394 range First_Partition_Elaboration_Policy_Name
18395 .. Last_Partition_Elaboration_Policy_Name;
18396 PEP_Val : PEP_Range;
18397 PEP : Character;
18399 begin
18400 Ada_2005_Pragma;
18401 Check_Arg_Count (1);
18402 Check_No_Identifiers;
18403 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
18404 Check_Valid_Configuration_Pragma;
18405 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
18407 case PEP_Val is
18408 when Name_Concurrent =>
18409 PEP := 'C';
18410 when Name_Sequential =>
18411 PEP := 'S';
18412 end case;
18414 if Partition_Elaboration_Policy /= ' '
18415 and then Partition_Elaboration_Policy /= PEP
18416 then
18417 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
18418 Error_Pragma
18419 ("partition elaboration policy incompatible with policy#");
18421 -- Set new policy, but always preserve System_Location since we
18422 -- like the error message with the run time name.
18424 else
18425 Partition_Elaboration_Policy := PEP;
18427 if Partition_Elaboration_Policy_Sloc /= System_Location then
18428 Partition_Elaboration_Policy_Sloc := Loc;
18429 end if;
18430 end if;
18431 end;
18433 -------------
18434 -- Passive --
18435 -------------
18437 -- pragma Passive [(PASSIVE_FORM)];
18439 -- PASSIVE_FORM ::= Semaphore | No
18441 when Pragma_Passive =>
18442 GNAT_Pragma;
18444 if Nkind (Parent (N)) /= N_Task_Definition then
18445 Error_Pragma ("pragma% must be within task definition");
18446 end if;
18448 if Arg_Count /= 0 then
18449 Check_Arg_Count (1);
18450 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
18451 end if;
18453 ----------------------------------
18454 -- Preelaborable_Initialization --
18455 ----------------------------------
18457 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18459 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
18460 Ent : Entity_Id;
18462 begin
18463 Ada_2005_Pragma;
18464 Check_Arg_Count (1);
18465 Check_No_Identifiers;
18466 Check_Arg_Is_Identifier (Arg1);
18467 Check_Arg_Is_Local_Name (Arg1);
18468 Check_First_Subtype (Arg1);
18469 Ent := Entity (Get_Pragma_Arg (Arg1));
18471 -- A pragma that applies to a Ghost entity becomes Ghost for the
18472 -- purposes of legality checks and removal of ignored Ghost code.
18474 Mark_Pragma_As_Ghost (N, Ent);
18476 -- The pragma may come from an aspect on a private declaration,
18477 -- even if the freeze point at which this is analyzed in the
18478 -- private part after the full view.
18480 if Has_Private_Declaration (Ent)
18481 and then From_Aspect_Specification (N)
18482 then
18483 null;
18485 -- Check appropriate type argument
18487 elsif Is_Private_Type (Ent)
18488 or else Is_Protected_Type (Ent)
18489 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
18491 -- AI05-0028: The pragma applies to all composite types. Note
18492 -- that we apply this binding interpretation to earlier versions
18493 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18494 -- choice since there are other compilers that do the same.
18496 or else Is_Composite_Type (Ent)
18497 then
18498 null;
18500 else
18501 Error_Pragma_Arg
18502 ("pragma % can only be applied to private, formal derived, "
18503 & "protected, or composite type", Arg1);
18504 end if;
18506 -- Give an error if the pragma is applied to a protected type that
18507 -- does not qualify (due to having entries, or due to components
18508 -- that do not qualify).
18510 if Is_Protected_Type (Ent)
18511 and then not Has_Preelaborable_Initialization (Ent)
18512 then
18513 Error_Msg_N
18514 ("protected type & does not have preelaborable "
18515 & "initialization", Ent);
18517 -- Otherwise mark the type as definitely having preelaborable
18518 -- initialization.
18520 else
18521 Set_Known_To_Have_Preelab_Init (Ent);
18522 end if;
18524 if Has_Pragma_Preelab_Init (Ent)
18525 and then Warn_On_Redundant_Constructs
18526 then
18527 Error_Pragma ("?r?duplicate pragma%!");
18528 else
18529 Set_Has_Pragma_Preelab_Init (Ent);
18530 end if;
18531 end Preelab_Init;
18533 --------------------
18534 -- Persistent_BSS --
18535 --------------------
18537 -- pragma Persistent_BSS [(object_NAME)];
18539 when Pragma_Persistent_BSS => Persistent_BSS : declare
18540 Decl : Node_Id;
18541 Ent : Entity_Id;
18542 Prag : Node_Id;
18544 begin
18545 GNAT_Pragma;
18546 Check_At_Most_N_Arguments (1);
18548 -- Case of application to specific object (one argument)
18550 if Arg_Count = 1 then
18551 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18553 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18554 or else not
18555 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18556 E_Constant)
18557 then
18558 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18559 end if;
18561 Ent := Entity (Get_Pragma_Arg (Arg1));
18562 Decl := Parent (Ent);
18564 -- A pragma that applies to a Ghost entity becomes Ghost for
18565 -- the purposes of legality checks and removal of ignored Ghost
18566 -- code.
18568 Mark_Pragma_As_Ghost (N, Ent);
18570 -- Check for duplication before inserting in list of
18571 -- representation items.
18573 Check_Duplicate_Pragma (Ent);
18575 if Rep_Item_Too_Late (Ent, N) then
18576 return;
18577 end if;
18579 if Present (Expression (Decl)) then
18580 Error_Pragma_Arg
18581 ("object for pragma% cannot have initialization", Arg1);
18582 end if;
18584 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18585 Error_Pragma_Arg
18586 ("object type for pragma% is not potentially persistent",
18587 Arg1);
18588 end if;
18590 Prag :=
18591 Make_Linker_Section_Pragma
18592 (Ent, Sloc (N), ".persistent.bss");
18593 Insert_After (N, Prag);
18594 Analyze (Prag);
18596 -- Case of use as configuration pragma with no arguments
18598 else
18599 Check_Valid_Configuration_Pragma;
18600 Persistent_BSS_Mode := True;
18601 end if;
18602 end Persistent_BSS;
18604 -------------
18605 -- Polling --
18606 -------------
18608 -- pragma Polling (ON | OFF);
18610 when Pragma_Polling =>
18611 GNAT_Pragma;
18612 Check_Arg_Count (1);
18613 Check_No_Identifiers;
18614 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18615 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
18617 -----------------------------------
18618 -- Post/Post_Class/Postcondition --
18619 -----------------------------------
18621 -- pragma Post (Boolean_EXPRESSION);
18622 -- pragma Post_Class (Boolean_EXPRESSION);
18623 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18624 -- [,[Message =>] String_EXPRESSION]);
18626 -- Characteristics:
18628 -- * Analysis - The annotation undergoes initial checks to verify
18629 -- the legal placement and context. Secondary checks preanalyze the
18630 -- expression in:
18632 -- Analyze_Pre_Post_Condition_In_Decl_Part
18634 -- * Expansion - The annotation is expanded during the expansion of
18635 -- the related subprogram [body] contract as performed in:
18637 -- Expand_Subprogram_Contract
18639 -- * Template - The annotation utilizes the generic template of the
18640 -- related subprogram [body] when it is:
18642 -- aspect on subprogram declaration
18643 -- aspect on stand alone subprogram body
18644 -- pragma on stand alone subprogram body
18646 -- The annotation must prepare its own template when it is:
18648 -- pragma on subprogram declaration
18650 -- * Globals - Capture of global references must occur after full
18651 -- analysis.
18653 -- * Instance - The annotation is instantiated automatically when
18654 -- the related generic subprogram [body] is instantiated except for
18655 -- the "pragma on subprogram declaration" case. In that scenario
18656 -- the annotation must instantiate itself.
18658 when Pragma_Post |
18659 Pragma_Post_Class |
18660 Pragma_Postcondition =>
18661 Analyze_Pre_Post_Condition;
18663 --------------------------------
18664 -- Pre/Pre_Class/Precondition --
18665 --------------------------------
18667 -- pragma Pre (Boolean_EXPRESSION);
18668 -- pragma Pre_Class (Boolean_EXPRESSION);
18669 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18670 -- [,[Message =>] String_EXPRESSION]);
18672 -- Characteristics:
18674 -- * Analysis - The annotation undergoes initial checks to verify
18675 -- the legal placement and context. Secondary checks preanalyze the
18676 -- expression in:
18678 -- Analyze_Pre_Post_Condition_In_Decl_Part
18680 -- * Expansion - The annotation is expanded during the expansion of
18681 -- the related subprogram [body] contract as performed in:
18683 -- Expand_Subprogram_Contract
18685 -- * Template - The annotation utilizes the generic template of the
18686 -- related subprogram [body] when it is:
18688 -- aspect on subprogram declaration
18689 -- aspect on stand alone subprogram body
18690 -- pragma on stand alone subprogram body
18692 -- The annotation must prepare its own template when it is:
18694 -- pragma on subprogram declaration
18696 -- * Globals - Capture of global references must occur after full
18697 -- analysis.
18699 -- * Instance - The annotation is instantiated automatically when
18700 -- the related generic subprogram [body] is instantiated except for
18701 -- the "pragma on subprogram declaration" case. In that scenario
18702 -- the annotation must instantiate itself.
18704 when Pragma_Pre |
18705 Pragma_Pre_Class |
18706 Pragma_Precondition =>
18707 Analyze_Pre_Post_Condition;
18709 ---------------
18710 -- Predicate --
18711 ---------------
18713 -- pragma Predicate
18714 -- ([Entity =>] type_LOCAL_NAME,
18715 -- [Check =>] boolean_EXPRESSION);
18717 when Pragma_Predicate => Predicate : declare
18718 Discard : Boolean;
18719 Typ : Entity_Id;
18720 Type_Id : Node_Id;
18722 begin
18723 GNAT_Pragma;
18724 Check_Arg_Count (2);
18725 Check_Optional_Identifier (Arg1, Name_Entity);
18726 Check_Optional_Identifier (Arg2, Name_Check);
18728 Check_Arg_Is_Local_Name (Arg1);
18730 Type_Id := Get_Pragma_Arg (Arg1);
18731 Find_Type (Type_Id);
18732 Typ := Entity (Type_Id);
18734 if Typ = Any_Type then
18735 return;
18736 end if;
18738 -- A pragma that applies to a Ghost entity becomes Ghost for the
18739 -- purposes of legality checks and removal of ignored Ghost code.
18741 Mark_Pragma_As_Ghost (N, Typ);
18743 -- The remaining processing is simply to link the pragma on to
18744 -- the rep item chain, for processing when the type is frozen.
18745 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18746 -- mark the type as having predicates.
18747 -- If the current policy is Ignore mark the subtype accordingly.
18748 -- In the case of predicates we consider them enabled unless an
18749 -- Ignore is specified, to preserve existing warnings.
18751 Set_Has_Predicates (Typ);
18752 Set_Predicates_Ignored (Typ,
18753 Present (Check_Policy_List)
18754 and then
18755 Policy_In_Effect (Name_Assertion_Policy) = Name_Ignore);
18756 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18757 end Predicate;
18759 -----------------------
18760 -- Predicate_Failure --
18761 -----------------------
18763 -- pragma Predicate_Failure
18764 -- ([Entity =>] type_LOCAL_NAME,
18765 -- [Message =>] string_EXPRESSION);
18767 when Pragma_Predicate_Failure => Predicate_Failure : declare
18768 Discard : Boolean;
18769 Typ : Entity_Id;
18770 Type_Id : Node_Id;
18772 begin
18773 GNAT_Pragma;
18774 Check_Arg_Count (2);
18775 Check_Optional_Identifier (Arg1, Name_Entity);
18776 Check_Optional_Identifier (Arg2, Name_Message);
18778 Check_Arg_Is_Local_Name (Arg1);
18780 Type_Id := Get_Pragma_Arg (Arg1);
18781 Find_Type (Type_Id);
18782 Typ := Entity (Type_Id);
18784 if Typ = Any_Type then
18785 return;
18786 end if;
18788 -- A pragma that applies to a Ghost entity becomes Ghost for the
18789 -- purposes of legality checks and removal of ignored Ghost code.
18791 Mark_Pragma_As_Ghost (N, Typ);
18793 -- The remaining processing is simply to link the pragma on to
18794 -- the rep item chain, for processing when the type is frozen.
18795 -- This is accomplished by a call to Rep_Item_Too_Late.
18797 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18798 end Predicate_Failure;
18800 ------------------
18801 -- Preelaborate --
18802 ------------------
18804 -- pragma Preelaborate [(library_unit_NAME)];
18806 -- Set the flag Is_Preelaborated of program unit name entity
18808 when Pragma_Preelaborate => Preelaborate : declare
18809 Pa : constant Node_Id := Parent (N);
18810 Pk : constant Node_Kind := Nkind (Pa);
18811 Ent : Entity_Id;
18813 begin
18814 Check_Ada_83_Warning;
18815 Check_Valid_Library_Unit_Pragma;
18817 if Nkind (N) = N_Null_Statement then
18818 return;
18819 end if;
18821 Ent := Find_Lib_Unit_Name;
18823 -- A pragma that applies to a Ghost entity becomes Ghost for the
18824 -- purposes of legality checks and removal of ignored Ghost code.
18826 Mark_Pragma_As_Ghost (N, Ent);
18827 Check_Duplicate_Pragma (Ent);
18829 -- This filters out pragmas inside generic parents that show up
18830 -- inside instantiations. Pragmas that come from aspects in the
18831 -- unit are not ignored.
18833 if Present (Ent) then
18834 if Pk = N_Package_Specification
18835 and then Present (Generic_Parent (Pa))
18836 and then not From_Aspect_Specification (N)
18837 then
18838 null;
18840 else
18841 if not Debug_Flag_U then
18842 Set_Is_Preelaborated (Ent);
18843 Set_Suppress_Elaboration_Warnings (Ent);
18844 end if;
18845 end if;
18846 end if;
18847 end Preelaborate;
18849 -------------------------------
18850 -- Prefix_Exception_Messages --
18851 -------------------------------
18853 -- pragma Prefix_Exception_Messages;
18855 when Pragma_Prefix_Exception_Messages =>
18856 GNAT_Pragma;
18857 Check_Valid_Configuration_Pragma;
18858 Check_Arg_Count (0);
18859 Prefix_Exception_Messages := True;
18861 --------------
18862 -- Priority --
18863 --------------
18865 -- pragma Priority (EXPRESSION);
18867 when Pragma_Priority => Priority : declare
18868 P : constant Node_Id := Parent (N);
18869 Arg : Node_Id;
18870 Ent : Entity_Id;
18872 begin
18873 Check_No_Identifiers;
18874 Check_Arg_Count (1);
18876 -- Subprogram case
18878 if Nkind (P) = N_Subprogram_Body then
18879 Check_In_Main_Program;
18881 Ent := Defining_Unit_Name (Specification (P));
18883 if Nkind (Ent) = N_Defining_Program_Unit_Name then
18884 Ent := Defining_Identifier (Ent);
18885 end if;
18887 Arg := Get_Pragma_Arg (Arg1);
18888 Analyze_And_Resolve (Arg, Standard_Integer);
18890 -- Must be static
18892 if not Is_OK_Static_Expression (Arg) then
18893 Flag_Non_Static_Expr
18894 ("main subprogram priority is not static!", Arg);
18895 raise Pragma_Exit;
18897 -- If constraint error, then we already signalled an error
18899 elsif Raises_Constraint_Error (Arg) then
18900 null;
18902 -- Otherwise check in range except if Relaxed_RM_Semantics
18903 -- where we ignore the value if out of range.
18905 else
18906 if not Relaxed_RM_Semantics
18907 and then not Is_In_Range (Arg, RTE (RE_Priority))
18908 then
18909 Error_Pragma_Arg
18910 ("main subprogram priority is out of range", Arg1);
18911 else
18912 Set_Main_Priority
18913 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
18914 end if;
18915 end if;
18917 -- Load an arbitrary entity from System.Tasking.Stages or
18918 -- System.Tasking.Restricted.Stages (depending on the
18919 -- supported profile) to make sure that one of these packages
18920 -- is implicitly with'ed, since we need to have the tasking
18921 -- run time active for the pragma Priority to have any effect.
18922 -- Previously we with'ed the package System.Tasking, but this
18923 -- package does not trigger the required initialization of the
18924 -- run-time library.
18926 declare
18927 Discard : Entity_Id;
18928 pragma Warnings (Off, Discard);
18929 begin
18930 if Restricted_Profile then
18931 Discard := RTE (RE_Activate_Restricted_Tasks);
18932 else
18933 Discard := RTE (RE_Activate_Tasks);
18934 end if;
18935 end;
18937 -- Task or Protected, must be of type Integer
18939 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
18940 Arg := Get_Pragma_Arg (Arg1);
18941 Ent := Defining_Identifier (Parent (P));
18943 -- The expression must be analyzed in the special manner
18944 -- described in "Handling of Default and Per-Object
18945 -- Expressions" in sem.ads.
18947 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
18949 if not Is_OK_Static_Expression (Arg) then
18950 Check_Restriction (Static_Priorities, Arg);
18951 end if;
18953 -- Anything else is incorrect
18955 else
18956 Pragma_Misplaced;
18957 end if;
18959 -- Check duplicate pragma before we chain the pragma in the Rep
18960 -- Item chain of Ent.
18962 Check_Duplicate_Pragma (Ent);
18963 Record_Rep_Item (Ent, N);
18964 end Priority;
18966 -----------------------------------
18967 -- Priority_Specific_Dispatching --
18968 -----------------------------------
18970 -- pragma Priority_Specific_Dispatching (
18971 -- policy_IDENTIFIER,
18972 -- first_priority_EXPRESSION,
18973 -- last_priority_EXPRESSION);
18975 when Pragma_Priority_Specific_Dispatching =>
18976 Priority_Specific_Dispatching : declare
18977 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
18978 -- This is the entity System.Any_Priority;
18980 DP : Character;
18981 Lower_Bound : Node_Id;
18982 Upper_Bound : Node_Id;
18983 Lower_Val : Uint;
18984 Upper_Val : Uint;
18986 begin
18987 Ada_2005_Pragma;
18988 Check_Arg_Count (3);
18989 Check_No_Identifiers;
18990 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18991 Check_Valid_Configuration_Pragma;
18992 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18993 DP := Fold_Upper (Name_Buffer (1));
18995 Lower_Bound := Get_Pragma_Arg (Arg2);
18996 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
18997 Lower_Val := Expr_Value (Lower_Bound);
18999 Upper_Bound := Get_Pragma_Arg (Arg3);
19000 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19001 Upper_Val := Expr_Value (Upper_Bound);
19003 -- It is not allowed to use Task_Dispatching_Policy and
19004 -- Priority_Specific_Dispatching in the same partition.
19006 if Task_Dispatching_Policy /= ' ' then
19007 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19008 Error_Pragma
19009 ("pragma% incompatible with Task_Dispatching_Policy#");
19011 -- Check lower bound in range
19013 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19014 or else
19015 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19016 then
19017 Error_Pragma_Arg
19018 ("first_priority is out of range", Arg2);
19020 -- Check upper bound in range
19022 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19023 or else
19024 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19025 then
19026 Error_Pragma_Arg
19027 ("last_priority is out of range", Arg3);
19029 -- Check that the priority range is valid
19031 elsif Lower_Val > Upper_Val then
19032 Error_Pragma
19033 ("last_priority_expression must be greater than or equal to "
19034 & "first_priority_expression");
19036 -- Store the new policy, but always preserve System_Location since
19037 -- we like the error message with the run-time name.
19039 else
19040 -- Check overlapping in the priority ranges specified in other
19041 -- Priority_Specific_Dispatching pragmas within the same
19042 -- partition. We can only check those we know about.
19044 for J in
19045 Specific_Dispatching.First .. Specific_Dispatching.Last
19046 loop
19047 if Specific_Dispatching.Table (J).First_Priority in
19048 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19049 or else Specific_Dispatching.Table (J).Last_Priority in
19050 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19051 then
19052 Error_Msg_Sloc :=
19053 Specific_Dispatching.Table (J).Pragma_Loc;
19054 Error_Pragma
19055 ("priority range overlaps with "
19056 & "Priority_Specific_Dispatching#");
19057 end if;
19058 end loop;
19060 -- The use of Priority_Specific_Dispatching is incompatible
19061 -- with Task_Dispatching_Policy.
19063 if Task_Dispatching_Policy /= ' ' then
19064 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19065 Error_Pragma
19066 ("Priority_Specific_Dispatching incompatible "
19067 & "with Task_Dispatching_Policy#");
19068 end if;
19070 -- The use of Priority_Specific_Dispatching forces ceiling
19071 -- locking policy.
19073 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19074 Error_Msg_Sloc := Locking_Policy_Sloc;
19075 Error_Pragma
19076 ("Priority_Specific_Dispatching incompatible "
19077 & "with Locking_Policy#");
19079 -- Set the Ceiling_Locking policy, but preserve System_Location
19080 -- since we like the error message with the run time name.
19082 else
19083 Locking_Policy := 'C';
19085 if Locking_Policy_Sloc /= System_Location then
19086 Locking_Policy_Sloc := Loc;
19087 end if;
19088 end if;
19090 -- Add entry in the table
19092 Specific_Dispatching.Append
19093 ((Dispatching_Policy => DP,
19094 First_Priority => UI_To_Int (Lower_Val),
19095 Last_Priority => UI_To_Int (Upper_Val),
19096 Pragma_Loc => Loc));
19097 end if;
19098 end Priority_Specific_Dispatching;
19100 -------------
19101 -- Profile --
19102 -------------
19104 -- pragma Profile (profile_IDENTIFIER);
19106 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19108 when Pragma_Profile =>
19109 Ada_2005_Pragma;
19110 Check_Arg_Count (1);
19111 Check_Valid_Configuration_Pragma;
19112 Check_No_Identifiers;
19114 declare
19115 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19117 begin
19118 if Chars (Argx) = Name_Ravenscar then
19119 Set_Ravenscar_Profile (Ravenscar, N);
19121 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
19122 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
19124 elsif Chars (Argx) = Name_Restricted then
19125 Set_Profile_Restrictions
19126 (Restricted,
19127 N, Warn => Treat_Restrictions_As_Warnings);
19129 elsif Chars (Argx) = Name_Rational then
19130 Set_Rational_Profile;
19132 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19133 Set_Profile_Restrictions
19134 (No_Implementation_Extensions,
19135 N, Warn => Treat_Restrictions_As_Warnings);
19137 else
19138 Error_Pragma_Arg ("& is not a valid profile", Argx);
19139 end if;
19140 end;
19142 ----------------------
19143 -- Profile_Warnings --
19144 ----------------------
19146 -- pragma Profile_Warnings (profile_IDENTIFIER);
19148 -- profile_IDENTIFIER => Restricted | Ravenscar
19150 when Pragma_Profile_Warnings =>
19151 GNAT_Pragma;
19152 Check_Arg_Count (1);
19153 Check_Valid_Configuration_Pragma;
19154 Check_No_Identifiers;
19156 declare
19157 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19159 begin
19160 if Chars (Argx) = Name_Ravenscar then
19161 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
19163 elsif Chars (Argx) = Name_Restricted then
19164 Set_Profile_Restrictions (Restricted, N, Warn => True);
19166 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19167 Set_Profile_Restrictions
19168 (No_Implementation_Extensions, N, Warn => True);
19170 else
19171 Error_Pragma_Arg ("& is not a valid profile", Argx);
19172 end if;
19173 end;
19175 --------------------------
19176 -- Propagate_Exceptions --
19177 --------------------------
19179 -- pragma Propagate_Exceptions;
19181 -- Note: this pragma is obsolete and has no effect
19183 when Pragma_Propagate_Exceptions =>
19184 GNAT_Pragma;
19185 Check_Arg_Count (0);
19187 if Warn_On_Obsolescent_Feature then
19188 Error_Msg_N
19189 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19190 "and has no effect?j?", N);
19191 end if;
19193 -----------------------------
19194 -- Provide_Shift_Operators --
19195 -----------------------------
19197 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19199 when Pragma_Provide_Shift_Operators =>
19200 Provide_Shift_Operators : declare
19201 Ent : Entity_Id;
19203 procedure Declare_Shift_Operator (Nam : Name_Id);
19204 -- Insert declaration and pragma Instrinsic for named shift op
19206 ----------------------------
19207 -- Declare_Shift_Operator --
19208 ----------------------------
19210 procedure Declare_Shift_Operator (Nam : Name_Id) is
19211 Func : Node_Id;
19212 Import : Node_Id;
19214 begin
19215 Func :=
19216 Make_Subprogram_Declaration (Loc,
19217 Make_Function_Specification (Loc,
19218 Defining_Unit_Name =>
19219 Make_Defining_Identifier (Loc, Chars => Nam),
19221 Result_Definition =>
19222 Make_Identifier (Loc, Chars => Chars (Ent)),
19224 Parameter_Specifications => New_List (
19225 Make_Parameter_Specification (Loc,
19226 Defining_Identifier =>
19227 Make_Defining_Identifier (Loc, Name_Value),
19228 Parameter_Type =>
19229 Make_Identifier (Loc, Chars => Chars (Ent))),
19231 Make_Parameter_Specification (Loc,
19232 Defining_Identifier =>
19233 Make_Defining_Identifier (Loc, Name_Amount),
19234 Parameter_Type =>
19235 New_Occurrence_Of (Standard_Natural, Loc)))));
19237 Import :=
19238 Make_Pragma (Loc,
19239 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
19240 Pragma_Argument_Associations => New_List (
19241 Make_Pragma_Argument_Association (Loc,
19242 Expression => Make_Identifier (Loc, Name_Intrinsic)),
19243 Make_Pragma_Argument_Association (Loc,
19244 Expression => Make_Identifier (Loc, Nam))));
19246 Insert_After (N, Import);
19247 Insert_After (N, Func);
19248 end Declare_Shift_Operator;
19250 -- Start of processing for Provide_Shift_Operators
19252 begin
19253 GNAT_Pragma;
19254 Check_Arg_Count (1);
19255 Check_Arg_Is_Local_Name (Arg1);
19257 Arg1 := Get_Pragma_Arg (Arg1);
19259 -- We must have an entity name
19261 if not Is_Entity_Name (Arg1) then
19262 Error_Pragma_Arg
19263 ("pragma % must apply to integer first subtype", Arg1);
19264 end if;
19266 -- If no Entity, means there was a prior error so ignore
19268 if Present (Entity (Arg1)) then
19269 Ent := Entity (Arg1);
19271 -- Apply error checks
19273 if not Is_First_Subtype (Ent) then
19274 Error_Pragma_Arg
19275 ("cannot apply pragma %",
19276 "\& is not a first subtype",
19277 Arg1);
19279 elsif not Is_Integer_Type (Ent) then
19280 Error_Pragma_Arg
19281 ("cannot apply pragma %",
19282 "\& is not an integer type",
19283 Arg1);
19285 elsif Has_Shift_Operator (Ent) then
19286 Error_Pragma_Arg
19287 ("cannot apply pragma %",
19288 "\& already has declared shift operators",
19289 Arg1);
19291 elsif Is_Frozen (Ent) then
19292 Error_Pragma_Arg
19293 ("pragma % appears too late",
19294 "\& is already frozen",
19295 Arg1);
19296 end if;
19298 -- Now declare the operators. We do this during analysis rather
19299 -- than expansion, since we want the operators available if we
19300 -- are operating in -gnatc or ASIS mode.
19302 Declare_Shift_Operator (Name_Rotate_Left);
19303 Declare_Shift_Operator (Name_Rotate_Right);
19304 Declare_Shift_Operator (Name_Shift_Left);
19305 Declare_Shift_Operator (Name_Shift_Right);
19306 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
19307 end if;
19308 end Provide_Shift_Operators;
19310 ------------------
19311 -- Psect_Object --
19312 ------------------
19314 -- pragma Psect_Object (
19315 -- [Internal =>] LOCAL_NAME,
19316 -- [, [External =>] EXTERNAL_SYMBOL]
19317 -- [, [Size =>] EXTERNAL_SYMBOL]);
19319 when Pragma_Psect_Object | Pragma_Common_Object =>
19320 Psect_Object : declare
19321 Args : Args_List (1 .. 3);
19322 Names : constant Name_List (1 .. 3) := (
19323 Name_Internal,
19324 Name_External,
19325 Name_Size);
19327 Internal : Node_Id renames Args (1);
19328 External : Node_Id renames Args (2);
19329 Size : Node_Id renames Args (3);
19331 Def_Id : Entity_Id;
19333 procedure Check_Arg (Arg : Node_Id);
19334 -- Checks that argument is either a string literal or an
19335 -- identifier, and posts error message if not.
19337 ---------------
19338 -- Check_Arg --
19339 ---------------
19341 procedure Check_Arg (Arg : Node_Id) is
19342 begin
19343 if not Nkind_In (Original_Node (Arg),
19344 N_String_Literal,
19345 N_Identifier)
19346 then
19347 Error_Pragma_Arg
19348 ("inappropriate argument for pragma %", Arg);
19349 end if;
19350 end Check_Arg;
19352 -- Start of processing for Common_Object/Psect_Object
19354 begin
19355 GNAT_Pragma;
19356 Gather_Associations (Names, Args);
19357 Process_Extended_Import_Export_Internal_Arg (Internal);
19359 Def_Id := Entity (Internal);
19361 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
19362 Error_Pragma_Arg
19363 ("pragma% must designate an object", Internal);
19364 end if;
19366 Check_Arg (Internal);
19368 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
19369 Error_Pragma_Arg
19370 ("cannot use pragma% for imported/exported object",
19371 Internal);
19372 end if;
19374 if Is_Concurrent_Type (Etype (Internal)) then
19375 Error_Pragma_Arg
19376 ("cannot specify pragma % for task/protected object",
19377 Internal);
19378 end if;
19380 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
19381 or else
19382 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
19383 then
19384 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
19385 end if;
19387 if Ekind (Def_Id) = E_Constant then
19388 Error_Pragma_Arg
19389 ("cannot specify pragma % for a constant", Internal);
19390 end if;
19392 if Is_Record_Type (Etype (Internal)) then
19393 declare
19394 Ent : Entity_Id;
19395 Decl : Entity_Id;
19397 begin
19398 Ent := First_Entity (Etype (Internal));
19399 while Present (Ent) loop
19400 Decl := Declaration_Node (Ent);
19402 if Ekind (Ent) = E_Component
19403 and then Nkind (Decl) = N_Component_Declaration
19404 and then Present (Expression (Decl))
19405 and then Warn_On_Export_Import
19406 then
19407 Error_Msg_N
19408 ("?x?object for pragma % has defaults", Internal);
19409 exit;
19411 else
19412 Next_Entity (Ent);
19413 end if;
19414 end loop;
19415 end;
19416 end if;
19418 if Present (Size) then
19419 Check_Arg (Size);
19420 end if;
19422 if Present (External) then
19423 Check_Arg_Is_External_Name (External);
19424 end if;
19426 -- If all error tests pass, link pragma on to the rep item chain
19428 Record_Rep_Item (Def_Id, N);
19429 end Psect_Object;
19431 ----------
19432 -- Pure --
19433 ----------
19435 -- pragma Pure [(library_unit_NAME)];
19437 when Pragma_Pure => Pure : declare
19438 Ent : Entity_Id;
19440 begin
19441 Check_Ada_83_Warning;
19443 -- If the pragma comes from a subprogram instantiation, nothing to
19444 -- check, this can happen at any level of nesting.
19446 if Is_Wrapper_Package (Current_Scope) then
19447 return;
19448 else
19449 Check_Valid_Library_Unit_Pragma;
19450 end if;
19452 if Nkind (N) = N_Null_Statement then
19453 return;
19454 end if;
19456 Ent := Find_Lib_Unit_Name;
19458 -- A pragma that applies to a Ghost entity becomes Ghost for the
19459 -- purposes of legality checks and removal of ignored Ghost code.
19461 Mark_Pragma_As_Ghost (N, Ent);
19463 if not Debug_Flag_U then
19464 Set_Is_Pure (Ent);
19465 Set_Has_Pragma_Pure (Ent);
19466 Set_Suppress_Elaboration_Warnings (Ent);
19467 end if;
19468 end Pure;
19470 -------------------
19471 -- Pure_Function --
19472 -------------------
19474 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19476 when Pragma_Pure_Function => Pure_Function : declare
19477 Def_Id : Entity_Id;
19478 E : Entity_Id;
19479 E_Id : Node_Id;
19480 Effective : Boolean := False;
19482 begin
19483 GNAT_Pragma;
19484 Check_Arg_Count (1);
19485 Check_Optional_Identifier (Arg1, Name_Entity);
19486 Check_Arg_Is_Local_Name (Arg1);
19487 E_Id := Get_Pragma_Arg (Arg1);
19489 if Error_Posted (E_Id) then
19490 return;
19491 end if;
19493 -- Loop through homonyms (overloadings) of referenced entity
19495 E := Entity (E_Id);
19497 -- A pragma that applies to a Ghost entity becomes Ghost for the
19498 -- purposes of legality checks and removal of ignored Ghost code.
19500 Mark_Pragma_As_Ghost (N, E);
19502 if Present (E) then
19503 loop
19504 Def_Id := Get_Base_Subprogram (E);
19506 if not Ekind_In (Def_Id, E_Function,
19507 E_Generic_Function,
19508 E_Operator)
19509 then
19510 Error_Pragma_Arg
19511 ("pragma% requires a function name", Arg1);
19512 end if;
19514 Set_Is_Pure (Def_Id);
19516 if not Has_Pragma_Pure_Function (Def_Id) then
19517 Set_Has_Pragma_Pure_Function (Def_Id);
19518 Effective := True;
19519 end if;
19521 exit when From_Aspect_Specification (N);
19522 E := Homonym (E);
19523 exit when No (E) or else Scope (E) /= Current_Scope;
19524 end loop;
19526 if not Effective
19527 and then Warn_On_Redundant_Constructs
19528 then
19529 Error_Msg_NE
19530 ("pragma Pure_Function on& is redundant?r?",
19531 N, Entity (E_Id));
19532 end if;
19533 end if;
19534 end Pure_Function;
19536 --------------------
19537 -- Queuing_Policy --
19538 --------------------
19540 -- pragma Queuing_Policy (policy_IDENTIFIER);
19542 when Pragma_Queuing_Policy => declare
19543 QP : Character;
19545 begin
19546 Check_Ada_83_Warning;
19547 Check_Arg_Count (1);
19548 Check_No_Identifiers;
19549 Check_Arg_Is_Queuing_Policy (Arg1);
19550 Check_Valid_Configuration_Pragma;
19551 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19552 QP := Fold_Upper (Name_Buffer (1));
19554 if Queuing_Policy /= ' '
19555 and then Queuing_Policy /= QP
19556 then
19557 Error_Msg_Sloc := Queuing_Policy_Sloc;
19558 Error_Pragma ("queuing policy incompatible with policy#");
19560 -- Set new policy, but always preserve System_Location since we
19561 -- like the error message with the run time name.
19563 else
19564 Queuing_Policy := QP;
19566 if Queuing_Policy_Sloc /= System_Location then
19567 Queuing_Policy_Sloc := Loc;
19568 end if;
19569 end if;
19570 end;
19572 --------------
19573 -- Rational --
19574 --------------
19576 -- pragma Rational, for compatibility with foreign compiler
19578 when Pragma_Rational =>
19579 Set_Rational_Profile;
19581 ---------------------
19582 -- Refined_Depends --
19583 ---------------------
19585 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19587 -- DEPENDENCY_RELATION ::=
19588 -- null
19589 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19591 -- DEPENDENCY_CLAUSE ::=
19592 -- OUTPUT_LIST =>[+] INPUT_LIST
19593 -- | NULL_DEPENDENCY_CLAUSE
19595 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19597 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19599 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19601 -- OUTPUT ::= NAME | FUNCTION_RESULT
19602 -- INPUT ::= NAME
19604 -- where FUNCTION_RESULT is a function Result attribute_reference
19606 -- Characteristics:
19608 -- * Analysis - The annotation undergoes initial checks to verify
19609 -- the legal placement and context. Secondary checks fully analyze
19610 -- the dependency clauses/global list in:
19612 -- Analyze_Refined_Depends_In_Decl_Part
19614 -- * Expansion - None.
19616 -- * Template - The annotation utilizes the generic template of the
19617 -- related subprogram body.
19619 -- * Globals - Capture of global references must occur after full
19620 -- analysis.
19622 -- * Instance - The annotation is instantiated automatically when
19623 -- the related generic subprogram body is instantiated.
19625 when Pragma_Refined_Depends => Refined_Depends : declare
19626 Body_Id : Entity_Id;
19627 Legal : Boolean;
19628 Spec_Id : Entity_Id;
19630 begin
19631 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19633 if Legal then
19635 -- Chain the pragma on the contract for further processing by
19636 -- Analyze_Refined_Depends_In_Decl_Part.
19638 Add_Contract_Item (N, Body_Id);
19640 -- The legality checks of pragmas Refined_Depends and
19641 -- Refined_Global are affected by the SPARK mode in effect and
19642 -- the volatility of the context. In addition these two pragmas
19643 -- are subject to an inherent order:
19645 -- 1) Refined_Global
19646 -- 2) Refined_Depends
19648 -- Analyze all these pragmas in the order outlined above
19650 Analyze_If_Present (Pragma_SPARK_Mode);
19651 Analyze_If_Present (Pragma_Volatile_Function);
19652 Analyze_If_Present (Pragma_Refined_Global);
19653 Analyze_Refined_Depends_In_Decl_Part (N);
19654 end if;
19655 end Refined_Depends;
19657 --------------------
19658 -- Refined_Global --
19659 --------------------
19661 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19663 -- GLOBAL_SPECIFICATION ::=
19664 -- null
19665 -- | (GLOBAL_LIST)
19666 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
19668 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19670 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19671 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19672 -- GLOBAL_ITEM ::= NAME
19674 -- Characteristics:
19676 -- * Analysis - The annotation undergoes initial checks to verify
19677 -- the legal placement and context. Secondary checks fully analyze
19678 -- the dependency clauses/global list in:
19680 -- Analyze_Refined_Global_In_Decl_Part
19682 -- * Expansion - None.
19684 -- * Template - The annotation utilizes the generic template of the
19685 -- related subprogram body.
19687 -- * Globals - Capture of global references must occur after full
19688 -- analysis.
19690 -- * Instance - The annotation is instantiated automatically when
19691 -- the related generic subprogram body is instantiated.
19693 when Pragma_Refined_Global => Refined_Global : declare
19694 Body_Id : Entity_Id;
19695 Legal : Boolean;
19696 Spec_Id : Entity_Id;
19698 begin
19699 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19701 if Legal then
19703 -- Chain the pragma on the contract for further processing by
19704 -- Analyze_Refined_Global_In_Decl_Part.
19706 Add_Contract_Item (N, Body_Id);
19708 -- The legality checks of pragmas Refined_Depends and
19709 -- Refined_Global are affected by the SPARK mode in effect and
19710 -- the volatility of the context. In addition these two pragmas
19711 -- are subject to an inherent order:
19713 -- 1) Refined_Global
19714 -- 2) Refined_Depends
19716 -- Analyze all these pragmas in the order outlined above
19718 Analyze_If_Present (Pragma_SPARK_Mode);
19719 Analyze_If_Present (Pragma_Volatile_Function);
19720 Analyze_Refined_Global_In_Decl_Part (N);
19721 Analyze_If_Present (Pragma_Refined_Depends);
19722 end if;
19723 end Refined_Global;
19725 ------------------
19726 -- Refined_Post --
19727 ------------------
19729 -- pragma Refined_Post (boolean_EXPRESSION);
19731 -- Characteristics:
19733 -- * Analysis - The annotation is fully analyzed immediately upon
19734 -- elaboration as it cannot forward reference entities.
19736 -- * Expansion - The annotation is expanded during the expansion of
19737 -- the related subprogram body contract as performed in:
19739 -- Expand_Subprogram_Contract
19741 -- * Template - The annotation utilizes the generic template of the
19742 -- related subprogram body.
19744 -- * Globals - Capture of global references must occur after full
19745 -- analysis.
19747 -- * Instance - The annotation is instantiated automatically when
19748 -- the related generic subprogram body is instantiated.
19750 when Pragma_Refined_Post => Refined_Post : declare
19751 Body_Id : Entity_Id;
19752 Legal : Boolean;
19753 Spec_Id : Entity_Id;
19755 begin
19756 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19758 -- Fully analyze the pragma when it appears inside a subprogram
19759 -- body because it cannot benefit from forward references.
19761 if Legal then
19763 -- Chain the pragma on the contract for completeness
19765 Add_Contract_Item (N, Body_Id);
19767 -- The legality checks of pragma Refined_Post are affected by
19768 -- the SPARK mode in effect and the volatility of the context.
19769 -- Analyze all pragmas in a specific order.
19771 Analyze_If_Present (Pragma_SPARK_Mode);
19772 Analyze_If_Present (Pragma_Volatile_Function);
19773 Analyze_Pre_Post_Condition_In_Decl_Part (N);
19775 -- Currently it is not possible to inline pre/postconditions on
19776 -- a subprogram subject to pragma Inline_Always.
19778 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
19779 end if;
19780 end Refined_Post;
19782 -------------------
19783 -- Refined_State --
19784 -------------------
19786 -- pragma Refined_State (REFINEMENT_LIST);
19788 -- REFINEMENT_LIST ::=
19789 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19791 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19793 -- CONSTITUENT_LIST ::=
19794 -- null
19795 -- | CONSTITUENT
19796 -- | (CONSTITUENT {, CONSTITUENT})
19798 -- CONSTITUENT ::= object_NAME | state_NAME
19800 -- Characteristics:
19802 -- * Analysis - The annotation undergoes initial checks to verify
19803 -- the legal placement and context. Secondary checks preanalyze the
19804 -- refinement clauses in:
19806 -- Analyze_Refined_State_In_Decl_Part
19808 -- * Expansion - None.
19810 -- * Template - The annotation utilizes the template of the related
19811 -- package body.
19813 -- * Globals - Capture of global references must occur after full
19814 -- analysis.
19816 -- * Instance - The annotation is instantiated automatically when
19817 -- the related generic package body is instantiated.
19819 when Pragma_Refined_State => Refined_State : declare
19820 Pack_Decl : Node_Id;
19821 Spec_Id : Entity_Id;
19823 begin
19824 GNAT_Pragma;
19825 Check_No_Identifiers;
19826 Check_Arg_Count (1);
19828 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
19830 -- Ensure the proper placement of the pragma. Refined states must
19831 -- be associated with a package body.
19833 if Nkind (Pack_Decl) = N_Package_Body then
19834 null;
19836 -- Otherwise the pragma is associated with an illegal construct
19838 else
19839 Pragma_Misplaced;
19840 return;
19841 end if;
19843 Spec_Id := Corresponding_Spec (Pack_Decl);
19845 -- Chain the pragma on the contract for further processing by
19846 -- Analyze_Refined_State_In_Decl_Part.
19848 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
19850 -- The legality checks of pragma Refined_State are affected by the
19851 -- SPARK mode in effect. Analyze all pragmas in a specific order.
19853 Analyze_If_Present (Pragma_SPARK_Mode);
19855 -- A pragma that applies to a Ghost entity becomes Ghost for the
19856 -- purposes of legality checks and removal of ignored Ghost code.
19858 Mark_Pragma_As_Ghost (N, Spec_Id);
19860 -- State refinement is allowed only when the corresponding package
19861 -- declaration has non-null pragma Abstract_State. Refinement not
19862 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19864 if SPARK_Mode /= Off
19865 and then
19866 (No (Abstract_States (Spec_Id))
19867 or else Has_Null_Abstract_State (Spec_Id))
19868 then
19869 Error_Msg_NE
19870 ("useless refinement, package & does not define abstract "
19871 & "states", N, Spec_Id);
19872 return;
19873 end if;
19874 end Refined_State;
19876 -----------------------
19877 -- Relative_Deadline --
19878 -----------------------
19880 -- pragma Relative_Deadline (time_span_EXPRESSION);
19882 when Pragma_Relative_Deadline => Relative_Deadline : declare
19883 P : constant Node_Id := Parent (N);
19884 Arg : Node_Id;
19886 begin
19887 Ada_2005_Pragma;
19888 Check_No_Identifiers;
19889 Check_Arg_Count (1);
19891 Arg := Get_Pragma_Arg (Arg1);
19893 -- The expression must be analyzed in the special manner described
19894 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19896 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
19898 -- Subprogram case
19900 if Nkind (P) = N_Subprogram_Body then
19901 Check_In_Main_Program;
19903 -- Only Task and subprogram cases allowed
19905 elsif Nkind (P) /= N_Task_Definition then
19906 Pragma_Misplaced;
19907 end if;
19909 -- Check duplicate pragma before we set the corresponding flag
19911 if Has_Relative_Deadline_Pragma (P) then
19912 Error_Pragma ("duplicate pragma% not allowed");
19913 end if;
19915 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19916 -- Relative_Deadline pragma node cannot be inserted in the Rep
19917 -- Item chain of Ent since it is rewritten by the expander as a
19918 -- procedure call statement that will break the chain.
19920 Set_Has_Relative_Deadline_Pragma (P);
19921 end Relative_Deadline;
19923 ------------------------
19924 -- Remote_Access_Type --
19925 ------------------------
19927 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19929 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
19930 E : Entity_Id;
19932 begin
19933 GNAT_Pragma;
19934 Check_Arg_Count (1);
19935 Check_Optional_Identifier (Arg1, Name_Entity);
19936 Check_Arg_Is_Local_Name (Arg1);
19938 E := Entity (Get_Pragma_Arg (Arg1));
19940 -- A pragma that applies to a Ghost entity becomes Ghost for the
19941 -- purposes of legality checks and removal of ignored Ghost code.
19943 Mark_Pragma_As_Ghost (N, E);
19945 if Nkind (Parent (E)) = N_Formal_Type_Declaration
19946 and then Ekind (E) = E_General_Access_Type
19947 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
19948 and then Scope (Root_Type (Directly_Designated_Type (E)))
19949 = Scope (E)
19950 and then Is_Valid_Remote_Object_Type
19951 (Root_Type (Directly_Designated_Type (E)))
19952 then
19953 Set_Is_Remote_Types (E);
19955 else
19956 Error_Pragma_Arg
19957 ("pragma% applies only to formal access to classwide types",
19958 Arg1);
19959 end if;
19960 end Remote_Access_Type;
19962 ---------------------------
19963 -- Remote_Call_Interface --
19964 ---------------------------
19966 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19968 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
19969 Cunit_Node : Node_Id;
19970 Cunit_Ent : Entity_Id;
19971 K : Node_Kind;
19973 begin
19974 Check_Ada_83_Warning;
19975 Check_Valid_Library_Unit_Pragma;
19977 if Nkind (N) = N_Null_Statement then
19978 return;
19979 end if;
19981 Cunit_Node := Cunit (Current_Sem_Unit);
19982 K := Nkind (Unit (Cunit_Node));
19983 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19985 -- A pragma that applies to a Ghost entity becomes Ghost for the
19986 -- purposes of legality checks and removal of ignored Ghost code.
19988 Mark_Pragma_As_Ghost (N, Cunit_Ent);
19990 if K = N_Package_Declaration
19991 or else K = N_Generic_Package_Declaration
19992 or else K = N_Subprogram_Declaration
19993 or else K = N_Generic_Subprogram_Declaration
19994 or else (K = N_Subprogram_Body
19995 and then Acts_As_Spec (Unit (Cunit_Node)))
19996 then
19997 null;
19998 else
19999 Error_Pragma (
20000 "pragma% must apply to package or subprogram declaration");
20001 end if;
20003 Set_Is_Remote_Call_Interface (Cunit_Ent);
20004 end Remote_Call_Interface;
20006 ------------------
20007 -- Remote_Types --
20008 ------------------
20010 -- pragma Remote_Types [(library_unit_NAME)];
20012 when Pragma_Remote_Types => Remote_Types : declare
20013 Cunit_Node : Node_Id;
20014 Cunit_Ent : Entity_Id;
20016 begin
20017 Check_Ada_83_Warning;
20018 Check_Valid_Library_Unit_Pragma;
20020 if Nkind (N) = N_Null_Statement then
20021 return;
20022 end if;
20024 Cunit_Node := Cunit (Current_Sem_Unit);
20025 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20027 -- A pragma that applies to a Ghost entity becomes Ghost for the
20028 -- purposes of legality checks and removal of ignored Ghost code.
20030 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20032 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20033 N_Generic_Package_Declaration)
20034 then
20035 Error_Pragma
20036 ("pragma% can only apply to a package declaration");
20037 end if;
20039 Set_Is_Remote_Types (Cunit_Ent);
20040 end Remote_Types;
20042 ---------------
20043 -- Ravenscar --
20044 ---------------
20046 -- pragma Ravenscar;
20048 when Pragma_Ravenscar =>
20049 GNAT_Pragma;
20050 Check_Arg_Count (0);
20051 Check_Valid_Configuration_Pragma;
20052 Set_Ravenscar_Profile (Ravenscar, N);
20054 if Warn_On_Obsolescent_Feature then
20055 Error_Msg_N
20056 ("pragma Ravenscar is an obsolescent feature?j?", N);
20057 Error_Msg_N
20058 ("|use pragma Profile (Ravenscar) instead?j?", N);
20059 end if;
20061 -------------------------
20062 -- Restricted_Run_Time --
20063 -------------------------
20065 -- pragma Restricted_Run_Time;
20067 when Pragma_Restricted_Run_Time =>
20068 GNAT_Pragma;
20069 Check_Arg_Count (0);
20070 Check_Valid_Configuration_Pragma;
20071 Set_Profile_Restrictions
20072 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20074 if Warn_On_Obsolescent_Feature then
20075 Error_Msg_N
20076 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20078 Error_Msg_N
20079 ("|use pragma Profile (Restricted) instead?j?", N);
20080 end if;
20082 ------------------
20083 -- Restrictions --
20084 ------------------
20086 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20088 -- RESTRICTION ::=
20089 -- restriction_IDENTIFIER
20090 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20092 when Pragma_Restrictions =>
20093 Process_Restrictions_Or_Restriction_Warnings
20094 (Warn => Treat_Restrictions_As_Warnings);
20096 --------------------------
20097 -- Restriction_Warnings --
20098 --------------------------
20100 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20102 -- RESTRICTION ::=
20103 -- restriction_IDENTIFIER
20104 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20106 when Pragma_Restriction_Warnings =>
20107 GNAT_Pragma;
20108 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
20110 ----------------
20111 -- Reviewable --
20112 ----------------
20114 -- pragma Reviewable;
20116 when Pragma_Reviewable =>
20117 Check_Ada_83_Warning;
20118 Check_Arg_Count (0);
20120 -- Call dummy debugging function rv. This is done to assist front
20121 -- end debugging. By placing a Reviewable pragma in the source
20122 -- program, a breakpoint on rv catches this place in the source,
20123 -- allowing convenient stepping to the point of interest.
20127 --------------------------
20128 -- Short_Circuit_And_Or --
20129 --------------------------
20131 -- pragma Short_Circuit_And_Or;
20133 when Pragma_Short_Circuit_And_Or =>
20134 GNAT_Pragma;
20135 Check_Arg_Count (0);
20136 Check_Valid_Configuration_Pragma;
20137 Short_Circuit_And_Or := True;
20139 -------------------
20140 -- Share_Generic --
20141 -------------------
20143 -- pragma Share_Generic (GNAME {, GNAME});
20145 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20147 when Pragma_Share_Generic =>
20148 GNAT_Pragma;
20149 Process_Generic_List;
20151 ------------
20152 -- Shared --
20153 ------------
20155 -- pragma Shared (LOCAL_NAME);
20157 when Pragma_Shared =>
20158 GNAT_Pragma;
20159 Process_Atomic_Independent_Shared_Volatile;
20161 --------------------
20162 -- Shared_Passive --
20163 --------------------
20165 -- pragma Shared_Passive [(library_unit_NAME)];
20167 -- Set the flag Is_Shared_Passive of program unit name entity
20169 when Pragma_Shared_Passive => Shared_Passive : declare
20170 Cunit_Node : Node_Id;
20171 Cunit_Ent : Entity_Id;
20173 begin
20174 Check_Ada_83_Warning;
20175 Check_Valid_Library_Unit_Pragma;
20177 if Nkind (N) = N_Null_Statement then
20178 return;
20179 end if;
20181 Cunit_Node := Cunit (Current_Sem_Unit);
20182 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20184 -- A pragma that applies to a Ghost entity becomes Ghost for the
20185 -- purposes of legality checks and removal of ignored Ghost code.
20187 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20189 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20190 N_Generic_Package_Declaration)
20191 then
20192 Error_Pragma
20193 ("pragma% can only apply to a package declaration");
20194 end if;
20196 Set_Is_Shared_Passive (Cunit_Ent);
20197 end Shared_Passive;
20199 -----------------------
20200 -- Short_Descriptors --
20201 -----------------------
20203 -- pragma Short_Descriptors;
20205 -- Recognize and validate, but otherwise ignore
20207 when Pragma_Short_Descriptors =>
20208 GNAT_Pragma;
20209 Check_Arg_Count (0);
20210 Check_Valid_Configuration_Pragma;
20212 ------------------------------
20213 -- Simple_Storage_Pool_Type --
20214 ------------------------------
20216 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20218 when Pragma_Simple_Storage_Pool_Type =>
20219 Simple_Storage_Pool_Type : declare
20220 Typ : Entity_Id;
20221 Type_Id : Node_Id;
20223 begin
20224 GNAT_Pragma;
20225 Check_Arg_Count (1);
20226 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20228 Type_Id := Get_Pragma_Arg (Arg1);
20229 Find_Type (Type_Id);
20230 Typ := Entity (Type_Id);
20232 if Typ = Any_Type then
20233 return;
20234 end if;
20236 -- A pragma that applies to a Ghost entity becomes Ghost for the
20237 -- purposes of legality checks and removal of ignored Ghost code.
20239 Mark_Pragma_As_Ghost (N, Typ);
20241 -- We require the pragma to apply to a type declared in a package
20242 -- declaration, but not (immediately) within a package body.
20244 if Ekind (Current_Scope) /= E_Package
20245 or else In_Package_Body (Current_Scope)
20246 then
20247 Error_Pragma
20248 ("pragma% can only apply to type declared immediately "
20249 & "within a package declaration");
20250 end if;
20252 -- A simple storage pool type must be an immutably limited record
20253 -- or private type. If the pragma is given for a private type,
20254 -- the full type is similarly restricted (which is checked later
20255 -- in Freeze_Entity).
20257 if Is_Record_Type (Typ)
20258 and then not Is_Limited_View (Typ)
20259 then
20260 Error_Pragma
20261 ("pragma% can only apply to explicitly limited record type");
20263 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
20264 Error_Pragma
20265 ("pragma% can only apply to a private type that is limited");
20267 elsif not Is_Record_Type (Typ)
20268 and then not Is_Private_Type (Typ)
20269 then
20270 Error_Pragma
20271 ("pragma% can only apply to limited record or private type");
20272 end if;
20274 Record_Rep_Item (Typ, N);
20275 end Simple_Storage_Pool_Type;
20277 ----------------------
20278 -- Source_File_Name --
20279 ----------------------
20281 -- There are five forms for this pragma:
20283 -- pragma Source_File_Name (
20284 -- [UNIT_NAME =>] unit_NAME,
20285 -- BODY_FILE_NAME => STRING_LITERAL
20286 -- [, [INDEX =>] INTEGER_LITERAL]);
20288 -- pragma Source_File_Name (
20289 -- [UNIT_NAME =>] unit_NAME,
20290 -- SPEC_FILE_NAME => STRING_LITERAL
20291 -- [, [INDEX =>] INTEGER_LITERAL]);
20293 -- pragma Source_File_Name (
20294 -- BODY_FILE_NAME => STRING_LITERAL
20295 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20296 -- [, CASING => CASING_SPEC]);
20298 -- pragma Source_File_Name (
20299 -- SPEC_FILE_NAME => STRING_LITERAL
20300 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20301 -- [, CASING => CASING_SPEC]);
20303 -- pragma Source_File_Name (
20304 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20305 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20306 -- [, CASING => CASING_SPEC]);
20308 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20310 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20311 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20312 -- only be used when no project file is used, while SFNP can only be
20313 -- used when a project file is used.
20315 -- No processing here. Processing was completed during parsing, since
20316 -- we need to have file names set as early as possible. Units are
20317 -- loaded well before semantic processing starts.
20319 -- The only processing we defer to this point is the check for
20320 -- correct placement.
20322 when Pragma_Source_File_Name =>
20323 GNAT_Pragma;
20324 Check_Valid_Configuration_Pragma;
20326 ------------------------------
20327 -- Source_File_Name_Project --
20328 ------------------------------
20330 -- See Source_File_Name for syntax
20332 -- No processing here. Processing was completed during parsing, since
20333 -- we need to have file names set as early as possible. Units are
20334 -- loaded well before semantic processing starts.
20336 -- The only processing we defer to this point is the check for
20337 -- correct placement.
20339 when Pragma_Source_File_Name_Project =>
20340 GNAT_Pragma;
20341 Check_Valid_Configuration_Pragma;
20343 -- Check that a pragma Source_File_Name_Project is used only in a
20344 -- configuration pragmas file.
20346 -- Pragmas Source_File_Name_Project should only be generated by
20347 -- the Project Manager in configuration pragmas files.
20349 -- This is really an ugly test. It seems to depend on some
20350 -- accidental and undocumented property. At the very least it
20351 -- needs to be documented, but it would be better to have a
20352 -- clean way of testing if we are in a configuration file???
20354 if Present (Parent (N)) then
20355 Error_Pragma
20356 ("pragma% can only appear in a configuration pragmas file");
20357 end if;
20359 ----------------------
20360 -- Source_Reference --
20361 ----------------------
20363 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20365 -- Nothing to do, all processing completed in Par.Prag, since we need
20366 -- the information for possible parser messages that are output.
20368 when Pragma_Source_Reference =>
20369 GNAT_Pragma;
20371 ----------------
20372 -- SPARK_Mode --
20373 ----------------
20375 -- pragma SPARK_Mode [(On | Off)];
20377 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
20378 Mode_Id : SPARK_Mode_Type;
20380 procedure Check_Pragma_Conformance
20381 (Context_Pragma : Node_Id;
20382 Entity : Entity_Id;
20383 Entity_Pragma : Node_Id);
20384 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20385 -- conformance of pragma N depending the following scenarios:
20387 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20388 -- compatible with the pragma Context_Pragma that was inherited
20389 -- from the context:
20390 -- * If the mode of Context_Pragma is ON, then the new mode can
20391 -- be anything.
20392 -- * If the mode of Context_Pragma is OFF, then the only allowed
20393 -- new mode is also OFF. Emit error if this is not the case.
20395 -- If Entity is not Empty, verify that pragma N is compatible with
20396 -- pragma Entity_Pragma that belongs to Entity.
20397 -- * If Entity_Pragma is Empty, always issue an error as this
20398 -- corresponds to the case where a previous section of Entity
20399 -- has no SPARK_Mode set.
20400 -- * If the mode of Entity_Pragma is ON, then the new mode can
20401 -- be anything.
20402 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20403 -- new mode is also OFF. Emit error if this is not the case.
20405 procedure Check_Library_Level_Entity (E : Entity_Id);
20406 -- Subsidiary to routines Process_xxx. Verify that the related
20407 -- entity E subject to pragma SPARK_Mode is library-level.
20409 procedure Process_Body (Decl : Node_Id);
20410 -- Verify the legality of pragma SPARK_Mode when it appears as the
20411 -- top of the body declarations of entry, package, protected unit,
20412 -- subprogram or task unit body denoted by Decl.
20414 procedure Process_Overloadable (Decl : Node_Id);
20415 -- Verify the legality of pragma SPARK_Mode when it applies to an
20416 -- entry or [generic] subprogram declaration denoted by Decl.
20418 procedure Process_Private_Part (Decl : Node_Id);
20419 -- Verify the legality of pragma SPARK_Mode when it appears at the
20420 -- top of the private declarations of a package spec, protected or
20421 -- task unit declaration denoted by Decl.
20423 procedure Process_Statement_Part (Decl : Node_Id);
20424 -- Verify the legality of pragma SPARK_Mode when it appears at the
20425 -- top of the statement sequence of a package body denoted by node
20426 -- Decl.
20428 procedure Process_Visible_Part (Decl : Node_Id);
20429 -- Verify the legality of pragma SPARK_Mode when it appears at the
20430 -- top of the visible declarations of a package spec, protected or
20431 -- task unit declaration denoted by Decl. The routine is also used
20432 -- on protected or task units declared without a definition.
20434 procedure Set_SPARK_Context;
20435 -- Subsidiary to routines Process_xxx. Set the global variables
20436 -- which represent the mode of the context from pragma N. Ensure
20437 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20439 ------------------------------
20440 -- Check_Pragma_Conformance --
20441 ------------------------------
20443 procedure Check_Pragma_Conformance
20444 (Context_Pragma : Node_Id;
20445 Entity : Entity_Id;
20446 Entity_Pragma : Node_Id)
20448 Err_Id : Entity_Id;
20449 Err_N : Node_Id;
20451 begin
20452 -- The current pragma may appear without an argument. If this
20453 -- is the case, associate all error messages with the pragma
20454 -- itself.
20456 if Present (Arg1) then
20457 Err_N := Arg1;
20458 else
20459 Err_N := N;
20460 end if;
20462 -- The mode of the current pragma is compared against that of
20463 -- an enclosing context.
20465 if Present (Context_Pragma) then
20466 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
20468 -- Issue an error if the new mode is less restrictive than
20469 -- that of the context.
20471 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
20472 and then Get_SPARK_Mode_From_Annotation (N) = On
20473 then
20474 Error_Msg_N
20475 ("cannot change SPARK_Mode from Off to On", Err_N);
20476 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20477 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
20478 raise Pragma_Exit;
20479 end if;
20480 end if;
20482 -- The mode of the current pragma is compared against that of
20483 -- an initial package, protected type, subprogram or task type
20484 -- declaration.
20486 if Present (Entity) then
20488 -- A simple protected or task type is transformed into an
20489 -- anonymous type whose name cannot be used to issue error
20490 -- messages. Recover the original entity of the type.
20492 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
20493 Err_Id :=
20494 Defining_Entity
20495 (Original_Node (Unit_Declaration_Node (Entity)));
20496 else
20497 Err_Id := Entity;
20498 end if;
20500 -- Both the initial declaration and the completion carry
20501 -- SPARK_Mode pragmas.
20503 if Present (Entity_Pragma) then
20504 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
20506 -- Issue an error if the new mode is less restrictive
20507 -- than that of the initial declaration.
20509 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
20510 and then Get_SPARK_Mode_From_Annotation (N) = On
20511 then
20512 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20513 Error_Msg_Sloc := Sloc (Entity_Pragma);
20514 Error_Msg_NE
20515 ("\value Off was set for SPARK_Mode on&#",
20516 Err_N, Err_Id);
20517 raise Pragma_Exit;
20518 end if;
20520 -- Otherwise the initial declaration lacks a SPARK_Mode
20521 -- pragma in which case the current pragma is illegal as
20522 -- it cannot "complete".
20524 else
20525 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20526 Error_Msg_Sloc := Sloc (Err_Id);
20527 Error_Msg_NE
20528 ("\no value was set for SPARK_Mode on&#",
20529 Err_N, Err_Id);
20530 raise Pragma_Exit;
20531 end if;
20532 end if;
20533 end Check_Pragma_Conformance;
20535 --------------------------------
20536 -- Check_Library_Level_Entity --
20537 --------------------------------
20539 procedure Check_Library_Level_Entity (E : Entity_Id) is
20540 procedure Add_Entity_To_Name_Buffer;
20541 -- Add the E_Kind of entity E to the name buffer
20543 -------------------------------
20544 -- Add_Entity_To_Name_Buffer --
20545 -------------------------------
20547 procedure Add_Entity_To_Name_Buffer is
20548 begin
20549 if Ekind_In (E, E_Entry, E_Entry_Family) then
20550 Add_Str_To_Name_Buffer ("entry");
20552 elsif Ekind_In (E, E_Generic_Package,
20553 E_Package,
20554 E_Package_Body)
20555 then
20556 Add_Str_To_Name_Buffer ("package");
20558 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
20559 Add_Str_To_Name_Buffer ("protected type");
20561 elsif Ekind_In (E, E_Function,
20562 E_Generic_Function,
20563 E_Generic_Procedure,
20564 E_Procedure,
20565 E_Subprogram_Body)
20566 then
20567 Add_Str_To_Name_Buffer ("subprogram");
20569 else
20570 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
20571 Add_Str_To_Name_Buffer ("task type");
20572 end if;
20573 end Add_Entity_To_Name_Buffer;
20575 -- Local variables
20577 Msg_1 : constant String := "incorrect placement of pragma%";
20578 Msg_2 : Name_Id;
20580 -- Start of processing for Check_Library_Level_Entity
20582 begin
20583 if not Is_Library_Level_Entity (E) then
20584 Error_Msg_Name_1 := Pname;
20585 Error_Msg_N (Fix_Error (Msg_1), N);
20587 Name_Len := 0;
20588 Add_Str_To_Name_Buffer ("\& is not a library-level ");
20589 Add_Entity_To_Name_Buffer;
20591 Msg_2 := Name_Find;
20592 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
20594 raise Pragma_Exit;
20595 end if;
20596 end Check_Library_Level_Entity;
20598 ------------------
20599 -- Process_Body --
20600 ------------------
20602 procedure Process_Body (Decl : Node_Id) is
20603 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20604 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
20606 begin
20607 -- Ignore pragma when applied to the special body created for
20608 -- inlining, recognized by its internal name _Parent.
20610 if Chars (Body_Id) = Name_uParent then
20611 return;
20612 end if;
20614 Check_Library_Level_Entity (Body_Id);
20616 -- For entry bodies, verify the legality against:
20617 -- * The mode of the context
20618 -- * The mode of the spec (if any)
20620 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
20622 -- A stand alone subprogram body
20624 if Body_Id = Spec_Id then
20625 Check_Pragma_Conformance
20626 (Context_Pragma => SPARK_Pragma (Body_Id),
20627 Entity => Empty,
20628 Entity_Pragma => Empty);
20630 -- An entry or subprogram body that completes a previous
20631 -- declaration.
20633 else
20634 Check_Pragma_Conformance
20635 (Context_Pragma => SPARK_Pragma (Body_Id),
20636 Entity => Spec_Id,
20637 Entity_Pragma => SPARK_Pragma (Spec_Id));
20638 end if;
20640 Set_SPARK_Context;
20641 Set_SPARK_Pragma (Body_Id, N);
20642 Set_SPARK_Pragma_Inherited (Body_Id, False);
20644 -- For package bodies, verify the legality against:
20645 -- * The mode of the context
20646 -- * The mode of the private part
20648 -- This case is separated from protected and task bodies
20649 -- because the statement part of the package body inherits
20650 -- the mode of the body declarations.
20652 elsif Nkind (Decl) = N_Package_Body then
20653 Check_Pragma_Conformance
20654 (Context_Pragma => SPARK_Pragma (Body_Id),
20655 Entity => Spec_Id,
20656 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
20658 Set_SPARK_Context;
20659 Set_SPARK_Pragma (Body_Id, N);
20660 Set_SPARK_Pragma_Inherited (Body_Id, False);
20661 Set_SPARK_Aux_Pragma (Body_Id, N);
20662 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
20664 -- For protected and task bodies, verify the legality against:
20665 -- * The mode of the context
20666 -- * The mode of the private part
20668 else
20669 pragma Assert
20670 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
20672 Check_Pragma_Conformance
20673 (Context_Pragma => SPARK_Pragma (Body_Id),
20674 Entity => Spec_Id,
20675 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
20677 Set_SPARK_Context;
20678 Set_SPARK_Pragma (Body_Id, N);
20679 Set_SPARK_Pragma_Inherited (Body_Id, False);
20680 end if;
20681 end Process_Body;
20683 --------------------------
20684 -- Process_Overloadable --
20685 --------------------------
20687 procedure Process_Overloadable (Decl : Node_Id) is
20688 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20689 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
20691 begin
20692 Check_Library_Level_Entity (Spec_Id);
20694 -- Verify the legality against:
20695 -- * The mode of the context
20697 Check_Pragma_Conformance
20698 (Context_Pragma => SPARK_Pragma (Spec_Id),
20699 Entity => Empty,
20700 Entity_Pragma => Empty);
20702 Set_SPARK_Pragma (Spec_Id, N);
20703 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20705 -- When the pragma applies to the anonymous object created for
20706 -- a single task type, decorate the type as well. This scenario
20707 -- arises when the single task type lacks a task definition,
20708 -- therefore there is no issue with respect to a potential
20709 -- pragma SPARK_Mode in the private part.
20711 -- task type Anon_Task_Typ;
20712 -- Obj : Anon_Task_Typ;
20713 -- pragma SPARK_Mode ...;
20715 if Is_Single_Task_Object (Spec_Id) then
20716 Set_SPARK_Pragma (Spec_Typ, N);
20717 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
20718 Set_SPARK_Aux_Pragma (Spec_Typ, N);
20719 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
20720 end if;
20721 end Process_Overloadable;
20723 --------------------------
20724 -- Process_Private_Part --
20725 --------------------------
20727 procedure Process_Private_Part (Decl : Node_Id) is
20728 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20730 begin
20731 Check_Library_Level_Entity (Spec_Id);
20733 -- Verify the legality against:
20734 -- * The mode of the visible declarations
20736 Check_Pragma_Conformance
20737 (Context_Pragma => Empty,
20738 Entity => Spec_Id,
20739 Entity_Pragma => SPARK_Pragma (Spec_Id));
20741 Set_SPARK_Context;
20742 Set_SPARK_Aux_Pragma (Spec_Id, N);
20743 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
20744 end Process_Private_Part;
20746 ----------------------------
20747 -- Process_Statement_Part --
20748 ----------------------------
20750 procedure Process_Statement_Part (Decl : Node_Id) is
20751 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20753 begin
20754 Check_Library_Level_Entity (Body_Id);
20756 -- Verify the legality against:
20757 -- * The mode of the body declarations
20759 Check_Pragma_Conformance
20760 (Context_Pragma => Empty,
20761 Entity => Body_Id,
20762 Entity_Pragma => SPARK_Pragma (Body_Id));
20764 Set_SPARK_Context;
20765 Set_SPARK_Aux_Pragma (Body_Id, N);
20766 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
20767 end Process_Statement_Part;
20769 --------------------------
20770 -- Process_Visible_Part --
20771 --------------------------
20773 procedure Process_Visible_Part (Decl : Node_Id) is
20774 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20775 Obj_Id : Entity_Id;
20777 begin
20778 Check_Library_Level_Entity (Spec_Id);
20780 -- Verify the legality against:
20781 -- * The mode of the context
20783 Check_Pragma_Conformance
20784 (Context_Pragma => SPARK_Pragma (Spec_Id),
20785 Entity => Empty,
20786 Entity_Pragma => Empty);
20788 -- A task unit declared without a definition does not set the
20789 -- SPARK_Mode of the context because the task does not have any
20790 -- entries that could inherit the mode.
20792 if not Nkind_In (Decl, N_Single_Task_Declaration,
20793 N_Task_Type_Declaration)
20794 then
20795 Set_SPARK_Context;
20796 end if;
20798 Set_SPARK_Pragma (Spec_Id, N);
20799 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20800 Set_SPARK_Aux_Pragma (Spec_Id, N);
20801 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
20803 -- When the pragma applies to a single protected or task type,
20804 -- decorate the corresponding anonymous object as well.
20806 -- protected Anon_Prot_Typ is
20807 -- pragma SPARK_Mode ...;
20808 -- ...
20809 -- end Anon_Prot_Typ;
20811 -- Obj : Anon_Prot_Typ;
20813 if Is_Single_Concurrent_Type (Spec_Id) then
20814 Obj_Id := Anonymous_Object (Spec_Id);
20816 Set_SPARK_Pragma (Obj_Id, N);
20817 Set_SPARK_Pragma_Inherited (Obj_Id, False);
20818 end if;
20819 end Process_Visible_Part;
20821 -----------------------
20822 -- Set_SPARK_Context --
20823 -----------------------
20825 procedure Set_SPARK_Context is
20826 begin
20827 SPARK_Mode := Mode_Id;
20828 SPARK_Mode_Pragma := N;
20830 if SPARK_Mode = On then
20831 Dynamic_Elaboration_Checks := False;
20832 end if;
20833 end Set_SPARK_Context;
20835 -- Local variables
20837 Context : Node_Id;
20838 Mode : Name_Id;
20839 Stmt : Node_Id;
20841 -- Start of processing for Do_SPARK_Mode
20843 begin
20844 -- When a SPARK_Mode pragma appears inside an instantiation whose
20845 -- enclosing context has SPARK_Mode set to "off", the pragma has
20846 -- no semantic effect.
20848 if Ignore_Pragma_SPARK_Mode then
20849 Rewrite (N, Make_Null_Statement (Loc));
20850 Analyze (N);
20851 return;
20852 end if;
20854 GNAT_Pragma;
20855 Check_No_Identifiers;
20856 Check_At_Most_N_Arguments (1);
20858 -- Check the legality of the mode (no argument = ON)
20860 if Arg_Count = 1 then
20861 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20862 Mode := Chars (Get_Pragma_Arg (Arg1));
20863 else
20864 Mode := Name_On;
20865 end if;
20867 Mode_Id := Get_SPARK_Mode_Type (Mode);
20868 Context := Parent (N);
20870 -- The pragma appears in a configuration pragmas file
20872 if No (Context) then
20873 Check_Valid_Configuration_Pragma;
20875 if Present (SPARK_Mode_Pragma) then
20876 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20877 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20878 raise Pragma_Exit;
20879 end if;
20881 Set_SPARK_Context;
20883 -- The pragma acts as a configuration pragma in a compilation unit
20885 -- pragma SPARK_Mode ...;
20886 -- package Pack is ...;
20888 elsif Nkind (Context) = N_Compilation_Unit
20889 and then List_Containing (N) = Context_Items (Context)
20890 then
20891 Check_Valid_Configuration_Pragma;
20892 Set_SPARK_Context;
20894 -- Otherwise the placement of the pragma within the tree dictates
20895 -- its associated construct. Inspect the declarative list where
20896 -- the pragma resides to find a potential construct.
20898 else
20899 Stmt := Prev (N);
20900 while Present (Stmt) loop
20902 -- Skip prior pragmas, but check for duplicates. Note that
20903 -- this also takes care of pragmas generated for aspects.
20905 if Nkind (Stmt) = N_Pragma then
20906 if Pragma_Name (Stmt) = Pname then
20907 Error_Msg_Name_1 := Pname;
20908 Error_Msg_Sloc := Sloc (Stmt);
20909 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20910 raise Pragma_Exit;
20911 end if;
20913 -- The pragma applies to an expression function that has
20914 -- already been rewritten into a subprogram declaration.
20916 -- function Expr_Func return ... is (...);
20917 -- pragma SPARK_Mode ...;
20919 elsif Nkind (Stmt) = N_Subprogram_Declaration
20920 and then Nkind (Original_Node (Stmt)) =
20921 N_Expression_Function
20922 then
20923 Process_Overloadable (Stmt);
20924 return;
20926 -- The pragma applies to the anonymous object created for a
20927 -- single concurrent type.
20929 -- protected type Anon_Prot_Typ ...;
20930 -- Obj : Anon_Prot_Typ;
20931 -- pragma SPARK_Mode ...;
20933 elsif Nkind (Stmt) = N_Object_Declaration
20934 and then Is_Single_Concurrent_Object
20935 (Defining_Entity (Stmt))
20936 then
20937 Process_Overloadable (Stmt);
20938 return;
20940 -- Skip internally generated code
20942 elsif not Comes_From_Source (Stmt) then
20943 null;
20945 -- The pragma applies to an entry or [generic] subprogram
20946 -- declaration.
20948 -- entry Ent ...;
20949 -- pragma SPARK_Mode ...;
20951 -- [generic]
20952 -- procedure Proc ...;
20953 -- pragma SPARK_Mode ...;
20955 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
20956 N_Subprogram_Declaration)
20957 or else (Nkind (Stmt) = N_Entry_Declaration
20958 and then Is_Protected_Type
20959 (Scope (Defining_Entity (Stmt))))
20960 then
20961 Process_Overloadable (Stmt);
20962 return;
20964 -- Otherwise the pragma does not apply to a legal construct
20965 -- or it does not appear at the top of a declarative or a
20966 -- statement list. Issue an error and stop the analysis.
20968 else
20969 Pragma_Misplaced;
20970 exit;
20971 end if;
20973 Prev (Stmt);
20974 end loop;
20976 -- The pragma applies to a package or a subprogram that acts as
20977 -- a compilation unit.
20979 -- procedure Proc ...;
20980 -- pragma SPARK_Mode ...;
20982 if Nkind (Context) = N_Compilation_Unit_Aux then
20983 Context := Unit (Parent (Context));
20984 end if;
20986 -- The pragma appears at the top of entry, package, protected
20987 -- unit, subprogram or task unit body declarations.
20989 -- entry Ent when ... is
20990 -- pragma SPARK_Mode ...;
20992 -- package body Pack is
20993 -- pragma SPARK_Mode ...;
20995 -- procedure Proc ... is
20996 -- pragma SPARK_Mode;
20998 -- protected body Prot is
20999 -- pragma SPARK_Mode ...;
21001 if Nkind_In (Context, N_Entry_Body,
21002 N_Package_Body,
21003 N_Protected_Body,
21004 N_Subprogram_Body,
21005 N_Task_Body)
21006 then
21007 Process_Body (Context);
21009 -- The pragma appears at the top of the visible or private
21010 -- declaration of a package spec, protected or task unit.
21012 -- package Pack is
21013 -- pragma SPARK_Mode ...;
21014 -- private
21015 -- pragma SPARK_Mode ...;
21017 -- protected [type] Prot is
21018 -- pragma SPARK_Mode ...;
21019 -- private
21020 -- pragma SPARK_Mode ...;
21022 elsif Nkind_In (Context, N_Package_Specification,
21023 N_Protected_Definition,
21024 N_Task_Definition)
21025 then
21026 if List_Containing (N) = Visible_Declarations (Context) then
21027 Process_Visible_Part (Parent (Context));
21028 else
21029 Process_Private_Part (Parent (Context));
21030 end if;
21032 -- The pragma appears at the top of package body statements
21034 -- package body Pack is
21035 -- begin
21036 -- pragma SPARK_Mode;
21038 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
21039 and then Nkind (Parent (Context)) = N_Package_Body
21040 then
21041 Process_Statement_Part (Parent (Context));
21043 -- The pragma appeared as an aspect of a [generic] subprogram
21044 -- declaration that acts as a compilation unit.
21046 -- [generic]
21047 -- procedure Proc ...;
21048 -- pragma SPARK_Mode ...;
21050 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
21051 N_Subprogram_Declaration)
21052 then
21053 Process_Overloadable (Context);
21055 -- The pragma does not apply to a legal construct, issue error
21057 else
21058 Pragma_Misplaced;
21059 end if;
21060 end if;
21061 end Do_SPARK_Mode;
21063 --------------------------------
21064 -- Static_Elaboration_Desired --
21065 --------------------------------
21067 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21069 when Pragma_Static_Elaboration_Desired =>
21070 GNAT_Pragma;
21071 Check_At_Most_N_Arguments (1);
21073 if Is_Compilation_Unit (Current_Scope)
21074 and then Ekind (Current_Scope) = E_Package
21075 then
21076 Set_Static_Elaboration_Desired (Current_Scope, True);
21077 else
21078 Error_Pragma ("pragma% must apply to a library-level package");
21079 end if;
21081 ------------------
21082 -- Storage_Size --
21083 ------------------
21085 -- pragma Storage_Size (EXPRESSION);
21087 when Pragma_Storage_Size => Storage_Size : declare
21088 P : constant Node_Id := Parent (N);
21089 Arg : Node_Id;
21091 begin
21092 Check_No_Identifiers;
21093 Check_Arg_Count (1);
21095 -- The expression must be analyzed in the special manner described
21096 -- in "Handling of Default Expressions" in sem.ads.
21098 Arg := Get_Pragma_Arg (Arg1);
21099 Preanalyze_Spec_Expression (Arg, Any_Integer);
21101 if not Is_OK_Static_Expression (Arg) then
21102 Check_Restriction (Static_Storage_Size, Arg);
21103 end if;
21105 if Nkind (P) /= N_Task_Definition then
21106 Pragma_Misplaced;
21107 return;
21109 else
21110 if Has_Storage_Size_Pragma (P) then
21111 Error_Pragma ("duplicate pragma% not allowed");
21112 else
21113 Set_Has_Storage_Size_Pragma (P, True);
21114 end if;
21116 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
21117 end if;
21118 end Storage_Size;
21120 ------------------
21121 -- Storage_Unit --
21122 ------------------
21124 -- pragma Storage_Unit (NUMERIC_LITERAL);
21126 -- Only permitted argument is System'Storage_Unit value
21128 when Pragma_Storage_Unit =>
21129 Check_No_Identifiers;
21130 Check_Arg_Count (1);
21131 Check_Arg_Is_Integer_Literal (Arg1);
21133 if Intval (Get_Pragma_Arg (Arg1)) /=
21134 UI_From_Int (Ttypes.System_Storage_Unit)
21135 then
21136 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
21137 Error_Pragma_Arg
21138 ("the only allowed argument for pragma% is ^", Arg1);
21139 end if;
21141 --------------------
21142 -- Stream_Convert --
21143 --------------------
21145 -- pragma Stream_Convert (
21146 -- [Entity =>] type_LOCAL_NAME,
21147 -- [Read =>] function_NAME,
21148 -- [Write =>] function NAME);
21150 when Pragma_Stream_Convert => Stream_Convert : declare
21152 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
21153 -- Check that the given argument is the name of a local function
21154 -- of one argument that is not overloaded earlier in the current
21155 -- local scope. A check is also made that the argument is a
21156 -- function with one parameter.
21158 --------------------------------------
21159 -- Check_OK_Stream_Convert_Function --
21160 --------------------------------------
21162 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
21163 Ent : Entity_Id;
21165 begin
21166 Check_Arg_Is_Local_Name (Arg);
21167 Ent := Entity (Get_Pragma_Arg (Arg));
21169 if Has_Homonym (Ent) then
21170 Error_Pragma_Arg
21171 ("argument for pragma% may not be overloaded", Arg);
21172 end if;
21174 if Ekind (Ent) /= E_Function
21175 or else No (First_Formal (Ent))
21176 or else Present (Next_Formal (First_Formal (Ent)))
21177 then
21178 Error_Pragma_Arg
21179 ("argument for pragma% must be function of one argument",
21180 Arg);
21181 end if;
21182 end Check_OK_Stream_Convert_Function;
21184 -- Start of processing for Stream_Convert
21186 begin
21187 GNAT_Pragma;
21188 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
21189 Check_Arg_Count (3);
21190 Check_Optional_Identifier (Arg1, Name_Entity);
21191 Check_Optional_Identifier (Arg2, Name_Read);
21192 Check_Optional_Identifier (Arg3, Name_Write);
21193 Check_Arg_Is_Local_Name (Arg1);
21194 Check_OK_Stream_Convert_Function (Arg2);
21195 Check_OK_Stream_Convert_Function (Arg3);
21197 declare
21198 Typ : constant Entity_Id :=
21199 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
21200 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
21201 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
21203 begin
21204 Check_First_Subtype (Arg1);
21206 -- Check for too early or too late. Note that we don't enforce
21207 -- the rule about primitive operations in this case, since, as
21208 -- is the case for explicit stream attributes themselves, these
21209 -- restrictions are not appropriate. Note that the chaining of
21210 -- the pragma by Rep_Item_Too_Late is actually the critical
21211 -- processing done for this pragma.
21213 if Rep_Item_Too_Early (Typ, N)
21214 or else
21215 Rep_Item_Too_Late (Typ, N, FOnly => True)
21216 then
21217 return;
21218 end if;
21220 -- Return if previous error
21222 if Etype (Typ) = Any_Type
21223 or else
21224 Etype (Read) = Any_Type
21225 or else
21226 Etype (Write) = Any_Type
21227 then
21228 return;
21229 end if;
21231 -- Error checks
21233 if Underlying_Type (Etype (Read)) /= Typ then
21234 Error_Pragma_Arg
21235 ("incorrect return type for function&", Arg2);
21236 end if;
21238 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
21239 Error_Pragma_Arg
21240 ("incorrect parameter type for function&", Arg3);
21241 end if;
21243 if Underlying_Type (Etype (First_Formal (Read))) /=
21244 Underlying_Type (Etype (Write))
21245 then
21246 Error_Pragma_Arg
21247 ("result type of & does not match Read parameter type",
21248 Arg3);
21249 end if;
21250 end;
21251 end Stream_Convert;
21253 ------------------
21254 -- Style_Checks --
21255 ------------------
21257 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21259 -- This is processed by the parser since some of the style checks
21260 -- take place during source scanning and parsing. This means that
21261 -- we don't need to issue error messages here.
21263 when Pragma_Style_Checks => Style_Checks : declare
21264 A : constant Node_Id := Get_Pragma_Arg (Arg1);
21265 S : String_Id;
21266 C : Char_Code;
21268 begin
21269 GNAT_Pragma;
21270 Check_No_Identifiers;
21272 -- Two argument form
21274 if Arg_Count = 2 then
21275 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21277 declare
21278 E_Id : Node_Id;
21279 E : Entity_Id;
21281 begin
21282 E_Id := Get_Pragma_Arg (Arg2);
21283 Analyze (E_Id);
21285 if not Is_Entity_Name (E_Id) then
21286 Error_Pragma_Arg
21287 ("second argument of pragma% must be entity name",
21288 Arg2);
21289 end if;
21291 E := Entity (E_Id);
21293 if not Ignore_Style_Checks_Pragmas then
21294 if E = Any_Id then
21295 return;
21296 else
21297 loop
21298 Set_Suppress_Style_Checks
21299 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
21300 exit when No (Homonym (E));
21301 E := Homonym (E);
21302 end loop;
21303 end if;
21304 end if;
21305 end;
21307 -- One argument form
21309 else
21310 Check_Arg_Count (1);
21312 if Nkind (A) = N_String_Literal then
21313 S := Strval (A);
21315 declare
21316 Slen : constant Natural := Natural (String_Length (S));
21317 Options : String (1 .. Slen);
21318 J : Positive;
21320 begin
21321 J := 1;
21322 loop
21323 C := Get_String_Char (S, Pos (J));
21324 exit when not In_Character_Range (C);
21325 Options (J) := Get_Character (C);
21327 -- If at end of string, set options. As per discussion
21328 -- above, no need to check for errors, since we issued
21329 -- them in the parser.
21331 if J = Slen then
21332 if not Ignore_Style_Checks_Pragmas then
21333 Set_Style_Check_Options (Options);
21334 end if;
21336 exit;
21337 end if;
21339 J := J + 1;
21340 end loop;
21341 end;
21343 elsif Nkind (A) = N_Identifier then
21344 if Chars (A) = Name_All_Checks then
21345 if not Ignore_Style_Checks_Pragmas then
21346 if GNAT_Mode then
21347 Set_GNAT_Style_Check_Options;
21348 else
21349 Set_Default_Style_Check_Options;
21350 end if;
21351 end if;
21353 elsif Chars (A) = Name_On then
21354 if not Ignore_Style_Checks_Pragmas then
21355 Style_Check := True;
21356 end if;
21358 elsif Chars (A) = Name_Off then
21359 if not Ignore_Style_Checks_Pragmas then
21360 Style_Check := False;
21361 end if;
21362 end if;
21363 end if;
21364 end if;
21365 end Style_Checks;
21367 --------------
21368 -- Subtitle --
21369 --------------
21371 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21373 when Pragma_Subtitle =>
21374 GNAT_Pragma;
21375 Check_Arg_Count (1);
21376 Check_Optional_Identifier (Arg1, Name_Subtitle);
21377 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21378 Store_Note (N);
21380 --------------
21381 -- Suppress --
21382 --------------
21384 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21386 when Pragma_Suppress =>
21387 Process_Suppress_Unsuppress (Suppress_Case => True);
21389 ------------------
21390 -- Suppress_All --
21391 ------------------
21393 -- pragma Suppress_All;
21395 -- The only check made here is that the pragma has no arguments.
21396 -- There are no placement rules, and the processing required (setting
21397 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21398 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21399 -- then creates and inserts a pragma Suppress (All_Checks).
21401 when Pragma_Suppress_All =>
21402 GNAT_Pragma;
21403 Check_Arg_Count (0);
21405 -------------------------
21406 -- Suppress_Debug_Info --
21407 -------------------------
21409 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21411 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
21412 Nam_Id : Entity_Id;
21414 begin
21415 GNAT_Pragma;
21416 Check_Arg_Count (1);
21417 Check_Optional_Identifier (Arg1, Name_Entity);
21418 Check_Arg_Is_Local_Name (Arg1);
21420 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
21422 -- A pragma that applies to a Ghost entity becomes Ghost for the
21423 -- purposes of legality checks and removal of ignored Ghost code.
21425 Mark_Pragma_As_Ghost (N, Nam_Id);
21426 Set_Debug_Info_Off (Nam_Id);
21427 end Suppress_Debug_Info;
21429 ----------------------------------
21430 -- Suppress_Exception_Locations --
21431 ----------------------------------
21433 -- pragma Suppress_Exception_Locations;
21435 when Pragma_Suppress_Exception_Locations =>
21436 GNAT_Pragma;
21437 Check_Arg_Count (0);
21438 Check_Valid_Configuration_Pragma;
21439 Exception_Locations_Suppressed := True;
21441 -----------------------------
21442 -- Suppress_Initialization --
21443 -----------------------------
21445 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21447 when Pragma_Suppress_Initialization => Suppress_Init : declare
21448 E : Entity_Id;
21449 E_Id : Node_Id;
21451 begin
21452 GNAT_Pragma;
21453 Check_Arg_Count (1);
21454 Check_Optional_Identifier (Arg1, Name_Entity);
21455 Check_Arg_Is_Local_Name (Arg1);
21457 E_Id := Get_Pragma_Arg (Arg1);
21459 if Etype (E_Id) = Any_Type then
21460 return;
21461 end if;
21463 E := Entity (E_Id);
21465 -- A pragma that applies to a Ghost entity becomes Ghost for the
21466 -- purposes of legality checks and removal of ignored Ghost code.
21468 Mark_Pragma_As_Ghost (N, E);
21470 if not Is_Type (E) and then Ekind (E) /= E_Variable then
21471 Error_Pragma_Arg
21472 ("pragma% requires variable, type or subtype", Arg1);
21473 end if;
21475 if Rep_Item_Too_Early (E, N)
21476 or else
21477 Rep_Item_Too_Late (E, N, FOnly => True)
21478 then
21479 return;
21480 end if;
21482 -- For incomplete/private type, set flag on full view
21484 if Is_Incomplete_Or_Private_Type (E) then
21485 if No (Full_View (Base_Type (E))) then
21486 Error_Pragma_Arg
21487 ("argument of pragma% cannot be an incomplete type", Arg1);
21488 else
21489 Set_Suppress_Initialization (Full_View (Base_Type (E)));
21490 end if;
21492 -- For first subtype, set flag on base type
21494 elsif Is_First_Subtype (E) then
21495 Set_Suppress_Initialization (Base_Type (E));
21497 -- For other than first subtype, set flag on subtype or variable
21499 else
21500 Set_Suppress_Initialization (E);
21501 end if;
21502 end Suppress_Init;
21504 -----------------
21505 -- System_Name --
21506 -----------------
21508 -- pragma System_Name (DIRECT_NAME);
21510 -- Syntax check: one argument, which must be the identifier GNAT or
21511 -- the identifier GCC, no other identifiers are acceptable.
21513 when Pragma_System_Name =>
21514 GNAT_Pragma;
21515 Check_No_Identifiers;
21516 Check_Arg_Count (1);
21517 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
21519 -----------------------------
21520 -- Task_Dispatching_Policy --
21521 -----------------------------
21523 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21525 when Pragma_Task_Dispatching_Policy => declare
21526 DP : Character;
21528 begin
21529 Check_Ada_83_Warning;
21530 Check_Arg_Count (1);
21531 Check_No_Identifiers;
21532 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21533 Check_Valid_Configuration_Pragma;
21534 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21535 DP := Fold_Upper (Name_Buffer (1));
21537 if Task_Dispatching_Policy /= ' '
21538 and then Task_Dispatching_Policy /= DP
21539 then
21540 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21541 Error_Pragma
21542 ("task dispatching policy incompatible with policy#");
21544 -- Set new policy, but always preserve System_Location since we
21545 -- like the error message with the run time name.
21547 else
21548 Task_Dispatching_Policy := DP;
21550 if Task_Dispatching_Policy_Sloc /= System_Location then
21551 Task_Dispatching_Policy_Sloc := Loc;
21552 end if;
21553 end if;
21554 end;
21556 ---------------
21557 -- Task_Info --
21558 ---------------
21560 -- pragma Task_Info (EXPRESSION);
21562 when Pragma_Task_Info => Task_Info : declare
21563 P : constant Node_Id := Parent (N);
21564 Ent : Entity_Id;
21566 begin
21567 GNAT_Pragma;
21569 if Warn_On_Obsolescent_Feature then
21570 Error_Msg_N
21571 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21572 & "instead?j?", N);
21573 end if;
21575 if Nkind (P) /= N_Task_Definition then
21576 Error_Pragma ("pragma% must appear in task definition");
21577 end if;
21579 Check_No_Identifiers;
21580 Check_Arg_Count (1);
21582 Analyze_And_Resolve
21583 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
21585 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
21586 return;
21587 end if;
21589 Ent := Defining_Identifier (Parent (P));
21591 -- Check duplicate pragma before we chain the pragma in the Rep
21592 -- Item chain of Ent.
21594 if Has_Rep_Pragma
21595 (Ent, Name_Task_Info, Check_Parents => False)
21596 then
21597 Error_Pragma ("duplicate pragma% not allowed");
21598 end if;
21600 Record_Rep_Item (Ent, N);
21601 end Task_Info;
21603 ---------------
21604 -- Task_Name --
21605 ---------------
21607 -- pragma Task_Name (string_EXPRESSION);
21609 when Pragma_Task_Name => Task_Name : declare
21610 P : constant Node_Id := Parent (N);
21611 Arg : Node_Id;
21612 Ent : Entity_Id;
21614 begin
21615 Check_No_Identifiers;
21616 Check_Arg_Count (1);
21618 Arg := Get_Pragma_Arg (Arg1);
21620 -- The expression is used in the call to Create_Task, and must be
21621 -- expanded there, not in the context of the current spec. It must
21622 -- however be analyzed to capture global references, in case it
21623 -- appears in a generic context.
21625 Preanalyze_And_Resolve (Arg, Standard_String);
21627 if Nkind (P) /= N_Task_Definition then
21628 Pragma_Misplaced;
21629 end if;
21631 Ent := Defining_Identifier (Parent (P));
21633 -- Check duplicate pragma before we chain the pragma in the Rep
21634 -- Item chain of Ent.
21636 if Has_Rep_Pragma
21637 (Ent, Name_Task_Name, Check_Parents => False)
21638 then
21639 Error_Pragma ("duplicate pragma% not allowed");
21640 end if;
21642 Record_Rep_Item (Ent, N);
21643 end Task_Name;
21645 ------------------
21646 -- Task_Storage --
21647 ------------------
21649 -- pragma Task_Storage (
21650 -- [Task_Type =>] LOCAL_NAME,
21651 -- [Top_Guard =>] static_integer_EXPRESSION);
21653 when Pragma_Task_Storage => Task_Storage : declare
21654 Args : Args_List (1 .. 2);
21655 Names : constant Name_List (1 .. 2) := (
21656 Name_Task_Type,
21657 Name_Top_Guard);
21659 Task_Type : Node_Id renames Args (1);
21660 Top_Guard : Node_Id renames Args (2);
21662 Ent : Entity_Id;
21664 begin
21665 GNAT_Pragma;
21666 Gather_Associations (Names, Args);
21668 if No (Task_Type) then
21669 Error_Pragma
21670 ("missing task_type argument for pragma%");
21671 end if;
21673 Check_Arg_Is_Local_Name (Task_Type);
21675 Ent := Entity (Task_Type);
21677 if not Is_Task_Type (Ent) then
21678 Error_Pragma_Arg
21679 ("argument for pragma% must be task type", Task_Type);
21680 end if;
21682 if No (Top_Guard) then
21683 Error_Pragma_Arg
21684 ("pragma% takes two arguments", Task_Type);
21685 else
21686 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
21687 end if;
21689 Check_First_Subtype (Task_Type);
21691 if Rep_Item_Too_Late (Ent, N) then
21692 raise Pragma_Exit;
21693 end if;
21694 end Task_Storage;
21696 ---------------
21697 -- Test_Case --
21698 ---------------
21700 -- pragma Test_Case
21701 -- ([Name =>] Static_String_EXPRESSION
21702 -- ,[Mode =>] MODE_TYPE
21703 -- [, Requires => Boolean_EXPRESSION]
21704 -- [, Ensures => Boolean_EXPRESSION]);
21706 -- MODE_TYPE ::= Nominal | Robustness
21708 -- Characteristics:
21710 -- * Analysis - The annotation undergoes initial checks to verify
21711 -- the legal placement and context. Secondary checks preanalyze the
21712 -- expressions in:
21714 -- Analyze_Test_Case_In_Decl_Part
21716 -- * Expansion - None.
21718 -- * Template - The annotation utilizes the generic template of the
21719 -- related subprogram when it is:
21721 -- aspect on subprogram declaration
21723 -- The annotation must prepare its own template when it is:
21725 -- pragma on subprogram declaration
21727 -- * Globals - Capture of global references must occur after full
21728 -- analysis.
21730 -- * Instance - The annotation is instantiated automatically when
21731 -- the related generic subprogram is instantiated except for the
21732 -- "pragma on subprogram declaration" case. In that scenario the
21733 -- annotation must instantiate itself.
21735 when Pragma_Test_Case => Test_Case : declare
21736 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
21737 -- Ensure that the contract of subprogram Subp_Id does not contain
21738 -- another Test_Case pragma with the same Name as the current one.
21740 -------------------------
21741 -- Check_Distinct_Name --
21742 -------------------------
21744 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
21745 Items : constant Node_Id := Contract (Subp_Id);
21746 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
21747 Prag : Node_Id;
21749 begin
21750 -- Inspect all Test_Case pragma of the related subprogram
21751 -- looking for one with a duplicate "Name" argument.
21753 if Present (Items) then
21754 Prag := Contract_Test_Cases (Items);
21755 while Present (Prag) loop
21756 if Pragma_Name (Prag) = Name_Test_Case
21757 and then Prag /= N
21758 and then String_Equal
21759 (Name, Get_Name_From_CTC_Pragma (Prag))
21760 then
21761 Error_Msg_Sloc := Sloc (Prag);
21762 Error_Pragma ("name for pragma % is already used #");
21763 end if;
21765 Prag := Next_Pragma (Prag);
21766 end loop;
21767 end if;
21768 end Check_Distinct_Name;
21770 -- Local variables
21772 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
21773 Asp_Arg : Node_Id;
21774 Context : Node_Id;
21775 Subp_Decl : Node_Id;
21776 Subp_Id : Entity_Id;
21778 -- Start of processing for Test_Case
21780 begin
21781 GNAT_Pragma;
21782 Check_At_Least_N_Arguments (2);
21783 Check_At_Most_N_Arguments (4);
21784 Check_Arg_Order
21785 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
21787 -- Argument "Name"
21789 Check_Optional_Identifier (Arg1, Name_Name);
21790 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21792 -- Argument "Mode"
21794 Check_Optional_Identifier (Arg2, Name_Mode);
21795 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
21797 -- Arguments "Requires" and "Ensures"
21799 if Present (Arg3) then
21800 if Present (Arg4) then
21801 Check_Identifier (Arg3, Name_Requires);
21802 Check_Identifier (Arg4, Name_Ensures);
21803 else
21804 Check_Identifier_Is_One_Of
21805 (Arg3, Name_Requires, Name_Ensures);
21806 end if;
21807 end if;
21809 -- Pragma Test_Case must be associated with a subprogram declared
21810 -- in a library-level package. First determine whether the current
21811 -- compilation unit is a legal context.
21813 if Nkind_In (Pack_Decl, N_Package_Declaration,
21814 N_Generic_Package_Declaration)
21815 then
21816 null;
21818 -- Otherwise the placement is illegal
21820 else
21821 Error_Pragma
21822 ("pragma % must be specified within a package declaration");
21823 return;
21824 end if;
21826 Subp_Decl := Find_Related_Declaration_Or_Body (N);
21828 -- Find the enclosing context
21830 Context := Parent (Subp_Decl);
21832 if Present (Context) then
21833 Context := Parent (Context);
21834 end if;
21836 -- Verify the placement of the pragma
21838 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
21839 Error_Pragma
21840 ("pragma % cannot be applied to abstract subprogram");
21841 return;
21843 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
21844 Error_Pragma ("pragma % cannot be applied to entry");
21845 return;
21847 -- The context is a [generic] subprogram declared at the top level
21848 -- of the [generic] package unit.
21850 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
21851 N_Subprogram_Declaration)
21852 and then Present (Context)
21853 and then Nkind_In (Context, N_Generic_Package_Declaration,
21854 N_Package_Declaration)
21855 then
21856 null;
21858 -- Otherwise the placement is illegal
21860 else
21861 Error_Pragma
21862 ("pragma % must be applied to a library-level subprogram "
21863 & "declaration");
21864 return;
21865 end if;
21867 Subp_Id := Defining_Entity (Subp_Decl);
21869 -- Chain the pragma on the contract for further processing by
21870 -- Analyze_Test_Case_In_Decl_Part.
21872 Add_Contract_Item (N, Subp_Id);
21874 -- A pragma that applies to a Ghost entity becomes Ghost for the
21875 -- purposes of legality checks and removal of ignored Ghost code.
21877 Mark_Pragma_As_Ghost (N, Subp_Id);
21879 -- Preanalyze the original aspect argument "Name" for ASIS or for
21880 -- a generic subprogram to properly capture global references.
21882 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
21883 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
21885 if Present (Asp_Arg) then
21887 -- The argument appears with an identifier in association
21888 -- form.
21890 if Nkind (Asp_Arg) = N_Component_Association then
21891 Asp_Arg := Expression (Asp_Arg);
21892 end if;
21894 Check_Expr_Is_OK_Static_Expression
21895 (Asp_Arg, Standard_String);
21896 end if;
21897 end if;
21899 -- Ensure that the all Test_Case pragmas of the related subprogram
21900 -- have distinct names.
21902 Check_Distinct_Name (Subp_Id);
21904 -- Fully analyze the pragma when it appears inside an entry
21905 -- or subprogram body because it cannot benefit from forward
21906 -- references.
21908 if Nkind_In (Subp_Decl, N_Entry_Body,
21909 N_Subprogram_Body,
21910 N_Subprogram_Body_Stub)
21911 then
21912 -- The legality checks of pragma Test_Case are affected by the
21913 -- SPARK mode in effect and the volatility of the context.
21914 -- Analyze all pragmas in a specific order.
21916 Analyze_If_Present (Pragma_SPARK_Mode);
21917 Analyze_If_Present (Pragma_Volatile_Function);
21918 Analyze_Test_Case_In_Decl_Part (N);
21919 end if;
21920 end Test_Case;
21922 --------------------------
21923 -- Thread_Local_Storage --
21924 --------------------------
21926 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
21928 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
21929 E : Entity_Id;
21930 Id : Node_Id;
21932 begin
21933 GNAT_Pragma;
21934 Check_Arg_Count (1);
21935 Check_Optional_Identifier (Arg1, Name_Entity);
21936 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21938 Id := Get_Pragma_Arg (Arg1);
21939 Analyze (Id);
21941 if not Is_Entity_Name (Id)
21942 or else Ekind (Entity (Id)) /= E_Variable
21943 then
21944 Error_Pragma_Arg ("local variable name required", Arg1);
21945 end if;
21947 E := Entity (Id);
21949 -- A pragma that applies to a Ghost entity becomes Ghost for the
21950 -- purposes of legality checks and removal of ignored Ghost code.
21952 Mark_Pragma_As_Ghost (N, E);
21954 if Rep_Item_Too_Early (E, N)
21955 or else
21956 Rep_Item_Too_Late (E, N)
21957 then
21958 raise Pragma_Exit;
21959 end if;
21961 Set_Has_Pragma_Thread_Local_Storage (E);
21962 Set_Has_Gigi_Rep_Item (E);
21963 end Thread_Local_Storage;
21965 ----------------
21966 -- Time_Slice --
21967 ----------------
21969 -- pragma Time_Slice (static_duration_EXPRESSION);
21971 when Pragma_Time_Slice => Time_Slice : declare
21972 Val : Ureal;
21973 Nod : Node_Id;
21975 begin
21976 GNAT_Pragma;
21977 Check_Arg_Count (1);
21978 Check_No_Identifiers;
21979 Check_In_Main_Program;
21980 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
21982 if not Error_Posted (Arg1) then
21983 Nod := Next (N);
21984 while Present (Nod) loop
21985 if Nkind (Nod) = N_Pragma
21986 and then Pragma_Name (Nod) = Name_Time_Slice
21987 then
21988 Error_Msg_Name_1 := Pname;
21989 Error_Msg_N ("duplicate pragma% not permitted", Nod);
21990 end if;
21992 Next (Nod);
21993 end loop;
21994 end if;
21996 -- Process only if in main unit
21998 if Get_Source_Unit (Loc) = Main_Unit then
21999 Opt.Time_Slice_Set := True;
22000 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22002 if Val <= Ureal_0 then
22003 Opt.Time_Slice_Value := 0;
22005 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22006 Opt.Time_Slice_Value := 1_000_000_000;
22008 else
22009 Opt.Time_Slice_Value :=
22010 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22011 end if;
22012 end if;
22013 end Time_Slice;
22015 -----------
22016 -- Title --
22017 -----------
22019 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22021 -- TITLING_OPTION ::=
22022 -- [Title =>] STRING_LITERAL
22023 -- | [Subtitle =>] STRING_LITERAL
22025 when Pragma_Title => Title : declare
22026 Args : Args_List (1 .. 2);
22027 Names : constant Name_List (1 .. 2) := (
22028 Name_Title,
22029 Name_Subtitle);
22031 begin
22032 GNAT_Pragma;
22033 Gather_Associations (Names, Args);
22034 Store_Note (N);
22036 for J in 1 .. 2 loop
22037 if Present (Args (J)) then
22038 Check_Arg_Is_OK_Static_Expression
22039 (Args (J), Standard_String);
22040 end if;
22041 end loop;
22042 end Title;
22044 ----------------------------
22045 -- Type_Invariant[_Class] --
22046 ----------------------------
22048 -- pragma Type_Invariant[_Class]
22049 -- ([Entity =>] type_LOCAL_NAME,
22050 -- [Check =>] EXPRESSION);
22052 when Pragma_Type_Invariant |
22053 Pragma_Type_Invariant_Class =>
22054 Type_Invariant : declare
22055 I_Pragma : Node_Id;
22057 begin
22058 Check_Arg_Count (2);
22060 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22061 -- setting Class_Present for the Type_Invariant_Class case.
22063 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
22064 I_Pragma := New_Copy (N);
22065 Set_Pragma_Identifier
22066 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
22067 Rewrite (N, I_Pragma);
22068 Set_Analyzed (N, False);
22069 Analyze (N);
22070 end Type_Invariant;
22072 ---------------------
22073 -- Unchecked_Union --
22074 ---------------------
22076 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22078 when Pragma_Unchecked_Union => Unchecked_Union : declare
22079 Assoc : constant Node_Id := Arg1;
22080 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
22081 Clist : Node_Id;
22082 Comp : Node_Id;
22083 Tdef : Node_Id;
22084 Typ : Entity_Id;
22085 Variant : Node_Id;
22086 Vpart : Node_Id;
22088 begin
22089 Ada_2005_Pragma;
22090 Check_No_Identifiers;
22091 Check_Arg_Count (1);
22092 Check_Arg_Is_Local_Name (Arg1);
22094 Find_Type (Type_Id);
22096 Typ := Entity (Type_Id);
22098 -- A pragma that applies to a Ghost entity becomes Ghost for the
22099 -- purposes of legality checks and removal of ignored Ghost code.
22101 Mark_Pragma_As_Ghost (N, Typ);
22103 if Typ = Any_Type
22104 or else Rep_Item_Too_Early (Typ, N)
22105 then
22106 return;
22107 else
22108 Typ := Underlying_Type (Typ);
22109 end if;
22111 if Rep_Item_Too_Late (Typ, N) then
22112 return;
22113 end if;
22115 Check_First_Subtype (Arg1);
22117 -- Note remaining cases are references to a type in the current
22118 -- declarative part. If we find an error, we post the error on
22119 -- the relevant type declaration at an appropriate point.
22121 if not Is_Record_Type (Typ) then
22122 Error_Msg_N ("unchecked union must be record type", Typ);
22123 return;
22125 elsif Is_Tagged_Type (Typ) then
22126 Error_Msg_N ("unchecked union must not be tagged", Typ);
22127 return;
22129 elsif not Has_Discriminants (Typ) then
22130 Error_Msg_N
22131 ("unchecked union must have one discriminant", Typ);
22132 return;
22134 -- Note: in previous versions of GNAT we used to check for limited
22135 -- types and give an error, but in fact the standard does allow
22136 -- Unchecked_Union on limited types, so this check was removed.
22138 -- Similarly, GNAT used to require that all discriminants have
22139 -- default values, but this is not mandated by the RM.
22141 -- Proceed with basic error checks completed
22143 else
22144 Tdef := Type_Definition (Declaration_Node (Typ));
22145 Clist := Component_List (Tdef);
22147 -- Check presence of component list and variant part
22149 if No (Clist) or else No (Variant_Part (Clist)) then
22150 Error_Msg_N
22151 ("unchecked union must have variant part", Tdef);
22152 return;
22153 end if;
22155 -- Check components
22157 Comp := First (Component_Items (Clist));
22158 while Present (Comp) loop
22159 Check_Component (Comp, Typ);
22160 Next (Comp);
22161 end loop;
22163 -- Check variant part
22165 Vpart := Variant_Part (Clist);
22167 Variant := First (Variants (Vpart));
22168 while Present (Variant) loop
22169 Check_Variant (Variant, Typ);
22170 Next (Variant);
22171 end loop;
22172 end if;
22174 Set_Is_Unchecked_Union (Typ);
22175 Set_Convention (Typ, Convention_C);
22176 Set_Has_Unchecked_Union (Base_Type (Typ));
22177 Set_Is_Unchecked_Union (Base_Type (Typ));
22178 end Unchecked_Union;
22180 ------------------------
22181 -- Unimplemented_Unit --
22182 ------------------------
22184 -- pragma Unimplemented_Unit;
22186 -- Note: this only gives an error if we are generating code, or if
22187 -- we are in a generic library unit (where the pragma appears in the
22188 -- body, not in the spec).
22190 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
22191 Cunitent : constant Entity_Id :=
22192 Cunit_Entity (Get_Source_Unit (Loc));
22193 Ent_Kind : constant Entity_Kind :=
22194 Ekind (Cunitent);
22196 begin
22197 GNAT_Pragma;
22198 Check_Arg_Count (0);
22200 if Operating_Mode = Generate_Code
22201 or else Ent_Kind = E_Generic_Function
22202 or else Ent_Kind = E_Generic_Procedure
22203 or else Ent_Kind = E_Generic_Package
22204 then
22205 Get_Name_String (Chars (Cunitent));
22206 Set_Casing (Mixed_Case);
22207 Write_Str (Name_Buffer (1 .. Name_Len));
22208 Write_Str (" is not supported in this configuration");
22209 Write_Eol;
22210 raise Unrecoverable_Error;
22211 end if;
22212 end Unimplemented_Unit;
22214 ------------------------
22215 -- Universal_Aliasing --
22216 ------------------------
22218 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22220 when Pragma_Universal_Aliasing => Universal_Alias : declare
22221 E_Id : Entity_Id;
22223 begin
22224 GNAT_Pragma;
22225 Check_Arg_Count (1);
22226 Check_Optional_Identifier (Arg2, Name_Entity);
22227 Check_Arg_Is_Local_Name (Arg1);
22228 E_Id := Entity (Get_Pragma_Arg (Arg1));
22230 if E_Id = Any_Type then
22231 return;
22232 elsif No (E_Id) or else not Is_Type (E_Id) then
22233 Error_Pragma_Arg ("pragma% requires type", Arg1);
22234 end if;
22236 -- A pragma that applies to a Ghost entity becomes Ghost for the
22237 -- purposes of legality checks and removal of ignored Ghost code.
22239 Mark_Pragma_As_Ghost (N, E_Id);
22240 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
22241 Record_Rep_Item (E_Id, N);
22242 end Universal_Alias;
22244 --------------------
22245 -- Universal_Data --
22246 --------------------
22248 -- pragma Universal_Data [(library_unit_NAME)];
22250 when Pragma_Universal_Data =>
22251 GNAT_Pragma;
22253 -- If this is a configuration pragma, then set the universal
22254 -- addressing option, otherwise confirm that the pragma satisfies
22255 -- the requirements of library unit pragma placement and leave it
22256 -- to the GNAAMP back end to detect the pragma (avoids transitive
22257 -- setting of the option due to withed units).
22259 if Is_Configuration_Pragma then
22260 Universal_Addressing_On_AAMP := True;
22261 else
22262 Check_Valid_Library_Unit_Pragma;
22263 end if;
22265 if not AAMP_On_Target then
22266 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
22267 end if;
22269 ----------------
22270 -- Unmodified --
22271 ----------------
22273 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22275 when Pragma_Unmodified => Unmodified : declare
22276 Arg : Node_Id;
22277 Arg_Expr : Node_Id;
22278 Arg_Id : Entity_Id;
22280 Ghost_Error_Posted : Boolean := False;
22281 -- Flag set when an error concerning the illegal mix of Ghost and
22282 -- non-Ghost variables is emitted.
22284 Ghost_Id : Entity_Id := Empty;
22285 -- The entity of the first Ghost variable encountered while
22286 -- processing the arguments of the pragma.
22288 begin
22289 GNAT_Pragma;
22290 Check_At_Least_N_Arguments (1);
22292 -- Loop through arguments
22294 Arg := Arg1;
22295 while Present (Arg) loop
22296 Check_No_Identifier (Arg);
22298 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
22299 -- in fact generate reference, so that the entity will have a
22300 -- reference, which will inhibit any warnings about it not
22301 -- being referenced, and also properly show up in the ali file
22302 -- as a reference. But this reference is recorded before the
22303 -- Has_Pragma_Unreferenced flag is set, so that no warning is
22304 -- generated for this reference.
22306 Check_Arg_Is_Local_Name (Arg);
22307 Arg_Expr := Get_Pragma_Arg (Arg);
22309 if Is_Entity_Name (Arg_Expr) then
22310 Arg_Id := Entity (Arg_Expr);
22312 if Is_Assignable (Arg_Id) then
22313 Set_Has_Pragma_Unmodified (Arg_Id);
22315 -- A pragma that applies to a Ghost entity becomes Ghost
22316 -- for the purposes of legality checks and removal of
22317 -- ignored Ghost code.
22319 Mark_Pragma_As_Ghost (N, Arg_Id);
22321 -- Capture the entity of the first Ghost variable being
22322 -- processed for error detection purposes.
22324 if Is_Ghost_Entity (Arg_Id) then
22325 if No (Ghost_Id) then
22326 Ghost_Id := Arg_Id;
22327 end if;
22329 -- Otherwise the variable is non-Ghost. It is illegal
22330 -- to mix references to Ghost and non-Ghost entities
22331 -- (SPARK RM 6.9).
22333 elsif Present (Ghost_Id)
22334 and then not Ghost_Error_Posted
22335 then
22336 Ghost_Error_Posted := True;
22338 Error_Msg_Name_1 := Pname;
22339 Error_Msg_N
22340 ("pragma % cannot mention ghost and non-ghost "
22341 & "variables", N);
22343 Error_Msg_Sloc := Sloc (Ghost_Id);
22344 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22346 Error_Msg_Sloc := Sloc (Arg_Id);
22347 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22348 end if;
22350 -- Otherwise the pragma referenced an illegal entity
22352 else
22353 Error_Pragma_Arg
22354 ("pragma% can only be applied to a variable", Arg_Expr);
22355 end if;
22356 end if;
22358 Next (Arg);
22359 end loop;
22360 end Unmodified;
22362 ------------------
22363 -- Unreferenced --
22364 ------------------
22366 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22368 -- or when used in a context clause:
22370 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22372 when Pragma_Unreferenced => Unreferenced : declare
22373 Arg : Node_Id;
22374 Arg_Expr : Node_Id;
22375 Arg_Id : Entity_Id;
22376 Citem : Node_Id;
22378 Ghost_Error_Posted : Boolean := False;
22379 -- Flag set when an error concerning the illegal mix of Ghost and
22380 -- non-Ghost names is emitted.
22382 Ghost_Id : Entity_Id := Empty;
22383 -- The entity of the first Ghost name encountered while processing
22384 -- the arguments of the pragma.
22386 begin
22387 GNAT_Pragma;
22388 Check_At_Least_N_Arguments (1);
22390 -- Check case of appearing within context clause
22392 if Is_In_Context_Clause then
22394 -- The arguments must all be units mentioned in a with clause
22395 -- in the same context clause. Note we already checked (in
22396 -- Par.Prag) that the arguments are either identifiers or
22397 -- selected components.
22399 Arg := Arg1;
22400 while Present (Arg) loop
22401 Citem := First (List_Containing (N));
22402 while Citem /= N loop
22403 Arg_Expr := Get_Pragma_Arg (Arg);
22405 if Nkind (Citem) = N_With_Clause
22406 and then Same_Name (Name (Citem), Arg_Expr)
22407 then
22408 Set_Has_Pragma_Unreferenced
22409 (Cunit_Entity
22410 (Get_Source_Unit
22411 (Library_Unit (Citem))));
22412 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
22413 exit;
22414 end if;
22416 Next (Citem);
22417 end loop;
22419 if Citem = N then
22420 Error_Pragma_Arg
22421 ("argument of pragma% is not withed unit", Arg);
22422 end if;
22424 Next (Arg);
22425 end loop;
22427 -- Case of not in list of context items
22429 else
22430 Arg := Arg1;
22431 while Present (Arg) loop
22432 Check_No_Identifier (Arg);
22434 -- Note: the analyze call done by Check_Arg_Is_Local_Name
22435 -- will in fact generate reference, so that the entity will
22436 -- have a reference, which will inhibit any warnings about
22437 -- it not being referenced, and also properly show up in the
22438 -- ali file as a reference. But this reference is recorded
22439 -- before the Has_Pragma_Unreferenced flag is set, so that
22440 -- no warning is generated for this reference.
22442 Check_Arg_Is_Local_Name (Arg);
22443 Arg_Expr := Get_Pragma_Arg (Arg);
22445 if Is_Entity_Name (Arg_Expr) then
22446 Arg_Id := Entity (Arg_Expr);
22448 -- If the entity is overloaded, the pragma applies to the
22449 -- most recent overloading, as documented. In this case,
22450 -- name resolution does not generate a reference, so it
22451 -- must be done here explicitly.
22453 if Is_Overloaded (Arg_Expr) then
22454 Generate_Reference (Arg_Id, N);
22455 end if;
22457 Set_Has_Pragma_Unreferenced (Arg_Id);
22459 -- A pragma that applies to a Ghost entity becomes Ghost
22460 -- for the purposes of legality checks and removal of
22461 -- ignored Ghost code.
22463 Mark_Pragma_As_Ghost (N, Arg_Id);
22465 -- Capture the entity of the first Ghost name being
22466 -- processed for error detection purposes.
22468 if Is_Ghost_Entity (Arg_Id) then
22469 if No (Ghost_Id) then
22470 Ghost_Id := Arg_Id;
22471 end if;
22473 -- Otherwise the name is non-Ghost. It is illegal to mix
22474 -- references to Ghost and non-Ghost entities
22475 -- (SPARK RM 6.9).
22477 elsif Present (Ghost_Id)
22478 and then not Ghost_Error_Posted
22479 then
22480 Ghost_Error_Posted := True;
22482 Error_Msg_Name_1 := Pname;
22483 Error_Msg_N
22484 ("pragma % cannot mention ghost and non-ghost names",
22487 Error_Msg_Sloc := Sloc (Ghost_Id);
22488 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22490 Error_Msg_Sloc := Sloc (Arg_Id);
22491 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22492 end if;
22493 end if;
22495 Next (Arg);
22496 end loop;
22497 end if;
22498 end Unreferenced;
22500 --------------------------
22501 -- Unreferenced_Objects --
22502 --------------------------
22504 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22506 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
22507 Arg : Node_Id;
22508 Arg_Expr : Node_Id;
22509 Arg_Id : Entity_Id;
22511 Ghost_Error_Posted : Boolean := False;
22512 -- Flag set when an error concerning the illegal mix of Ghost and
22513 -- non-Ghost types is emitted.
22515 Ghost_Id : Entity_Id := Empty;
22516 -- The entity of the first Ghost type encountered while processing
22517 -- the arguments of the pragma.
22519 begin
22520 GNAT_Pragma;
22521 Check_At_Least_N_Arguments (1);
22523 Arg := Arg1;
22524 while Present (Arg) loop
22525 Check_No_Identifier (Arg);
22526 Check_Arg_Is_Local_Name (Arg);
22527 Arg_Expr := Get_Pragma_Arg (Arg);
22529 if Is_Entity_Name (Arg_Expr) then
22530 Arg_Id := Entity (Arg_Expr);
22532 if Is_Type (Arg_Id) then
22533 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
22535 -- A pragma that applies to a Ghost entity becomes Ghost
22536 -- for the purposes of legality checks and removal of
22537 -- ignored Ghost code.
22539 Mark_Pragma_As_Ghost (N, Arg_Id);
22541 -- Capture the entity of the first Ghost type being
22542 -- processed for error detection purposes.
22544 if Is_Ghost_Entity (Arg_Id) then
22545 if No (Ghost_Id) then
22546 Ghost_Id := Arg_Id;
22547 end if;
22549 -- Otherwise the type is non-Ghost. It is illegal to mix
22550 -- references to Ghost and non-Ghost entities
22551 -- (SPARK RM 6.9).
22553 elsif Present (Ghost_Id)
22554 and then not Ghost_Error_Posted
22555 then
22556 Ghost_Error_Posted := True;
22558 Error_Msg_Name_1 := Pname;
22559 Error_Msg_N
22560 ("pragma % cannot mention ghost and non-ghost types",
22563 Error_Msg_Sloc := Sloc (Ghost_Id);
22564 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22566 Error_Msg_Sloc := Sloc (Arg_Id);
22567 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22568 end if;
22569 else
22570 Error_Pragma_Arg
22571 ("argument for pragma% must be type or subtype", Arg);
22572 end if;
22573 else
22574 Error_Pragma_Arg
22575 ("argument for pragma% must be type or subtype", Arg);
22576 end if;
22578 Next (Arg);
22579 end loop;
22580 end Unreferenced_Objects;
22582 ------------------------------
22583 -- Unreserve_All_Interrupts --
22584 ------------------------------
22586 -- pragma Unreserve_All_Interrupts;
22588 when Pragma_Unreserve_All_Interrupts =>
22589 GNAT_Pragma;
22590 Check_Arg_Count (0);
22592 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
22593 Unreserve_All_Interrupts := True;
22594 end if;
22596 ----------------
22597 -- Unsuppress --
22598 ----------------
22600 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22602 when Pragma_Unsuppress =>
22603 Ada_2005_Pragma;
22604 Process_Suppress_Unsuppress (Suppress_Case => False);
22606 ----------------------------
22607 -- Unevaluated_Use_Of_Old --
22608 ----------------------------
22610 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22612 when Pragma_Unevaluated_Use_Of_Old =>
22613 GNAT_Pragma;
22614 Check_Arg_Count (1);
22615 Check_No_Identifiers;
22616 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
22618 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22619 -- a declarative part or a package spec.
22621 if not Is_Configuration_Pragma then
22622 Check_Is_In_Decl_Part_Or_Package_Spec;
22623 end if;
22625 -- Store proper setting of Uneval_Old
22627 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22628 Uneval_Old := Fold_Upper (Name_Buffer (1));
22630 -------------------
22631 -- Use_VADS_Size --
22632 -------------------
22634 -- pragma Use_VADS_Size;
22636 when Pragma_Use_VADS_Size =>
22637 GNAT_Pragma;
22638 Check_Arg_Count (0);
22639 Check_Valid_Configuration_Pragma;
22640 Use_VADS_Size := True;
22642 ---------------------
22643 -- Validity_Checks --
22644 ---------------------
22646 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22648 when Pragma_Validity_Checks => Validity_Checks : declare
22649 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22650 S : String_Id;
22651 C : Char_Code;
22653 begin
22654 GNAT_Pragma;
22655 Check_Arg_Count (1);
22656 Check_No_Identifiers;
22658 -- Pragma always active unless in CodePeer or GNATprove modes,
22659 -- which use a fixed configuration of validity checks.
22661 if not (CodePeer_Mode or GNATprove_Mode) then
22662 if Nkind (A) = N_String_Literal then
22663 S := Strval (A);
22665 declare
22666 Slen : constant Natural := Natural (String_Length (S));
22667 Options : String (1 .. Slen);
22668 J : Positive;
22670 begin
22671 -- Couldn't we use a for loop here over Options'Range???
22673 J := 1;
22674 loop
22675 C := Get_String_Char (S, Pos (J));
22677 -- This is a weird test, it skips setting validity
22678 -- checks entirely if any element of S is out of
22679 -- range of Character, what is that about ???
22681 exit when not In_Character_Range (C);
22682 Options (J) := Get_Character (C);
22684 if J = Slen then
22685 Set_Validity_Check_Options (Options);
22686 exit;
22687 else
22688 J := J + 1;
22689 end if;
22690 end loop;
22691 end;
22693 elsif Nkind (A) = N_Identifier then
22694 if Chars (A) = Name_All_Checks then
22695 Set_Validity_Check_Options ("a");
22696 elsif Chars (A) = Name_On then
22697 Validity_Checks_On := True;
22698 elsif Chars (A) = Name_Off then
22699 Validity_Checks_On := False;
22700 end if;
22701 end if;
22702 end if;
22703 end Validity_Checks;
22705 --------------
22706 -- Volatile --
22707 --------------
22709 -- pragma Volatile (LOCAL_NAME);
22711 when Pragma_Volatile =>
22712 Process_Atomic_Independent_Shared_Volatile;
22714 -------------------------
22715 -- Volatile_Components --
22716 -------------------------
22718 -- pragma Volatile_Components (array_LOCAL_NAME);
22720 -- Volatile is handled by the same circuit as Atomic_Components
22722 --------------------------
22723 -- Volatile_Full_Access --
22724 --------------------------
22726 -- pragma Volatile_Full_Access (LOCAL_NAME);
22728 when Pragma_Volatile_Full_Access =>
22729 GNAT_Pragma;
22730 Process_Atomic_Independent_Shared_Volatile;
22732 -----------------------
22733 -- Volatile_Function --
22734 -----------------------
22736 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22738 when Pragma_Volatile_Function => Volatile_Function : declare
22739 Over_Id : Entity_Id;
22740 Spec_Id : Entity_Id;
22741 Subp_Decl : Node_Id;
22743 begin
22744 GNAT_Pragma;
22745 Check_No_Identifiers;
22746 Check_At_Most_N_Arguments (1);
22748 Subp_Decl :=
22749 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
22751 -- Generic subprogram
22753 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
22754 null;
22756 -- Body acts as spec
22758 elsif Nkind (Subp_Decl) = N_Subprogram_Body
22759 and then No (Corresponding_Spec (Subp_Decl))
22760 then
22761 null;
22763 -- Body stub acts as spec
22765 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
22766 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
22767 then
22768 null;
22770 -- Subprogram
22772 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
22773 null;
22775 else
22776 Pragma_Misplaced;
22777 return;
22778 end if;
22780 Spec_Id := Unique_Defining_Entity (Subp_Decl);
22782 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
22783 Pragma_Misplaced;
22784 return;
22785 end if;
22787 -- Chain the pragma on the contract for completeness
22789 Add_Contract_Item (N, Spec_Id);
22791 -- The legality checks of pragma Volatile_Function are affected by
22792 -- the SPARK mode in effect. Analyze all pragmas in a specific
22793 -- order.
22795 Analyze_If_Present (Pragma_SPARK_Mode);
22797 -- A pragma that applies to a Ghost entity becomes Ghost for the
22798 -- purposes of legality checks and removal of ignored Ghost code.
22800 Mark_Pragma_As_Ghost (N, Spec_Id);
22802 -- A volatile function cannot override a non-volatile function
22803 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22804 -- in New_Overloaded_Entity, however at that point the pragma has
22805 -- not been processed yet.
22807 Over_Id := Overridden_Operation (Spec_Id);
22809 if Present (Over_Id)
22810 and then not Is_Volatile_Function (Over_Id)
22811 then
22812 Error_Msg_N
22813 ("incompatible volatile function values in effect", Spec_Id);
22815 Error_Msg_Sloc := Sloc (Over_Id);
22816 Error_Msg_N
22817 ("\& declared # with Volatile_Function value False",
22818 Spec_Id);
22820 Error_Msg_Sloc := Sloc (Spec_Id);
22821 Error_Msg_N
22822 ("\overridden # with Volatile_Function value True",
22823 Spec_Id);
22824 end if;
22826 -- Analyze the Boolean expression (if any)
22828 if Present (Arg1) then
22829 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
22830 end if;
22831 end Volatile_Function;
22833 ----------------------
22834 -- Warning_As_Error --
22835 ----------------------
22837 -- pragma Warning_As_Error (static_string_EXPRESSION);
22839 when Pragma_Warning_As_Error =>
22840 GNAT_Pragma;
22841 Check_Arg_Count (1);
22842 Check_No_Identifiers;
22843 Check_Valid_Configuration_Pragma;
22845 if not Is_Static_String_Expression (Arg1) then
22846 Error_Pragma_Arg
22847 ("argument of pragma% must be static string expression",
22848 Arg1);
22850 -- OK static string expression
22852 else
22853 Acquire_Warning_Match_String (Arg1);
22854 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
22855 Warnings_As_Errors (Warnings_As_Errors_Count) :=
22856 new String'(Name_Buffer (1 .. Name_Len));
22857 end if;
22859 --------------
22860 -- Warnings --
22861 --------------
22863 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
22865 -- DETAILS ::= On | Off
22866 -- DETAILS ::= On | Off, local_NAME
22867 -- DETAILS ::= static_string_EXPRESSION
22868 -- DETAILS ::= On | Off, static_string_EXPRESSION
22870 -- TOOL_NAME ::= GNAT | GNATProve
22872 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
22874 -- Note: If the first argument matches an allowed tool name, it is
22875 -- always considered to be a tool name, even if there is a string
22876 -- variable of that name.
22878 -- Note if the second argument of DETAILS is a local_NAME then the
22879 -- second form is always understood. If the intention is to use
22880 -- the fourth form, then you can write NAME & "" to force the
22881 -- intepretation as a static_string_EXPRESSION.
22883 when Pragma_Warnings => Warnings : declare
22884 Reason : String_Id;
22886 begin
22887 GNAT_Pragma;
22888 Check_At_Least_N_Arguments (1);
22890 -- See if last argument is labeled Reason. If so, make sure we
22891 -- have a string literal or a concatenation of string literals,
22892 -- and acquire the REASON string. Then remove the REASON argument
22893 -- by decreasing Num_Args by one; Remaining processing looks only
22894 -- at first Num_Args arguments).
22896 declare
22897 Last_Arg : constant Node_Id :=
22898 Last (Pragma_Argument_Associations (N));
22900 begin
22901 if Nkind (Last_Arg) = N_Pragma_Argument_Association
22902 and then Chars (Last_Arg) = Name_Reason
22903 then
22904 Start_String;
22905 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
22906 Reason := End_String;
22907 Arg_Count := Arg_Count - 1;
22909 -- Not allowed in compiler units (bootstrap issues)
22911 Check_Compiler_Unit ("Reason for pragma Warnings", N);
22913 -- No REASON string, set null string as reason
22915 else
22916 Reason := Null_String_Id;
22917 end if;
22918 end;
22920 -- Now proceed with REASON taken care of and eliminated
22922 Check_No_Identifiers;
22924 -- If debug flag -gnatd.i is set, pragma is ignored
22926 if Debug_Flag_Dot_I then
22927 return;
22928 end if;
22930 -- Process various forms of the pragma
22932 declare
22933 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22934 Shifted_Args : List_Id;
22936 begin
22937 -- See if first argument is a tool name, currently either
22938 -- GNAT or GNATprove. If so, either ignore the pragma if the
22939 -- tool used does not match, or continue as if no tool name
22940 -- was given otherwise, by shifting the arguments.
22942 if Nkind (Argx) = N_Identifier
22943 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
22944 then
22945 if Chars (Argx) = Name_Gnat then
22946 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
22947 Rewrite (N, Make_Null_Statement (Loc));
22948 Analyze (N);
22949 raise Pragma_Exit;
22950 end if;
22952 elsif Chars (Argx) = Name_Gnatprove then
22953 if not GNATprove_Mode then
22954 Rewrite (N, Make_Null_Statement (Loc));
22955 Analyze (N);
22956 raise Pragma_Exit;
22957 end if;
22959 else
22960 raise Program_Error;
22961 end if;
22963 -- At this point, the pragma Warnings applies to the tool,
22964 -- so continue with shifted arguments.
22966 Arg_Count := Arg_Count - 1;
22968 if Arg_Count = 1 then
22969 Shifted_Args := New_List (New_Copy (Arg2));
22970 elsif Arg_Count = 2 then
22971 Shifted_Args := New_List (New_Copy (Arg2),
22972 New_Copy (Arg3));
22973 elsif Arg_Count = 3 then
22974 Shifted_Args := New_List (New_Copy (Arg2),
22975 New_Copy (Arg3),
22976 New_Copy (Arg4));
22977 else
22978 raise Program_Error;
22979 end if;
22981 Rewrite (N,
22982 Make_Pragma (Loc,
22983 Chars => Name_Warnings,
22984 Pragma_Argument_Associations => Shifted_Args));
22985 Analyze (N);
22986 raise Pragma_Exit;
22987 end if;
22989 -- One argument case
22991 if Arg_Count = 1 then
22993 -- On/Off one argument case was processed by parser
22995 if Nkind (Argx) = N_Identifier
22996 and then Nam_In (Chars (Argx), Name_On, Name_Off)
22997 then
22998 null;
23000 -- One argument case must be ON/OFF or static string expr
23002 elsif not Is_Static_String_Expression (Arg1) then
23003 Error_Pragma_Arg
23004 ("argument of pragma% must be On/Off or static string "
23005 & "expression", Arg1);
23007 -- One argument string expression case
23009 else
23010 declare
23011 Lit : constant Node_Id := Expr_Value_S (Argx);
23012 Str : constant String_Id := Strval (Lit);
23013 Len : constant Nat := String_Length (Str);
23014 C : Char_Code;
23015 J : Nat;
23016 OK : Boolean;
23017 Chr : Character;
23019 begin
23020 J := 1;
23021 while J <= Len loop
23022 C := Get_String_Char (Str, J);
23023 OK := In_Character_Range (C);
23025 if OK then
23026 Chr := Get_Character (C);
23028 -- Dash case: only -Wxxx is accepted
23030 if J = 1
23031 and then J < Len
23032 and then Chr = '-'
23033 then
23034 J := J + 1;
23035 C := Get_String_Char (Str, J);
23036 Chr := Get_Character (C);
23037 exit when Chr = 'W';
23038 OK := False;
23040 -- Dot case
23042 elsif J < Len and then Chr = '.' then
23043 J := J + 1;
23044 C := Get_String_Char (Str, J);
23045 Chr := Get_Character (C);
23047 if not Set_Dot_Warning_Switch (Chr) then
23048 Error_Pragma_Arg
23049 ("invalid warning switch character "
23050 & '.' & Chr, Arg1);
23051 end if;
23053 -- Non-Dot case
23055 else
23056 OK := Set_Warning_Switch (Chr);
23057 end if;
23058 end if;
23060 if not OK then
23061 Error_Pragma_Arg
23062 ("invalid warning switch character " & Chr,
23063 Arg1);
23064 end if;
23066 J := J + 1;
23067 end loop;
23068 end;
23069 end if;
23071 -- Two or more arguments (must be two)
23073 else
23074 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23075 Check_Arg_Count (2);
23077 declare
23078 E_Id : Node_Id;
23079 E : Entity_Id;
23080 Err : Boolean;
23082 begin
23083 E_Id := Get_Pragma_Arg (Arg2);
23084 Analyze (E_Id);
23086 -- In the expansion of an inlined body, a reference to
23087 -- the formal may be wrapped in a conversion if the
23088 -- actual is a conversion. Retrieve the real entity name.
23090 if (In_Instance_Body or In_Inlined_Body)
23091 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23092 then
23093 E_Id := Expression (E_Id);
23094 end if;
23096 -- Entity name case
23098 if Is_Entity_Name (E_Id) then
23099 E := Entity (E_Id);
23101 if E = Any_Id then
23102 return;
23103 else
23104 loop
23105 Set_Warnings_Off
23106 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23107 Name_Off));
23109 -- For OFF case, make entry in warnings off
23110 -- pragma table for later processing. But we do
23111 -- not do that within an instance, since these
23112 -- warnings are about what is needed in the
23113 -- template, not an instance of it.
23115 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23116 and then Warn_On_Warnings_Off
23117 and then not In_Instance
23118 then
23119 Warnings_Off_Pragmas.Append ((N, E, Reason));
23120 end if;
23122 if Is_Enumeration_Type (E) then
23123 declare
23124 Lit : Entity_Id;
23125 begin
23126 Lit := First_Literal (E);
23127 while Present (Lit) loop
23128 Set_Warnings_Off (Lit);
23129 Next_Literal (Lit);
23130 end loop;
23131 end;
23132 end if;
23134 exit when No (Homonym (E));
23135 E := Homonym (E);
23136 end loop;
23137 end if;
23139 -- Error if not entity or static string expression case
23141 elsif not Is_Static_String_Expression (Arg2) then
23142 Error_Pragma_Arg
23143 ("second argument of pragma% must be entity name "
23144 & "or static string expression", Arg2);
23146 -- Static string expression case
23148 else
23149 Acquire_Warning_Match_String (Arg2);
23151 -- Note on configuration pragma case: If this is a
23152 -- configuration pragma, then for an OFF pragma, we
23153 -- just set Config True in the call, which is all
23154 -- that needs to be done. For the case of ON, this
23155 -- is normally an error, unless it is canceling the
23156 -- effect of a previous OFF pragma in the same file.
23157 -- In any other case, an error will be signalled (ON
23158 -- with no matching OFF).
23160 -- Note: We set Used if we are inside a generic to
23161 -- disable the test that the non-config case actually
23162 -- cancels a warning. That's because we can't be sure
23163 -- there isn't an instantiation in some other unit
23164 -- where a warning is suppressed.
23166 -- We could do a little better here by checking if the
23167 -- generic unit we are inside is public, but for now
23168 -- we don't bother with that refinement.
23170 if Chars (Argx) = Name_Off then
23171 Set_Specific_Warning_Off
23172 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23173 Config => Is_Configuration_Pragma,
23174 Used => Inside_A_Generic or else In_Instance);
23176 elsif Chars (Argx) = Name_On then
23177 Set_Specific_Warning_On
23178 (Loc, Name_Buffer (1 .. Name_Len), Err);
23180 if Err then
23181 Error_Msg
23182 ("??pragma Warnings On with no matching "
23183 & "Warnings Off", Loc);
23184 end if;
23185 end if;
23186 end if;
23187 end;
23188 end if;
23189 end;
23190 end Warnings;
23192 -------------------
23193 -- Weak_External --
23194 -------------------
23196 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23198 when Pragma_Weak_External => Weak_External : declare
23199 Ent : Entity_Id;
23201 begin
23202 GNAT_Pragma;
23203 Check_Arg_Count (1);
23204 Check_Optional_Identifier (Arg1, Name_Entity);
23205 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23206 Ent := Entity (Get_Pragma_Arg (Arg1));
23208 if Rep_Item_Too_Early (Ent, N) then
23209 return;
23210 else
23211 Ent := Underlying_Type (Ent);
23212 end if;
23214 -- The only processing required is to link this item on to the
23215 -- list of rep items for the given entity. This is accomplished
23216 -- by the call to Rep_Item_Too_Late (when no error is detected
23217 -- and False is returned).
23219 if Rep_Item_Too_Late (Ent, N) then
23220 return;
23221 else
23222 Set_Has_Gigi_Rep_Item (Ent);
23223 end if;
23224 end Weak_External;
23226 -----------------------------
23227 -- Wide_Character_Encoding --
23228 -----------------------------
23230 -- pragma Wide_Character_Encoding (IDENTIFIER);
23232 when Pragma_Wide_Character_Encoding =>
23233 GNAT_Pragma;
23235 -- Nothing to do, handled in parser. Note that we do not enforce
23236 -- configuration pragma placement, this pragma can appear at any
23237 -- place in the source, allowing mixed encodings within a single
23238 -- source program.
23240 null;
23242 --------------------
23243 -- Unknown_Pragma --
23244 --------------------
23246 -- Should be impossible, since the case of an unknown pragma is
23247 -- separately processed before the case statement is entered.
23249 when Unknown_Pragma =>
23250 raise Program_Error;
23251 end case;
23253 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23254 -- until AI is formally approved.
23256 -- Check_Order_Dependence;
23258 exception
23259 when Pragma_Exit => null;
23260 end Analyze_Pragma;
23262 ---------------------------------------------
23263 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23264 ---------------------------------------------
23266 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23267 (N : Node_Id;
23268 Freeze_Id : Entity_Id := Empty)
23270 -- Local variables
23272 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23273 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23274 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23276 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23278 Errors : Nat;
23279 Disp_Typ : Entity_Id;
23280 Restore_Scope : Boolean := False;
23282 function Check_References (N : Node_Id) return Traverse_Result;
23283 -- Check that the expression does not mention non-primitives of
23284 -- the type, global objects of the type, or other illegalities
23285 -- described and implied by AI12-0113.
23287 ----------------------
23288 -- Check_References --
23289 ----------------------
23291 function Check_References (N : Node_Id) return Traverse_Result is
23292 begin
23293 if Nkind (N) = N_Function_Call
23294 and then Is_Entity_Name (Name (N))
23295 then
23296 declare
23297 Func : constant Entity_Id := Entity (Name (N));
23298 Form : Entity_Id;
23299 begin
23301 -- An operation of the type must be a primitive.
23303 if No (Find_Dispatching_Type (Func)) then
23304 Form := First_Formal (Func);
23305 while Present (Form) loop
23306 if Etype (Form) = Disp_Typ then
23307 Error_Msg_NE ("operation in class-wide condition "
23308 & "must be primitive of&", N, Disp_Typ);
23309 end if;
23310 Next_Formal (Form);
23311 end loop;
23313 -- A return object of the type is illegal as well.
23315 if Etype (Func) = Disp_Typ
23316 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23317 then
23318 Error_Msg_NE ("operation in class-wide condition "
23319 & "must be primitive of&", N, Disp_Typ);
23320 end if;
23321 end if;
23322 end;
23324 elsif Is_Entity_Name (N)
23325 and then
23326 (Etype (N) = Disp_Typ
23327 or else Etype (N) = Class_Wide_Type (Disp_Typ))
23328 and then Ekind_In (Entity (N), E_Variable, E_Constant)
23329 then
23330 Error_Msg_NE
23331 ("object in class-wide condition must be formal of type&",
23332 N, Disp_Typ);
23334 elsif Nkind (N) = N_Explicit_Dereference
23335 and then (Etype (N) = Disp_Typ
23336 or else Etype (N) = Class_Wide_Type (Disp_Typ))
23337 and then (not Is_Entity_Name (Prefix (N))
23338 or else not Is_Formal (Entity (Prefix (N))))
23339 then
23340 Error_Msg_NE ("operation in class-wide condition "
23341 & "must be primitive of&", N, Disp_Typ);
23342 end if;
23344 return OK;
23345 end Check_References;
23347 procedure Check_Class_Wide_Condition is new
23348 Traverse_Proc (Check_References);
23350 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23352 begin
23353 -- Do not analyze the pragma multiple times
23355 if Is_Analyzed_Pragma (N) then
23356 return;
23357 end if;
23359 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23360 -- analysis of the pragma, the Ghost mode at point of declaration and
23361 -- point of analysis may not necessarily be the same. Use the mode in
23362 -- effect at the point of declaration.
23364 Set_Ghost_Mode (N);
23366 -- Ensure that the subprogram and its formals are visible when analyzing
23367 -- the expression of the pragma.
23369 if not In_Open_Scopes (Spec_Id) then
23370 Restore_Scope := True;
23371 Push_Scope (Spec_Id);
23373 if Is_Generic_Subprogram (Spec_Id) then
23374 Install_Generic_Formals (Spec_Id);
23375 else
23376 Install_Formals (Spec_Id);
23377 end if;
23378 end if;
23380 Errors := Serious_Errors_Detected;
23381 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23383 -- Emit a clarification message when the expression contains at least
23384 -- one undefined reference, possibly due to contract "freezing".
23386 if Errors /= Serious_Errors_Detected
23387 and then Present (Freeze_Id)
23388 and then Has_Undefined_Reference (Expr)
23389 then
23390 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23391 end if;
23393 if Class_Present (N) then
23395 -- Verify that a class-wide condition is legal, i.e. the operation is
23396 -- a primitive of a tagged type. Note that a generic subprogram is
23397 -- not a primitive operation.
23399 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23401 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23402 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23404 if From_Aspect_Specification (N) then
23405 Error_Msg_N
23406 ("aspect % can only be specified for a primitive operation "
23407 & "of a tagged type", Corresponding_Aspect (N));
23409 -- The pragma is a source construct
23411 else
23412 Error_Msg_N
23413 ("pragma % can only be specified for a primitive operation "
23414 & "of a tagged type", N);
23415 end if;
23417 else
23418 -- Remaining semantic checks require a full tree traversal.
23420 Check_Class_Wide_Condition (Expr);
23421 end if;
23423 end if;
23425 if Restore_Scope then
23426 End_Scope;
23427 end if;
23429 -- Currently it is not possible to inline pre/postconditions on a
23430 -- subprogram subject to pragma Inline_Always.
23432 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23433 Ghost_Mode := Save_Ghost_Mode;
23435 Set_Is_Analyzed_Pragma (N);
23436 end Analyze_Pre_Post_Condition_In_Decl_Part;
23438 ------------------------------------------
23439 -- Analyze_Refined_Depends_In_Decl_Part --
23440 ------------------------------------------
23442 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23443 Body_Inputs : Elist_Id := No_Elist;
23444 Body_Outputs : Elist_Id := No_Elist;
23445 -- The inputs and outputs of the subprogram body synthesized from pragma
23446 -- Refined_Depends.
23448 Dependencies : List_Id := No_List;
23449 Depends : Node_Id;
23450 -- The corresponding Depends pragma along with its clauses
23452 Matched_Items : Elist_Id := No_Elist;
23453 -- A list containing the entities of all successfully matched items
23454 -- found in pragma Depends.
23456 Refinements : List_Id := No_List;
23457 -- The clauses of pragma Refined_Depends
23459 Spec_Id : Entity_Id;
23460 -- The entity of the subprogram subject to pragma Refined_Depends
23462 Spec_Inputs : Elist_Id := No_Elist;
23463 Spec_Outputs : Elist_Id := No_Elist;
23464 -- The inputs and outputs of the subprogram spec synthesized from pragma
23465 -- Depends.
23467 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23468 -- Try to match a single dependency clause Dep_Clause against one or
23469 -- more refinement clauses found in list Refinements. Each successful
23470 -- match eliminates at least one refinement clause from Refinements.
23472 procedure Check_Output_States;
23473 -- Determine whether pragma Depends contains an output state with a
23474 -- visible refinement and if so, ensure that pragma Refined_Depends
23475 -- mentions all its constituents as outputs.
23477 procedure Normalize_Clauses (Clauses : List_Id);
23478 -- Given a list of dependence or refinement clauses Clauses, normalize
23479 -- each clause by creating multiple dependencies with exactly one input
23480 -- and one output.
23482 procedure Report_Extra_Clauses;
23483 -- Emit an error for each extra clause found in list Refinements
23485 -----------------------------
23486 -- Check_Dependency_Clause --
23487 -----------------------------
23489 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23490 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23491 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23493 function Is_In_Out_State_Clause return Boolean;
23494 -- Determine whether dependence clause Dep_Clause denotes an abstract
23495 -- state that depends on itself (State => State).
23497 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23498 -- Determine whether item Item denotes an abstract state with visible
23499 -- null refinement.
23501 procedure Match_Items
23502 (Dep_Item : Node_Id;
23503 Ref_Item : Node_Id;
23504 Matched : out Boolean);
23505 -- Try to match dependence item Dep_Item against refinement item
23506 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23507 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23508 -- the following conformance scenarios is in effect:
23509 -- 1) Both items denote null
23510 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23511 -- 3) Both items denote attribute 'Result
23512 -- 4) Both items denote the same object
23513 -- 5) Both items denote the same formal parameter
23514 -- 6) Both items denote the same current instance of a type
23515 -- 7) Both items denote the same discriminant
23516 -- 8) Dep_Item is an abstract state with visible null refinement
23517 -- and Ref_Item denotes null.
23518 -- 9) Dep_Item is an abstract state with visible null refinement
23519 -- and Ref_Item is Empty (special case).
23520 -- 10) Dep_Item is an abstract state with visible non-null
23521 -- refinement and Ref_Item denotes one of its constituents.
23522 -- 11) Dep_Item is an abstract state without a visible refinement
23523 -- and Ref_Item denotes the same state.
23524 -- When scenario 10 is in effect, the entity of the abstract state
23525 -- denoted by Dep_Item is added to list Refined_States.
23527 procedure Record_Item (Item_Id : Entity_Id);
23528 -- Store the entity of an item denoted by Item_Id in Matched_Items
23530 ----------------------------
23531 -- Is_In_Out_State_Clause --
23532 ----------------------------
23534 function Is_In_Out_State_Clause return Boolean is
23535 Dep_Input_Id : Entity_Id;
23536 Dep_Output_Id : Entity_Id;
23538 begin
23539 -- Detect the following clause:
23540 -- State => State
23542 if Is_Entity_Name (Dep_Input)
23543 and then Is_Entity_Name (Dep_Output)
23544 then
23545 -- Handle abstract views generated for limited with clauses
23547 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
23548 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
23550 return
23551 Ekind (Dep_Input_Id) = E_Abstract_State
23552 and then Dep_Input_Id = Dep_Output_Id;
23553 else
23554 return False;
23555 end if;
23556 end Is_In_Out_State_Clause;
23558 ---------------------------
23559 -- Is_Null_Refined_State --
23560 ---------------------------
23562 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
23563 Item_Id : Entity_Id;
23565 begin
23566 if Is_Entity_Name (Item) then
23568 -- Handle abstract views generated for limited with clauses
23570 Item_Id := Available_View (Entity_Of (Item));
23572 return
23573 Ekind (Item_Id) = E_Abstract_State
23574 and then Has_Null_Visible_Refinement (Item_Id);
23575 else
23576 return False;
23577 end if;
23578 end Is_Null_Refined_State;
23580 -----------------
23581 -- Match_Items --
23582 -----------------
23584 procedure Match_Items
23585 (Dep_Item : Node_Id;
23586 Ref_Item : Node_Id;
23587 Matched : out Boolean)
23589 Dep_Item_Id : Entity_Id;
23590 Ref_Item_Id : Entity_Id;
23592 begin
23593 -- Assume that the two items do not match
23595 Matched := False;
23597 -- A null matches null or Empty (special case)
23599 if Nkind (Dep_Item) = N_Null
23600 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23601 then
23602 Matched := True;
23604 -- Attribute 'Result matches attribute 'Result
23606 elsif Is_Attribute_Result (Dep_Item)
23607 and then Is_Attribute_Result (Dep_Item)
23608 then
23609 Matched := True;
23611 -- Abstract states, current instances of concurrent types,
23612 -- discriminants, formal parameters and objects.
23614 elsif Is_Entity_Name (Dep_Item) then
23616 -- Handle abstract views generated for limited with clauses
23618 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
23620 if Ekind (Dep_Item_Id) = E_Abstract_State then
23622 -- An abstract state with visible null refinement matches
23623 -- null or Empty (special case).
23625 if Has_Null_Visible_Refinement (Dep_Item_Id)
23626 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23627 then
23628 Record_Item (Dep_Item_Id);
23629 Matched := True;
23631 -- An abstract state with visible non-null refinement
23632 -- matches one of its constituents.
23634 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
23635 if Is_Entity_Name (Ref_Item) then
23636 Ref_Item_Id := Entity_Of (Ref_Item);
23638 if Ekind_In (Ref_Item_Id, E_Abstract_State,
23639 E_Constant,
23640 E_Variable)
23641 and then Present (Encapsulating_State (Ref_Item_Id))
23642 and then Encapsulating_State (Ref_Item_Id) =
23643 Dep_Item_Id
23644 then
23645 Record_Item (Dep_Item_Id);
23646 Matched := True;
23647 end if;
23648 end if;
23650 -- An abstract state without a visible refinement matches
23651 -- itself.
23653 elsif Is_Entity_Name (Ref_Item)
23654 and then Entity_Of (Ref_Item) = Dep_Item_Id
23655 then
23656 Record_Item (Dep_Item_Id);
23657 Matched := True;
23658 end if;
23660 -- A current instance of a concurrent type, discriminant,
23661 -- formal parameter or an object matches itself.
23663 elsif Is_Entity_Name (Ref_Item)
23664 and then Entity_Of (Ref_Item) = Dep_Item_Id
23665 then
23666 Record_Item (Dep_Item_Id);
23667 Matched := True;
23668 end if;
23669 end if;
23670 end Match_Items;
23672 -----------------
23673 -- Record_Item --
23674 -----------------
23676 procedure Record_Item (Item_Id : Entity_Id) is
23677 begin
23678 if not Contains (Matched_Items, Item_Id) then
23679 Append_New_Elmt (Item_Id, Matched_Items);
23680 end if;
23681 end Record_Item;
23683 -- Local variables
23685 Clause_Matched : Boolean := False;
23686 Dummy : Boolean := False;
23687 Inputs_Match : Boolean;
23688 Next_Ref_Clause : Node_Id;
23689 Outputs_Match : Boolean;
23690 Ref_Clause : Node_Id;
23691 Ref_Input : Node_Id;
23692 Ref_Output : Node_Id;
23694 -- Start of processing for Check_Dependency_Clause
23696 begin
23697 -- Do not perform this check in an instance because it was already
23698 -- performed successfully in the generic template.
23700 if Is_Generic_Instance (Spec_Id) then
23701 return;
23702 end if;
23704 -- Examine all refinement clauses and compare them against the
23705 -- dependence clause.
23707 Ref_Clause := First (Refinements);
23708 while Present (Ref_Clause) loop
23709 Next_Ref_Clause := Next (Ref_Clause);
23711 -- Obtain the attributes of the current refinement clause
23713 Ref_Input := Expression (Ref_Clause);
23714 Ref_Output := First (Choices (Ref_Clause));
23716 -- The current refinement clause matches the dependence clause
23717 -- when both outputs match and both inputs match. See routine
23718 -- Match_Items for all possible conformance scenarios.
23720 -- Depends Dep_Output => Dep_Input
23721 -- ^ ^
23722 -- match ? match ?
23723 -- v v
23724 -- Refined_Depends Ref_Output => Ref_Input
23726 Match_Items
23727 (Dep_Item => Dep_Input,
23728 Ref_Item => Ref_Input,
23729 Matched => Inputs_Match);
23731 Match_Items
23732 (Dep_Item => Dep_Output,
23733 Ref_Item => Ref_Output,
23734 Matched => Outputs_Match);
23736 -- An In_Out state clause may be matched against a refinement with
23737 -- a null input or null output as long as the non-null side of the
23738 -- relation contains a valid constituent of the In_Out_State.
23740 if Is_In_Out_State_Clause then
23742 -- Depends => (State => State)
23743 -- Refined_Depends => (null => Constit) -- OK
23745 if Inputs_Match
23746 and then not Outputs_Match
23747 and then Nkind (Ref_Output) = N_Null
23748 then
23749 Outputs_Match := True;
23750 end if;
23752 -- Depends => (State => State)
23753 -- Refined_Depends => (Constit => null) -- OK
23755 if not Inputs_Match
23756 and then Outputs_Match
23757 and then Nkind (Ref_Input) = N_Null
23758 then
23759 Inputs_Match := True;
23760 end if;
23761 end if;
23763 -- The current refinement clause is legally constructed following
23764 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23765 -- the pool of candidates. The seach continues because a single
23766 -- dependence clause may have multiple matching refinements.
23768 if Inputs_Match and Outputs_Match then
23769 Clause_Matched := True;
23770 Remove (Ref_Clause);
23771 end if;
23773 Ref_Clause := Next_Ref_Clause;
23774 end loop;
23776 -- Depending on the order or composition of refinement clauses, an
23777 -- In_Out state clause may not be directly refinable.
23779 -- Depends => ((Output, State) => (Input, State))
23780 -- Refined_State => (State => (Constit_1, Constit_2))
23781 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23783 -- Matching normalized clause (State => State) fails because there is
23784 -- no direct refinement capable of satisfying this relation. Another
23785 -- similar case arises when clauses (Constit_1 => Input) and (Output
23786 -- => Constit_2) are matched first, leaving no candidates for clause
23787 -- (State => State). Both scenarios are legal as long as one of the
23788 -- previous clauses mentioned a valid constituent of State.
23790 if not Clause_Matched
23791 and then Is_In_Out_State_Clause
23792 and then
23793 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23794 then
23795 Clause_Matched := True;
23796 end if;
23798 -- A clause where the input is an abstract state with visible null
23799 -- refinement is implicitly matched when the output has already been
23800 -- matched in a previous clause.
23802 -- Depends => (Output => State) -- implicitly OK
23803 -- Refined_State => (State => null)
23804 -- Refined_Depends => (Output => ...)
23806 if not Clause_Matched
23807 and then Is_Null_Refined_State (Dep_Input)
23808 and then Is_Entity_Name (Dep_Output)
23809 and then
23810 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
23811 then
23812 Clause_Matched := True;
23813 end if;
23815 -- A clause where the output is an abstract state with visible null
23816 -- refinement is implicitly matched when the input has already been
23817 -- matched in a previous clause.
23819 -- Depends => (State => Input) -- implicitly OK
23820 -- Refined_State => (State => null)
23821 -- Refined_Depends => (... => Input)
23823 if not Clause_Matched
23824 and then Is_Null_Refined_State (Dep_Output)
23825 and then Is_Entity_Name (Dep_Input)
23826 and then
23827 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23828 then
23829 Clause_Matched := True;
23830 end if;
23832 -- At this point either all refinement clauses have been examined or
23833 -- pragma Refined_Depends contains a solitary null. Only an abstract
23834 -- state with null refinement can possibly match these cases.
23836 -- Depends => (State => null)
23837 -- Refined_State => (State => null)
23838 -- Refined_Depends => null -- OK
23840 if not Clause_Matched then
23841 Match_Items
23842 (Dep_Item => Dep_Input,
23843 Ref_Item => Empty,
23844 Matched => Inputs_Match);
23846 Match_Items
23847 (Dep_Item => Dep_Output,
23848 Ref_Item => Empty,
23849 Matched => Outputs_Match);
23851 Clause_Matched := Inputs_Match and Outputs_Match;
23852 end if;
23854 -- If the contents of Refined_Depends are legal, then the current
23855 -- dependence clause should be satisfied either by an explicit match
23856 -- or by one of the special cases.
23858 if not Clause_Matched then
23859 SPARK_Msg_NE
23860 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
23861 & "matching refinement in body"), Dep_Clause, Spec_Id);
23862 end if;
23863 end Check_Dependency_Clause;
23865 -------------------------
23866 -- Check_Output_States --
23867 -------------------------
23869 procedure Check_Output_States is
23870 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23871 -- Determine whether all constituents of state State_Id with visible
23872 -- refinement are used as outputs in pragma Refined_Depends. Emit an
23873 -- error if this is not the case.
23875 -----------------------------
23876 -- Check_Constituent_Usage --
23877 -----------------------------
23879 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23880 Constits : constant Elist_Id :=
23881 Refinement_Constituents (State_Id);
23882 Constit_Elmt : Elmt_Id;
23883 Constit_Id : Entity_Id;
23884 Posted : Boolean := False;
23886 begin
23887 if Present (Constits) then
23888 Constit_Elmt := First_Elmt (Constits);
23889 while Present (Constit_Elmt) loop
23890 Constit_Id := Node (Constit_Elmt);
23892 -- The constituent acts as an input (SPARK RM 7.2.5(3))
23894 if Present (Body_Inputs)
23895 and then Appears_In (Body_Inputs, Constit_Id)
23896 then
23897 Error_Msg_Name_1 := Chars (State_Id);
23898 SPARK_Msg_NE
23899 ("constituent & of state % must act as output in "
23900 & "dependence refinement", N, Constit_Id);
23902 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23904 elsif No (Body_Outputs)
23905 or else not Appears_In (Body_Outputs, Constit_Id)
23906 then
23907 if not Posted then
23908 Posted := True;
23909 SPARK_Msg_NE
23910 ("output state & must be replaced by all its "
23911 & "constituents in dependence refinement",
23912 N, State_Id);
23913 end if;
23915 SPARK_Msg_NE
23916 ("\constituent & is missing in output list",
23917 N, Constit_Id);
23918 end if;
23920 Next_Elmt (Constit_Elmt);
23921 end loop;
23922 end if;
23923 end Check_Constituent_Usage;
23925 -- Local variables
23927 Item : Node_Id;
23928 Item_Elmt : Elmt_Id;
23929 Item_Id : Entity_Id;
23931 -- Start of processing for Check_Output_States
23933 begin
23934 -- Do not perform this check in an instance because it was already
23935 -- performed successfully in the generic template.
23937 if Is_Generic_Instance (Spec_Id) then
23938 null;
23940 -- Inspect the outputs of pragma Depends looking for a state with a
23941 -- visible refinement.
23943 elsif Present (Spec_Outputs) then
23944 Item_Elmt := First_Elmt (Spec_Outputs);
23945 while Present (Item_Elmt) loop
23946 Item := Node (Item_Elmt);
23948 -- Deal with the mixed nature of the input and output lists
23950 if Nkind (Item) = N_Defining_Identifier then
23951 Item_Id := Item;
23952 else
23953 Item_Id := Available_View (Entity_Of (Item));
23954 end if;
23956 if Ekind (Item_Id) = E_Abstract_State then
23958 -- The state acts as an input-output, skip it
23960 if Present (Spec_Inputs)
23961 and then Appears_In (Spec_Inputs, Item_Id)
23962 then
23963 null;
23965 -- Ensure that all of the constituents are utilized as
23966 -- outputs in pragma Refined_Depends.
23968 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
23969 Check_Constituent_Usage (Item_Id);
23970 end if;
23971 end if;
23973 Next_Elmt (Item_Elmt);
23974 end loop;
23975 end if;
23976 end Check_Output_States;
23978 -----------------------
23979 -- Normalize_Clauses --
23980 -----------------------
23982 procedure Normalize_Clauses (Clauses : List_Id) is
23983 procedure Normalize_Inputs (Clause : Node_Id);
23984 -- Normalize clause Clause by creating multiple clauses for each
23985 -- input item of Clause. It is assumed that Clause has exactly one
23986 -- output. The transformation is as follows:
23988 -- Output => (Input_1, Input_2) -- original
23990 -- Output => Input_1 -- normalizations
23991 -- Output => Input_2
23993 procedure Normalize_Outputs (Clause : Node_Id);
23994 -- Normalize clause Clause by creating multiple clause for each
23995 -- output item of Clause. The transformation is as follows:
23997 -- (Output_1, Output_2) => Input -- original
23999 -- Output_1 => Input -- normalization
24000 -- Output_2 => Input
24002 ----------------------
24003 -- Normalize_Inputs --
24004 ----------------------
24006 procedure Normalize_Inputs (Clause : Node_Id) is
24007 Inputs : constant Node_Id := Expression (Clause);
24008 Loc : constant Source_Ptr := Sloc (Clause);
24009 Output : constant List_Id := Choices (Clause);
24010 Last_Input : Node_Id;
24011 Input : Node_Id;
24012 New_Clause : Node_Id;
24013 Next_Input : Node_Id;
24015 begin
24016 -- Normalization is performed only when the original clause has
24017 -- more than one input. Multiple inputs appear as an aggregate.
24019 if Nkind (Inputs) = N_Aggregate then
24020 Last_Input := Last (Expressions (Inputs));
24022 -- Create a new clause for each input
24024 Input := First (Expressions (Inputs));
24025 while Present (Input) loop
24026 Next_Input := Next (Input);
24028 -- Unhook the current input from the original input list
24029 -- because it will be relocated to a new clause.
24031 Remove (Input);
24033 -- Special processing for the last input. At this point the
24034 -- original aggregate has been stripped down to one element.
24035 -- Replace the aggregate by the element itself.
24037 if Input = Last_Input then
24038 Rewrite (Inputs, Input);
24040 -- Generate a clause of the form:
24041 -- Output => Input
24043 else
24044 New_Clause :=
24045 Make_Component_Association (Loc,
24046 Choices => New_Copy_List_Tree (Output),
24047 Expression => Input);
24049 -- The new clause contains replicated content that has
24050 -- already been analyzed, mark the clause as analyzed.
24052 Set_Analyzed (New_Clause);
24053 Insert_After (Clause, New_Clause);
24054 end if;
24056 Input := Next_Input;
24057 end loop;
24058 end if;
24059 end Normalize_Inputs;
24061 -----------------------
24062 -- Normalize_Outputs --
24063 -----------------------
24065 procedure Normalize_Outputs (Clause : Node_Id) is
24066 Inputs : constant Node_Id := Expression (Clause);
24067 Loc : constant Source_Ptr := Sloc (Clause);
24068 Outputs : constant Node_Id := First (Choices (Clause));
24069 Last_Output : Node_Id;
24070 New_Clause : Node_Id;
24071 Next_Output : Node_Id;
24072 Output : Node_Id;
24074 begin
24075 -- Multiple outputs appear as an aggregate. Nothing to do when
24076 -- the clause has exactly one output.
24078 if Nkind (Outputs) = N_Aggregate then
24079 Last_Output := Last (Expressions (Outputs));
24081 -- Create a clause for each output. Note that each time a new
24082 -- clause is created, the original output list slowly shrinks
24083 -- until there is one item left.
24085 Output := First (Expressions (Outputs));
24086 while Present (Output) loop
24087 Next_Output := Next (Output);
24089 -- Unhook the output from the original output list as it
24090 -- will be relocated to a new clause.
24092 Remove (Output);
24094 -- Special processing for the last output. At this point
24095 -- the original aggregate has been stripped down to one
24096 -- element. Replace the aggregate by the element itself.
24098 if Output = Last_Output then
24099 Rewrite (Outputs, Output);
24101 else
24102 -- Generate a clause of the form:
24103 -- (Output => Inputs)
24105 New_Clause :=
24106 Make_Component_Association (Loc,
24107 Choices => New_List (Output),
24108 Expression => New_Copy_Tree (Inputs));
24110 -- The new clause contains replicated content that has
24111 -- already been analyzed. There is not need to reanalyze
24112 -- them.
24114 Set_Analyzed (New_Clause);
24115 Insert_After (Clause, New_Clause);
24116 end if;
24118 Output := Next_Output;
24119 end loop;
24120 end if;
24121 end Normalize_Outputs;
24123 -- Local variables
24125 Clause : Node_Id;
24127 -- Start of processing for Normalize_Clauses
24129 begin
24130 Clause := First (Clauses);
24131 while Present (Clause) loop
24132 Normalize_Outputs (Clause);
24133 Next (Clause);
24134 end loop;
24136 Clause := First (Clauses);
24137 while Present (Clause) loop
24138 Normalize_Inputs (Clause);
24139 Next (Clause);
24140 end loop;
24141 end Normalize_Clauses;
24143 --------------------------
24144 -- Report_Extra_Clauses --
24145 --------------------------
24147 procedure Report_Extra_Clauses is
24148 Clause : Node_Id;
24150 begin
24151 -- Do not perform this check in an instance because it was already
24152 -- performed successfully in the generic template.
24154 if Is_Generic_Instance (Spec_Id) then
24155 null;
24157 elsif Present (Refinements) then
24158 Clause := First (Refinements);
24159 while Present (Clause) loop
24161 -- Do not complain about a null input refinement, since a null
24162 -- input legitimately matches anything.
24164 if Nkind (Clause) = N_Component_Association
24165 and then Nkind (Expression (Clause)) = N_Null
24166 then
24167 null;
24169 else
24170 SPARK_Msg_N
24171 ("unmatched or extra clause in dependence refinement",
24172 Clause);
24173 end if;
24175 Next (Clause);
24176 end loop;
24177 end if;
24178 end Report_Extra_Clauses;
24180 -- Local variables
24182 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24183 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
24184 Errors : constant Nat := Serious_Errors_Detected;
24185 Clause : Node_Id;
24186 Deps : Node_Id;
24187 Dummy : Boolean;
24188 Refs : Node_Id;
24190 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24192 begin
24193 -- Do not analyze the pragma multiple times
24195 if Is_Analyzed_Pragma (N) then
24196 return;
24197 end if;
24199 Spec_Id := Unique_Defining_Entity (Body_Decl);
24201 -- Use the anonymous object as the proper spec when Refined_Depends
24202 -- applies to the body of a single task type. The object carries the
24203 -- proper Chars as well as all non-refined versions of pragmas.
24205 if Is_Single_Concurrent_Type (Spec_Id) then
24206 Spec_Id := Anonymous_Object (Spec_Id);
24207 end if;
24209 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
24211 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24212 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24214 if No (Depends) then
24215 SPARK_Msg_NE
24216 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
24217 & "& lacks aspect or pragma Depends"), N, Spec_Id);
24218 goto Leave;
24219 end if;
24221 Deps := Expression (Get_Argument (Depends, Spec_Id));
24223 -- A null dependency relation renders the refinement useless because it
24224 -- cannot possibly mention abstract states with visible refinement. Note
24225 -- that the inverse is not true as states may be refined to null
24226 -- (SPARK RM 7.2.5(2)).
24228 if Nkind (Deps) = N_Null then
24229 SPARK_Msg_NE
24230 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
24231 & "depend on abstract state with visible refinement"), N, Spec_Id);
24232 goto Leave;
24233 end if;
24235 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24236 -- This ensures that the categorization of all refined dependency items
24237 -- is consistent with their role.
24239 Analyze_Depends_In_Decl_Part (N);
24241 -- Do not match dependencies against refinements if Refined_Depends is
24242 -- illegal to avoid emitting misleading error.
24244 if Serious_Errors_Detected = Errors then
24246 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24247 -- the inputs and outputs of the subprogram spec and body to verify
24248 -- the use of states with visible refinement and their constituents.
24250 if No (Get_Pragma (Spec_Id, Pragma_Global))
24251 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
24252 then
24253 Collect_Subprogram_Inputs_Outputs
24254 (Subp_Id => Spec_Id,
24255 Synthesize => True,
24256 Subp_Inputs => Spec_Inputs,
24257 Subp_Outputs => Spec_Outputs,
24258 Global_Seen => Dummy);
24260 Collect_Subprogram_Inputs_Outputs
24261 (Subp_Id => Body_Id,
24262 Synthesize => True,
24263 Subp_Inputs => Body_Inputs,
24264 Subp_Outputs => Body_Outputs,
24265 Global_Seen => Dummy);
24267 -- For an output state with a visible refinement, ensure that all
24268 -- constituents appear as outputs in the dependency refinement.
24270 Check_Output_States;
24271 end if;
24273 -- Matching is disabled in ASIS because clauses are not normalized as
24274 -- this is a tree altering activity similar to expansion.
24276 if ASIS_Mode then
24277 goto Leave;
24278 end if;
24280 -- Multiple dependency clauses appear as component associations of an
24281 -- aggregate. Note that the clauses are copied because the algorithm
24282 -- modifies them and this should not be visible in Depends.
24284 pragma Assert (Nkind (Deps) = N_Aggregate);
24285 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
24286 Normalize_Clauses (Dependencies);
24288 Refs := Expression (Get_Argument (N, Spec_Id));
24290 if Nkind (Refs) = N_Null then
24291 Refinements := No_List;
24293 -- Multiple dependency clauses appear as component associations of an
24294 -- aggregate. Note that the clauses are copied because the algorithm
24295 -- modifies them and this should not be visible in Refined_Depends.
24297 else pragma Assert (Nkind (Refs) = N_Aggregate);
24298 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
24299 Normalize_Clauses (Refinements);
24300 end if;
24302 -- At this point the clauses of pragmas Depends and Refined_Depends
24303 -- have been normalized into simple dependencies between one output
24304 -- and one input. Examine all clauses of pragma Depends looking for
24305 -- matching clauses in pragma Refined_Depends.
24307 Clause := First (Dependencies);
24308 while Present (Clause) loop
24309 Check_Dependency_Clause (Clause);
24310 Next (Clause);
24311 end loop;
24313 if Serious_Errors_Detected = Errors then
24314 Report_Extra_Clauses;
24315 end if;
24316 end if;
24318 <<Leave>>
24319 Set_Is_Analyzed_Pragma (N);
24320 end Analyze_Refined_Depends_In_Decl_Part;
24322 -----------------------------------------
24323 -- Analyze_Refined_Global_In_Decl_Part --
24324 -----------------------------------------
24326 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
24327 Global : Node_Id;
24328 -- The corresponding Global pragma
24330 Has_In_State : Boolean := False;
24331 Has_In_Out_State : Boolean := False;
24332 Has_Out_State : Boolean := False;
24333 Has_Proof_In_State : Boolean := False;
24334 -- These flags are set when the corresponding Global pragma has a state
24335 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24336 -- refinement.
24338 Has_Null_State : Boolean := False;
24339 -- This flag is set when the corresponding Global pragma has at least
24340 -- one state with a null refinement.
24342 In_Constits : Elist_Id := No_Elist;
24343 In_Out_Constits : Elist_Id := No_Elist;
24344 Out_Constits : Elist_Id := No_Elist;
24345 Proof_In_Constits : Elist_Id := No_Elist;
24346 -- These lists contain the entities of all Input, In_Out, Output and
24347 -- Proof_In constituents that appear in Refined_Global and participate
24348 -- in state refinement.
24350 In_Items : Elist_Id := No_Elist;
24351 In_Out_Items : Elist_Id := No_Elist;
24352 Out_Items : Elist_Id := No_Elist;
24353 Proof_In_Items : Elist_Id := No_Elist;
24354 -- These list contain the entities of all Input, In_Out, Output and
24355 -- Proof_In items defined in the corresponding Global pragma.
24357 Spec_Id : Entity_Id;
24358 -- The entity of the subprogram subject to pragma Refined_Global
24360 States : Elist_Id := No_Elist;
24361 -- A list of all states with visible refinement found in pragma Global
24363 procedure Check_In_Out_States;
24364 -- Determine whether the corresponding Global pragma mentions In_Out
24365 -- states with visible refinement and if so, ensure that one of the
24366 -- following completions apply to the constituents of the state:
24367 -- 1) there is at least one constituent of mode In_Out
24368 -- 2) there is at least one Input and one Output constituent
24369 -- 3) not all constituents are present and one of them is of mode
24370 -- Output.
24371 -- This routine may remove elements from In_Constits, In_Out_Constits,
24372 -- Out_Constits and Proof_In_Constits.
24374 procedure Check_Input_States;
24375 -- Determine whether the corresponding Global pragma mentions Input
24376 -- states with visible refinement and if so, ensure that at least one of
24377 -- its constituents appears as an Input item in Refined_Global.
24378 -- This routine may remove elements from In_Constits, In_Out_Constits,
24379 -- Out_Constits and Proof_In_Constits.
24381 procedure Check_Output_States;
24382 -- Determine whether the corresponding Global pragma mentions Output
24383 -- states with visible refinement and if so, ensure that all of its
24384 -- constituents appear as Output items in Refined_Global.
24385 -- This routine may remove elements from In_Constits, In_Out_Constits,
24386 -- Out_Constits and Proof_In_Constits.
24388 procedure Check_Proof_In_States;
24389 -- Determine whether the corresponding Global pragma mentions Proof_In
24390 -- states with visible refinement and if so, ensure that at least one of
24391 -- its constituents appears as a Proof_In item in Refined_Global.
24392 -- This routine may remove elements from In_Constits, In_Out_Constits,
24393 -- Out_Constits and Proof_In_Constits.
24395 procedure Check_Refined_Global_List
24396 (List : Node_Id;
24397 Global_Mode : Name_Id := Name_Input);
24398 -- Verify the legality of a single global list declaration. Global_Mode
24399 -- denotes the current mode in effect.
24401 procedure Collect_Global_Items
24402 (List : Node_Id;
24403 Mode : Name_Id := Name_Input);
24404 -- Gather all input, in out, output and Proof_In items from node List
24405 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24406 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24407 -- and Has_Proof_In_State are set when there is at least one abstract
24408 -- state with visible refinement available in the corresponding mode.
24409 -- Flag Has_Null_State is set when at least state has a null refinement.
24410 -- Mode enotes the current global mode in effect.
24412 function Present_Then_Remove
24413 (List : Elist_Id;
24414 Item : Entity_Id) return Boolean;
24415 -- Search List for a particular entity Item. If Item has been found,
24416 -- remove it from List. This routine is used to strip lists In_Constits,
24417 -- In_Out_Constits and Out_Constits of valid constituents.
24419 procedure Report_Extra_Constituents;
24420 -- Emit an error for each constituent found in lists In_Constits,
24421 -- In_Out_Constits and Out_Constits.
24423 -------------------------
24424 -- Check_In_Out_States --
24425 -------------------------
24427 procedure Check_In_Out_States is
24428 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24429 -- Determine whether one of the following coverage scenarios is in
24430 -- effect:
24431 -- 1) there is at least one constituent of mode In_Out or Output
24432 -- 2) there is at least one pair of constituents with modes Input
24433 -- and Output, or Proof_In and Output.
24434 -- 3) there is at least one constituent of mode Output and not all
24435 -- constituents are present.
24436 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24438 -----------------------------
24439 -- Check_Constituent_Usage --
24440 -----------------------------
24442 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24443 Constits : constant Elist_Id :=
24444 Refinement_Constituents (State_Id);
24445 Constit_Elmt : Elmt_Id;
24446 Constit_Id : Entity_Id;
24447 Has_Missing : Boolean := False;
24448 In_Out_Seen : Boolean := False;
24449 Input_Seen : Boolean := False;
24450 Output_Seen : Boolean := False;
24451 Proof_In_Seen : Boolean := False;
24453 begin
24454 -- Process all the constituents of the state and note their modes
24455 -- within the global refinement.
24457 if Present (Constits) then
24458 Constit_Elmt := First_Elmt (Constits);
24459 while Present (Constit_Elmt) loop
24460 Constit_Id := Node (Constit_Elmt);
24462 if Present_Then_Remove (In_Constits, Constit_Id) then
24463 Input_Seen := True;
24465 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
24466 In_Out_Seen := True;
24468 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
24469 Output_Seen := True;
24471 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24472 then
24473 Proof_In_Seen := True;
24475 else
24476 Has_Missing := True;
24477 end if;
24479 Next_Elmt (Constit_Elmt);
24480 end loop;
24481 end if;
24483 -- An In_Out constituent is a valid completion
24485 if In_Out_Seen then
24486 null;
24488 -- A pair of one Input/Proof_In and one Output constituent is a
24489 -- valid completion.
24491 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
24492 null;
24494 elsif Output_Seen then
24496 -- A single Output constituent is a valid completion only when
24497 -- some of the other constituents are missing.
24499 if Has_Missing then
24500 null;
24502 -- Otherwise all constituents are of mode Output
24504 else
24505 SPARK_Msg_NE
24506 ("global refinement of state & must include at least one "
24507 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24508 N, State_Id);
24509 end if;
24511 -- The state lacks a completion
24513 elsif not Input_Seen
24514 and not In_Out_Seen
24515 and not Output_Seen
24516 and not Proof_In_Seen
24517 then
24518 SPARK_Msg_NE
24519 ("missing global refinement of state &", N, State_Id);
24521 -- Otherwise the state has a malformed completion where at least
24522 -- one of the constituents has a different mode.
24524 else
24525 SPARK_Msg_NE
24526 ("global refinement of state & redefines the mode of its "
24527 & "constituents", N, State_Id);
24528 end if;
24529 end Check_Constituent_Usage;
24531 -- Local variables
24533 Item_Elmt : Elmt_Id;
24534 Item_Id : Entity_Id;
24536 -- Start of processing for Check_In_Out_States
24538 begin
24539 -- Do not perform this check in an instance because it was already
24540 -- performed successfully in the generic template.
24542 if Is_Generic_Instance (Spec_Id) then
24543 null;
24545 -- Inspect the In_Out items of the corresponding Global pragma
24546 -- looking for a state with a visible refinement.
24548 elsif Has_In_Out_State and then Present (In_Out_Items) then
24549 Item_Elmt := First_Elmt (In_Out_Items);
24550 while Present (Item_Elmt) loop
24551 Item_Id := Node (Item_Elmt);
24553 -- Ensure that one of the three coverage variants is satisfied
24555 if Ekind (Item_Id) = E_Abstract_State
24556 and then Has_Non_Null_Visible_Refinement (Item_Id)
24557 then
24558 Check_Constituent_Usage (Item_Id);
24559 end if;
24561 Next_Elmt (Item_Elmt);
24562 end loop;
24563 end if;
24564 end Check_In_Out_States;
24566 ------------------------
24567 -- Check_Input_States --
24568 ------------------------
24570 procedure Check_Input_States is
24571 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24572 -- Determine whether at least one constituent of state State_Id with
24573 -- visible refinement is used and has mode Input. Ensure that the
24574 -- remaining constituents do not have In_Out or Output modes. Emit an
24575 -- error if this is not the case (SPARK RM 7.2.4(5)).
24577 -----------------------------
24578 -- Check_Constituent_Usage --
24579 -----------------------------
24581 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24582 Constits : constant Elist_Id :=
24583 Refinement_Constituents (State_Id);
24584 Constit_Elmt : Elmt_Id;
24585 Constit_Id : Entity_Id;
24586 In_Seen : Boolean := False;
24588 begin
24589 if Present (Constits) then
24590 Constit_Elmt := First_Elmt (Constits);
24591 while Present (Constit_Elmt) loop
24592 Constit_Id := Node (Constit_Elmt);
24594 -- At least one of the constituents appears as an Input
24596 if Present_Then_Remove (In_Constits, Constit_Id) then
24597 In_Seen := True;
24599 -- A Proof_In constituent can refine an Input state as long
24600 -- as there is at least one Input constituent present.
24602 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24603 then
24604 null;
24606 -- The constituent appears in the global refinement, but has
24607 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
24609 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
24610 or else Present_Then_Remove (Out_Constits, Constit_Id)
24611 then
24612 Error_Msg_Name_1 := Chars (State_Id);
24613 SPARK_Msg_NE
24614 ("constituent & of state % must have mode `Input` in "
24615 & "global refinement", N, Constit_Id);
24616 end if;
24618 Next_Elmt (Constit_Elmt);
24619 end loop;
24620 end if;
24622 -- Not one of the constituents appeared as Input
24624 if not In_Seen then
24625 SPARK_Msg_NE
24626 ("global refinement of state & must include at least one "
24627 & "constituent of mode `Input`", N, State_Id);
24628 end if;
24629 end Check_Constituent_Usage;
24631 -- Local variables
24633 Item_Elmt : Elmt_Id;
24634 Item_Id : Entity_Id;
24636 -- Start of processing for Check_Input_States
24638 begin
24639 -- Do not perform this check in an instance because it was already
24640 -- performed successfully in the generic template.
24642 if Is_Generic_Instance (Spec_Id) then
24643 null;
24645 -- Inspect the Input items of the corresponding Global pragma looking
24646 -- for a state with a visible refinement.
24648 elsif Has_In_State and then Present (In_Items) then
24649 Item_Elmt := First_Elmt (In_Items);
24650 while Present (Item_Elmt) loop
24651 Item_Id := Node (Item_Elmt);
24653 -- Ensure that at least one of the constituents is utilized and
24654 -- is of mode Input.
24656 if Ekind (Item_Id) = E_Abstract_State
24657 and then Has_Non_Null_Visible_Refinement (Item_Id)
24658 then
24659 Check_Constituent_Usage (Item_Id);
24660 end if;
24662 Next_Elmt (Item_Elmt);
24663 end loop;
24664 end if;
24665 end Check_Input_States;
24667 -------------------------
24668 -- Check_Output_States --
24669 -------------------------
24671 procedure Check_Output_States is
24672 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24673 -- Determine whether all constituents of state State_Id with visible
24674 -- refinement are used and have mode Output. Emit an error if this is
24675 -- not the case (SPARK RM 7.2.4(5)).
24677 -----------------------------
24678 -- Check_Constituent_Usage --
24679 -----------------------------
24681 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24682 Constits : constant Elist_Id :=
24683 Refinement_Constituents (State_Id);
24684 Constit_Elmt : Elmt_Id;
24685 Constit_Id : Entity_Id;
24686 Posted : Boolean := False;
24688 begin
24689 if Present (Constits) then
24690 Constit_Elmt := First_Elmt (Constits);
24691 while Present (Constit_Elmt) loop
24692 Constit_Id := Node (Constit_Elmt);
24694 if Present_Then_Remove (Out_Constits, Constit_Id) then
24695 null;
24697 -- The constituent appears in the global refinement, but has
24698 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24700 elsif Present_Then_Remove (In_Constits, Constit_Id)
24701 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24702 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
24703 then
24704 Error_Msg_Name_1 := Chars (State_Id);
24705 SPARK_Msg_NE
24706 ("constituent & of state % must have mode `Output` in "
24707 & "global refinement", N, Constit_Id);
24709 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24711 else
24712 if not Posted then
24713 Posted := True;
24714 SPARK_Msg_NE
24715 ("`Output` state & must be replaced by all its "
24716 & "constituents in global refinement", N, State_Id);
24717 end if;
24719 SPARK_Msg_NE
24720 ("\constituent & is missing in output list",
24721 N, Constit_Id);
24722 end if;
24724 Next_Elmt (Constit_Elmt);
24725 end loop;
24726 end if;
24727 end Check_Constituent_Usage;
24729 -- Local variables
24731 Item_Elmt : Elmt_Id;
24732 Item_Id : Entity_Id;
24734 -- Start of processing for Check_Output_States
24736 begin
24737 -- Do not perform this check in an instance because it was already
24738 -- performed successfully in the generic template.
24740 if Is_Generic_Instance (Spec_Id) then
24741 null;
24743 -- Inspect the Output items of the corresponding Global pragma
24744 -- looking for a state with a visible refinement.
24746 elsif Has_Out_State and then Present (Out_Items) then
24747 Item_Elmt := First_Elmt (Out_Items);
24748 while Present (Item_Elmt) loop
24749 Item_Id := Node (Item_Elmt);
24751 -- Ensure that all of the constituents are utilized and they
24752 -- have mode Output.
24754 if Ekind (Item_Id) = E_Abstract_State
24755 and then Has_Non_Null_Visible_Refinement (Item_Id)
24756 then
24757 Check_Constituent_Usage (Item_Id);
24758 end if;
24760 Next_Elmt (Item_Elmt);
24761 end loop;
24762 end if;
24763 end Check_Output_States;
24765 ---------------------------
24766 -- Check_Proof_In_States --
24767 ---------------------------
24769 procedure Check_Proof_In_States is
24770 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24771 -- Determine whether at least one constituent of state State_Id with
24772 -- visible refinement is used and has mode Proof_In. Ensure that the
24773 -- remaining constituents do not have Input, In_Out or Output modes.
24774 -- Emit an error of this is not the case (SPARK RM 7.2.4(5)).
24776 -----------------------------
24777 -- Check_Constituent_Usage --
24778 -----------------------------
24780 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24781 Constits : constant Elist_Id :=
24782 Refinement_Constituents (State_Id);
24783 Constit_Elmt : Elmt_Id;
24784 Constit_Id : Entity_Id;
24785 Proof_In_Seen : Boolean := False;
24787 begin
24788 if Present (Constits) then
24789 Constit_Elmt := First_Elmt (Constits);
24790 while Present (Constit_Elmt) loop
24791 Constit_Id := Node (Constit_Elmt);
24793 -- At least one of the constituents appears as Proof_In
24795 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
24796 Proof_In_Seen := True;
24798 -- The constituent appears in the global refinement, but has
24799 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24801 elsif Present_Then_Remove (In_Constits, Constit_Id)
24802 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24803 or else Present_Then_Remove (Out_Constits, Constit_Id)
24804 then
24805 Error_Msg_Name_1 := Chars (State_Id);
24806 SPARK_Msg_NE
24807 ("constituent & of state % must have mode `Proof_In` "
24808 & "in global refinement", N, Constit_Id);
24809 end if;
24811 Next_Elmt (Constit_Elmt);
24812 end loop;
24813 end if;
24815 -- Not one of the constituents appeared as Proof_In
24817 if not Proof_In_Seen then
24818 SPARK_Msg_NE
24819 ("global refinement of state & must include at least one "
24820 & "constituent of mode `Proof_In`", N, State_Id);
24821 end if;
24822 end Check_Constituent_Usage;
24824 -- Local variables
24826 Item_Elmt : Elmt_Id;
24827 Item_Id : Entity_Id;
24829 -- Start of processing for Check_Proof_In_States
24831 begin
24832 -- Do not perform this check in an instance because it was already
24833 -- performed successfully in the generic template.
24835 if Is_Generic_Instance (Spec_Id) then
24836 null;
24838 -- Inspect the Proof_In items of the corresponding Global pragma
24839 -- looking for a state with a visible refinement.
24841 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
24842 Item_Elmt := First_Elmt (Proof_In_Items);
24843 while Present (Item_Elmt) loop
24844 Item_Id := Node (Item_Elmt);
24846 -- Ensure that at least one of the constituents is utilized and
24847 -- is of mode Proof_In
24849 if Ekind (Item_Id) = E_Abstract_State
24850 and then Has_Non_Null_Visible_Refinement (Item_Id)
24851 then
24852 Check_Constituent_Usage (Item_Id);
24853 end if;
24855 Next_Elmt (Item_Elmt);
24856 end loop;
24857 end if;
24858 end Check_Proof_In_States;
24860 -------------------------------
24861 -- Check_Refined_Global_List --
24862 -------------------------------
24864 procedure Check_Refined_Global_List
24865 (List : Node_Id;
24866 Global_Mode : Name_Id := Name_Input)
24868 procedure Check_Refined_Global_Item
24869 (Item : Node_Id;
24870 Global_Mode : Name_Id);
24871 -- Verify the legality of a single global item declaration. Parameter
24872 -- Global_Mode denotes the current mode in effect.
24874 -------------------------------
24875 -- Check_Refined_Global_Item --
24876 -------------------------------
24878 procedure Check_Refined_Global_Item
24879 (Item : Node_Id;
24880 Global_Mode : Name_Id)
24882 Item_Id : constant Entity_Id := Entity_Of (Item);
24884 procedure Inconsistent_Mode_Error (Expect : Name_Id);
24885 -- Issue a common error message for all mode mismatches. Expect
24886 -- denotes the expected mode.
24888 -----------------------------
24889 -- Inconsistent_Mode_Error --
24890 -----------------------------
24892 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
24893 begin
24894 SPARK_Msg_NE
24895 ("global item & has inconsistent modes", Item, Item_Id);
24897 Error_Msg_Name_1 := Global_Mode;
24898 Error_Msg_Name_2 := Expect;
24899 SPARK_Msg_N ("\expected mode %, found mode %", Item);
24900 end Inconsistent_Mode_Error;
24902 -- Start of processing for Check_Refined_Global_Item
24904 begin
24905 -- When the state or object acts as a constituent of another
24906 -- state with a visible refinement, collect it for the state
24907 -- completeness checks performed later on. Note that the item
24908 -- acts as a constituent only when the encapsulating state is
24909 -- present in pragma Global.
24911 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
24912 and then Present (Encapsulating_State (Item_Id))
24913 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
24914 and then Contains (States, Encapsulating_State (Item_Id))
24915 then
24916 if Global_Mode = Name_Input then
24917 Append_New_Elmt (Item_Id, In_Constits);
24919 elsif Global_Mode = Name_In_Out then
24920 Append_New_Elmt (Item_Id, In_Out_Constits);
24922 elsif Global_Mode = Name_Output then
24923 Append_New_Elmt (Item_Id, Out_Constits);
24925 elsif Global_Mode = Name_Proof_In then
24926 Append_New_Elmt (Item_Id, Proof_In_Constits);
24927 end if;
24929 -- When not a constituent, ensure that both occurrences of the
24930 -- item in pragmas Global and Refined_Global match.
24932 elsif Contains (In_Items, Item_Id) then
24933 if Global_Mode /= Name_Input then
24934 Inconsistent_Mode_Error (Name_Input);
24935 end if;
24937 elsif Contains (In_Out_Items, Item_Id) then
24938 if Global_Mode /= Name_In_Out then
24939 Inconsistent_Mode_Error (Name_In_Out);
24940 end if;
24942 elsif Contains (Out_Items, Item_Id) then
24943 if Global_Mode /= Name_Output then
24944 Inconsistent_Mode_Error (Name_Output);
24945 end if;
24947 elsif Contains (Proof_In_Items, Item_Id) then
24948 null;
24950 -- The item does not appear in the corresponding Global pragma,
24951 -- it must be an extra (SPARK RM 7.2.4(3)).
24953 else
24954 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
24955 end if;
24956 end Check_Refined_Global_Item;
24958 -- Local variables
24960 Item : Node_Id;
24962 -- Start of processing for Check_Refined_Global_List
24964 begin
24965 -- Do not perform this check in an instance because it was already
24966 -- performed successfully in the generic template.
24968 if Is_Generic_Instance (Spec_Id) then
24969 null;
24971 elsif Nkind (List) = N_Null then
24972 null;
24974 -- Single global item declaration
24976 elsif Nkind_In (List, N_Expanded_Name,
24977 N_Identifier,
24978 N_Selected_Component)
24979 then
24980 Check_Refined_Global_Item (List, Global_Mode);
24982 -- Simple global list or moded global list declaration
24984 elsif Nkind (List) = N_Aggregate then
24986 -- The declaration of a simple global list appear as a collection
24987 -- of expressions.
24989 if Present (Expressions (List)) then
24990 Item := First (Expressions (List));
24991 while Present (Item) loop
24992 Check_Refined_Global_Item (Item, Global_Mode);
24993 Next (Item);
24994 end loop;
24996 -- The declaration of a moded global list appears as a collection
24997 -- of component associations where individual choices denote
24998 -- modes.
25000 elsif Present (Component_Associations (List)) then
25001 Item := First (Component_Associations (List));
25002 while Present (Item) loop
25003 Check_Refined_Global_List
25004 (List => Expression (Item),
25005 Global_Mode => Chars (First (Choices (Item))));
25007 Next (Item);
25008 end loop;
25010 -- Invalid tree
25012 else
25013 raise Program_Error;
25014 end if;
25016 -- Invalid list
25018 else
25019 raise Program_Error;
25020 end if;
25021 end Check_Refined_Global_List;
25023 --------------------------
25024 -- Collect_Global_Items --
25025 --------------------------
25027 procedure Collect_Global_Items
25028 (List : Node_Id;
25029 Mode : Name_Id := Name_Input)
25031 procedure Collect_Global_Item
25032 (Item : Node_Id;
25033 Item_Mode : Name_Id);
25034 -- Add a single item to the appropriate list. Item_Mode denotes the
25035 -- current mode in effect.
25037 -------------------------
25038 -- Collect_Global_Item --
25039 -------------------------
25041 procedure Collect_Global_Item
25042 (Item : Node_Id;
25043 Item_Mode : Name_Id)
25045 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
25046 -- The above handles abstract views of variables and states built
25047 -- for limited with clauses.
25049 begin
25050 -- Signal that the global list contains at least one abstract
25051 -- state with a visible refinement. Note that the refinement may
25052 -- be null in which case there are no constituents.
25054 if Ekind (Item_Id) = E_Abstract_State then
25055 if Has_Null_Visible_Refinement (Item_Id) then
25056 Has_Null_State := True;
25058 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
25059 Append_New_Elmt (Item_Id, States);
25061 if Item_Mode = Name_Input then
25062 Has_In_State := True;
25063 elsif Item_Mode = Name_In_Out then
25064 Has_In_Out_State := True;
25065 elsif Item_Mode = Name_Output then
25066 Has_Out_State := True;
25067 elsif Item_Mode = Name_Proof_In then
25068 Has_Proof_In_State := True;
25069 end if;
25070 end if;
25071 end if;
25073 -- Add the item to the proper list
25075 if Item_Mode = Name_Input then
25076 Append_New_Elmt (Item_Id, In_Items);
25077 elsif Item_Mode = Name_In_Out then
25078 Append_New_Elmt (Item_Id, In_Out_Items);
25079 elsif Item_Mode = Name_Output then
25080 Append_New_Elmt (Item_Id, Out_Items);
25081 elsif Item_Mode = Name_Proof_In then
25082 Append_New_Elmt (Item_Id, Proof_In_Items);
25083 end if;
25084 end Collect_Global_Item;
25086 -- Local variables
25088 Item : Node_Id;
25090 -- Start of processing for Collect_Global_Items
25092 begin
25093 if Nkind (List) = N_Null then
25094 null;
25096 -- Single global item declaration
25098 elsif Nkind_In (List, N_Expanded_Name,
25099 N_Identifier,
25100 N_Selected_Component)
25101 then
25102 Collect_Global_Item (List, Mode);
25104 -- Single global list or moded global list declaration
25106 elsif Nkind (List) = N_Aggregate then
25108 -- The declaration of a simple global list appear as a collection
25109 -- of expressions.
25111 if Present (Expressions (List)) then
25112 Item := First (Expressions (List));
25113 while Present (Item) loop
25114 Collect_Global_Item (Item, Mode);
25115 Next (Item);
25116 end loop;
25118 -- The declaration of a moded global list appears as a collection
25119 -- of component associations where individual choices denote mode.
25121 elsif Present (Component_Associations (List)) then
25122 Item := First (Component_Associations (List));
25123 while Present (Item) loop
25124 Collect_Global_Items
25125 (List => Expression (Item),
25126 Mode => Chars (First (Choices (Item))));
25128 Next (Item);
25129 end loop;
25131 -- Invalid tree
25133 else
25134 raise Program_Error;
25135 end if;
25137 -- To accomodate partial decoration of disabled SPARK features, this
25138 -- routine may be called with illegal input. If this is the case, do
25139 -- not raise Program_Error.
25141 else
25142 null;
25143 end if;
25144 end Collect_Global_Items;
25146 -------------------------
25147 -- Present_Then_Remove --
25148 -------------------------
25150 function Present_Then_Remove
25151 (List : Elist_Id;
25152 Item : Entity_Id) return Boolean
25154 Elmt : Elmt_Id;
25156 begin
25157 if Present (List) then
25158 Elmt := First_Elmt (List);
25159 while Present (Elmt) loop
25160 if Node (Elmt) = Item then
25161 Remove_Elmt (List, Elmt);
25162 return True;
25163 end if;
25165 Next_Elmt (Elmt);
25166 end loop;
25167 end if;
25169 return False;
25170 end Present_Then_Remove;
25172 -------------------------------
25173 -- Report_Extra_Constituents --
25174 -------------------------------
25176 procedure Report_Extra_Constituents is
25177 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
25178 -- Emit an error for every element of List
25180 ---------------------------------------
25181 -- Report_Extra_Constituents_In_List --
25182 ---------------------------------------
25184 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
25185 Constit_Elmt : Elmt_Id;
25187 begin
25188 if Present (List) then
25189 Constit_Elmt := First_Elmt (List);
25190 while Present (Constit_Elmt) loop
25191 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
25192 Next_Elmt (Constit_Elmt);
25193 end loop;
25194 end if;
25195 end Report_Extra_Constituents_In_List;
25197 -- Start of processing for Report_Extra_Constituents
25199 begin
25200 -- Do not perform this check in an instance because it was already
25201 -- performed successfully in the generic template.
25203 if Is_Generic_Instance (Spec_Id) then
25204 null;
25206 else
25207 Report_Extra_Constituents_In_List (In_Constits);
25208 Report_Extra_Constituents_In_List (In_Out_Constits);
25209 Report_Extra_Constituents_In_List (Out_Constits);
25210 Report_Extra_Constituents_In_List (Proof_In_Constits);
25211 end if;
25212 end Report_Extra_Constituents;
25214 -- Local variables
25216 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25217 Errors : constant Nat := Serious_Errors_Detected;
25218 Items : Node_Id;
25220 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25222 begin
25223 -- Do not analyze the pragma multiple times
25225 if Is_Analyzed_Pragma (N) then
25226 return;
25227 end if;
25229 Spec_Id := Unique_Defining_Entity (Body_Decl);
25231 -- Use the anonymous object as the proper spec when Refined_Global
25232 -- applies to the body of a single task type. The object carries the
25233 -- proper Chars as well as all non-refined versions of pragmas.
25235 if Is_Single_Concurrent_Type (Spec_Id) then
25236 Spec_Id := Anonymous_Object (Spec_Id);
25237 end if;
25239 Global := Get_Pragma (Spec_Id, Pragma_Global);
25240 Items := Expression (Get_Argument (N, Spec_Id));
25242 -- The subprogram declaration lacks pragma Global. This renders
25243 -- Refined_Global useless as there is nothing to refine.
25245 if No (Global) then
25246 SPARK_Msg_NE
25247 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25248 & "& lacks aspect or pragma Global"), N, Spec_Id);
25249 goto Leave;
25250 end if;
25252 -- Extract all relevant items from the corresponding Global pragma
25254 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
25256 -- Package and subprogram bodies are instantiated individually in
25257 -- a separate compiler pass. Due to this mode of instantiation, the
25258 -- refinement of a state may no longer be visible when a subprogram
25259 -- body contract is instantiated. Since the generic template is legal,
25260 -- do not perform this check in the instance to circumvent this oddity.
25262 if Is_Generic_Instance (Spec_Id) then
25263 null;
25265 -- Non-instance case
25267 else
25268 -- The corresponding Global pragma must mention at least one state
25269 -- witha visible refinement at the point Refined_Global is processed.
25270 -- States with null refinements need Refined_Global pragma
25271 -- (SPARK RM 7.2.4(2)).
25273 if not Has_In_State
25274 and then not Has_In_Out_State
25275 and then not Has_Out_State
25276 and then not Has_Proof_In_State
25277 and then not Has_Null_State
25278 then
25279 SPARK_Msg_NE
25280 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25281 & "depend on abstract state with visible refinement"),
25282 N, Spec_Id);
25283 goto Leave;
25285 -- The global refinement of inputs and outputs cannot be null when
25286 -- the corresponding Global pragma contains at least one item except
25287 -- in the case where we have states with null refinements.
25289 elsif Nkind (Items) = N_Null
25290 and then
25291 (Present (In_Items)
25292 or else Present (In_Out_Items)
25293 or else Present (Out_Items)
25294 or else Present (Proof_In_Items))
25295 and then not Has_Null_State
25296 then
25297 SPARK_Msg_NE
25298 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
25299 & "global items"), N, Spec_Id);
25300 goto Leave;
25301 end if;
25302 end if;
25304 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25305 -- This ensures that the categorization of all refined global items is
25306 -- consistent with their role.
25308 Analyze_Global_In_Decl_Part (N);
25310 -- Perform all refinement checks with respect to completeness and mode
25311 -- matching.
25313 if Serious_Errors_Detected = Errors then
25314 Check_Refined_Global_List (Items);
25315 end if;
25317 -- For Input states with visible refinement, at least one constituent
25318 -- must be used as an Input in the global refinement.
25320 if Serious_Errors_Detected = Errors then
25321 Check_Input_States;
25322 end if;
25324 -- Verify all possible completion variants for In_Out states with
25325 -- visible refinement.
25327 if Serious_Errors_Detected = Errors then
25328 Check_In_Out_States;
25329 end if;
25331 -- For Output states with visible refinement, all constituents must be
25332 -- used as Outputs in the global refinement.
25334 if Serious_Errors_Detected = Errors then
25335 Check_Output_States;
25336 end if;
25338 -- For Proof_In states with visible refinement, at least one constituent
25339 -- must be used as Proof_In in the global refinement.
25341 if Serious_Errors_Detected = Errors then
25342 Check_Proof_In_States;
25343 end if;
25345 -- Emit errors for all constituents that belong to other states with
25346 -- visible refinement that do not appear in Global.
25348 if Serious_Errors_Detected = Errors then
25349 Report_Extra_Constituents;
25350 end if;
25352 <<Leave>>
25353 Set_Is_Analyzed_Pragma (N);
25354 end Analyze_Refined_Global_In_Decl_Part;
25356 ----------------------------------------
25357 -- Analyze_Refined_State_In_Decl_Part --
25358 ----------------------------------------
25360 procedure Analyze_Refined_State_In_Decl_Part
25361 (N : Node_Id;
25362 Freeze_Id : Entity_Id := Empty)
25364 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
25365 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
25366 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
25368 Available_States : Elist_Id := No_Elist;
25369 -- A list of all abstract states defined in the package declaration that
25370 -- are available for refinement. The list is used to report unrefined
25371 -- states.
25373 Body_States : Elist_Id := No_Elist;
25374 -- A list of all hidden states that appear in the body of the related
25375 -- package. The list is used to report unused hidden states.
25377 Constituents_Seen : Elist_Id := No_Elist;
25378 -- A list that contains all constituents processed so far. The list is
25379 -- used to detect multiple uses of the same constituent.
25381 Freeze_Posted : Boolean := False;
25382 -- A flag that controls the output of a freezing-related error (see use
25383 -- below).
25385 Refined_States_Seen : Elist_Id := No_Elist;
25386 -- A list that contains all refined states processed so far. The list is
25387 -- used to detect duplicate refinements.
25389 procedure Analyze_Refinement_Clause (Clause : Node_Id);
25390 -- Perform full analysis of a single refinement clause
25392 procedure Report_Unrefined_States (States : Elist_Id);
25393 -- Emit errors for all unrefined abstract states found in list States
25395 -------------------------------
25396 -- Analyze_Refinement_Clause --
25397 -------------------------------
25399 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
25400 AR_Constit : Entity_Id := Empty;
25401 AW_Constit : Entity_Id := Empty;
25402 ER_Constit : Entity_Id := Empty;
25403 EW_Constit : Entity_Id := Empty;
25404 -- The entities of external constituents that contain one of the
25405 -- following enabled properties: Async_Readers, Async_Writers,
25406 -- Effective_Reads and Effective_Writes.
25408 External_Constit_Seen : Boolean := False;
25409 -- Flag used to mark when at least one external constituent is part
25410 -- of the state refinement.
25412 Non_Null_Seen : Boolean := False;
25413 Null_Seen : Boolean := False;
25414 -- Flags used to detect multiple uses of null in a single clause or a
25415 -- mixture of null and non-null constituents.
25417 Part_Of_Constits : Elist_Id := No_Elist;
25418 -- A list of all candidate constituents subject to indicator Part_Of
25419 -- where the encapsulating state is the current state.
25421 State : Node_Id;
25422 State_Id : Entity_Id;
25423 -- The current state being refined
25425 procedure Analyze_Constituent (Constit : Node_Id);
25426 -- Perform full analysis of a single constituent
25428 procedure Check_External_Property
25429 (Prop_Nam : Name_Id;
25430 Enabled : Boolean;
25431 Constit : Entity_Id);
25432 -- Determine whether a property denoted by name Prop_Nam is present
25433 -- in the refined state. Emit an error if this is not the case. Flag
25434 -- Enabled should be set when the property applies to the refined
25435 -- state. Constit denotes the constituent (if any) which introduces
25436 -- the property in the refinement.
25438 procedure Match_State;
25439 -- Determine whether the state being refined appears in list
25440 -- Available_States. Emit an error when attempting to re-refine the
25441 -- state or when the state is not defined in the package declaration,
25442 -- otherwise remove the state from Available_States.
25444 procedure Report_Unused_Constituents (Constits : Elist_Id);
25445 -- Emit errors for all unused Part_Of constituents in list Constits
25447 -------------------------
25448 -- Analyze_Constituent --
25449 -------------------------
25451 procedure Analyze_Constituent (Constit : Node_Id) is
25452 procedure Match_Constituent (Constit_Id : Entity_Id);
25453 -- Determine whether constituent Constit denoted by its entity
25454 -- Constit_Id appears in Body_States. Emit an error when the
25455 -- constituent is not a valid hidden state of the related package
25456 -- or when it is used more than once. Otherwise remove the
25457 -- constituent from Body_States.
25459 -----------------------
25460 -- Match_Constituent --
25461 -----------------------
25463 procedure Match_Constituent (Constit_Id : Entity_Id) is
25464 procedure Collect_Constituent;
25465 -- Verify the legality of constituent Constit_Id and add it to
25466 -- the refinements of State_Id.
25468 -------------------------
25469 -- Collect_Constituent --
25470 -------------------------
25472 procedure Collect_Constituent is
25473 Constits : Elist_Id;
25475 begin
25476 -- The Ghost policy in effect at the point of abstract state
25477 -- declaration and constituent must match (SPARK RM 6.9(15))
25479 Check_Ghost_Refinement
25480 (State, State_Id, Constit, Constit_Id);
25482 -- A synchronized state must be refined by a synchronized
25483 -- object or another synchronized state (SPARK RM 9.6).
25485 if Is_Synchronized_State (State_Id)
25486 and then not Is_Synchronized_Object (Constit_Id)
25487 and then not Is_Synchronized_State (Constit_Id)
25488 then
25489 SPARK_Msg_NE
25490 ("constituent of synchronized state & must be "
25491 & "synchronized", Constit, State_Id);
25492 end if;
25494 -- Add the constituent to the list of processed items to aid
25495 -- with the detection of duplicates.
25497 Append_New_Elmt (Constit_Id, Constituents_Seen);
25499 -- Collect the constituent in the list of refinement items
25500 -- and establish a relation between the refined state and
25501 -- the item.
25503 Constits := Refinement_Constituents (State_Id);
25505 if No (Constits) then
25506 Constits := New_Elmt_List;
25507 Set_Refinement_Constituents (State_Id, Constits);
25508 end if;
25510 Append_Elmt (Constit_Id, Constits);
25511 Set_Encapsulating_State (Constit_Id, State_Id);
25513 -- The state has at least one legal constituent, mark the
25514 -- start of the refinement region. The region ends when the
25515 -- body declarations end (see routine Analyze_Declarations).
25517 Set_Has_Visible_Refinement (State_Id);
25519 -- When the constituent is external, save its relevant
25520 -- property for further checks.
25522 if Async_Readers_Enabled (Constit_Id) then
25523 AR_Constit := Constit_Id;
25524 External_Constit_Seen := True;
25525 end if;
25527 if Async_Writers_Enabled (Constit_Id) then
25528 AW_Constit := Constit_Id;
25529 External_Constit_Seen := True;
25530 end if;
25532 if Effective_Reads_Enabled (Constit_Id) then
25533 ER_Constit := Constit_Id;
25534 External_Constit_Seen := True;
25535 end if;
25537 if Effective_Writes_Enabled (Constit_Id) then
25538 EW_Constit := Constit_Id;
25539 External_Constit_Seen := True;
25540 end if;
25541 end Collect_Constituent;
25543 -- Local variables
25545 State_Elmt : Elmt_Id;
25547 -- Start of processing for Match_Constituent
25549 begin
25550 -- Detect a duplicate use of a constituent
25552 if Contains (Constituents_Seen, Constit_Id) then
25553 SPARK_Msg_NE
25554 ("duplicate use of constituent &", Constit, Constit_Id);
25555 return;
25556 end if;
25558 -- The constituent is subject to a Part_Of indicator
25560 if Present (Encapsulating_State (Constit_Id)) then
25561 if Encapsulating_State (Constit_Id) = State_Id then
25562 Remove (Part_Of_Constits, Constit_Id);
25563 Collect_Constituent;
25565 -- The constituent is part of another state and is used
25566 -- incorrectly in the refinement of the current state.
25568 else
25569 Error_Msg_Name_1 := Chars (State_Id);
25570 SPARK_Msg_NE
25571 ("& cannot act as constituent of state %",
25572 Constit, Constit_Id);
25573 SPARK_Msg_NE
25574 ("\Part_Of indicator specifies encapsulator &",
25575 Constit, Encapsulating_State (Constit_Id));
25576 end if;
25578 -- The only other source of legal constituents is the body
25579 -- state space of the related package.
25581 else
25582 if Present (Body_States) then
25583 State_Elmt := First_Elmt (Body_States);
25584 while Present (State_Elmt) loop
25586 -- Consume a valid constituent to signal that it has
25587 -- been encountered.
25589 if Node (State_Elmt) = Constit_Id then
25590 Remove_Elmt (Body_States, State_Elmt);
25591 Collect_Constituent;
25592 return;
25593 end if;
25595 Next_Elmt (State_Elmt);
25596 end loop;
25597 end if;
25599 -- Constants are part of the hidden state of a package, but
25600 -- the compiler cannot determine whether they have variable
25601 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25602 -- hidden state. Accept the constant quietly even if it is
25603 -- a visible state or lacks a Part_Of indicator.
25605 if Ekind (Constit_Id) = E_Constant then
25606 Collect_Constituent;
25608 -- If we get here, then the constituent is not a hidden
25609 -- state of the related package and may not be used in a
25610 -- refinement (SPARK RM 7.2.2(9)).
25612 else
25613 Error_Msg_Name_1 := Chars (Spec_Id);
25614 SPARK_Msg_NE
25615 ("cannot use & in refinement, constituent is not a "
25616 & "hidden state of package %", Constit, Constit_Id);
25617 end if;
25618 end if;
25619 end Match_Constituent;
25621 -- Local variables
25623 Constit_Id : Entity_Id;
25624 Constits : Elist_Id;
25626 -- Start of processing for Analyze_Constituent
25628 begin
25629 -- Detect multiple uses of null in a single refinement clause or a
25630 -- mixture of null and non-null constituents.
25632 if Nkind (Constit) = N_Null then
25633 if Null_Seen then
25634 SPARK_Msg_N
25635 ("multiple null constituents not allowed", Constit);
25637 elsif Non_Null_Seen then
25638 SPARK_Msg_N
25639 ("cannot mix null and non-null constituents", Constit);
25641 else
25642 Null_Seen := True;
25644 -- Collect the constituent in the list of refinement items
25646 Constits := Refinement_Constituents (State_Id);
25648 if No (Constits) then
25649 Constits := New_Elmt_List;
25650 Set_Refinement_Constituents (State_Id, Constits);
25651 end if;
25653 Append_Elmt (Constit, Constits);
25655 -- The state has at least one legal constituent, mark the
25656 -- start of the refinement region. The region ends when the
25657 -- body declarations end (see Analyze_Declarations).
25659 Set_Has_Visible_Refinement (State_Id);
25660 end if;
25662 -- Non-null constituents
25664 else
25665 Non_Null_Seen := True;
25667 if Null_Seen then
25668 SPARK_Msg_N
25669 ("cannot mix null and non-null constituents", Constit);
25670 end if;
25672 Analyze (Constit);
25673 Resolve_State (Constit);
25675 -- Ensure that the constituent denotes a valid state or a
25676 -- whole object (SPARK RM 7.2.2(5)).
25678 if Is_Entity_Name (Constit) then
25679 Constit_Id := Entity_Of (Constit);
25681 -- When a constituent is declared after a subprogram body
25682 -- that caused "freezing" of the related contract where
25683 -- pragma Refined_State resides, the constituent appears
25684 -- undefined and carries Any_Id as its entity.
25686 -- package body Pack
25687 -- with Refined_State => (State => Constit)
25688 -- is
25689 -- procedure Proc
25690 -- with Refined_Global => (Input => Constit)
25691 -- is
25692 -- ...
25693 -- end Proc;
25695 -- Constit : ...;
25696 -- end Pack;
25698 if Constit_Id = Any_Id then
25699 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
25701 -- Emit a specialized info message when the contract of
25702 -- the related package body was "frozen" by another body.
25703 -- Note that it is not possible to precisely identify why
25704 -- the constituent is undefined because it is not visible
25705 -- when pragma Refined_State is analyzed. This message is
25706 -- a reasonable approximation.
25708 if Present (Freeze_Id) and then not Freeze_Posted then
25709 Freeze_Posted := True;
25711 Error_Msg_Name_1 := Chars (Body_Id);
25712 Error_Msg_Sloc := Sloc (Freeze_Id);
25713 SPARK_Msg_NE
25714 ("body & declared # freezes the contract of %",
25715 N, Freeze_Id);
25716 SPARK_Msg_N
25717 ("\all constituents must be declared before body #",
25720 -- A misplaced constituent is a critical error because
25721 -- pragma Refined_Depends or Refined_Global depends on
25722 -- the proper link between a state and a constituent.
25723 -- Stop the compilation, as this leads to a multitude
25724 -- of misleading cascaded errors.
25726 raise Program_Error;
25727 end if;
25729 -- The constituent is a valid state or object
25731 elsif Ekind_In (Constit_Id, E_Abstract_State,
25732 E_Constant,
25733 E_Variable)
25734 then
25735 Match_Constituent (Constit_Id);
25737 -- The variable may eventually become a constituent of a
25738 -- single protected/task type. Record the reference now
25739 -- and verify its legality when analyzing the contract of
25740 -- the variable (SPARK RM 9.3).
25742 if Ekind (Constit_Id) = E_Variable then
25743 Record_Possible_Part_Of_Reference
25744 (Var_Id => Constit_Id,
25745 Ref => Constit);
25746 end if;
25748 -- Otherwise the constituent is illegal
25750 else
25751 SPARK_Msg_NE
25752 ("constituent & must denote object or state",
25753 Constit, Constit_Id);
25754 end if;
25756 -- The constituent is illegal
25758 else
25759 SPARK_Msg_N ("malformed constituent", Constit);
25760 end if;
25761 end if;
25762 end Analyze_Constituent;
25764 -----------------------------
25765 -- Check_External_Property --
25766 -----------------------------
25768 procedure Check_External_Property
25769 (Prop_Nam : Name_Id;
25770 Enabled : Boolean;
25771 Constit : Entity_Id)
25773 begin
25774 -- The property is missing in the declaration of the state, but
25775 -- a constituent is introducing it in the state refinement
25776 -- (SPARK RM 7.2.8(2)).
25778 if not Enabled and then Present (Constit) then
25779 Error_Msg_Name_1 := Prop_Nam;
25780 Error_Msg_Name_2 := Chars (State_Id);
25781 SPARK_Msg_NE
25782 ("constituent & introduces external property % in refinement "
25783 & "of state %", State, Constit);
25785 Error_Msg_Sloc := Sloc (State_Id);
25786 SPARK_Msg_N
25787 ("\property is missing in abstract state declaration #",
25788 State);
25789 end if;
25790 end Check_External_Property;
25792 -----------------
25793 -- Match_State --
25794 -----------------
25796 procedure Match_State is
25797 State_Elmt : Elmt_Id;
25799 begin
25800 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25802 if Contains (Refined_States_Seen, State_Id) then
25803 SPARK_Msg_NE
25804 ("duplicate refinement of state &", State, State_Id);
25805 return;
25806 end if;
25808 -- Inspect the abstract states defined in the package declaration
25809 -- looking for a match.
25811 State_Elmt := First_Elmt (Available_States);
25812 while Present (State_Elmt) loop
25814 -- A valid abstract state is being refined in the body. Add
25815 -- the state to the list of processed refined states to aid
25816 -- with the detection of duplicate refinements. Remove the
25817 -- state from Available_States to signal that it has already
25818 -- been refined.
25820 if Node (State_Elmt) = State_Id then
25821 Append_New_Elmt (State_Id, Refined_States_Seen);
25822 Remove_Elmt (Available_States, State_Elmt);
25823 return;
25824 end if;
25826 Next_Elmt (State_Elmt);
25827 end loop;
25829 -- If we get here, we are refining a state that is not defined in
25830 -- the package declaration.
25832 Error_Msg_Name_1 := Chars (Spec_Id);
25833 SPARK_Msg_NE
25834 ("cannot refine state, & is not defined in package %",
25835 State, State_Id);
25836 end Match_State;
25838 --------------------------------
25839 -- Report_Unused_Constituents --
25840 --------------------------------
25842 procedure Report_Unused_Constituents (Constits : Elist_Id) is
25843 Constit_Elmt : Elmt_Id;
25844 Constit_Id : Entity_Id;
25845 Posted : Boolean := False;
25847 begin
25848 if Present (Constits) then
25849 Constit_Elmt := First_Elmt (Constits);
25850 while Present (Constit_Elmt) loop
25851 Constit_Id := Node (Constit_Elmt);
25853 -- Generate an error message of the form:
25855 -- state ... has unused Part_Of constituents
25856 -- abstract state ... defined at ...
25857 -- constant ... defined at ...
25858 -- variable ... defined at ...
25860 if not Posted then
25861 Posted := True;
25862 SPARK_Msg_NE
25863 ("state & has unused Part_Of constituents",
25864 State, State_Id);
25865 end if;
25867 Error_Msg_Sloc := Sloc (Constit_Id);
25869 if Ekind (Constit_Id) = E_Abstract_State then
25870 SPARK_Msg_NE
25871 ("\abstract state & defined #", State, Constit_Id);
25873 elsif Ekind (Constit_Id) = E_Constant then
25874 SPARK_Msg_NE
25875 ("\constant & defined #", State, Constit_Id);
25877 else
25878 pragma Assert (Ekind (Constit_Id) = E_Variable);
25879 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
25880 end if;
25882 Next_Elmt (Constit_Elmt);
25883 end loop;
25884 end if;
25885 end Report_Unused_Constituents;
25887 -- Local declarations
25889 Body_Ref : Node_Id;
25890 Body_Ref_Elmt : Elmt_Id;
25891 Constit : Node_Id;
25892 Extra_State : Node_Id;
25894 -- Start of processing for Analyze_Refinement_Clause
25896 begin
25897 -- A refinement clause appears as a component association where the
25898 -- sole choice is the state and the expressions are the constituents.
25899 -- This is a syntax error, always report.
25901 if Nkind (Clause) /= N_Component_Association then
25902 Error_Msg_N ("malformed state refinement clause", Clause);
25903 return;
25904 end if;
25906 -- Analyze the state name of a refinement clause
25908 State := First (Choices (Clause));
25910 Analyze (State);
25911 Resolve_State (State);
25913 -- Ensure that the state name denotes a valid abstract state that is
25914 -- defined in the spec of the related package.
25916 if Is_Entity_Name (State) then
25917 State_Id := Entity_Of (State);
25919 -- When the abstract state is undefined, it appears as Any_Id. Do
25920 -- not continue with the analysis of the clause.
25922 if State_Id = Any_Id then
25923 return;
25925 -- Catch any attempts to re-refine a state or refine a state that
25926 -- is not defined in the package declaration.
25928 elsif Ekind (State_Id) = E_Abstract_State then
25929 Match_State;
25931 else
25932 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
25933 return;
25934 end if;
25936 -- References to a state with visible refinement are illegal.
25937 -- When nested packages are involved, detecting such references is
25938 -- tricky because pragma Refined_State is analyzed later than the
25939 -- offending pragma Depends or Global. References that occur in
25940 -- such nested context are stored in a list. Emit errors for all
25941 -- references found in Body_References (SPARK RM 6.1.4(8)).
25943 if Present (Body_References (State_Id)) then
25944 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
25945 while Present (Body_Ref_Elmt) loop
25946 Body_Ref := Node (Body_Ref_Elmt);
25948 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
25949 Error_Msg_Sloc := Sloc (State);
25950 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
25952 Next_Elmt (Body_Ref_Elmt);
25953 end loop;
25954 end if;
25956 -- The state name is illegal. This is a syntax error, always report.
25958 else
25959 Error_Msg_N ("malformed state name in refinement clause", State);
25960 return;
25961 end if;
25963 -- A refinement clause may only refine one state at a time
25965 Extra_State := Next (State);
25967 if Present (Extra_State) then
25968 SPARK_Msg_N
25969 ("refinement clause cannot cover multiple states", Extra_State);
25970 end if;
25972 -- Replicate the Part_Of constituents of the refined state because
25973 -- the algorithm will consume items.
25975 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
25977 -- Analyze all constituents of the refinement. Multiple constituents
25978 -- appear as an aggregate.
25980 Constit := Expression (Clause);
25982 if Nkind (Constit) = N_Aggregate then
25983 if Present (Component_Associations (Constit)) then
25984 SPARK_Msg_N
25985 ("constituents of refinement clause must appear in "
25986 & "positional form", Constit);
25988 else pragma Assert (Present (Expressions (Constit)));
25989 Constit := First (Expressions (Constit));
25990 while Present (Constit) loop
25991 Analyze_Constituent (Constit);
25992 Next (Constit);
25993 end loop;
25994 end if;
25996 -- Various forms of a single constituent. Note that these may include
25997 -- malformed constituents.
25999 else
26000 Analyze_Constituent (Constit);
26001 end if;
26003 -- Verify that external constituents do not introduce new external
26004 -- property in the state refinement (SPARK RM 7.2.8(2)).
26006 if Is_External_State (State_Id) then
26007 Check_External_Property
26008 (Prop_Nam => Name_Async_Readers,
26009 Enabled => Async_Readers_Enabled (State_Id),
26010 Constit => AR_Constit);
26012 Check_External_Property
26013 (Prop_Nam => Name_Async_Writers,
26014 Enabled => Async_Writers_Enabled (State_Id),
26015 Constit => AW_Constit);
26017 Check_External_Property
26018 (Prop_Nam => Name_Effective_Reads,
26019 Enabled => Effective_Reads_Enabled (State_Id),
26020 Constit => ER_Constit);
26022 Check_External_Property
26023 (Prop_Nam => Name_Effective_Writes,
26024 Enabled => Effective_Writes_Enabled (State_Id),
26025 Constit => EW_Constit);
26027 -- When a refined state is not external, it should not have external
26028 -- constituents (SPARK RM 7.2.8(1)).
26030 elsif External_Constit_Seen then
26031 SPARK_Msg_NE
26032 ("non-external state & cannot contain external constituents in "
26033 & "refinement", State, State_Id);
26034 end if;
26036 -- Ensure that all Part_Of candidate constituents have been mentioned
26037 -- in the refinement clause.
26039 Report_Unused_Constituents (Part_Of_Constits);
26040 end Analyze_Refinement_Clause;
26042 -----------------------------
26043 -- Report_Unrefined_States --
26044 -----------------------------
26046 procedure Report_Unrefined_States (States : Elist_Id) is
26047 State_Elmt : Elmt_Id;
26049 begin
26050 if Present (States) then
26051 State_Elmt := First_Elmt (States);
26052 while Present (State_Elmt) loop
26053 SPARK_Msg_N
26054 ("abstract state & must be refined", Node (State_Elmt));
26056 Next_Elmt (State_Elmt);
26057 end loop;
26058 end if;
26059 end Report_Unrefined_States;
26061 -- Local declarations
26063 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26064 Clause : Node_Id;
26066 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26068 begin
26069 -- Do not analyze the pragma multiple times
26071 if Is_Analyzed_Pragma (N) then
26072 return;
26073 end if;
26075 -- Replicate the abstract states declared by the package because the
26076 -- matching algorithm will consume states.
26078 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
26080 -- Gather all abstract states and objects declared in the visible
26081 -- state space of the package body. These items must be utilized as
26082 -- constituents in a state refinement.
26084 Body_States := Collect_Body_States (Body_Id);
26086 -- Multiple non-null state refinements appear as an aggregate
26088 if Nkind (Clauses) = N_Aggregate then
26089 if Present (Expressions (Clauses)) then
26090 SPARK_Msg_N
26091 ("state refinements must appear as component associations",
26092 Clauses);
26094 else pragma Assert (Present (Component_Associations (Clauses)));
26095 Clause := First (Component_Associations (Clauses));
26096 while Present (Clause) loop
26097 Analyze_Refinement_Clause (Clause);
26098 Next (Clause);
26099 end loop;
26100 end if;
26102 -- Various forms of a single state refinement. Note that these may
26103 -- include malformed refinements.
26105 else
26106 Analyze_Refinement_Clause (Clauses);
26107 end if;
26109 -- List all abstract states that were left unrefined
26111 Report_Unrefined_States (Available_States);
26113 Set_Is_Analyzed_Pragma (N);
26114 end Analyze_Refined_State_In_Decl_Part;
26116 ------------------------------------
26117 -- Analyze_Test_Case_In_Decl_Part --
26118 ------------------------------------
26120 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
26121 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26122 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26124 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
26125 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26126 -- denoted by Arg_Nam.
26128 ------------------------------
26129 -- Preanalyze_Test_Case_Arg --
26130 ------------------------------
26132 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
26133 Arg : Node_Id;
26135 begin
26136 -- Preanalyze the original aspect argument for ASIS or for a generic
26137 -- subprogram to properly capture global references.
26139 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
26140 Arg :=
26141 Test_Case_Arg
26142 (Prag => N,
26143 Arg_Nam => Arg_Nam,
26144 From_Aspect => True);
26146 if Present (Arg) then
26147 Preanalyze_Assert_Expression
26148 (Expression (Arg), Standard_Boolean);
26149 end if;
26150 end if;
26152 Arg := Test_Case_Arg (N, Arg_Nam);
26154 if Present (Arg) then
26155 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
26156 end if;
26157 end Preanalyze_Test_Case_Arg;
26159 -- Local variables
26161 Restore_Scope : Boolean := False;
26163 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26165 begin
26166 -- Do not analyze the pragma multiple times
26168 if Is_Analyzed_Pragma (N) then
26169 return;
26170 end if;
26172 -- Ensure that the formal parameters are visible when analyzing all
26173 -- clauses. This falls out of the general rule of aspects pertaining
26174 -- to subprogram declarations.
26176 if not In_Open_Scopes (Spec_Id) then
26177 Restore_Scope := True;
26178 Push_Scope (Spec_Id);
26180 if Is_Generic_Subprogram (Spec_Id) then
26181 Install_Generic_Formals (Spec_Id);
26182 else
26183 Install_Formals (Spec_Id);
26184 end if;
26185 end if;
26187 Preanalyze_Test_Case_Arg (Name_Requires);
26188 Preanalyze_Test_Case_Arg (Name_Ensures);
26190 if Restore_Scope then
26191 End_Scope;
26192 end if;
26194 -- Currently it is not possible to inline pre/postconditions on a
26195 -- subprogram subject to pragma Inline_Always.
26197 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26199 Set_Is_Analyzed_Pragma (N);
26200 end Analyze_Test_Case_In_Decl_Part;
26202 ----------------
26203 -- Appears_In --
26204 ----------------
26206 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
26207 Elmt : Elmt_Id;
26208 Id : Entity_Id;
26210 begin
26211 if Present (List) then
26212 Elmt := First_Elmt (List);
26213 while Present (Elmt) loop
26214 if Nkind (Node (Elmt)) = N_Defining_Identifier then
26215 Id := Node (Elmt);
26216 else
26217 Id := Entity_Of (Node (Elmt));
26218 end if;
26220 if Id = Item_Id then
26221 return True;
26222 end if;
26224 Next_Elmt (Elmt);
26225 end loop;
26226 end if;
26228 return False;
26229 end Appears_In;
26231 -----------------------------------
26232 -- Build_Pragma_Check_Equivalent --
26233 -----------------------------------
26235 function Build_Pragma_Check_Equivalent
26236 (Prag : Node_Id;
26237 Subp_Id : Entity_Id := Empty;
26238 Inher_Id : Entity_Id := Empty) return Node_Id
26240 Map : Elist_Id;
26241 -- List containing the following mappings
26242 -- * Formal parameters of inherited subprogram Inher_Id and subprogram
26243 -- Subp_Id.
26245 -- * The dispatching type of Inher_Id and the dispatching type of
26246 -- Subp_Id.
26248 -- * Primitives of the dispatching type of Inher_Id and primitives of
26249 -- the dispatching type of Subp_Id.
26251 function Replace_Entity (N : Node_Id) return Traverse_Result;
26252 -- Replace reference to formal of inherited operation or to primitive
26253 -- operation of root type, with corresponding entity for derived type.
26255 function Suppress_Reference (N : Node_Id) return Traverse_Result;
26256 -- Detect whether node N references a formal parameter subject to
26257 -- pragma Unreferenced. If this is the case, set Comes_From_Source
26258 -- to False to suppress the generation of a reference when analyzing
26259 -- N later on.
26261 --------------------
26262 -- Replace_Entity --
26263 --------------------
26265 function Replace_Entity (N : Node_Id) return Traverse_Result is
26266 Elmt : Elmt_Id;
26267 New_E : Entity_Id;
26269 begin
26270 if Nkind (N) = N_Identifier
26271 and then Present (Entity (N))
26272 and then
26273 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
26274 and then
26275 (Nkind (Parent (N)) /= N_Attribute_Reference
26276 or else Attribute_Name (Parent (N)) /= Name_Class)
26277 then
26278 -- The replacement does not apply to dispatching calls within the
26279 -- condition, but only to calls whose static tag is that of the
26280 -- parent type.
26282 if Is_Subprogram (Entity (N))
26283 and then Nkind (Parent (N)) = N_Function_Call
26284 and then Present (Controlling_Argument (Parent (N)))
26285 then
26286 return OK;
26287 end if;
26289 -- Loop to find out if entity has a renaming
26291 New_E := Empty;
26292 Elmt := First_Elmt (Map);
26293 while Present (Elmt) loop
26294 if Node (Elmt) = Entity (N) then
26295 New_E := Node (Next_Elmt (Elmt));
26296 exit;
26297 end if;
26299 Next_Elmt (Elmt);
26300 end loop;
26302 if Present (New_E) then
26303 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
26304 end if;
26306 -- Check that there are no calls left to abstract operations
26307 -- if the current subprogram is not abstract.
26309 if Nkind (Parent (N)) = N_Function_Call
26310 and then N = Name (Parent (N))
26311 and then not Is_Abstract_Subprogram (Subp_Id)
26312 and then Is_Abstract_Subprogram (Entity (N))
26313 then
26314 Error_Msg_Sloc := Sloc (Current_Scope);
26315 Error_Msg_NE
26316 ("cannot call abstract subprogram in inherited condition "
26317 & "for&#", N, Current_Scope);
26318 end if;
26320 -- The whole expression will be reanalyzed
26322 elsif Nkind (N) in N_Has_Etype then
26323 Set_Analyzed (N, False);
26324 end if;
26326 return OK;
26327 end Replace_Entity;
26329 ------------------------
26330 -- Suppress_Reference --
26331 ------------------------
26333 function Suppress_Reference (N : Node_Id) return Traverse_Result is
26334 Formal : Entity_Id;
26336 begin
26337 if Is_Entity_Name (N) and then Present (Entity (N)) then
26338 Formal := Entity (N);
26340 -- The formal parameter is subject to pragma Unreferenced.
26341 -- Prevent the generation of a reference by resetting the
26342 -- Comes_From_Source flag.
26344 if Is_Formal (Formal)
26345 and then Has_Pragma_Unreferenced (Formal)
26346 then
26347 Set_Comes_From_Source (N, False);
26348 end if;
26349 end if;
26351 return OK;
26352 end Suppress_Reference;
26354 procedure Replace_Condition_Entities is
26355 new Traverse_Proc (Replace_Entity);
26357 procedure Suppress_References is
26358 new Traverse_Proc (Suppress_Reference);
26360 -- Local variables
26362 Loc : constant Source_Ptr := Sloc (Prag);
26363 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
26364 Check_Prag : Node_Id;
26365 Inher_Formal : Entity_Id;
26366 Msg_Arg : Node_Id;
26367 Nam : Name_Id;
26368 Subp_Formal : Entity_Id;
26370 -- Start of processing for Build_Pragma_Check_Equivalent
26372 begin
26373 Map := No_Elist;
26375 -- When the pre- or postcondition is inherited, map the formals of the
26376 -- inherited subprogram to those of the current subprogram. In addition,
26377 -- map primitive operations of the parent type into the corresponding
26378 -- primitive operations of the descendant.
26380 if Present (Inher_Id) then
26381 pragma Assert (Present (Subp_Id));
26383 Map := New_Elmt_List;
26385 -- Create a mapping <inherited formal> => <subprogram formal>
26387 Inher_Formal := First_Formal (Inher_Id);
26388 Subp_Formal := First_Formal (Subp_Id);
26389 while Present (Inher_Formal) and then Present (Subp_Formal) loop
26390 Append_Elmt (Inher_Formal, Map);
26391 Append_Elmt (Subp_Formal, Map);
26393 Next_Formal (Inher_Formal);
26394 Next_Formal (Subp_Formal);
26395 end loop;
26397 -- Map primitive operations of the parent type to the corresponding
26398 -- operations of the descendant. Note that the descendant type may
26399 -- not be frozen yet, so we cannot use the dispatch table directly.
26401 -- Note : the construction of the map involves a full traversal of
26402 -- the list of primitive operations, as well as a scan of the
26403 -- declarations in the scope of the operation. Given that class-wide
26404 -- conditions are typically short expressions, it might be much more
26405 -- efficient to collect the identifiers in the expression first, and
26406 -- then determine the ones that have to be mapped. Optimization ???
26408 Primitive_Mapping : declare
26409 function Overridden_Ancestor (S : Entity_Id) return Entity_Id;
26410 -- Given the controlling type of the overridden operation and a
26411 -- primitive of the current type, find the corresponding operation
26412 -- of the parent type.
26414 -------------------------
26415 -- Overridden_Ancestor --
26416 -------------------------
26418 function Overridden_Ancestor (S : Entity_Id) return Entity_Id is
26419 Par : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
26420 Anc : Entity_Id;
26422 begin
26423 Anc := S;
26425 -- Locate the ancestor subprogram with the proper controlling
26426 -- type.
26428 while Present (Overridden_Operation (Anc)) loop
26429 Anc := Overridden_Operation (Anc);
26430 exit when Find_Dispatching_Type (Anc) = Par;
26431 end loop;
26433 return Anc;
26434 end Overridden_Ancestor;
26436 -- Local variables
26438 Old_Typ : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
26439 Typ : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
26440 Decl : Node_Id;
26441 Old_Elmt : Elmt_Id;
26442 Old_Prim : Entity_Id;
26443 Prim : Entity_Id;
26445 -- Start of processing for Primitive_Mapping
26447 begin
26448 Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id)));
26450 -- Look for primitive operations of the current type that have
26451 -- overridden an operation of the type related to the original
26452 -- class-wide precondition. There may be several intermediate
26453 -- overridings between them.
26455 while Present (Decl) loop
26456 if Nkind_In (Decl,
26457 N_Subprogram_Declaration, N_Abstract_Subprogram_Declaration)
26458 then
26459 Prim := Defining_Entity (Decl);
26461 if Is_Subprogram (Prim)
26462 and then Present (Overridden_Operation (Prim))
26463 and then Find_Dispatching_Type (Prim) = Typ
26464 then
26465 Old_Prim := Overridden_Ancestor (Prim);
26467 Append_Elmt (Old_Prim, Map);
26468 Append_Elmt (Prim, Map);
26469 end if;
26470 end if;
26472 Next (Decl);
26473 end loop;
26475 -- Now examine inherited operations. These do not override, but
26476 -- have an alias, which is the entity used in a call. In turn
26477 -- that alias may be inherited or comes from source, in which
26478 -- case it may override an earlier operation. We only need to
26479 -- examine inherited functions, that may appear within the
26480 -- inherited expression.
26482 Prim := First_Entity (Scope (Subp_Id));
26483 while Present (Prim) loop
26484 if not Comes_From_Source (Prim)
26485 and then Ekind (Prim) = E_Function
26486 and then Present (Alias (Prim))
26487 then
26488 Old_Prim := Alias (Prim);
26490 if Comes_From_Source (Old_Prim) then
26491 Old_Prim := Overridden_Ancestor (Old_Prim);
26493 else
26494 while Present (Alias (Old_Prim))
26495 and then Scope (Old_Prim) /= Scope (Inher_Id)
26496 loop
26497 Old_Prim := Alias (Old_Prim);
26499 if Comes_From_Source (Old_Prim) then
26500 Old_Prim := Overridden_Ancestor (Old_Prim);
26501 exit;
26502 end if;
26503 end loop;
26504 end if;
26506 Append_Elmt (Old_Prim, Map);
26507 Append_Elmt (Prim, Map);
26508 end if;
26510 Next_Entity (Prim);
26511 end loop;
26513 -- If the parent operation is an interface operation, the
26514 -- overriding indicator is not present. Instead, we get from
26515 -- the interface operation the primitive of the current type
26516 -- that implements it.
26518 if Is_Interface (Old_Typ) then
26519 Old_Elmt := First_Elmt (Collect_Primitive_Operations (Old_Typ));
26520 while Present (Old_Elmt) loop
26521 Old_Prim := Node (Old_Elmt);
26522 Prim := Find_Primitive_Covering_Interface (Typ, Old_Prim);
26524 if Present (Prim) then
26525 Append_Elmt (Old_Prim, Map);
26526 Append_Elmt (Prim, Map);
26527 end if;
26529 Next_Elmt (Old_Elmt);
26530 end loop;
26531 end if;
26533 if Map /= No_Elist then
26534 Append_Elmt (Old_Typ, Map);
26535 Append_Elmt (Typ, Map);
26536 end if;
26537 end Primitive_Mapping;
26538 end if;
26540 -- Copy the original pragma while performing substitutions (if
26541 -- applicable).
26543 Check_Prag := New_Copy_Tree (Source => Prag);
26545 if Map /= No_Elist then
26546 Replace_Condition_Entities (Check_Prag);
26547 end if;
26549 -- Mark the pragma as being internally generated and reset the Analyzed
26550 -- flag.
26552 Set_Analyzed (Check_Prag, False);
26553 Set_Comes_From_Source (Check_Prag, False);
26554 Set_Class_Present (Check_Prag, False);
26556 -- The tree of the original pragma may contain references to the
26557 -- formal parameters of the related subprogram. At the same time
26558 -- the corresponding body may mark the formals as unreferenced:
26560 -- procedure Proc (Formal : ...)
26561 -- with Pre => Formal ...;
26563 -- procedure Proc (Formal : ...) is
26564 -- pragma Unreferenced (Formal);
26565 -- ...
26567 -- This creates problems because all pragma Check equivalents are
26568 -- analyzed at the end of the body declarations. Since all source
26569 -- references have already been accounted for, reset any references
26570 -- to such formals in the generated pragma Check equivalent.
26572 Suppress_References (Check_Prag);
26574 if Present (Corresponding_Aspect (Prag)) then
26575 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
26576 else
26577 Nam := Prag_Nam;
26578 end if;
26580 -- Convert the copy into pragma Check by correcting the name and adding
26581 -- a check_kind argument.
26583 Set_Pragma_Identifier
26584 (Check_Prag, Make_Identifier (Loc, Name_Check));
26586 Prepend_To (Pragma_Argument_Associations (Check_Prag),
26587 Make_Pragma_Argument_Association (Loc,
26588 Expression => Make_Identifier (Loc, Nam)));
26590 -- Update the error message when the pragma is inherited
26592 if Present (Inher_Id) then
26593 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
26595 if Chars (Msg_Arg) = Name_Message then
26596 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
26598 -- Insert "inherited" to improve the error message
26600 if Name_Buffer (1 .. 8) = "failed p" then
26601 Insert_Str_In_Name_Buffer ("inherited ", 8);
26602 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
26603 end if;
26604 end if;
26605 end if;
26607 return Check_Prag;
26608 end Build_Pragma_Check_Equivalent;
26610 -----------------------------
26611 -- Check_Applicable_Policy --
26612 -----------------------------
26614 procedure Check_Applicable_Policy (N : Node_Id) is
26615 PP : Node_Id;
26616 Policy : Name_Id;
26618 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
26620 begin
26621 -- No effect if not valid assertion kind name
26623 if not Is_Valid_Assertion_Kind (Ename) then
26624 return;
26625 end if;
26627 -- Loop through entries in check policy list
26629 PP := Opt.Check_Policy_List;
26630 while Present (PP) loop
26631 declare
26632 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26633 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26635 begin
26636 if Ename = Pnm
26637 or else Pnm = Name_Assertion
26638 or else (Pnm = Name_Statement_Assertions
26639 and then Nam_In (Ename, Name_Assert,
26640 Name_Assert_And_Cut,
26641 Name_Assume,
26642 Name_Loop_Invariant,
26643 Name_Loop_Variant))
26644 then
26645 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
26647 case Policy is
26648 when Name_Off | Name_Ignore =>
26649 Set_Is_Ignored (N, True);
26650 Set_Is_Checked (N, False);
26652 when Name_On | Name_Check =>
26653 Set_Is_Checked (N, True);
26654 Set_Is_Ignored (N, False);
26656 when Name_Disable =>
26657 Set_Is_Ignored (N, True);
26658 Set_Is_Checked (N, False);
26659 Set_Is_Disabled (N, True);
26661 -- That should be exhaustive, the null here is a defence
26662 -- against a malformed tree from previous errors.
26664 when others =>
26665 null;
26666 end case;
26668 return;
26669 end if;
26671 PP := Next_Pragma (PP);
26672 end;
26673 end loop;
26675 -- If there are no specific entries that matched, then we let the
26676 -- setting of assertions govern. Note that this provides the needed
26677 -- compatibility with the RM for the cases of assertion, invariant,
26678 -- precondition, predicate, and postcondition.
26680 if Assertions_Enabled then
26681 Set_Is_Checked (N, True);
26682 Set_Is_Ignored (N, False);
26683 else
26684 Set_Is_Checked (N, False);
26685 Set_Is_Ignored (N, True);
26686 end if;
26687 end Check_Applicable_Policy;
26689 -------------------------------
26690 -- Check_External_Properties --
26691 -------------------------------
26693 procedure Check_External_Properties
26694 (Item : Node_Id;
26695 AR : Boolean;
26696 AW : Boolean;
26697 ER : Boolean;
26698 EW : Boolean)
26700 begin
26701 -- All properties enabled
26703 if AR and AW and ER and EW then
26704 null;
26706 -- Async_Readers + Effective_Writes
26707 -- Async_Readers + Async_Writers + Effective_Writes
26709 elsif AR and EW and not ER then
26710 null;
26712 -- Async_Writers + Effective_Reads
26713 -- Async_Readers + Async_Writers + Effective_Reads
26715 elsif AW and ER and not EW then
26716 null;
26718 -- Async_Readers + Async_Writers
26720 elsif AR and AW and not ER and not EW then
26721 null;
26723 -- Async_Readers
26725 elsif AR and not AW and not ER and not EW then
26726 null;
26728 -- Async_Writers
26730 elsif AW and not AR and not ER and not EW then
26731 null;
26733 else
26734 SPARK_Msg_N
26735 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26736 Item);
26737 end if;
26738 end Check_External_Properties;
26740 ----------------
26741 -- Check_Kind --
26742 ----------------
26744 function Check_Kind (Nam : Name_Id) return Name_Id is
26745 PP : Node_Id;
26747 begin
26748 -- Loop through entries in check policy list
26750 PP := Opt.Check_Policy_List;
26751 while Present (PP) loop
26752 declare
26753 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26754 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26756 begin
26757 if Nam = Pnm
26758 or else (Pnm = Name_Assertion
26759 and then Is_Valid_Assertion_Kind (Nam))
26760 or else (Pnm = Name_Statement_Assertions
26761 and then Nam_In (Nam, Name_Assert,
26762 Name_Assert_And_Cut,
26763 Name_Assume,
26764 Name_Loop_Invariant,
26765 Name_Loop_Variant))
26766 then
26767 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
26768 when Name_On | Name_Check =>
26769 return Name_Check;
26770 when Name_Off | Name_Ignore =>
26771 return Name_Ignore;
26772 when Name_Disable =>
26773 return Name_Disable;
26774 when others =>
26775 raise Program_Error;
26776 end case;
26778 else
26779 PP := Next_Pragma (PP);
26780 end if;
26781 end;
26782 end loop;
26784 -- If there are no specific entries that matched, then we let the
26785 -- setting of assertions govern. Note that this provides the needed
26786 -- compatibility with the RM for the cases of assertion, invariant,
26787 -- precondition, predicate, and postcondition.
26789 if Assertions_Enabled then
26790 return Name_Check;
26791 else
26792 return Name_Ignore;
26793 end if;
26794 end Check_Kind;
26796 ---------------------------
26797 -- Check_Missing_Part_Of --
26798 ---------------------------
26800 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
26801 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
26802 -- Determine whether a package denoted by Pack_Id declares at least one
26803 -- visible state.
26805 -----------------------
26806 -- Has_Visible_State --
26807 -----------------------
26809 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
26810 Item_Id : Entity_Id;
26812 begin
26813 -- Traverse the entity chain of the package trying to find at least
26814 -- one visible abstract state, variable or a package [instantiation]
26815 -- that declares a visible state.
26817 Item_Id := First_Entity (Pack_Id);
26818 while Present (Item_Id)
26819 and then not In_Private_Part (Item_Id)
26820 loop
26821 -- Do not consider internally generated items
26823 if not Comes_From_Source (Item_Id) then
26824 null;
26826 -- A visible state has been found
26828 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
26829 return True;
26831 -- Recursively peek into nested packages and instantiations
26833 elsif Ekind (Item_Id) = E_Package
26834 and then Has_Visible_State (Item_Id)
26835 then
26836 return True;
26837 end if;
26839 Next_Entity (Item_Id);
26840 end loop;
26842 return False;
26843 end Has_Visible_State;
26845 -- Local variables
26847 Pack_Id : Entity_Id;
26848 Placement : State_Space_Kind;
26850 -- Start of processing for Check_Missing_Part_Of
26852 begin
26853 -- Do not consider abstract states, variables or package instantiations
26854 -- coming from an instance as those always inherit the Part_Of indicator
26855 -- of the instance itself.
26857 if In_Instance then
26858 return;
26860 -- Do not consider internally generated entities as these can never
26861 -- have a Part_Of indicator.
26863 elsif not Comes_From_Source (Item_Id) then
26864 return;
26866 -- Perform these checks only when SPARK_Mode is enabled as they will
26867 -- interfere with standard Ada rules and produce false positives.
26869 elsif SPARK_Mode /= On then
26870 return;
26872 -- Do not consider constants, because the compiler cannot accurately
26873 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26874 -- act as a hidden state of a package.
26876 elsif Ekind (Item_Id) = E_Constant then
26877 return;
26878 end if;
26880 -- Find where the abstract state, variable or package instantiation
26881 -- lives with respect to the state space.
26883 Find_Placement_In_State_Space
26884 (Item_Id => Item_Id,
26885 Placement => Placement,
26886 Pack_Id => Pack_Id);
26888 -- Items that appear in a non-package construct (subprogram, block, etc)
26889 -- do not require a Part_Of indicator because they can never act as a
26890 -- hidden state.
26892 if Placement = Not_In_Package then
26893 null;
26895 -- An item declared in the body state space of a package always act as a
26896 -- constituent and does not need explicit Part_Of indicator.
26898 elsif Placement = Body_State_Space then
26899 null;
26901 -- In general an item declared in the visible state space of a package
26902 -- does not require a Part_Of indicator. The only exception is when the
26903 -- related package is a private child unit in which case Part_Of must
26904 -- denote a state in the parent unit or in one of its descendants.
26906 elsif Placement = Visible_State_Space then
26907 if Is_Child_Unit (Pack_Id)
26908 and then Is_Private_Descendant (Pack_Id)
26909 then
26910 -- A package instantiation does not need a Part_Of indicator when
26911 -- the related generic template has no visible state.
26913 if Ekind (Item_Id) = E_Package
26914 and then Is_Generic_Instance (Item_Id)
26915 and then not Has_Visible_State (Item_Id)
26916 then
26917 null;
26919 -- All other cases require Part_Of
26921 else
26922 Error_Msg_N
26923 ("indicator Part_Of is required in this context "
26924 & "(SPARK RM 7.2.6(3))", Item_Id);
26925 Error_Msg_Name_1 := Chars (Pack_Id);
26926 Error_Msg_N
26927 ("\& is declared in the visible part of private child "
26928 & "unit %", Item_Id);
26929 end if;
26930 end if;
26932 -- When the item appears in the private state space of a packge, it must
26933 -- be a part of some state declared by the said package.
26935 else pragma Assert (Placement = Private_State_Space);
26937 -- The related package does not declare a state, the item cannot act
26938 -- as a Part_Of constituent.
26940 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
26941 null;
26943 -- A package instantiation does not need a Part_Of indicator when the
26944 -- related generic template has no visible state.
26946 elsif Ekind (Pack_Id) = E_Package
26947 and then Is_Generic_Instance (Pack_Id)
26948 and then not Has_Visible_State (Pack_Id)
26949 then
26950 null;
26952 -- All other cases require Part_Of
26954 else
26955 Error_Msg_N
26956 ("indicator Part_Of is required in this context "
26957 & "(SPARK RM 7.2.6(2))", Item_Id);
26958 Error_Msg_Name_1 := Chars (Pack_Id);
26959 Error_Msg_N
26960 ("\& is declared in the private part of package %", Item_Id);
26961 end if;
26962 end if;
26963 end Check_Missing_Part_Of;
26965 ---------------------------------------------------
26966 -- Check_Postcondition_Use_In_Inlined_Subprogram --
26967 ---------------------------------------------------
26969 procedure Check_Postcondition_Use_In_Inlined_Subprogram
26970 (Prag : Node_Id;
26971 Spec_Id : Entity_Id)
26973 begin
26974 if Warn_On_Redundant_Constructs
26975 and then Has_Pragma_Inline_Always (Spec_Id)
26976 then
26977 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
26979 if From_Aspect_Specification (Prag) then
26980 Error_Msg_NE
26981 ("aspect % not enforced on inlined subprogram &?r?",
26982 Corresponding_Aspect (Prag), Spec_Id);
26983 else
26984 Error_Msg_NE
26985 ("pragma % not enforced on inlined subprogram &?r?",
26986 Prag, Spec_Id);
26987 end if;
26988 end if;
26989 end Check_Postcondition_Use_In_Inlined_Subprogram;
26991 -------------------------------------
26992 -- Check_State_And_Constituent_Use --
26993 -------------------------------------
26995 procedure Check_State_And_Constituent_Use
26996 (States : Elist_Id;
26997 Constits : Elist_Id;
26998 Context : Node_Id)
27000 function Find_Encapsulating_State
27001 (Constit_Id : Entity_Id) return Entity_Id;
27002 -- Given the entity of a constituent, try to find a corresponding
27003 -- encapsulating state that appears in the same context. The routine
27004 -- returns Empty is no such state is found.
27006 ------------------------------
27007 -- Find_Encapsulating_State --
27008 ------------------------------
27010 function Find_Encapsulating_State
27011 (Constit_Id : Entity_Id) return Entity_Id
27013 State_Id : Entity_Id;
27015 begin
27016 -- Since a constituent may be part of a larger constituent set, climb
27017 -- the encapsulating state chain looking for a state that appears in
27018 -- the same context.
27020 State_Id := Encapsulating_State (Constit_Id);
27021 while Present (State_Id) loop
27022 if Contains (States, State_Id) then
27023 return State_Id;
27024 end if;
27026 State_Id := Encapsulating_State (State_Id);
27027 end loop;
27029 return Empty;
27030 end Find_Encapsulating_State;
27032 -- Local variables
27034 Constit_Elmt : Elmt_Id;
27035 Constit_Id : Entity_Id;
27036 State_Id : Entity_Id;
27038 -- Start of processing for Check_State_And_Constituent_Use
27040 begin
27041 -- Nothing to do if there are no states or constituents
27043 if No (States) or else No (Constits) then
27044 return;
27045 end if;
27047 -- Inspect the list of constituents and try to determine whether its
27048 -- encapsulating state is in list States.
27050 Constit_Elmt := First_Elmt (Constits);
27051 while Present (Constit_Elmt) loop
27052 Constit_Id := Node (Constit_Elmt);
27054 -- Determine whether the constituent is part of an encapsulating
27055 -- state that appears in the same context and if this is the case,
27056 -- emit an error (SPARK RM 7.2.6(7)).
27058 State_Id := Find_Encapsulating_State (Constit_Id);
27060 if Present (State_Id) then
27061 Error_Msg_Name_1 := Chars (Constit_Id);
27062 SPARK_Msg_NE
27063 ("cannot mention state & and its constituent % in the same "
27064 & "context", Context, State_Id);
27065 exit;
27066 end if;
27068 Next_Elmt (Constit_Elmt);
27069 end loop;
27070 end Check_State_And_Constituent_Use;
27072 ---------------------------------------------
27073 -- Collect_Inherited_Class_Wide_Conditions --
27074 ---------------------------------------------
27076 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
27077 Parent_Subp : constant Entity_Id := Overridden_Operation (Subp);
27078 Prags : constant Node_Id := Contract (Parent_Subp);
27079 In_Spec_Expr : Boolean;
27080 Installed : Boolean;
27081 Prag : Node_Id;
27082 New_Prag : Node_Id;
27084 begin
27085 Installed := False;
27087 -- Iterate over the contract of the overridden subprogram to find all
27088 -- inherited class-wide pre- and postconditions.
27090 if Present (Prags) then
27091 Prag := Pre_Post_Conditions (Prags);
27093 while Present (Prag) loop
27094 if Nam_In (Pragma_Name (Prag), Name_Precondition,
27095 Name_Postcondition)
27096 and then Class_Present (Prag)
27097 then
27098 -- The generated pragma must be analyzed in the context of
27099 -- the subprogram, to make its formals visible. In addition,
27100 -- we must inhibit freezing and full analysis because the
27101 -- controlling type of the subprogram is not frozen yet, and
27102 -- may have further primitives.
27104 if not Installed then
27105 Installed := True;
27106 Push_Scope (Subp);
27107 Install_Formals (Subp);
27108 In_Spec_Expr := In_Spec_Expression;
27109 In_Spec_Expression := True;
27110 end if;
27112 New_Prag :=
27113 Build_Pragma_Check_Equivalent (Prag, Subp, Parent_Subp);
27114 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
27115 Preanalyze (New_Prag);
27117 -- Prevent further analysis in subsequent processing of the
27118 -- current list of declarations
27120 Set_Analyzed (New_Prag);
27121 end if;
27123 Prag := Next_Pragma (Prag);
27124 end loop;
27126 if Installed then
27127 In_Spec_Expression := In_Spec_Expr;
27128 End_Scope;
27129 end if;
27130 end if;
27131 end Collect_Inherited_Class_Wide_Conditions;
27133 ---------------------------------------
27134 -- Collect_Subprogram_Inputs_Outputs --
27135 ---------------------------------------
27137 procedure Collect_Subprogram_Inputs_Outputs
27138 (Subp_Id : Entity_Id;
27139 Synthesize : Boolean := False;
27140 Subp_Inputs : in out Elist_Id;
27141 Subp_Outputs : in out Elist_Id;
27142 Global_Seen : out Boolean)
27144 procedure Collect_Dependency_Clause (Clause : Node_Id);
27145 -- Collect all relevant items from a dependency clause
27147 procedure Collect_Global_List
27148 (List : Node_Id;
27149 Mode : Name_Id := Name_Input);
27150 -- Collect all relevant items from a global list
27152 -------------------------------
27153 -- Collect_Dependency_Clause --
27154 -------------------------------
27156 procedure Collect_Dependency_Clause (Clause : Node_Id) is
27157 procedure Collect_Dependency_Item
27158 (Item : Node_Id;
27159 Is_Input : Boolean);
27160 -- Add an item to the proper subprogram input or output collection
27162 -----------------------------
27163 -- Collect_Dependency_Item --
27164 -----------------------------
27166 procedure Collect_Dependency_Item
27167 (Item : Node_Id;
27168 Is_Input : Boolean)
27170 Extra : Node_Id;
27172 begin
27173 -- Nothing to collect when the item is null
27175 if Nkind (Item) = N_Null then
27176 null;
27178 -- Ditto for attribute 'Result
27180 elsif Is_Attribute_Result (Item) then
27181 null;
27183 -- Multiple items appear as an aggregate
27185 elsif Nkind (Item) = N_Aggregate then
27186 Extra := First (Expressions (Item));
27187 while Present (Extra) loop
27188 Collect_Dependency_Item (Extra, Is_Input);
27189 Next (Extra);
27190 end loop;
27192 -- Otherwise this is a solitary item
27194 else
27195 if Is_Input then
27196 Append_New_Elmt (Item, Subp_Inputs);
27197 else
27198 Append_New_Elmt (Item, Subp_Outputs);
27199 end if;
27200 end if;
27201 end Collect_Dependency_Item;
27203 -- Start of processing for Collect_Dependency_Clause
27205 begin
27206 if Nkind (Clause) = N_Null then
27207 null;
27209 -- A dependency cause appears as component association
27211 elsif Nkind (Clause) = N_Component_Association then
27212 Collect_Dependency_Item
27213 (Item => Expression (Clause),
27214 Is_Input => True);
27216 Collect_Dependency_Item
27217 (Item => First (Choices (Clause)),
27218 Is_Input => False);
27220 -- To accomodate partial decoration of disabled SPARK features, this
27221 -- routine may be called with illegal input. If this is the case, do
27222 -- not raise Program_Error.
27224 else
27225 null;
27226 end if;
27227 end Collect_Dependency_Clause;
27229 -------------------------
27230 -- Collect_Global_List --
27231 -------------------------
27233 procedure Collect_Global_List
27234 (List : Node_Id;
27235 Mode : Name_Id := Name_Input)
27237 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
27238 -- Add an item to the proper subprogram input or output collection
27240 -------------------------
27241 -- Collect_Global_Item --
27242 -------------------------
27244 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
27245 begin
27246 if Nam_In (Mode, Name_In_Out, Name_Input) then
27247 Append_New_Elmt (Item, Subp_Inputs);
27248 end if;
27250 if Nam_In (Mode, Name_In_Out, Name_Output) then
27251 Append_New_Elmt (Item, Subp_Outputs);
27252 end if;
27253 end Collect_Global_Item;
27255 -- Local variables
27257 Assoc : Node_Id;
27258 Item : Node_Id;
27260 -- Start of processing for Collect_Global_List
27262 begin
27263 if Nkind (List) = N_Null then
27264 null;
27266 -- Single global item declaration
27268 elsif Nkind_In (List, N_Expanded_Name,
27269 N_Identifier,
27270 N_Selected_Component)
27271 then
27272 Collect_Global_Item (List, Mode);
27274 -- Simple global list or moded global list declaration
27276 elsif Nkind (List) = N_Aggregate then
27277 if Present (Expressions (List)) then
27278 Item := First (Expressions (List));
27279 while Present (Item) loop
27280 Collect_Global_Item (Item, Mode);
27281 Next (Item);
27282 end loop;
27284 else
27285 Assoc := First (Component_Associations (List));
27286 while Present (Assoc) loop
27287 Collect_Global_List
27288 (List => Expression (Assoc),
27289 Mode => Chars (First (Choices (Assoc))));
27290 Next (Assoc);
27291 end loop;
27292 end if;
27294 -- To accomodate partial decoration of disabled SPARK features, this
27295 -- routine may be called with illegal input. If this is the case, do
27296 -- not raise Program_Error.
27298 else
27299 null;
27300 end if;
27301 end Collect_Global_List;
27303 -- Local variables
27305 Clause : Node_Id;
27306 Clauses : Node_Id;
27307 Depends : Node_Id;
27308 Formal : Entity_Id;
27309 Global : Node_Id;
27310 Spec_Id : Entity_Id;
27311 Subp_Decl : Node_Id;
27312 Typ : Entity_Id;
27314 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27316 begin
27317 Global_Seen := False;
27319 -- Process all formal parameters of entries, [generic] subprograms, and
27320 -- their bodies.
27322 if Ekind_In (Subp_Id, E_Entry,
27323 E_Entry_Family,
27324 E_Function,
27325 E_Generic_Function,
27326 E_Generic_Procedure,
27327 E_Procedure,
27328 E_Subprogram_Body)
27329 then
27330 Subp_Decl := Unit_Declaration_Node (Subp_Id);
27331 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27333 -- Process all [generic] formal parameters
27335 Formal := First_Entity (Spec_Id);
27336 while Present (Formal) loop
27337 if Ekind_In (Formal, E_Generic_In_Parameter,
27338 E_In_Out_Parameter,
27339 E_In_Parameter)
27340 then
27341 Append_New_Elmt (Formal, Subp_Inputs);
27342 end if;
27344 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
27345 E_In_Out_Parameter,
27346 E_Out_Parameter)
27347 then
27348 Append_New_Elmt (Formal, Subp_Outputs);
27350 -- Out parameters can act as inputs when the related type is
27351 -- tagged, unconstrained array, unconstrained record, or record
27352 -- with unconstrained components.
27354 if Ekind (Formal) = E_Out_Parameter
27355 and then Is_Unconstrained_Or_Tagged_Item (Formal)
27356 then
27357 Append_New_Elmt (Formal, Subp_Inputs);
27358 end if;
27359 end if;
27361 Next_Entity (Formal);
27362 end loop;
27364 -- Otherwise the input denotes a task type, a task body, or the
27365 -- anonymous object created for a single task type.
27367 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
27368 or else Is_Single_Task_Object (Subp_Id)
27369 then
27370 Subp_Decl := Declaration_Node (Subp_Id);
27371 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27372 end if;
27374 -- When processing an entry, subprogram or task body, look for pragmas
27375 -- Refined_Depends and Refined_Global as they specify the inputs and
27376 -- outputs.
27378 if Is_Entry_Body (Subp_Id)
27379 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
27380 then
27381 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
27382 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
27384 -- Subprogram declaration or stand alone body case, look for pragmas
27385 -- Depends and Global
27387 else
27388 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
27389 Global := Get_Pragma (Spec_Id, Pragma_Global);
27390 end if;
27392 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27393 -- because it provides finer granularity of inputs and outputs.
27395 if Present (Global) then
27396 Global_Seen := True;
27397 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
27399 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27400 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27401 -- the inputs and outputs from [Refined_]Depends.
27403 elsif Synthesize and then Present (Depends) then
27404 Clauses := Expression (Get_Argument (Depends, Spec_Id));
27406 -- Multiple dependency clauses appear as an aggregate
27408 if Nkind (Clauses) = N_Aggregate then
27409 Clause := First (Component_Associations (Clauses));
27410 while Present (Clause) loop
27411 Collect_Dependency_Clause (Clause);
27412 Next (Clause);
27413 end loop;
27415 -- Otherwise this is a single dependency clause
27417 else
27418 Collect_Dependency_Clause (Clauses);
27419 end if;
27420 end if;
27422 -- The current instance of a protected type acts as a formal parameter
27423 -- of mode IN for functions and IN OUT for entries and procedures
27424 -- (SPARK RM 6.1.4).
27426 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
27427 Typ := Scope (Spec_Id);
27429 -- Use the anonymous object when the type is single protected
27431 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27432 Typ := Anonymous_Object (Typ);
27433 end if;
27435 Append_New_Elmt (Typ, Subp_Inputs);
27437 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
27438 Append_New_Elmt (Typ, Subp_Outputs);
27439 end if;
27441 -- The current instance of a task type acts as a formal parameter of
27442 -- mode IN OUT (SPARK RM 6.1.4).
27444 elsif Ekind (Spec_Id) = E_Task_Type then
27445 Typ := Spec_Id;
27447 -- Use the anonymous object when the type is single task
27449 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27450 Typ := Anonymous_Object (Typ);
27451 end if;
27453 Append_New_Elmt (Typ, Subp_Inputs);
27454 Append_New_Elmt (Typ, Subp_Outputs);
27456 elsif Is_Single_Task_Object (Spec_Id) then
27457 Append_New_Elmt (Spec_Id, Subp_Inputs);
27458 Append_New_Elmt (Spec_Id, Subp_Outputs);
27459 end if;
27460 end Collect_Subprogram_Inputs_Outputs;
27462 ---------------------------
27463 -- Contract_Freeze_Error --
27464 ---------------------------
27466 procedure Contract_Freeze_Error
27467 (Contract_Id : Entity_Id;
27468 Freeze_Id : Entity_Id)
27470 begin
27471 Error_Msg_Name_1 := Chars (Contract_Id);
27472 Error_Msg_Sloc := Sloc (Freeze_Id);
27474 SPARK_Msg_NE
27475 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
27476 SPARK_Msg_N
27477 ("\all contractual items must be declared before body #", Contract_Id);
27478 end Contract_Freeze_Error;
27480 ---------------------------------
27481 -- Delay_Config_Pragma_Analyze --
27482 ---------------------------------
27484 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
27485 begin
27486 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
27487 Name_Priority_Specific_Dispatching);
27488 end Delay_Config_Pragma_Analyze;
27490 -----------------------
27491 -- Duplication_Error --
27492 -----------------------
27494 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
27495 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
27496 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
27498 begin
27499 Error_Msg_Sloc := Sloc (Prev);
27500 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27502 -- Emit a precise message to distinguish between source pragmas and
27503 -- pragmas generated from aspects. The ordering of the two pragmas is
27504 -- the following:
27506 -- Prev -- ok
27507 -- Prag -- duplicate
27509 -- No error is emitted when both pragmas come from aspects because this
27510 -- is already detected by the general aspect analysis mechanism.
27512 if Prag_From_Asp and Prev_From_Asp then
27513 null;
27514 elsif Prag_From_Asp then
27515 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
27516 elsif Prev_From_Asp then
27517 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
27518 else
27519 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
27520 end if;
27521 end Duplication_Error;
27523 --------------------------
27524 -- Find_Related_Context --
27525 --------------------------
27527 function Find_Related_Context
27528 (Prag : Node_Id;
27529 Do_Checks : Boolean := False) return Node_Id
27531 Stmt : Node_Id;
27533 begin
27534 Stmt := Prev (Prag);
27535 while Present (Stmt) loop
27537 -- Skip prior pragmas, but check for duplicates
27539 if Nkind (Stmt) = N_Pragma then
27540 if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
27541 Duplication_Error
27542 (Prag => Prag,
27543 Prev => Stmt);
27544 end if;
27546 -- Skip internally generated code
27548 elsif not Comes_From_Source (Stmt) then
27550 -- The anonymous object created for a single concurrent type is a
27551 -- suitable context.
27553 if Nkind (Stmt) = N_Object_Declaration
27554 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27555 then
27556 return Stmt;
27557 end if;
27559 -- Return the current source construct
27561 else
27562 return Stmt;
27563 end if;
27565 Prev (Stmt);
27566 end loop;
27568 return Empty;
27569 end Find_Related_Context;
27571 --------------------------------------
27572 -- Find_Related_Declaration_Or_Body --
27573 --------------------------------------
27575 function Find_Related_Declaration_Or_Body
27576 (Prag : Node_Id;
27577 Do_Checks : Boolean := False) return Node_Id
27579 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
27581 procedure Expression_Function_Error;
27582 -- Emit an error concerning pragma Prag that illegaly applies to an
27583 -- expression function.
27585 -------------------------------
27586 -- Expression_Function_Error --
27587 -------------------------------
27589 procedure Expression_Function_Error is
27590 begin
27591 Error_Msg_Name_1 := Prag_Nam;
27593 -- Emit a precise message to distinguish between source pragmas and
27594 -- pragmas generated from aspects.
27596 if From_Aspect_Specification (Prag) then
27597 Error_Msg_N
27598 ("aspect % cannot apply to a stand alone expression function",
27599 Prag);
27600 else
27601 Error_Msg_N
27602 ("pragma % cannot apply to a stand alone expression function",
27603 Prag);
27604 end if;
27605 end Expression_Function_Error;
27607 -- Local variables
27609 Context : constant Node_Id := Parent (Prag);
27610 Stmt : Node_Id;
27612 Look_For_Body : constant Boolean :=
27613 Nam_In (Prag_Nam, Name_Refined_Depends,
27614 Name_Refined_Global,
27615 Name_Refined_Post);
27616 -- Refinement pragmas must be associated with a subprogram body [stub]
27618 -- Start of processing for Find_Related_Declaration_Or_Body
27620 begin
27621 Stmt := Prev (Prag);
27622 while Present (Stmt) loop
27624 -- Skip prior pragmas, but check for duplicates. Pragmas produced
27625 -- by splitting a complex pre/postcondition are not considered to
27626 -- be duplicates.
27628 if Nkind (Stmt) = N_Pragma then
27629 if Do_Checks
27630 and then not Split_PPC (Stmt)
27631 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
27632 then
27633 Duplication_Error
27634 (Prag => Prag,
27635 Prev => Stmt);
27636 end if;
27638 -- Emit an error when a refinement pragma appears on an expression
27639 -- function without a completion.
27641 elsif Do_Checks
27642 and then Look_For_Body
27643 and then Nkind (Stmt) = N_Subprogram_Declaration
27644 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
27645 and then not Has_Completion (Defining_Entity (Stmt))
27646 then
27647 Expression_Function_Error;
27648 return Empty;
27650 -- The refinement pragma applies to a subprogram body stub
27652 elsif Look_For_Body
27653 and then Nkind (Stmt) = N_Subprogram_Body_Stub
27654 then
27655 return Stmt;
27657 -- Skip internally generated code
27659 elsif not Comes_From_Source (Stmt) then
27661 -- The anonymous object created for a single concurrent type is a
27662 -- suitable context.
27664 if Nkind (Stmt) = N_Object_Declaration
27665 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27666 then
27667 return Stmt;
27669 elsif Nkind (Stmt) = N_Subprogram_Declaration then
27671 -- The subprogram declaration is an internally generated spec
27672 -- for an expression function.
27674 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27675 return Stmt;
27677 -- The subprogram is actually an instance housed within an
27678 -- anonymous wrapper package.
27680 elsif Present (Generic_Parent (Specification (Stmt))) then
27681 return Stmt;
27682 end if;
27683 end if;
27685 -- Return the current construct which is either a subprogram body,
27686 -- a subprogram declaration or is illegal.
27688 else
27689 return Stmt;
27690 end if;
27692 Prev (Stmt);
27693 end loop;
27695 -- If we fall through, then the pragma was either the first declaration
27696 -- or it was preceded by other pragmas and no source constructs.
27698 -- The pragma is associated with a library-level subprogram
27700 if Nkind (Context) = N_Compilation_Unit_Aux then
27701 return Unit (Parent (Context));
27703 -- The pragma appears inside the declarations of an entry body
27705 elsif Nkind (Context) = N_Entry_Body then
27706 return Context;
27708 -- The pragma appears inside the statements of a subprogram body. This
27709 -- placement is the result of subprogram contract expansion.
27711 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
27712 return Parent (Context);
27714 -- The pragma appears inside the declarative part of a subprogram body
27716 elsif Nkind (Context) = N_Subprogram_Body then
27717 return Context;
27719 -- The pragma appears inside the declarative part of a task body
27721 elsif Nkind (Context) = N_Task_Body then
27722 return Context;
27724 -- The pragma is a byproduct of aspect expansion, return the related
27725 -- context of the original aspect. This case has a lower priority as
27726 -- the above circuitry pinpoints precisely the related context.
27728 elsif Present (Corresponding_Aspect (Prag)) then
27729 return Parent (Corresponding_Aspect (Prag));
27731 -- No candidate subprogram [body] found
27733 else
27734 return Empty;
27735 end if;
27736 end Find_Related_Declaration_Or_Body;
27738 ----------------------------------
27739 -- Find_Related_Package_Or_Body --
27740 ----------------------------------
27742 function Find_Related_Package_Or_Body
27743 (Prag : Node_Id;
27744 Do_Checks : Boolean := False) return Node_Id
27746 Context : constant Node_Id := Parent (Prag);
27747 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27748 Stmt : Node_Id;
27750 begin
27751 Stmt := Prev (Prag);
27752 while Present (Stmt) loop
27754 -- Skip prior pragmas, but check for duplicates
27756 if Nkind (Stmt) = N_Pragma then
27757 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
27758 Duplication_Error
27759 (Prag => Prag,
27760 Prev => Stmt);
27761 end if;
27763 -- Skip internally generated code
27765 elsif not Comes_From_Source (Stmt) then
27766 if Nkind (Stmt) = N_Subprogram_Declaration then
27768 -- The subprogram declaration is an internally generated spec
27769 -- for an expression function.
27771 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27772 return Stmt;
27774 -- The subprogram is actually an instance housed within an
27775 -- anonymous wrapper package.
27777 elsif Present (Generic_Parent (Specification (Stmt))) then
27778 return Stmt;
27779 end if;
27780 end if;
27782 -- Return the current source construct which is illegal
27784 else
27785 return Stmt;
27786 end if;
27788 Prev (Stmt);
27789 end loop;
27791 -- If we fall through, then the pragma was either the first declaration
27792 -- or it was preceded by other pragmas and no source constructs.
27794 -- The pragma is associated with a package. The immediate context in
27795 -- this case is the specification of the package.
27797 if Nkind (Context) = N_Package_Specification then
27798 return Parent (Context);
27800 -- The pragma appears in the declarations of a package body
27802 elsif Nkind (Context) = N_Package_Body then
27803 return Context;
27805 -- The pragma appears in the statements of a package body
27807 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
27808 and then Nkind (Parent (Context)) = N_Package_Body
27809 then
27810 return Parent (Context);
27812 -- The pragma is a byproduct of aspect expansion, return the related
27813 -- context of the original aspect. This case has a lower priority as
27814 -- the above circuitry pinpoints precisely the related context.
27816 elsif Present (Corresponding_Aspect (Prag)) then
27817 return Parent (Corresponding_Aspect (Prag));
27819 -- No candidate packge [body] found
27821 else
27822 return Empty;
27823 end if;
27824 end Find_Related_Package_Or_Body;
27826 ------------------
27827 -- Get_Argument --
27828 ------------------
27830 function Get_Argument
27831 (Prag : Node_Id;
27832 Context_Id : Entity_Id := Empty) return Node_Id
27834 Args : constant List_Id := Pragma_Argument_Associations (Prag);
27836 begin
27837 -- Use the expression of the original aspect when compiling for ASIS or
27838 -- when analyzing the template of a generic unit. In both cases the
27839 -- aspect's tree must be decorated to allow for ASIS queries or to save
27840 -- the global references in the generic context.
27842 if From_Aspect_Specification (Prag)
27843 and then (ASIS_Mode or else (Present (Context_Id)
27844 and then Is_Generic_Unit (Context_Id)))
27845 then
27846 return Corresponding_Aspect (Prag);
27848 -- Otherwise use the expression of the pragma
27850 elsif Present (Args) then
27851 return First (Args);
27853 else
27854 return Empty;
27855 end if;
27856 end Get_Argument;
27858 -------------------------
27859 -- Get_Base_Subprogram --
27860 -------------------------
27862 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
27863 Result : Entity_Id;
27865 begin
27866 -- Follow subprogram renaming chain
27868 Result := Def_Id;
27870 if Is_Subprogram (Result)
27871 and then
27872 Nkind (Parent (Declaration_Node (Result))) =
27873 N_Subprogram_Renaming_Declaration
27874 and then Present (Alias (Result))
27875 then
27876 Result := Alias (Result);
27877 end if;
27879 return Result;
27880 end Get_Base_Subprogram;
27882 -----------------------
27883 -- Get_SPARK_Mode_Type --
27884 -----------------------
27886 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
27887 begin
27888 if N = Name_On then
27889 return On;
27890 elsif N = Name_Off then
27891 return Off;
27893 -- Any other argument is illegal
27895 else
27896 raise Program_Error;
27897 end if;
27898 end Get_SPARK_Mode_Type;
27900 ------------------------------------
27901 -- Get_SPARK_Mode_From_Annotation --
27902 ------------------------------------
27904 function Get_SPARK_Mode_From_Annotation
27905 (N : Node_Id) return SPARK_Mode_Type
27907 Mode : Node_Id;
27909 begin
27910 if Nkind (N) = N_Aspect_Specification then
27911 Mode := Expression (N);
27913 else pragma Assert (Nkind (N) = N_Pragma);
27914 Mode := First (Pragma_Argument_Associations (N));
27916 if Present (Mode) then
27917 Mode := Get_Pragma_Arg (Mode);
27918 end if;
27919 end if;
27921 -- Aspect or pragma SPARK_Mode specifies an explicit mode
27923 if Present (Mode) then
27924 if Nkind (Mode) = N_Identifier then
27925 return Get_SPARK_Mode_Type (Chars (Mode));
27927 -- In case of a malformed aspect or pragma, return the default None
27929 else
27930 return None;
27931 end if;
27933 -- Otherwise the lack of an expression defaults SPARK_Mode to On
27935 else
27936 return On;
27937 end if;
27938 end Get_SPARK_Mode_From_Annotation;
27940 ---------------------------
27941 -- Has_Extra_Parentheses --
27942 ---------------------------
27944 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
27945 Expr : Node_Id;
27947 begin
27948 -- The aggregate should not have an expression list because a clause
27949 -- is always interpreted as a component association. The only way an
27950 -- expression list can sneak in is by adding extra parentheses around
27951 -- the individual clauses:
27953 -- Depends (Output => Input) -- proper form
27954 -- Depends ((Output => Input)) -- extra parentheses
27956 -- Since the extra parentheses are not allowed by the syntax of the
27957 -- pragma, flag them now to avoid emitting misleading errors down the
27958 -- line.
27960 if Nkind (Clause) = N_Aggregate
27961 and then Present (Expressions (Clause))
27962 then
27963 Expr := First (Expressions (Clause));
27964 while Present (Expr) loop
27966 -- A dependency clause surrounded by extra parentheses appears
27967 -- as an aggregate of component associations with an optional
27968 -- Paren_Count set.
27970 if Nkind (Expr) = N_Aggregate
27971 and then Present (Component_Associations (Expr))
27972 then
27973 SPARK_Msg_N
27974 ("dependency clause contains extra parentheses", Expr);
27976 -- Otherwise the expression is a malformed construct
27978 else
27979 SPARK_Msg_N ("malformed dependency clause", Expr);
27980 end if;
27982 Next (Expr);
27983 end loop;
27985 return True;
27986 end if;
27988 return False;
27989 end Has_Extra_Parentheses;
27991 ----------------
27992 -- Initialize --
27993 ----------------
27995 procedure Initialize is
27996 begin
27997 Externals.Init;
27998 end Initialize;
28000 --------
28001 -- ip --
28002 --------
28004 procedure ip is
28005 begin
28006 Dummy := Dummy + 1;
28007 end ip;
28009 -----------------------------
28010 -- Is_Config_Static_String --
28011 -----------------------------
28013 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
28015 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
28016 -- This is an internal recursive function that is just like the outer
28017 -- function except that it adds the string to the name buffer rather
28018 -- than placing the string in the name buffer.
28020 ------------------------------
28021 -- Add_Config_Static_String --
28022 ------------------------------
28024 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
28025 N : Node_Id;
28026 C : Char_Code;
28028 begin
28029 N := Arg;
28031 if Nkind (N) = N_Op_Concat then
28032 if Add_Config_Static_String (Left_Opnd (N)) then
28033 N := Right_Opnd (N);
28034 else
28035 return False;
28036 end if;
28037 end if;
28039 if Nkind (N) /= N_String_Literal then
28040 Error_Msg_N ("string literal expected for pragma argument", N);
28041 return False;
28043 else
28044 for J in 1 .. String_Length (Strval (N)) loop
28045 C := Get_String_Char (Strval (N), J);
28047 if not In_Character_Range (C) then
28048 Error_Msg
28049 ("string literal contains invalid wide character",
28050 Sloc (N) + 1 + Source_Ptr (J));
28051 return False;
28052 end if;
28054 Add_Char_To_Name_Buffer (Get_Character (C));
28055 end loop;
28056 end if;
28058 return True;
28059 end Add_Config_Static_String;
28061 -- Start of processing for Is_Config_Static_String
28063 begin
28064 Name_Len := 0;
28066 return Add_Config_Static_String (Arg);
28067 end Is_Config_Static_String;
28069 ---------------------
28070 -- Is_CCT_Instance --
28071 ---------------------
28073 function Is_CCT_Instance
28074 (Ref_Id : Entity_Id;
28075 Context_Id : Entity_Id) return Boolean
28077 S : Entity_Id;
28078 Typ : Entity_Id;
28080 begin
28081 -- When the reference denotes a single protected type, the context is
28082 -- either a protected subprogram or its body.
28084 if Is_Single_Protected_Object (Ref_Id) then
28085 Typ := Scope (Context_Id);
28087 return
28088 Ekind (Typ) = E_Protected_Type
28089 and then Present (Anonymous_Object (Typ))
28090 and then Anonymous_Object (Typ) = Ref_Id;
28092 -- When the reference denotes a single task type, the context is either
28093 -- the same type or if inside the body, the anonymous task type.
28095 elsif Is_Single_Task_Object (Ref_Id) then
28096 if Ekind (Context_Id) = E_Task_Type then
28097 return
28098 Present (Anonymous_Object (Context_Id))
28099 and then Anonymous_Object (Context_Id) = Ref_Id;
28100 else
28101 return Ref_Id = Context_Id;
28102 end if;
28104 -- Otherwise the reference denotes a protected or a task type. Climb the
28105 -- scope chain looking for an enclosing concurrent type that matches the
28106 -- referenced entity.
28108 else
28109 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
28111 S := Current_Scope;
28112 while Present (S) and then S /= Standard_Standard loop
28113 if Ekind_In (S, E_Protected_Type, E_Task_Type)
28114 and then S = Ref_Id
28115 then
28116 return True;
28117 end if;
28119 S := Scope (S);
28120 end loop;
28121 end if;
28123 return False;
28124 end Is_CCT_Instance;
28126 -------------------------------
28127 -- Is_Elaboration_SPARK_Mode --
28128 -------------------------------
28130 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
28131 begin
28132 pragma Assert
28133 (Nkind (N) = N_Pragma
28134 and then Pragma_Name (N) = Name_SPARK_Mode
28135 and then Is_List_Member (N));
28137 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28138 -- appears in the statement part of the body.
28140 return
28141 Present (Parent (N))
28142 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
28143 and then List_Containing (N) = Statements (Parent (N))
28144 and then Present (Parent (Parent (N)))
28145 and then Nkind (Parent (Parent (N))) = N_Package_Body;
28146 end Is_Elaboration_SPARK_Mode;
28148 -----------------------
28149 -- Is_Enabled_Pragma --
28150 -----------------------
28152 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
28153 Arg : Node_Id;
28155 begin
28156 if Present (Prag) then
28157 Arg := First (Pragma_Argument_Associations (Prag));
28159 if Present (Arg) then
28160 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
28162 -- The lack of a Boolean argument automatically enables the pragma
28164 else
28165 return True;
28166 end if;
28168 -- The pragma is missing, therefore it is not enabled
28170 else
28171 return False;
28172 end if;
28173 end Is_Enabled_Pragma;
28175 -----------------------------------------
28176 -- Is_Non_Significant_Pragma_Reference --
28177 -----------------------------------------
28179 -- This function makes use of the following static table which indicates
28180 -- whether appearance of some name in a given pragma is to be considered
28181 -- as a reference for the purposes of warnings about unreferenced objects.
28183 -- -1 indicates that appearence in any argument is significant
28184 -- 0 indicates that appearance in any argument is not significant
28185 -- +n indicates that appearance as argument n is significant, but all
28186 -- other arguments are not significant
28187 -- 9n arguments from n on are significant, before n insignificant
28189 Sig_Flags : constant array (Pragma_Id) of Int :=
28190 (Pragma_Abort_Defer => -1,
28191 Pragma_Abstract_State => -1,
28192 Pragma_Ada_83 => -1,
28193 Pragma_Ada_95 => -1,
28194 Pragma_Ada_05 => -1,
28195 Pragma_Ada_2005 => -1,
28196 Pragma_Ada_12 => -1,
28197 Pragma_Ada_2012 => -1,
28198 Pragma_All_Calls_Remote => -1,
28199 Pragma_Allow_Integer_Address => -1,
28200 Pragma_Annotate => 93,
28201 Pragma_Assert => -1,
28202 Pragma_Assert_And_Cut => -1,
28203 Pragma_Assertion_Policy => 0,
28204 Pragma_Assume => -1,
28205 Pragma_Assume_No_Invalid_Values => 0,
28206 Pragma_Async_Readers => 0,
28207 Pragma_Async_Writers => 0,
28208 Pragma_Asynchronous => 0,
28209 Pragma_Atomic => 0,
28210 Pragma_Atomic_Components => 0,
28211 Pragma_Attach_Handler => -1,
28212 Pragma_Attribute_Definition => 92,
28213 Pragma_Check => -1,
28214 Pragma_Check_Float_Overflow => 0,
28215 Pragma_Check_Name => 0,
28216 Pragma_Check_Policy => 0,
28217 Pragma_CPP_Class => 0,
28218 Pragma_CPP_Constructor => 0,
28219 Pragma_CPP_Virtual => 0,
28220 Pragma_CPP_Vtable => 0,
28221 Pragma_CPU => -1,
28222 Pragma_C_Pass_By_Copy => 0,
28223 Pragma_Comment => -1,
28224 Pragma_Common_Object => 0,
28225 Pragma_Compile_Time_Error => -1,
28226 Pragma_Compile_Time_Warning => -1,
28227 Pragma_Compiler_Unit => -1,
28228 Pragma_Compiler_Unit_Warning => -1,
28229 Pragma_Complete_Representation => 0,
28230 Pragma_Complex_Representation => 0,
28231 Pragma_Component_Alignment => 0,
28232 Pragma_Constant_After_Elaboration => 0,
28233 Pragma_Contract_Cases => -1,
28234 Pragma_Controlled => 0,
28235 Pragma_Convention => 0,
28236 Pragma_Convention_Identifier => 0,
28237 Pragma_Debug => -1,
28238 Pragma_Debug_Policy => 0,
28239 Pragma_Detect_Blocking => 0,
28240 Pragma_Default_Initial_Condition => -1,
28241 Pragma_Default_Scalar_Storage_Order => 0,
28242 Pragma_Default_Storage_Pool => 0,
28243 Pragma_Depends => -1,
28244 Pragma_Disable_Atomic_Synchronization => 0,
28245 Pragma_Discard_Names => 0,
28246 Pragma_Dispatching_Domain => -1,
28247 Pragma_Effective_Reads => 0,
28248 Pragma_Effective_Writes => 0,
28249 Pragma_Elaborate => 0,
28250 Pragma_Elaborate_All => 0,
28251 Pragma_Elaborate_Body => 0,
28252 Pragma_Elaboration_Checks => 0,
28253 Pragma_Eliminate => 0,
28254 Pragma_Enable_Atomic_Synchronization => 0,
28255 Pragma_Export => -1,
28256 Pragma_Export_Function => -1,
28257 Pragma_Export_Object => -1,
28258 Pragma_Export_Procedure => -1,
28259 Pragma_Export_Value => -1,
28260 Pragma_Export_Valued_Procedure => -1,
28261 Pragma_Extend_System => -1,
28262 Pragma_Extensions_Allowed => 0,
28263 Pragma_Extensions_Visible => 0,
28264 Pragma_External => -1,
28265 Pragma_Favor_Top_Level => 0,
28266 Pragma_External_Name_Casing => 0,
28267 Pragma_Fast_Math => 0,
28268 Pragma_Finalize_Storage_Only => 0,
28269 Pragma_Ghost => 0,
28270 Pragma_Global => -1,
28271 Pragma_Ident => -1,
28272 Pragma_Ignore_Pragma => 0,
28273 Pragma_Implementation_Defined => -1,
28274 Pragma_Implemented => -1,
28275 Pragma_Implicit_Packing => 0,
28276 Pragma_Import => 93,
28277 Pragma_Import_Function => 0,
28278 Pragma_Import_Object => 0,
28279 Pragma_Import_Procedure => 0,
28280 Pragma_Import_Valued_Procedure => 0,
28281 Pragma_Independent => 0,
28282 Pragma_Independent_Components => 0,
28283 Pragma_Initial_Condition => -1,
28284 Pragma_Initialize_Scalars => 0,
28285 Pragma_Initializes => -1,
28286 Pragma_Inline => 0,
28287 Pragma_Inline_Always => 0,
28288 Pragma_Inline_Generic => 0,
28289 Pragma_Inspection_Point => -1,
28290 Pragma_Interface => 92,
28291 Pragma_Interface_Name => 0,
28292 Pragma_Interrupt_Handler => -1,
28293 Pragma_Interrupt_Priority => -1,
28294 Pragma_Interrupt_State => -1,
28295 Pragma_Invariant => -1,
28296 Pragma_Keep_Names => 0,
28297 Pragma_License => 0,
28298 Pragma_Link_With => -1,
28299 Pragma_Linker_Alias => -1,
28300 Pragma_Linker_Constructor => -1,
28301 Pragma_Linker_Destructor => -1,
28302 Pragma_Linker_Options => -1,
28303 Pragma_Linker_Section => 0,
28304 Pragma_List => 0,
28305 Pragma_Lock_Free => 0,
28306 Pragma_Locking_Policy => 0,
28307 Pragma_Loop_Invariant => -1,
28308 Pragma_Loop_Optimize => 0,
28309 Pragma_Loop_Variant => -1,
28310 Pragma_Machine_Attribute => -1,
28311 Pragma_Main => -1,
28312 Pragma_Main_Storage => -1,
28313 Pragma_Memory_Size => 0,
28314 Pragma_No_Return => 0,
28315 Pragma_No_Body => 0,
28316 Pragma_No_Elaboration_Code_All => 0,
28317 Pragma_No_Inline => 0,
28318 Pragma_No_Run_Time => -1,
28319 Pragma_No_Strict_Aliasing => -1,
28320 Pragma_No_Tagged_Streams => 0,
28321 Pragma_Normalize_Scalars => 0,
28322 Pragma_Obsolescent => 0,
28323 Pragma_Optimize => 0,
28324 Pragma_Optimize_Alignment => 0,
28325 Pragma_Overflow_Mode => 0,
28326 Pragma_Overriding_Renamings => 0,
28327 Pragma_Ordered => 0,
28328 Pragma_Pack => 0,
28329 Pragma_Page => 0,
28330 Pragma_Part_Of => 0,
28331 Pragma_Partition_Elaboration_Policy => 0,
28332 Pragma_Passive => 0,
28333 Pragma_Persistent_BSS => 0,
28334 Pragma_Polling => 0,
28335 Pragma_Prefix_Exception_Messages => 0,
28336 Pragma_Post => -1,
28337 Pragma_Postcondition => -1,
28338 Pragma_Post_Class => -1,
28339 Pragma_Pre => -1,
28340 Pragma_Precondition => -1,
28341 Pragma_Predicate => -1,
28342 Pragma_Predicate_Failure => -1,
28343 Pragma_Preelaborable_Initialization => -1,
28344 Pragma_Preelaborate => 0,
28345 Pragma_Pre_Class => -1,
28346 Pragma_Priority => -1,
28347 Pragma_Priority_Specific_Dispatching => 0,
28348 Pragma_Profile => 0,
28349 Pragma_Profile_Warnings => 0,
28350 Pragma_Propagate_Exceptions => 0,
28351 Pragma_Provide_Shift_Operators => 0,
28352 Pragma_Psect_Object => 0,
28353 Pragma_Pure => 0,
28354 Pragma_Pure_Function => 0,
28355 Pragma_Queuing_Policy => 0,
28356 Pragma_Rational => 0,
28357 Pragma_Ravenscar => 0,
28358 Pragma_Refined_Depends => -1,
28359 Pragma_Refined_Global => -1,
28360 Pragma_Refined_Post => -1,
28361 Pragma_Refined_State => -1,
28362 Pragma_Relative_Deadline => 0,
28363 Pragma_Remote_Access_Type => -1,
28364 Pragma_Remote_Call_Interface => -1,
28365 Pragma_Remote_Types => -1,
28366 Pragma_Restricted_Run_Time => 0,
28367 Pragma_Restriction_Warnings => 0,
28368 Pragma_Restrictions => 0,
28369 Pragma_Reviewable => -1,
28370 Pragma_Short_Circuit_And_Or => 0,
28371 Pragma_Share_Generic => 0,
28372 Pragma_Shared => 0,
28373 Pragma_Shared_Passive => 0,
28374 Pragma_Short_Descriptors => 0,
28375 Pragma_Simple_Storage_Pool_Type => 0,
28376 Pragma_Source_File_Name => 0,
28377 Pragma_Source_File_Name_Project => 0,
28378 Pragma_Source_Reference => 0,
28379 Pragma_SPARK_Mode => 0,
28380 Pragma_Storage_Size => -1,
28381 Pragma_Storage_Unit => 0,
28382 Pragma_Static_Elaboration_Desired => 0,
28383 Pragma_Stream_Convert => 0,
28384 Pragma_Style_Checks => 0,
28385 Pragma_Subtitle => 0,
28386 Pragma_Suppress => 0,
28387 Pragma_Suppress_Exception_Locations => 0,
28388 Pragma_Suppress_All => 0,
28389 Pragma_Suppress_Debug_Info => 0,
28390 Pragma_Suppress_Initialization => 0,
28391 Pragma_System_Name => 0,
28392 Pragma_Task_Dispatching_Policy => 0,
28393 Pragma_Task_Info => -1,
28394 Pragma_Task_Name => -1,
28395 Pragma_Task_Storage => -1,
28396 Pragma_Test_Case => -1,
28397 Pragma_Thread_Local_Storage => -1,
28398 Pragma_Time_Slice => -1,
28399 Pragma_Title => 0,
28400 Pragma_Type_Invariant => -1,
28401 Pragma_Type_Invariant_Class => -1,
28402 Pragma_Unchecked_Union => 0,
28403 Pragma_Unimplemented_Unit => 0,
28404 Pragma_Universal_Aliasing => 0,
28405 Pragma_Universal_Data => 0,
28406 Pragma_Unmodified => 0,
28407 Pragma_Unreferenced => 0,
28408 Pragma_Unreferenced_Objects => 0,
28409 Pragma_Unreserve_All_Interrupts => 0,
28410 Pragma_Unsuppress => 0,
28411 Pragma_Unevaluated_Use_Of_Old => 0,
28412 Pragma_Use_VADS_Size => 0,
28413 Pragma_Validity_Checks => 0,
28414 Pragma_Volatile => 0,
28415 Pragma_Volatile_Components => 0,
28416 Pragma_Volatile_Full_Access => 0,
28417 Pragma_Volatile_Function => 0,
28418 Pragma_Warning_As_Error => 0,
28419 Pragma_Warnings => 0,
28420 Pragma_Weak_External => 0,
28421 Pragma_Wide_Character_Encoding => 0,
28422 Unknown_Pragma => 0);
28424 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
28425 Id : Pragma_Id;
28426 P : Node_Id;
28427 C : Int;
28428 AN : Nat;
28430 function Arg_No return Nat;
28431 -- Returns an integer showing what argument we are in. A value of
28432 -- zero means we are not in any of the arguments.
28434 ------------
28435 -- Arg_No --
28436 ------------
28438 function Arg_No return Nat is
28439 A : Node_Id;
28440 N : Nat;
28442 begin
28443 A := First (Pragma_Argument_Associations (Parent (P)));
28444 N := 1;
28445 loop
28446 if No (A) then
28447 return 0;
28448 elsif A = P then
28449 return N;
28450 end if;
28452 Next (A);
28453 N := N + 1;
28454 end loop;
28455 end Arg_No;
28457 -- Start of processing for Non_Significant_Pragma_Reference
28459 begin
28460 P := Parent (N);
28462 if Nkind (P) /= N_Pragma_Argument_Association then
28463 return False;
28465 else
28466 Id := Get_Pragma_Id (Parent (P));
28467 C := Sig_Flags (Id);
28468 AN := Arg_No;
28470 if AN = 0 then
28471 return False;
28472 end if;
28474 case C is
28475 when -1 =>
28476 return False;
28478 when 0 =>
28479 return True;
28481 when 92 .. 99 =>
28482 return AN < (C - 90);
28484 when others =>
28485 return AN /= C;
28486 end case;
28487 end if;
28488 end Is_Non_Significant_Pragma_Reference;
28490 ------------------------------
28491 -- Is_Pragma_String_Literal --
28492 ------------------------------
28494 -- This function returns true if the corresponding pragma argument is a
28495 -- static string expression. These are the only cases in which string
28496 -- literals can appear as pragma arguments. We also allow a string literal
28497 -- as the first argument to pragma Assert (although it will of course
28498 -- always generate a type error).
28500 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
28501 Pragn : constant Node_Id := Parent (Par);
28502 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
28503 Pname : constant Name_Id := Pragma_Name (Pragn);
28504 Argn : Natural;
28505 N : Node_Id;
28507 begin
28508 Argn := 1;
28509 N := First (Assoc);
28510 loop
28511 exit when N = Par;
28512 Argn := Argn + 1;
28513 Next (N);
28514 end loop;
28516 if Pname = Name_Assert then
28517 return True;
28519 elsif Pname = Name_Export then
28520 return Argn > 2;
28522 elsif Pname = Name_Ident then
28523 return Argn = 1;
28525 elsif Pname = Name_Import then
28526 return Argn > 2;
28528 elsif Pname = Name_Interface_Name then
28529 return Argn > 1;
28531 elsif Pname = Name_Linker_Alias then
28532 return Argn = 2;
28534 elsif Pname = Name_Linker_Section then
28535 return Argn = 2;
28537 elsif Pname = Name_Machine_Attribute then
28538 return Argn = 2;
28540 elsif Pname = Name_Source_File_Name then
28541 return True;
28543 elsif Pname = Name_Source_Reference then
28544 return Argn = 2;
28546 elsif Pname = Name_Title then
28547 return True;
28549 elsif Pname = Name_Subtitle then
28550 return True;
28552 else
28553 return False;
28554 end if;
28555 end Is_Pragma_String_Literal;
28557 ---------------------------
28558 -- Is_Private_SPARK_Mode --
28559 ---------------------------
28561 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
28562 begin
28563 pragma Assert
28564 (Nkind (N) = N_Pragma
28565 and then Pragma_Name (N) = Name_SPARK_Mode
28566 and then Is_List_Member (N));
28568 -- For pragma SPARK_Mode to be private, it has to appear in the private
28569 -- declarations of a package.
28571 return
28572 Present (Parent (N))
28573 and then Nkind (Parent (N)) = N_Package_Specification
28574 and then List_Containing (N) = Private_Declarations (Parent (N));
28575 end Is_Private_SPARK_Mode;
28577 -------------------------------------
28578 -- Is_Unconstrained_Or_Tagged_Item --
28579 -------------------------------------
28581 function Is_Unconstrained_Or_Tagged_Item
28582 (Item : Entity_Id) return Boolean
28584 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
28585 -- Determine whether record type Typ has at least one unconstrained
28586 -- component.
28588 ---------------------------------
28589 -- Has_Unconstrained_Component --
28590 ---------------------------------
28592 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
28593 Comp : Entity_Id;
28595 begin
28596 Comp := First_Component (Typ);
28597 while Present (Comp) loop
28598 if Is_Unconstrained_Or_Tagged_Item (Comp) then
28599 return True;
28600 end if;
28602 Next_Component (Comp);
28603 end loop;
28605 return False;
28606 end Has_Unconstrained_Component;
28608 -- Local variables
28610 Typ : constant Entity_Id := Etype (Item);
28612 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
28614 begin
28615 if Is_Tagged_Type (Typ) then
28616 return True;
28618 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
28619 return True;
28621 elsif Is_Record_Type (Typ) then
28622 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
28623 return True;
28624 else
28625 return Has_Unconstrained_Component (Typ);
28626 end if;
28628 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
28629 return True;
28631 else
28632 return False;
28633 end if;
28634 end Is_Unconstrained_Or_Tagged_Item;
28636 -----------------------------
28637 -- Is_Valid_Assertion_Kind --
28638 -----------------------------
28640 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
28641 begin
28642 case Nam is
28643 when
28644 -- RM defined
28646 Name_Assert |
28647 Name_Assertion_Policy |
28648 Name_Static_Predicate |
28649 Name_Dynamic_Predicate |
28650 Name_Pre |
28651 Name_uPre |
28652 Name_Post |
28653 Name_uPost |
28654 Name_Type_Invariant |
28655 Name_uType_Invariant |
28657 -- Impl defined
28659 Name_Assert_And_Cut |
28660 Name_Assume |
28661 Name_Contract_Cases |
28662 Name_Debug |
28663 Name_Default_Initial_Condition |
28664 Name_Ghost |
28665 Name_Initial_Condition |
28666 Name_Invariant |
28667 Name_uInvariant |
28668 Name_Loop_Invariant |
28669 Name_Loop_Variant |
28670 Name_Postcondition |
28671 Name_Precondition |
28672 Name_Predicate |
28673 Name_Refined_Post |
28674 Name_Statement_Assertions => return True;
28676 when others => return False;
28677 end case;
28678 end Is_Valid_Assertion_Kind;
28680 --------------------------------------
28681 -- Process_Compilation_Unit_Pragmas --
28682 --------------------------------------
28684 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
28685 begin
28686 -- A special check for pragma Suppress_All, a very strange DEC pragma,
28687 -- strange because it comes at the end of the unit. Rational has the
28688 -- same name for a pragma, but treats it as a program unit pragma, In
28689 -- GNAT we just decide to allow it anywhere at all. If it appeared then
28690 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
28691 -- node, and we insert a pragma Suppress (All_Checks) at the start of
28692 -- the context clause to ensure the correct processing.
28694 if Has_Pragma_Suppress_All (N) then
28695 Prepend_To (Context_Items (N),
28696 Make_Pragma (Sloc (N),
28697 Chars => Name_Suppress,
28698 Pragma_Argument_Associations => New_List (
28699 Make_Pragma_Argument_Association (Sloc (N),
28700 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
28701 end if;
28703 -- Nothing else to do at the current time
28705 end Process_Compilation_Unit_Pragmas;
28707 ------------------------------------
28708 -- Record_Possible_Body_Reference --
28709 ------------------------------------
28711 procedure Record_Possible_Body_Reference
28712 (State_Id : Entity_Id;
28713 Ref : Node_Id)
28715 Context : Node_Id;
28716 Spec_Id : Entity_Id;
28718 begin
28719 -- Ensure that we are dealing with a reference to a state
28721 pragma Assert (Ekind (State_Id) = E_Abstract_State);
28723 -- Climb the tree starting from the reference looking for a package body
28724 -- whose spec declares the referenced state. This criteria automatically
28725 -- excludes references in package specs which are legal. Note that it is
28726 -- not wise to emit an error now as the package body may lack pragma
28727 -- Refined_State or the referenced state may not be mentioned in the
28728 -- refinement. This approach avoids the generation of misleading errors.
28730 Context := Ref;
28731 while Present (Context) loop
28732 if Nkind (Context) = N_Package_Body then
28733 Spec_Id := Corresponding_Spec (Context);
28735 if Present (Abstract_States (Spec_Id))
28736 and then Contains (Abstract_States (Spec_Id), State_Id)
28737 then
28738 if No (Body_References (State_Id)) then
28739 Set_Body_References (State_Id, New_Elmt_List);
28740 end if;
28742 Append_Elmt (Ref, To => Body_References (State_Id));
28743 exit;
28744 end if;
28745 end if;
28747 Context := Parent (Context);
28748 end loop;
28749 end Record_Possible_Body_Reference;
28751 ------------------------------------------
28752 -- Relocate_Pragmas_To_Anonymous_Object --
28753 ------------------------------------------
28755 procedure Relocate_Pragmas_To_Anonymous_Object
28756 (Typ_Decl : Node_Id;
28757 Obj_Decl : Node_Id)
28759 Decl : Node_Id;
28760 Def : Node_Id;
28761 Next_Decl : Node_Id;
28763 begin
28764 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
28765 Def := Protected_Definition (Typ_Decl);
28766 else
28767 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
28768 Def := Task_Definition (Typ_Decl);
28769 end if;
28771 -- The concurrent definition has a visible declaration list. Inspect it
28772 -- and relocate all canidate pragmas.
28774 if Present (Def) and then Present (Visible_Declarations (Def)) then
28775 Decl := First (Visible_Declarations (Def));
28776 while Present (Decl) loop
28778 -- Preserve the following declaration for iteration purposes due
28779 -- to possible relocation of a pragma.
28781 Next_Decl := Next (Decl);
28783 if Nkind (Decl) = N_Pragma
28784 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
28785 then
28786 Remove (Decl);
28787 Insert_After (Obj_Decl, Decl);
28789 -- Skip internally generated code
28791 elsif not Comes_From_Source (Decl) then
28792 null;
28794 -- No candidate pragmas are available for relocation
28796 else
28797 exit;
28798 end if;
28800 Decl := Next_Decl;
28801 end loop;
28802 end if;
28803 end Relocate_Pragmas_To_Anonymous_Object;
28805 ------------------------------
28806 -- Relocate_Pragmas_To_Body --
28807 ------------------------------
28809 procedure Relocate_Pragmas_To_Body
28810 (Subp_Body : Node_Id;
28811 Target_Body : Node_Id := Empty)
28813 procedure Relocate_Pragma (Prag : Node_Id);
28814 -- Remove a single pragma from its current list and add it to the
28815 -- declarations of the proper body (either Subp_Body or Target_Body).
28817 ---------------------
28818 -- Relocate_Pragma --
28819 ---------------------
28821 procedure Relocate_Pragma (Prag : Node_Id) is
28822 Decls : List_Id;
28823 Target : Node_Id;
28825 begin
28826 -- When subprogram stubs or expression functions are involves, the
28827 -- destination declaration list belongs to the proper body.
28829 if Present (Target_Body) then
28830 Target := Target_Body;
28831 else
28832 Target := Subp_Body;
28833 end if;
28835 Decls := Declarations (Target);
28837 if No (Decls) then
28838 Decls := New_List;
28839 Set_Declarations (Target, Decls);
28840 end if;
28842 -- Unhook the pragma from its current list
28844 Remove (Prag);
28845 Prepend (Prag, Decls);
28846 end Relocate_Pragma;
28848 -- Local variables
28850 Body_Id : constant Entity_Id :=
28851 Defining_Unit_Name (Specification (Subp_Body));
28852 Next_Stmt : Node_Id;
28853 Stmt : Node_Id;
28855 -- Start of processing for Relocate_Pragmas_To_Body
28857 begin
28858 -- Do not process a body that comes from a separate unit as no construct
28859 -- can possibly follow it.
28861 if not Is_List_Member (Subp_Body) then
28862 return;
28864 -- Do not relocate pragmas that follow a stub if the stub does not have
28865 -- a proper body.
28867 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
28868 and then No (Target_Body)
28869 then
28870 return;
28872 -- Do not process internally generated routine _Postconditions
28874 elsif Ekind (Body_Id) = E_Procedure
28875 and then Chars (Body_Id) = Name_uPostconditions
28876 then
28877 return;
28878 end if;
28880 -- Look at what is following the body. We are interested in certain kind
28881 -- of pragmas (either from source or byproducts of expansion) that can
28882 -- apply to a body [stub].
28884 Stmt := Next (Subp_Body);
28885 while Present (Stmt) loop
28887 -- Preserve the following statement for iteration purposes due to a
28888 -- possible relocation of a pragma.
28890 Next_Stmt := Next (Stmt);
28892 -- Move a candidate pragma following the body to the declarations of
28893 -- the body.
28895 if Nkind (Stmt) = N_Pragma
28896 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
28897 then
28898 Relocate_Pragma (Stmt);
28900 -- Skip internally generated code
28902 elsif not Comes_From_Source (Stmt) then
28903 null;
28905 -- No candidate pragmas are available for relocation
28907 else
28908 exit;
28909 end if;
28911 Stmt := Next_Stmt;
28912 end loop;
28913 end Relocate_Pragmas_To_Body;
28915 -------------------
28916 -- Resolve_State --
28917 -------------------
28919 procedure Resolve_State (N : Node_Id) is
28920 Func : Entity_Id;
28921 State : Entity_Id;
28923 begin
28924 if Is_Entity_Name (N) and then Present (Entity (N)) then
28925 Func := Entity (N);
28927 -- Handle overloading of state names by functions. Traverse the
28928 -- homonym chain looking for an abstract state.
28930 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
28931 State := Homonym (Func);
28932 while Present (State) loop
28934 -- Resolve the overloading by setting the proper entity of the
28935 -- reference to that of the state.
28937 if Ekind (State) = E_Abstract_State then
28938 Set_Etype (N, Standard_Void_Type);
28939 Set_Entity (N, State);
28940 Set_Associated_Node (N, State);
28941 return;
28942 end if;
28944 State := Homonym (State);
28945 end loop;
28947 -- A function can never act as a state. If the homonym chain does
28948 -- not contain a corresponding state, then something went wrong in
28949 -- the overloading mechanism.
28951 raise Program_Error;
28952 end if;
28953 end if;
28954 end Resolve_State;
28956 ----------------------------
28957 -- Rewrite_Assertion_Kind --
28958 ----------------------------
28960 procedure Rewrite_Assertion_Kind (N : Node_Id) is
28961 Nam : Name_Id;
28963 begin
28964 if Nkind (N) = N_Attribute_Reference
28965 and then Attribute_Name (N) = Name_Class
28966 and then Nkind (Prefix (N)) = N_Identifier
28967 then
28968 case Chars (Prefix (N)) is
28969 when Name_Pre =>
28970 Nam := Name_uPre;
28971 when Name_Post =>
28972 Nam := Name_uPost;
28973 when Name_Type_Invariant =>
28974 Nam := Name_uType_Invariant;
28975 when Name_Invariant =>
28976 Nam := Name_uInvariant;
28977 when others =>
28978 return;
28979 end case;
28981 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
28982 end if;
28983 end Rewrite_Assertion_Kind;
28985 --------
28986 -- rv --
28987 --------
28989 procedure rv is
28990 begin
28991 Dummy := Dummy + 1;
28992 end rv;
28994 --------------------------------
28995 -- Set_Encoded_Interface_Name --
28996 --------------------------------
28998 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
28999 Str : constant String_Id := Strval (S);
29000 Len : constant Nat := String_Length (Str);
29001 CC : Char_Code;
29002 C : Character;
29003 J : Pos;
29005 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
29007 procedure Encode;
29008 -- Stores encoded value of character code CC. The encoding we use an
29009 -- underscore followed by four lower case hex digits.
29011 ------------
29012 -- Encode --
29013 ------------
29015 procedure Encode is
29016 begin
29017 Store_String_Char (Get_Char_Code ('_'));
29018 Store_String_Char
29019 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
29020 Store_String_Char
29021 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
29022 Store_String_Char
29023 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
29024 Store_String_Char
29025 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
29026 end Encode;
29028 -- Start of processing for Set_Encoded_Interface_Name
29030 begin
29031 -- If first character is asterisk, this is a link name, and we leave it
29032 -- completely unmodified. We also ignore null strings (the latter case
29033 -- happens only in error cases).
29035 if Len = 0
29036 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
29037 then
29038 Set_Interface_Name (E, S);
29040 else
29041 J := 1;
29042 loop
29043 CC := Get_String_Char (Str, J);
29045 exit when not In_Character_Range (CC);
29047 C := Get_Character (CC);
29049 exit when C /= '_' and then C /= '$'
29050 and then C not in '0' .. '9'
29051 and then C not in 'a' .. 'z'
29052 and then C not in 'A' .. 'Z';
29054 if J = Len then
29055 Set_Interface_Name (E, S);
29056 return;
29058 else
29059 J := J + 1;
29060 end if;
29061 end loop;
29063 -- Here we need to encode. The encoding we use as follows:
29064 -- three underscores + four hex digits (lower case)
29066 Start_String;
29068 for J in 1 .. String_Length (Str) loop
29069 CC := Get_String_Char (Str, J);
29071 if not In_Character_Range (CC) then
29072 Encode;
29073 else
29074 C := Get_Character (CC);
29076 if C = '_' or else C = '$'
29077 or else C in '0' .. '9'
29078 or else C in 'a' .. 'z'
29079 or else C in 'A' .. 'Z'
29080 then
29081 Store_String_Char (CC);
29082 else
29083 Encode;
29084 end if;
29085 end if;
29086 end loop;
29088 Set_Interface_Name (E,
29089 Make_String_Literal (Sloc (S),
29090 Strval => End_String));
29091 end if;
29092 end Set_Encoded_Interface_Name;
29094 ------------------------
29095 -- Set_Elab_Unit_Name --
29096 ------------------------
29098 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
29099 Pref : Node_Id;
29100 Scop : Entity_Id;
29102 begin
29103 if Nkind (N) = N_Identifier
29104 and then Nkind (With_Item) = N_Identifier
29105 then
29106 Set_Entity (N, Entity (With_Item));
29108 elsif Nkind (N) = N_Selected_Component then
29109 Change_Selected_Component_To_Expanded_Name (N);
29110 Set_Entity (N, Entity (With_Item));
29111 Set_Entity (Selector_Name (N), Entity (N));
29113 Pref := Prefix (N);
29114 Scop := Scope (Entity (N));
29115 while Nkind (Pref) = N_Selected_Component loop
29116 Change_Selected_Component_To_Expanded_Name (Pref);
29117 Set_Entity (Selector_Name (Pref), Scop);
29118 Set_Entity (Pref, Scop);
29119 Pref := Prefix (Pref);
29120 Scop := Scope (Scop);
29121 end loop;
29123 Set_Entity (Pref, Scop);
29124 end if;
29126 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
29127 end Set_Elab_Unit_Name;
29129 -------------------
29130 -- Test_Case_Arg --
29131 -------------------
29133 function Test_Case_Arg
29134 (Prag : Node_Id;
29135 Arg_Nam : Name_Id;
29136 From_Aspect : Boolean := False) return Node_Id
29138 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
29139 Arg : Node_Id;
29140 Args : Node_Id;
29142 begin
29143 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
29144 Name_Mode,
29145 Name_Name,
29146 Name_Requires));
29148 -- The caller requests the aspect argument
29150 if From_Aspect then
29151 if Present (Aspect)
29152 and then Nkind (Expression (Aspect)) = N_Aggregate
29153 then
29154 Args := Expression (Aspect);
29156 -- "Name" and "Mode" may appear without an identifier as a
29157 -- positional association.
29159 if Present (Expressions (Args)) then
29160 Arg := First (Expressions (Args));
29162 if Present (Arg) and then Arg_Nam = Name_Name then
29163 return Arg;
29164 end if;
29166 -- Skip "Name"
29168 Arg := Next (Arg);
29170 if Present (Arg) and then Arg_Nam = Name_Mode then
29171 return Arg;
29172 end if;
29173 end if;
29175 -- Some or all arguments may appear as component associatons
29177 if Present (Component_Associations (Args)) then
29178 Arg := First (Component_Associations (Args));
29179 while Present (Arg) loop
29180 if Chars (First (Choices (Arg))) = Arg_Nam then
29181 return Arg;
29182 end if;
29184 Next (Arg);
29185 end loop;
29186 end if;
29187 end if;
29189 -- Otherwise retrieve the argument directly from the pragma
29191 else
29192 Arg := First (Pragma_Argument_Associations (Prag));
29194 if Present (Arg) and then Arg_Nam = Name_Name then
29195 return Arg;
29196 end if;
29198 -- Skip argument "Name"
29200 Arg := Next (Arg);
29202 if Present (Arg) and then Arg_Nam = Name_Mode then
29203 return Arg;
29204 end if;
29206 -- Skip argument "Mode"
29208 Arg := Next (Arg);
29210 -- Arguments "Requires" and "Ensures" are optional and may not be
29211 -- present at all.
29213 while Present (Arg) loop
29214 if Chars (Arg) = Arg_Nam then
29215 return Arg;
29216 end if;
29218 Next (Arg);
29219 end loop;
29220 end if;
29222 return Empty;
29223 end Test_Case_Arg;
29225 end Sem_Prag;