File : sem_prag.adb
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 ------------------------------------------------------------------------------
25
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).
31
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_Ch7; use Exp_Ch7;
43 with Exp_Dist; use Exp_Dist;
44 with Exp_Util; use Exp_Util;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with Gnatvsn; use Gnatvsn;
48 with Lib; use Lib;
49 with Lib.Writ; use Lib.Writ;
50 with Lib.Xref; use Lib.Xref;
51 with Namet.Sp; use Namet.Sp;
52 with Nlists; use Nlists;
53 with Nmake; use Nmake;
54 with Output; use Output;
55 with Par_SCO; use Par_SCO;
56 with Restrict; use Restrict;
57 with Rident; use Rident;
58 with Rtsfind; use Rtsfind;
59 with Sem; use Sem;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Ch3; use Sem_Ch3;
62 with Sem_Ch6; use Sem_Ch6;
63 with Sem_Ch8; use Sem_Ch8;
64 with Sem_Ch12; use Sem_Ch12;
65 with Sem_Ch13; use Sem_Ch13;
66 with Sem_Disp; use Sem_Disp;
67 with Sem_Dist; use Sem_Dist;
68 with Sem_Elim; use Sem_Elim;
69 with Sem_Eval; use Sem_Eval;
70 with Sem_Intr; use Sem_Intr;
71 with Sem_Mech; use Sem_Mech;
72 with Sem_Res; use Sem_Res;
73 with Sem_Type; use Sem_Type;
74 with Sem_Util; use Sem_Util;
75 with Sem_Warn; use Sem_Warn;
76 with Stand; use Stand;
77 with Sinfo; use Sinfo;
78 with Sinfo.CN; use Sinfo.CN;
79 with Sinput; use Sinput;
80 with Stringt; use Stringt;
81 with Stylesw; use Stylesw;
82 with Table;
83 with Targparm; use Targparm;
84 with Tbuild; use Tbuild;
85 with Ttypes;
86 with Uintp; use Uintp;
87 with Uname; use Uname;
88 with Urealp; use Urealp;
89 with Validsw; use Validsw;
90 with Warnsw; use Warnsw;
91
92 with GNAT.HTable; use GNAT.HTable;
93
94 package body Sem_Prag is
95
96 ----------------------------------------------
97 -- Common Handling of Import-Export Pragmas --
98 ----------------------------------------------
99
100 -- In the following section, a number of Import_xxx and Export_xxx pragmas
101 -- are defined by GNAT. These are compatible with the DEC pragmas of the
102 -- same name, and all have the following common form and processing:
103
104 -- pragma Export_xxx
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
108
109 -- pragma Import_xxx
110 -- [Internal =>] LOCAL_NAME
111 -- [, [External =>] EXTERNAL_SYMBOL]
112 -- [, other optional parameters ]);
113
114 -- EXTERNAL_SYMBOL ::=
115 -- IDENTIFIER
116 -- | static_string_EXPRESSION
117
118 -- The internal LOCAL_NAME designates the entity that is imported or
119 -- exported, and must refer to an entity in the current declarative
120 -- part (as required by the rules for LOCAL_NAME).
121
122 -- The external linker name is designated by the External parameter if
123 -- given, or the Internal parameter if not (if there is no External
124 -- parameter, the External parameter is a copy of the Internal name).
125
126 -- If the External parameter is given as a string, then this string is
127 -- treated as an external name (exactly as though it had been given as an
128 -- External_Name parameter for a normal Import pragma).
129
130 -- If the External parameter is given as an identifier (or there is no
131 -- External parameter, so that the Internal identifier is used), then
132 -- the external name is the characters of the identifier, translated
133 -- to all lower case letters.
134
135 -- Note: the external name specified or implied by any of these special
136 -- Import_xxx or Export_xxx pragmas override an external or link name
137 -- specified in a previous Import or Export pragma.
138
139 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
140 -- named notation, following the standard rules for subprogram calls, i.e.
141 -- parameters can be given in any order if named notation is used, and
142 -- positional and named notation can be mixed, subject to the rule that all
143 -- positional parameters must appear first.
144
145 -- Note: All these pragmas are implemented exactly following the DEC design
146 -- and implementation and are intended to be fully compatible with the use
147 -- of these pragmas in the DEC Ada compiler.
148
149 --------------------------------------------
150 -- Checking for Duplicated External Names --
151 --------------------------------------------
152
153 -- It is suspicious if two separate Export pragmas use the same external
154 -- name. The following table is used to diagnose this situation so that
155 -- an appropriate warning can be issued.
156
157 -- The Node_Id stored is for the N_String_Literal node created to hold
158 -- the value of the external name. The Sloc of this node is used to
159 -- cross-reference the location of the duplication.
160
161 package Externals is new Table.Table (
162 Table_Component_Type => Node_Id,
163 Table_Index_Type => Int,
164 Table_Low_Bound => 0,
165 Table_Initial => 100,
166 Table_Increment => 100,
167 Table_Name => "Name_Externals");
168
169 --------------------------------------------------------
170 -- Handling of inherited classwide pre/postconditions --
171 --------------------------------------------------------
172
173 -- Following AI12-0113, the expression for a classwide condition is
174 -- transformed for a subprogram that inherits it, by replacing calls
175 -- to primitive operations of the original controlling type into the
176 -- corresponding overriding operations of the derived type. The following
177 -- hash table manages this mapping, and is expanded on demand whenever
178 -- such inherited expression needs to be constructed.
179
180 -- The mapping is also used to check whether an inherited operation has
181 -- a condition that depends on overridden operations. For such an
182 -- operation we must create a wrapper that is then treated as a normal
183 -- overriding. In SPARK mode such operations are illegal.
184
185 -- For a given root type there may be several type extensions with their
186 -- own overriding operations, so at various times a given operation of
187 -- the root will be mapped into different overridings. The root type is
188 -- also mapped into the current type extension to indicate that its
189 -- operations are mapped into the overriding operations of that current
190 -- type extension.
191
192 subtype Num_Primitives is Integer range 0 .. 510;
193 function Entity_Hash (E : Entity_Id) return Num_Primitives;
194
195 package Primitives_Mapping is new Gnat.HTable.Simple_Htable
196 (Header_Num => Num_Primitives,
197 Key => Entity_Id,
198 Element => Entity_Id,
199 No_element => Empty,
200 Hash => Entity_Hash,
201 Equal => "=");
202
203 -------------------------------------
204 -- Local Subprograms and Variables --
205 -------------------------------------
206
207 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
208 -- This routine is used for possible casing adjustment of an explicit
209 -- external name supplied as a string literal (the node N), according to
210 -- the casing requirement of Opt.External_Name_Casing. If this is set to
211 -- As_Is, then the string literal is returned unchanged, but if it is set
212 -- to Uppercase or Lowercase, then a new string literal with appropriate
213 -- casing is constructed.
214
215 procedure Analyze_Part_Of
216 (Indic : Node_Id;
217 Item_Id : Entity_Id;
218 Encap : Node_Id;
219 Encap_Id : out Entity_Id;
220 Legal : out Boolean);
221 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
222 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
223 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
224 -- package instantiation. Encap denotes the encapsulating state or single
225 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
226 -- the indicator is legal.
227
228 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
229 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
230 -- Query whether a particular item appears in a mixed list of nodes and
231 -- entities. It is assumed that all nodes in the list have entities.
232
233 procedure Check_Postcondition_Use_In_Inlined_Subprogram
234 (Prag : Node_Id;
235 Spec_Id : Entity_Id);
236 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
237 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
238 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
239
240 procedure Check_State_And_Constituent_Use
241 (States : Elist_Id;
242 Constits : Elist_Id;
243 Context : Node_Id);
244 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
245 -- Global and Initializes. Determine whether a state from list States and a
246 -- corresponding constituent from list Constits (if any) appear in the same
247 -- context denoted by Context. If this is the case, emit an error.
248
249 procedure Contract_Freeze_Error
250 (Contract_Id : Entity_Id;
251 Freeze_Id : Entity_Id);
252 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
253 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
254 -- of a body which caused contract "freezing" and Contract_Id denotes the
255 -- entity of the affected contstruct.
256
257 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
258 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
259 -- Prag that duplicates previous pragma Prev.
260
261 function Find_Related_Context
262 (Prag : Node_Id;
263 Do_Checks : Boolean := False) return Node_Id;
264 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
265 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
266 -- Part_Of. Find the first source declaration or statement found while
267 -- traversing the previous node chain starting from pragma Prag. If flag
268 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
269 -- returns Empty when reaching the start of the node chain.
270
271 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
272 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
273 -- original one, following the renaming chain) is returned. Otherwise the
274 -- entity is returned unchanged. Should be in Einfo???
275
276 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
277 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
278 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
279 -- value of type SPARK_Mode_Type.
280
281 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
282 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
283 -- Determine whether dependency clause Clause is surrounded by extra
284 -- parentheses. If this is the case, issue an error message.
285
286 function Is_CCT_Instance
287 (Ref_Id : Entity_Id;
288 Context_Id : Entity_Id) return Boolean;
289 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
290 -- Global. Determine whether entity Ref_Id denotes the current instance of
291 -- a concurrent type. Context_Id denotes the associated context where the
292 -- pragma appears.
293
294 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
295 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
296 -- pragma Depends. Determine whether the type of dependency item Item is
297 -- tagged, unconstrained array, unconstrained record or a record with at
298 -- least one unconstrained component.
299
300 procedure Record_Possible_Body_Reference
301 (State_Id : Entity_Id;
302 Ref : Node_Id);
303 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
304 -- Global. Given an abstract state denoted by State_Id and a reference Ref
305 -- to it, determine whether the reference appears in a package body that
306 -- will eventually refine the state. If this is the case, record the
307 -- reference for future checks (see Analyze_Refined_State_In_Decls).
308
309 procedure Resolve_State (N : Node_Id);
310 -- Handle the overloading of state names by functions. When N denotes a
311 -- function, this routine finds the corresponding state and sets the entity
312 -- of N to that of the state.
313
314 procedure Rewrite_Assertion_Kind (N : Node_Id);
315 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
316 -- then it is rewritten as an identifier with the corresponding special
317 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
318 -- and Check_Policy.
319
320 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
321 -- Place semantic information on the argument of an Elaborate/Elaborate_All
322 -- pragma. Entity name for unit and its parents is taken from item in
323 -- previous with_clause that mentions the unit.
324
325 Dummy : Integer := 0;
326 pragma Volatile (Dummy);
327 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
328
329 procedure ip;
330 pragma No_Inline (ip);
331 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
332 -- is just to help debugging the front end. If a pragma Inspection_Point
333 -- is added to a source program, then breaking on ip will get you to that
334 -- point in the program.
335
336 procedure rv;
337 pragma No_Inline (rv);
338 -- This is a dummy function called by the processing for pragma Reviewable.
339 -- It is there for assisting front end debugging. By placing a Reviewable
340 -- pragma in the source program, a breakpoint on rv catches this place in
341 -- the source, allowing convenient stepping to the point of interest.
342
343 -------------------------------
344 -- Adjust_External_Name_Case --
345 -------------------------------
346
347 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
348 CC : Char_Code;
349
350 begin
351 -- Adjust case of literal if required
352
353 if Opt.External_Name_Exp_Casing = As_Is then
354 return N;
355
356 else
357 -- Copy existing string
358
359 Start_String;
360
361 -- Set proper casing
362
363 for J in 1 .. String_Length (Strval (N)) loop
364 CC := Get_String_Char (Strval (N), J);
365
366 if Opt.External_Name_Exp_Casing = Uppercase
367 and then CC >= Get_Char_Code ('a')
368 and then CC <= Get_Char_Code ('z')
369 then
370 Store_String_Char (CC - 32);
371
372 elsif Opt.External_Name_Exp_Casing = Lowercase
373 and then CC >= Get_Char_Code ('A')
374 and then CC <= Get_Char_Code ('Z')
375 then
376 Store_String_Char (CC + 32);
377
378 else
379 Store_String_Char (CC);
380 end if;
381 end loop;
382
383 return
384 Make_String_Literal (Sloc (N),
385 Strval => End_String);
386 end if;
387 end Adjust_External_Name_Case;
388
389 -----------------------------------------
390 -- Analyze_Contract_Cases_In_Decl_Part --
391 -----------------------------------------
392
393 procedure Analyze_Contract_Cases_In_Decl_Part
394 (N : Node_Id;
395 Freeze_Id : Entity_Id := Empty)
396 is
397 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
398 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
399
400 Others_Seen : Boolean := False;
401 -- This flag is set when an "others" choice is encountered. It is used
402 -- to detect multiple illegal occurrences of "others".
403
404 procedure Analyze_Contract_Case (CCase : Node_Id);
405 -- Verify the legality of a single contract case
406
407 ---------------------------
408 -- Analyze_Contract_Case --
409 ---------------------------
410
411 procedure Analyze_Contract_Case (CCase : Node_Id) is
412 Case_Guard : Node_Id;
413 Conseq : Node_Id;
414 Errors : Nat;
415 Extra_Guard : Node_Id;
416
417 begin
418 if Nkind (CCase) = N_Component_Association then
419 Case_Guard := First (Choices (CCase));
420 Conseq := Expression (CCase);
421
422 -- Each contract case must have exactly one case guard
423
424 Extra_Guard := Next (Case_Guard);
425
426 if Present (Extra_Guard) then
427 Error_Msg_N
428 ("contract case must have exactly one case guard",
429 Extra_Guard);
430 end if;
431
432 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
433
434 if Nkind (Case_Guard) = N_Others_Choice then
435 if Others_Seen then
436 Error_Msg_N
437 ("only one others choice allowed in contract cases",
438 Case_Guard);
439 else
440 Others_Seen := True;
441 end if;
442
443 elsif Others_Seen then
444 Error_Msg_N
445 ("others must be the last choice in contract cases", N);
446 end if;
447
448 -- Preanalyze the case guard and consequence
449
450 if Nkind (Case_Guard) /= N_Others_Choice then
451 Errors := Serious_Errors_Detected;
452 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
453
454 -- Emit a clarification message when the case guard contains
455 -- at least one undefined reference, possibly due to contract
456 -- "freezing".
457
458 if Errors /= Serious_Errors_Detected
459 and then Present (Freeze_Id)
460 and then Has_Undefined_Reference (Case_Guard)
461 then
462 Contract_Freeze_Error (Spec_Id, Freeze_Id);
463 end if;
464 end if;
465
466 Errors := Serious_Errors_Detected;
467 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
468
469 -- Emit a clarification message when the consequence contains
470 -- at least one undefined reference, possibly due to contract
471 -- "freezing".
472
473 if Errors /= Serious_Errors_Detected
474 and then Present (Freeze_Id)
475 and then Has_Undefined_Reference (Conseq)
476 then
477 Contract_Freeze_Error (Spec_Id, Freeze_Id);
478 end if;
479
480 -- The contract case is malformed
481
482 else
483 Error_Msg_N ("wrong syntax in contract case", CCase);
484 end if;
485 end Analyze_Contract_Case;
486
487 -- Local variables
488
489 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
490
491 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
492
493 CCase : Node_Id;
494 Restore_Scope : Boolean := False;
495
496 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
497
498 begin
499 -- Do not analyze the pragma multiple times
500
501 if Is_Analyzed_Pragma (N) then
502 return;
503 end if;
504
505 -- Set the Ghost mode in effect from the pragma. Due to the delayed
506 -- analysis of the pragma, the Ghost mode at point of declaration and
507 -- point of analysis may not necessarily be the same. Use the mode in
508 -- effect at the point of declaration.
509
510 Set_Ghost_Mode (N);
511
512 -- Single and multiple contract cases must appear in aggregate form. If
513 -- this is not the case, then either the parser of the analysis of the
514 -- pragma failed to produce an aggregate.
515
516 pragma Assert (Nkind (CCases) = N_Aggregate);
517
518 if Present (Component_Associations (CCases)) then
519
520 -- Ensure that the formal parameters are visible when analyzing all
521 -- clauses. This falls out of the general rule of aspects pertaining
522 -- to subprogram declarations.
523
524 if not In_Open_Scopes (Spec_Id) then
525 Restore_Scope := True;
526 Push_Scope (Spec_Id);
527
528 if Is_Generic_Subprogram (Spec_Id) then
529 Install_Generic_Formals (Spec_Id);
530 else
531 Install_Formals (Spec_Id);
532 end if;
533 end if;
534
535 CCase := First (Component_Associations (CCases));
536 while Present (CCase) loop
537 Analyze_Contract_Case (CCase);
538 Next (CCase);
539 end loop;
540
541 if Restore_Scope then
542 End_Scope;
543 end if;
544
545 -- Currently it is not possible to inline pre/postconditions on a
546 -- subprogram subject to pragma Inline_Always.
547
548 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
549
550 -- Otherwise the pragma is illegal
551
552 else
553 Error_Msg_N ("wrong syntax for constract cases", N);
554 end if;
555
556 Ghost_Mode := Save_Ghost_Mode;
557 Set_Is_Analyzed_Pragma (N);
558 end Analyze_Contract_Cases_In_Decl_Part;
559
560 ----------------------------------
561 -- Analyze_Depends_In_Decl_Part --
562 ----------------------------------
563
564 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
565 Loc : constant Source_Ptr := Sloc (N);
566 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
567 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
568
569 All_Inputs_Seen : Elist_Id := No_Elist;
570 -- A list containing the entities of all the inputs processed so far.
571 -- The list is populated with unique entities because the same input
572 -- may appear in multiple input lists.
573
574 All_Outputs_Seen : Elist_Id := No_Elist;
575 -- A list containing the entities of all the outputs processed so far.
576 -- The list is populated with unique entities because output items are
577 -- unique in a dependence relation.
578
579 Constits_Seen : Elist_Id := No_Elist;
580 -- A list containing the entities of all constituents processed so far.
581 -- It aids in detecting illegal usage of a state and a corresponding
582 -- constituent in pragma [Refinde_]Depends.
583
584 Global_Seen : Boolean := False;
585 -- A flag set when pragma Global has been processed
586
587 Null_Output_Seen : Boolean := False;
588 -- A flag used to track the legality of a null output
589
590 Result_Seen : Boolean := False;
591 -- A flag set when Spec_Id'Result is processed
592
593 States_Seen : Elist_Id := No_Elist;
594 -- A list containing the entities of all states processed so far. It
595 -- helps in detecting illegal usage of a state and a corresponding
596 -- constituent in pragma [Refined_]Depends.
597
598 Subp_Inputs : Elist_Id := No_Elist;
599 Subp_Outputs : Elist_Id := No_Elist;
600 -- Two lists containing the full set of inputs and output of the related
601 -- subprograms. Note that these lists contain both nodes and entities.
602
603 Task_Input_Seen : Boolean := False;
604 Task_Output_Seen : Boolean := False;
605 -- Flags used to track the implicit dependence of a task unit on itself
606
607 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
608 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
609 -- to the name buffer. The individual kinds are as follows:
610 -- E_Abstract_State - "state"
611 -- E_Constant - "constant"
612 -- E_Discriminant - "discriminant"
613 -- E_Generic_In_Out_Parameter - "generic parameter"
614 -- E_Generic_In_Parameter - "generic parameter"
615 -- E_In_Parameter - "parameter"
616 -- E_In_Out_Parameter - "parameter"
617 -- E_Loop_Parameter - "loop parameter"
618 -- E_Out_Parameter - "parameter"
619 -- E_Protected_Type - "current instance of protected type"
620 -- E_Task_Type - "current instance of task type"
621 -- E_Variable - "global"
622
623 procedure Analyze_Dependency_Clause
624 (Clause : Node_Id;
625 Is_Last : Boolean);
626 -- Verify the legality of a single dependency clause. Flag Is_Last
627 -- denotes whether Clause is the last clause in the relation.
628
629 procedure Check_Function_Return;
630 -- Verify that Funtion'Result appears as one of the outputs
631 -- (SPARK RM 6.1.5(10)).
632
633 procedure Check_Role
634 (Item : Node_Id;
635 Item_Id : Entity_Id;
636 Is_Input : Boolean;
637 Self_Ref : Boolean);
638 -- Ensure that an item fulfills its designated input and/or output role
639 -- as specified by pragma Global (if any) or the enclosing context. If
640 -- this is not the case, emit an error. Item and Item_Id denote the
641 -- attributes of an item. Flag Is_Input should be set when item comes
642 -- from an input list. Flag Self_Ref should be set when the item is an
643 -- output and the dependency clause has operator "+".
644
645 procedure Check_Usage
646 (Subp_Items : Elist_Id;
647 Used_Items : Elist_Id;
648 Is_Input : Boolean);
649 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
650 -- error if this is not the case.
651
652 procedure Normalize_Clause (Clause : Node_Id);
653 -- Remove a self-dependency "+" from the input list of a clause
654
655 -----------------------------
656 -- Add_Item_To_Name_Buffer --
657 -----------------------------
658
659 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
660 begin
661 if Ekind (Item_Id) = E_Abstract_State then
662 Add_Str_To_Name_Buffer ("state");
663
664 elsif Ekind (Item_Id) = E_Constant then
665 Add_Str_To_Name_Buffer ("constant");
666
667 elsif Ekind (Item_Id) = E_Discriminant then
668 Add_Str_To_Name_Buffer ("discriminant");
669
670 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
671 E_Generic_In_Parameter)
672 then
673 Add_Str_To_Name_Buffer ("generic parameter");
674
675 elsif Is_Formal (Item_Id) then
676 Add_Str_To_Name_Buffer ("parameter");
677
678 elsif Ekind (Item_Id) = E_Loop_Parameter then
679 Add_Str_To_Name_Buffer ("loop parameter");
680
681 elsif Ekind (Item_Id) = E_Protected_Type
682 or else Is_Single_Protected_Object (Item_Id)
683 then
684 Add_Str_To_Name_Buffer ("current instance of protected type");
685
686 elsif Ekind (Item_Id) = E_Task_Type
687 or else Is_Single_Task_Object (Item_Id)
688 then
689 Add_Str_To_Name_Buffer ("current instance of task type");
690
691 elsif Ekind (Item_Id) = E_Variable then
692 Add_Str_To_Name_Buffer ("global");
693
694 -- The routine should not be called with non-SPARK items
695
696 else
697 raise Program_Error;
698 end if;
699 end Add_Item_To_Name_Buffer;
700
701 -------------------------------
702 -- Analyze_Dependency_Clause --
703 -------------------------------
704
705 procedure Analyze_Dependency_Clause
706 (Clause : Node_Id;
707 Is_Last : Boolean)
708 is
709 procedure Analyze_Input_List (Inputs : Node_Id);
710 -- Verify the legality of a single input list
711
712 procedure Analyze_Input_Output
713 (Item : Node_Id;
714 Is_Input : Boolean;
715 Self_Ref : Boolean;
716 Top_Level : Boolean;
717 Seen : in out Elist_Id;
718 Null_Seen : in out Boolean;
719 Non_Null_Seen : in out Boolean);
720 -- Verify the legality of a single input or output item. Flag
721 -- Is_Input should be set whenever Item is an input, False when it
722 -- denotes an output. Flag Self_Ref should be set when the item is an
723 -- output and the dependency clause has a "+". Flag Top_Level should
724 -- be set whenever Item appears immediately within an input or output
725 -- list. Seen is a collection of all abstract states, objects and
726 -- formals processed so far. Flag Null_Seen denotes whether a null
727 -- input or output has been encountered. Flag Non_Null_Seen denotes
728 -- whether a non-null input or output has been encountered.
729
730 ------------------------
731 -- Analyze_Input_List --
732 ------------------------
733
734 procedure Analyze_Input_List (Inputs : Node_Id) is
735 Inputs_Seen : Elist_Id := No_Elist;
736 -- A list containing the entities of all inputs that appear in the
737 -- current input list.
738
739 Non_Null_Input_Seen : Boolean := False;
740 Null_Input_Seen : Boolean := False;
741 -- Flags used to check the legality of an input list
742
743 Input : Node_Id;
744
745 begin
746 -- Multiple inputs appear as an aggregate
747
748 if Nkind (Inputs) = N_Aggregate then
749 if Present (Component_Associations (Inputs)) then
750 SPARK_Msg_N
751 ("nested dependency relations not allowed", Inputs);
752
753 elsif Present (Expressions (Inputs)) then
754 Input := First (Expressions (Inputs));
755 while Present (Input) loop
756 Analyze_Input_Output
757 (Item => Input,
758 Is_Input => True,
759 Self_Ref => False,
760 Top_Level => False,
761 Seen => Inputs_Seen,
762 Null_Seen => Null_Input_Seen,
763 Non_Null_Seen => Non_Null_Input_Seen);
764
765 Next (Input);
766 end loop;
767
768 -- Syntax error, always report
769
770 else
771 Error_Msg_N ("malformed input dependency list", Inputs);
772 end if;
773
774 -- Process a solitary input
775
776 else
777 Analyze_Input_Output
778 (Item => Inputs,
779 Is_Input => True,
780 Self_Ref => False,
781 Top_Level => False,
782 Seen => Inputs_Seen,
783 Null_Seen => Null_Input_Seen,
784 Non_Null_Seen => Non_Null_Input_Seen);
785 end if;
786
787 -- Detect an illegal dependency clause of the form
788
789 -- (null =>[+] null)
790
791 if Null_Output_Seen and then Null_Input_Seen then
792 SPARK_Msg_N
793 ("null dependency clause cannot have a null input list",
794 Inputs);
795 end if;
796 end Analyze_Input_List;
797
798 --------------------------
799 -- Analyze_Input_Output --
800 --------------------------
801
802 procedure Analyze_Input_Output
803 (Item : Node_Id;
804 Is_Input : Boolean;
805 Self_Ref : Boolean;
806 Top_Level : Boolean;
807 Seen : in out Elist_Id;
808 Null_Seen : in out Boolean;
809 Non_Null_Seen : in out Boolean)
810 is
811 procedure Current_Task_Instance_Seen;
812 -- Set the appropriate global flag when the current instance of a
813 -- task unit is encountered.
814
815 --------------------------------
816 -- Current_Task_Instance_Seen --
817 --------------------------------
818
819 procedure Current_Task_Instance_Seen is
820 begin
821 if Is_Input then
822 Task_Input_Seen := True;
823 else
824 Task_Output_Seen := True;
825 end if;
826 end Current_Task_Instance_Seen;
827
828 -- Local variables
829
830 Is_Output : constant Boolean := not Is_Input;
831 Grouped : Node_Id;
832 Item_Id : Entity_Id;
833
834 -- Start of processing for Analyze_Input_Output
835
836 begin
837 -- Multiple input or output items appear as an aggregate
838
839 if Nkind (Item) = N_Aggregate then
840 if not Top_Level then
841 SPARK_Msg_N ("nested grouping of items not allowed", Item);
842
843 elsif Present (Component_Associations (Item)) then
844 SPARK_Msg_N
845 ("nested dependency relations not allowed", Item);
846
847 -- Recursively analyze the grouped items
848
849 elsif Present (Expressions (Item)) then
850 Grouped := First (Expressions (Item));
851 while Present (Grouped) loop
852 Analyze_Input_Output
853 (Item => Grouped,
854 Is_Input => Is_Input,
855 Self_Ref => Self_Ref,
856 Top_Level => False,
857 Seen => Seen,
858 Null_Seen => Null_Seen,
859 Non_Null_Seen => Non_Null_Seen);
860
861 Next (Grouped);
862 end loop;
863
864 -- Syntax error, always report
865
866 else
867 Error_Msg_N ("malformed dependency list", Item);
868 end if;
869
870 -- Process attribute 'Result in the context of a dependency clause
871
872 elsif Is_Attribute_Result (Item) then
873 Non_Null_Seen := True;
874
875 Analyze (Item);
876
877 -- Attribute 'Result is allowed to appear on the output side of
878 -- a dependency clause (SPARK RM 6.1.5(6)).
879
880 if Is_Input then
881 SPARK_Msg_N ("function result cannot act as input", Item);
882
883 elsif Null_Seen then
884 SPARK_Msg_N
885 ("cannot mix null and non-null dependency items", Item);
886
887 else
888 Result_Seen := True;
889 end if;
890
891 -- Detect multiple uses of null in a single dependency list or
892 -- throughout the whole relation. Verify the placement of a null
893 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
894
895 elsif Nkind (Item) = N_Null then
896 if Null_Seen then
897 SPARK_Msg_N
898 ("multiple null dependency relations not allowed", Item);
899
900 elsif Non_Null_Seen then
901 SPARK_Msg_N
902 ("cannot mix null and non-null dependency items", Item);
903
904 else
905 Null_Seen := True;
906
907 if Is_Output then
908 if not Is_Last then
909 SPARK_Msg_N
910 ("null output list must be the last clause in a "
911 & "dependency relation", Item);
912
913 -- Catch a useless dependence of the form:
914 -- null =>+ ...
915
916 elsif Self_Ref then
917 SPARK_Msg_N
918 ("useless dependence, null depends on itself", Item);
919 end if;
920 end if;
921 end if;
922
923 -- Default case
924
925 else
926 Non_Null_Seen := True;
927
928 if Null_Seen then
929 SPARK_Msg_N ("cannot mix null and non-null items", Item);
930 end if;
931
932 Analyze (Item);
933 Resolve_State (Item);
934
935 -- Find the entity of the item. If this is a renaming, climb
936 -- the renaming chain to reach the root object. Renamings of
937 -- non-entire objects do not yield an entity (Empty).
938
939 Item_Id := Entity_Of (Item);
940
941 if Present (Item_Id) then
942
943 -- Constants
944
945 if Ekind_In (Item_Id, E_Constant,
946 E_Discriminant,
947 E_Loop_Parameter)
948 or else
949
950 -- Current instances of concurrent types
951
952 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
953 or else
954
955 -- Formal parameters
956
957 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
958 E_Generic_In_Parameter,
959 E_In_Parameter,
960 E_In_Out_Parameter,
961 E_Out_Parameter)
962 or else
963
964 -- States, variables
965
966 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
967 then
968 -- The item denotes a concurrent type. Note that single
969 -- protected/task types are not considered here because
970 -- they behave as objects in the context of pragma
971 -- [Refined_]Depends.
972
973 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
974
975 -- This use is legal as long as the concurrent type is
976 -- the current instance of an enclosing type.
977
978 if Is_CCT_Instance (Item_Id, Spec_Id) then
979
980 -- The dependence of a task unit on itself is
981 -- implicit and may or may not be explicitly
982 -- specified (SPARK RM 6.1.4).
983
984 if Ekind (Item_Id) = E_Task_Type then
985 Current_Task_Instance_Seen;
986 end if;
987
988 -- Otherwise this is not the current instance
989
990 else
991 SPARK_Msg_N
992 ("invalid use of subtype mark in dependency "
993 & "relation", Item);
994 end if;
995
996 -- The dependency of a task unit on itself is implicit
997 -- and may or may not be explicitly specified
998 -- (SPARK RM 6.1.4).
999
1000 elsif Is_Single_Task_Object (Item_Id)
1001 and then Is_CCT_Instance (Item_Id, Spec_Id)
1002 then
1003 Current_Task_Instance_Seen;
1004 end if;
1005
1006 -- Ensure that the item fulfills its role as input and/or
1007 -- output as specified by pragma Global or the enclosing
1008 -- context.
1009
1010 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1011
1012 -- Detect multiple uses of the same state, variable or
1013 -- formal parameter. If this is not the case, add the
1014 -- item to the list of processed relations.
1015
1016 if Contains (Seen, Item_Id) then
1017 SPARK_Msg_NE
1018 ("duplicate use of item &", Item, Item_Id);
1019 else
1020 Append_New_Elmt (Item_Id, Seen);
1021 end if;
1022
1023 -- Detect illegal use of an input related to a null
1024 -- output. Such input items cannot appear in other
1025 -- input lists (SPARK RM 6.1.5(13)).
1026
1027 if Is_Input
1028 and then Null_Output_Seen
1029 and then Contains (All_Inputs_Seen, Item_Id)
1030 then
1031 SPARK_Msg_N
1032 ("input of a null output list cannot appear in "
1033 & "multiple input lists", Item);
1034 end if;
1035
1036 -- Add an input or a self-referential output to the list
1037 -- of all processed inputs.
1038
1039 if Is_Input or else Self_Ref then
1040 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1041 end if;
1042
1043 -- State related checks (SPARK RM 6.1.5(3))
1044
1045 if Ekind (Item_Id) = E_Abstract_State then
1046
1047 -- Package and subprogram bodies are instantiated
1048 -- individually in a separate compiler pass. Due to
1049 -- this mode of instantiation, the refinement of a
1050 -- state may no longer be visible when a subprogram
1051 -- body contract is instantiated. Since the generic
1052 -- template is legal, do not perform this check in
1053 -- the instance to circumvent this oddity.
1054
1055 if Is_Generic_Instance (Spec_Id) then
1056 null;
1057
1058 -- An abstract state with visible refinement cannot
1059 -- appear in pragma [Refined_]Depends as its place
1060 -- must be taken by some of its constituents
1061 -- (SPARK RM 6.1.4(7)).
1062
1063 elsif Has_Visible_Refinement (Item_Id) then
1064 SPARK_Msg_NE
1065 ("cannot mention state & in dependence relation",
1066 Item, Item_Id);
1067 SPARK_Msg_N ("\use its constituents instead", Item);
1068 return;
1069
1070 -- If the reference to the abstract state appears in
1071 -- an enclosing package body that will eventually
1072 -- refine the state, record the reference for future
1073 -- checks.
1074
1075 else
1076 Record_Possible_Body_Reference
1077 (State_Id => Item_Id,
1078 Ref => Item);
1079 end if;
1080 end if;
1081
1082 -- When the item renames an entire object, replace the
1083 -- item with a reference to the object.
1084
1085 if Entity (Item) /= Item_Id then
1086 Rewrite (Item,
1087 New_Occurrence_Of (Item_Id, Sloc (Item)));
1088 Analyze (Item);
1089 end if;
1090
1091 -- Add the entity of the current item to the list of
1092 -- processed items.
1093
1094 if Ekind (Item_Id) = E_Abstract_State then
1095 Append_New_Elmt (Item_Id, States_Seen);
1096
1097 -- The variable may eventually become a constituent of a
1098 -- single protected/task type. Record the reference now
1099 -- and verify its legality when analyzing the contract of
1100 -- the variable (SPARK RM 9.3).
1101
1102 elsif Ekind (Item_Id) = E_Variable then
1103 Record_Possible_Part_Of_Reference
1104 (Var_Id => Item_Id,
1105 Ref => Item);
1106 end if;
1107
1108 if Ekind_In (Item_Id, E_Abstract_State,
1109 E_Constant,
1110 E_Variable)
1111 and then Present (Encapsulating_State (Item_Id))
1112 then
1113 Append_New_Elmt (Item_Id, Constits_Seen);
1114 end if;
1115
1116 -- All other input/output items are illegal
1117 -- (SPARK RM 6.1.5(1)).
1118
1119 else
1120 SPARK_Msg_N
1121 ("item must denote parameter, variable, state or "
1122 & "current instance of concurren type", Item);
1123 end if;
1124
1125 -- All other input/output items are illegal
1126 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1127
1128 else
1129 Error_Msg_N
1130 ("item must denote parameter, variable, state or current "
1131 & "instance of concurrent type", Item);
1132 end if;
1133 end if;
1134 end Analyze_Input_Output;
1135
1136 -- Local variables
1137
1138 Inputs : Node_Id;
1139 Output : Node_Id;
1140 Self_Ref : Boolean;
1141
1142 Non_Null_Output_Seen : Boolean := False;
1143 -- Flag used to check the legality of an output list
1144
1145 -- Start of processing for Analyze_Dependency_Clause
1146
1147 begin
1148 Inputs := Expression (Clause);
1149 Self_Ref := False;
1150
1151 -- An input list with a self-dependency appears as operator "+" where
1152 -- the actuals inputs are the right operand.
1153
1154 if Nkind (Inputs) = N_Op_Plus then
1155 Inputs := Right_Opnd (Inputs);
1156 Self_Ref := True;
1157 end if;
1158
1159 -- Process the output_list of a dependency_clause
1160
1161 Output := First (Choices (Clause));
1162 while Present (Output) loop
1163 Analyze_Input_Output
1164 (Item => Output,
1165 Is_Input => False,
1166 Self_Ref => Self_Ref,
1167 Top_Level => True,
1168 Seen => All_Outputs_Seen,
1169 Null_Seen => Null_Output_Seen,
1170 Non_Null_Seen => Non_Null_Output_Seen);
1171
1172 Next (Output);
1173 end loop;
1174
1175 -- Process the input_list of a dependency_clause
1176
1177 Analyze_Input_List (Inputs);
1178 end Analyze_Dependency_Clause;
1179
1180 ---------------------------
1181 -- Check_Function_Return --
1182 ---------------------------
1183
1184 procedure Check_Function_Return is
1185 begin
1186 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1187 and then not Result_Seen
1188 then
1189 SPARK_Msg_NE
1190 ("result of & must appear in exactly one output list",
1191 N, Spec_Id);
1192 end if;
1193 end Check_Function_Return;
1194
1195 ----------------
1196 -- Check_Role --
1197 ----------------
1198
1199 procedure Check_Role
1200 (Item : Node_Id;
1201 Item_Id : Entity_Id;
1202 Is_Input : Boolean;
1203 Self_Ref : Boolean)
1204 is
1205 procedure Find_Role
1206 (Item_Is_Input : out Boolean;
1207 Item_Is_Output : out Boolean);
1208 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1209 -- Item_Is_Output are set depending on the role.
1210
1211 procedure Role_Error
1212 (Item_Is_Input : Boolean;
1213 Item_Is_Output : Boolean);
1214 -- Emit an error message concerning the incorrect use of Item in
1215 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1216 -- denote whether the item is an input and/or an output.
1217
1218 ---------------
1219 -- Find_Role --
1220 ---------------
1221
1222 procedure Find_Role
1223 (Item_Is_Input : out Boolean;
1224 Item_Is_Output : out Boolean)
1225 is
1226 begin
1227 Item_Is_Input := False;
1228 Item_Is_Output := False;
1229
1230 -- Abstract states
1231
1232 if Ekind (Item_Id) = E_Abstract_State then
1233
1234 -- When pragma Global is present, the mode of the state may be
1235 -- further constrained by setting a more restrictive mode.
1236
1237 if Global_Seen then
1238 if Appears_In (Subp_Inputs, Item_Id) then
1239 Item_Is_Input := True;
1240 end if;
1241
1242 if Appears_In (Subp_Outputs, Item_Id) then
1243 Item_Is_Output := True;
1244 end if;
1245
1246 -- Otherwise the state has a default IN OUT mode
1247
1248 else
1249 Item_Is_Input := True;
1250 Item_Is_Output := True;
1251 end if;
1252
1253 -- Constants
1254
1255 elsif Ekind_In (Item_Id, E_Constant,
1256 E_Discriminant,
1257 E_Loop_Parameter)
1258 then
1259 Item_Is_Input := True;
1260
1261 -- Parameters
1262
1263 elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
1264 E_In_Parameter)
1265 then
1266 Item_Is_Input := True;
1267
1268 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
1269 E_In_Out_Parameter)
1270 then
1271 Item_Is_Input := True;
1272 Item_Is_Output := True;
1273
1274 elsif Ekind (Item_Id) = E_Out_Parameter then
1275 if Scope (Item_Id) = Spec_Id then
1276
1277 -- An OUT parameter of the related subprogram has mode IN
1278 -- if its type is unconstrained or tagged because array
1279 -- bounds, discriminants or tags can be read.
1280
1281 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1282 Item_Is_Input := True;
1283 end if;
1284
1285 Item_Is_Output := True;
1286
1287 -- An OUT parameter of an enclosing subprogram behaves as a
1288 -- read-write variable in which case the mode is IN OUT.
1289
1290 else
1291 Item_Is_Input := True;
1292 Item_Is_Output := True;
1293 end if;
1294
1295 -- Protected types
1296
1297 elsif Ekind (Item_Id) = E_Protected_Type then
1298
1299 -- A protected type acts as a formal parameter of mode IN when
1300 -- it applies to a protected function.
1301
1302 if Ekind (Spec_Id) = E_Function then
1303 Item_Is_Input := True;
1304
1305 -- Otherwise the protected type acts as a formal of mode IN OUT
1306
1307 else
1308 Item_Is_Input := True;
1309 Item_Is_Output := True;
1310 end if;
1311
1312 -- Task types
1313
1314 elsif Ekind (Item_Id) = E_Task_Type then
1315 Item_Is_Input := True;
1316 Item_Is_Output := True;
1317
1318 -- Variable case
1319
1320 else pragma Assert (Ekind (Item_Id) = E_Variable);
1321
1322 -- When pragma Global is present, the mode of the variable may
1323 -- be further constrained by setting a more restrictive mode.
1324
1325 if Global_Seen then
1326
1327 -- A variable has mode IN when its type is unconstrained or
1328 -- tagged because array bounds, discriminants or tags can be
1329 -- read.
1330
1331 if Appears_In (Subp_Inputs, Item_Id)
1332 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1333 then
1334 Item_Is_Input := True;
1335 end if;
1336
1337 if Appears_In (Subp_Outputs, Item_Id) then
1338 Item_Is_Output := True;
1339 end if;
1340
1341 -- Otherwise the variable has a default IN OUT mode
1342
1343 else
1344 Item_Is_Input := True;
1345 Item_Is_Output := True;
1346 end if;
1347 end if;
1348 end Find_Role;
1349
1350 ----------------
1351 -- Role_Error --
1352 ----------------
1353
1354 procedure Role_Error
1355 (Item_Is_Input : Boolean;
1356 Item_Is_Output : Boolean)
1357 is
1358 Error_Msg : Name_Id;
1359
1360 begin
1361 Name_Len := 0;
1362
1363 -- When the item is not part of the input and the output set of
1364 -- the related subprogram, then it appears as extra in pragma
1365 -- [Refined_]Depends.
1366
1367 if not Item_Is_Input and then not Item_Is_Output then
1368 Add_Item_To_Name_Buffer (Item_Id);
1369 Add_Str_To_Name_Buffer
1370 (" & cannot appear in dependence relation");
1371
1372 Error_Msg := Name_Find;
1373 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1374
1375 Error_Msg_Name_1 := Chars (Spec_Id);
1376 SPARK_Msg_NE
1377 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1378 & "set of subprogram %"), Item, Item_Id);
1379
1380 -- The mode of the item and its role in pragma [Refined_]Depends
1381 -- are in conflict. Construct a detailed message explaining the
1382 -- illegality (SPARK RM 6.1.5(5-6)).
1383
1384 else
1385 if Item_Is_Input then
1386 Add_Str_To_Name_Buffer ("read-only");
1387 else
1388 Add_Str_To_Name_Buffer ("write-only");
1389 end if;
1390
1391 Add_Char_To_Name_Buffer (' ');
1392 Add_Item_To_Name_Buffer (Item_Id);
1393 Add_Str_To_Name_Buffer (" & cannot appear as ");
1394
1395 if Item_Is_Input then
1396 Add_Str_To_Name_Buffer ("output");
1397 else
1398 Add_Str_To_Name_Buffer ("input");
1399 end if;
1400
1401 Add_Str_To_Name_Buffer (" in dependence relation");
1402 Error_Msg := Name_Find;
1403 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1404 end if;
1405 end Role_Error;
1406
1407 -- Local variables
1408
1409 Item_Is_Input : Boolean;
1410 Item_Is_Output : Boolean;
1411
1412 -- Start of processing for Check_Role
1413
1414 begin
1415 Find_Role (Item_Is_Input, Item_Is_Output);
1416
1417 -- Input item
1418
1419 if Is_Input then
1420 if not Item_Is_Input then
1421 Role_Error (Item_Is_Input, Item_Is_Output);
1422 end if;
1423
1424 -- Self-referential item
1425
1426 elsif Self_Ref then
1427 if not Item_Is_Input or else not Item_Is_Output then
1428 Role_Error (Item_Is_Input, Item_Is_Output);
1429 end if;
1430
1431 -- Output item
1432
1433 elsif not Item_Is_Output then
1434 Role_Error (Item_Is_Input, Item_Is_Output);
1435 end if;
1436 end Check_Role;
1437
1438 -----------------
1439 -- Check_Usage --
1440 -----------------
1441
1442 procedure Check_Usage
1443 (Subp_Items : Elist_Id;
1444 Used_Items : Elist_Id;
1445 Is_Input : Boolean)
1446 is
1447 procedure Usage_Error (Item_Id : Entity_Id);
1448 -- Emit an error concerning the illegal usage of an item
1449
1450 -----------------
1451 -- Usage_Error --
1452 -----------------
1453
1454 procedure Usage_Error (Item_Id : Entity_Id) is
1455 Error_Msg : Name_Id;
1456
1457 begin
1458 -- Input case
1459
1460 if Is_Input then
1461
1462 -- Unconstrained and tagged items are not part of the explicit
1463 -- input set of the related subprogram, they do not have to be
1464 -- present in a dependence relation and should not be flagged
1465 -- (SPARK RM 6.1.5(8)).
1466
1467 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1468 Name_Len := 0;
1469
1470 Add_Item_To_Name_Buffer (Item_Id);
1471 Add_Str_To_Name_Buffer
1472 (" & is missing from input dependence list");
1473
1474 Error_Msg := Name_Find;
1475 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1476 end if;
1477
1478 -- Output case (SPARK RM 6.1.5(10))
1479
1480 else
1481 Name_Len := 0;
1482
1483 Add_Item_To_Name_Buffer (Item_Id);
1484 Add_Str_To_Name_Buffer
1485 (" & is missing from output dependence list");
1486
1487 Error_Msg := Name_Find;
1488 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1489 end if;
1490 end Usage_Error;
1491
1492 -- Local variables
1493
1494 Elmt : Elmt_Id;
1495 Item : Node_Id;
1496 Item_Id : Entity_Id;
1497
1498 -- Start of processing for Check_Usage
1499
1500 begin
1501 if No (Subp_Items) then
1502 return;
1503 end if;
1504
1505 -- Each input or output of the subprogram must appear in a dependency
1506 -- relation.
1507
1508 Elmt := First_Elmt (Subp_Items);
1509 while Present (Elmt) loop
1510 Item := Node (Elmt);
1511
1512 if Nkind (Item) = N_Defining_Identifier then
1513 Item_Id := Item;
1514 else
1515 Item_Id := Entity_Of (Item);
1516 end if;
1517
1518 -- The item does not appear in a dependency
1519
1520 if Present (Item_Id)
1521 and then not Contains (Used_Items, Item_Id)
1522 then
1523 if Is_Formal (Item_Id) then
1524 Usage_Error (Item_Id);
1525
1526 -- The current instance of a protected type behaves as a formal
1527 -- parameter (SPARK RM 6.1.4).
1528
1529 elsif Ekind (Item_Id) = E_Protected_Type
1530 or else Is_Single_Protected_Object (Item_Id)
1531 then
1532 Usage_Error (Item_Id);
1533
1534 -- The current instance of a task type behaves as a formal
1535 -- parameter (SPARK RM 6.1.4).
1536
1537 elsif Ekind (Item_Id) = E_Task_Type
1538 or else Is_Single_Task_Object (Item_Id)
1539 then
1540 -- The dependence of a task unit on itself is implicit and
1541 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1542 -- Emit an error if only one input/output is present.
1543
1544 if Task_Input_Seen /= Task_Output_Seen then
1545 Usage_Error (Item_Id);
1546 end if;
1547
1548 -- States and global objects are not used properly only when
1549 -- the subprogram is subject to pragma Global.
1550
1551 elsif Global_Seen then
1552 Usage_Error (Item_Id);
1553 end if;
1554 end if;
1555
1556 Next_Elmt (Elmt);
1557 end loop;
1558 end Check_Usage;
1559
1560 ----------------------
1561 -- Normalize_Clause --
1562 ----------------------
1563
1564 procedure Normalize_Clause (Clause : Node_Id) is
1565 procedure Create_Or_Modify_Clause
1566 (Output : Node_Id;
1567 Outputs : Node_Id;
1568 Inputs : Node_Id;
1569 After : Node_Id;
1570 In_Place : Boolean;
1571 Multiple : Boolean);
1572 -- Create a brand new clause to represent the self-reference or
1573 -- modify the input and/or output lists of an existing clause. Output
1574 -- denotes a self-referencial output. Outputs is the output list of a
1575 -- clause. Inputs is the input list of a clause. After denotes the
1576 -- clause after which the new clause is to be inserted. Flag In_Place
1577 -- should be set when normalizing the last output of an output list.
1578 -- Flag Multiple should be set when Output comes from a list with
1579 -- multiple items.
1580
1581 -----------------------------
1582 -- Create_Or_Modify_Clause --
1583 -----------------------------
1584
1585 procedure Create_Or_Modify_Clause
1586 (Output : Node_Id;
1587 Outputs : Node_Id;
1588 Inputs : Node_Id;
1589 After : Node_Id;
1590 In_Place : Boolean;
1591 Multiple : Boolean)
1592 is
1593 procedure Propagate_Output
1594 (Output : Node_Id;
1595 Inputs : Node_Id);
1596 -- Handle the various cases of output propagation to the input
1597 -- list. Output denotes a self-referencial output item. Inputs
1598 -- is the input list of a clause.
1599
1600 ----------------------
1601 -- Propagate_Output --
1602 ----------------------
1603
1604 procedure Propagate_Output
1605 (Output : Node_Id;
1606 Inputs : Node_Id)
1607 is
1608 function In_Input_List
1609 (Item : Entity_Id;
1610 Inputs : List_Id) return Boolean;
1611 -- Determine whether a particulat item appears in the input
1612 -- list of a clause.
1613
1614 -------------------
1615 -- In_Input_List --
1616 -------------------
1617
1618 function In_Input_List
1619 (Item : Entity_Id;
1620 Inputs : List_Id) return Boolean
1621 is
1622 Elmt : Node_Id;
1623
1624 begin
1625 Elmt := First (Inputs);
1626 while Present (Elmt) loop
1627 if Entity_Of (Elmt) = Item then
1628 return True;
1629 end if;
1630
1631 Next (Elmt);
1632 end loop;
1633
1634 return False;
1635 end In_Input_List;
1636
1637 -- Local variables
1638
1639 Output_Id : constant Entity_Id := Entity_Of (Output);
1640 Grouped : List_Id;
1641
1642 -- Start of processing for Propagate_Output
1643
1644 begin
1645 -- The clause is of the form:
1646
1647 -- (Output =>+ null)
1648
1649 -- Remove null input and replace it with a copy of the output:
1650
1651 -- (Output => Output)
1652
1653 if Nkind (Inputs) = N_Null then
1654 Rewrite (Inputs, New_Copy_Tree (Output));
1655
1656 -- The clause is of the form:
1657
1658 -- (Output =>+ (Input1, ..., InputN))
1659
1660 -- Determine whether the output is not already mentioned in the
1661 -- input list and if not, add it to the list of inputs:
1662
1663 -- (Output => (Output, Input1, ..., InputN))
1664
1665 elsif Nkind (Inputs) = N_Aggregate then
1666 Grouped := Expressions (Inputs);
1667
1668 if not In_Input_List
1669 (Item => Output_Id,
1670 Inputs => Grouped)
1671 then
1672 Prepend_To (Grouped, New_Copy_Tree (Output));
1673 end if;
1674
1675 -- The clause is of the form:
1676
1677 -- (Output =>+ Input)
1678
1679 -- If the input does not mention the output, group the two
1680 -- together:
1681
1682 -- (Output => (Output, Input))
1683
1684 elsif Entity_Of (Inputs) /= Output_Id then
1685 Rewrite (Inputs,
1686 Make_Aggregate (Loc,
1687 Expressions => New_List (
1688 New_Copy_Tree (Output),
1689 New_Copy_Tree (Inputs))));
1690 end if;
1691 end Propagate_Output;
1692
1693 -- Local variables
1694
1695 Loc : constant Source_Ptr := Sloc (Clause);
1696 New_Clause : Node_Id;
1697
1698 -- Start of processing for Create_Or_Modify_Clause
1699
1700 begin
1701 -- A null output depending on itself does not require any
1702 -- normalization.
1703
1704 if Nkind (Output) = N_Null then
1705 return;
1706
1707 -- A function result cannot depend on itself because it cannot
1708 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1709
1710 elsif Is_Attribute_Result (Output) then
1711 SPARK_Msg_N ("function result cannot depend on itself", Output);
1712 return;
1713 end if;
1714
1715 -- When performing the transformation in place, simply add the
1716 -- output to the list of inputs (if not already there). This
1717 -- case arises when dealing with the last output of an output
1718 -- list. Perform the normalization in place to avoid generating
1719 -- a malformed tree.
1720
1721 if In_Place then
1722 Propagate_Output (Output, Inputs);
1723
1724 -- A list with multiple outputs is slowly trimmed until only
1725 -- one element remains. When this happens, replace aggregate
1726 -- with the element itself.
1727
1728 if Multiple then
1729 Remove (Output);
1730 Rewrite (Outputs, Output);
1731 end if;
1732
1733 -- Default case
1734
1735 else
1736 -- Unchain the output from its output list as it will appear in
1737 -- a new clause. Note that we cannot simply rewrite the output
1738 -- as null because this will violate the semantics of pragma
1739 -- Depends.
1740
1741 Remove (Output);
1742
1743 -- Generate a new clause of the form:
1744 -- (Output => Inputs)
1745
1746 New_Clause :=
1747 Make_Component_Association (Loc,
1748 Choices => New_List (Output),
1749 Expression => New_Copy_Tree (Inputs));
1750
1751 -- The new clause contains replicated content that has already
1752 -- been analyzed. There is not need to reanalyze or renormalize
1753 -- it again.
1754
1755 Set_Analyzed (New_Clause);
1756
1757 Propagate_Output
1758 (Output => First (Choices (New_Clause)),
1759 Inputs => Expression (New_Clause));
1760
1761 Insert_After (After, New_Clause);
1762 end if;
1763 end Create_Or_Modify_Clause;
1764
1765 -- Local variables
1766
1767 Outputs : constant Node_Id := First (Choices (Clause));
1768 Inputs : Node_Id;
1769 Last_Output : Node_Id;
1770 Next_Output : Node_Id;
1771 Output : Node_Id;
1772
1773 -- Start of processing for Normalize_Clause
1774
1775 begin
1776 -- A self-dependency appears as operator "+". Remove the "+" from the
1777 -- tree by moving the real inputs to their proper place.
1778
1779 if Nkind (Expression (Clause)) = N_Op_Plus then
1780 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1781 Inputs := Expression (Clause);
1782
1783 -- Multiple outputs appear as an aggregate
1784
1785 if Nkind (Outputs) = N_Aggregate then
1786 Last_Output := Last (Expressions (Outputs));
1787
1788 Output := First (Expressions (Outputs));
1789 while Present (Output) loop
1790
1791 -- Normalization may remove an output from its list,
1792 -- preserve the subsequent output now.
1793
1794 Next_Output := Next (Output);
1795
1796 Create_Or_Modify_Clause
1797 (Output => Output,
1798 Outputs => Outputs,
1799 Inputs => Inputs,
1800 After => Clause,
1801 In_Place => Output = Last_Output,
1802 Multiple => True);
1803
1804 Output := Next_Output;
1805 end loop;
1806
1807 -- Solitary output
1808
1809 else
1810 Create_Or_Modify_Clause
1811 (Output => Outputs,
1812 Outputs => Empty,
1813 Inputs => Inputs,
1814 After => Empty,
1815 In_Place => True,
1816 Multiple => False);
1817 end if;
1818 end if;
1819 end Normalize_Clause;
1820
1821 -- Local variables
1822
1823 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1824 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1825
1826 Clause : Node_Id;
1827 Errors : Nat;
1828 Last_Clause : Node_Id;
1829 Restore_Scope : Boolean := False;
1830
1831 -- Start of processing for Analyze_Depends_In_Decl_Part
1832
1833 begin
1834 -- Do not analyze the pragma multiple times
1835
1836 if Is_Analyzed_Pragma (N) then
1837 return;
1838 end if;
1839
1840 -- Empty dependency list
1841
1842 if Nkind (Deps) = N_Null then
1843
1844 -- Gather all states, objects and formal parameters that the
1845 -- subprogram may depend on. These items are obtained from the
1846 -- parameter profile or pragma [Refined_]Global (if available).
1847
1848 Collect_Subprogram_Inputs_Outputs
1849 (Subp_Id => Subp_Id,
1850 Subp_Inputs => Subp_Inputs,
1851 Subp_Outputs => Subp_Outputs,
1852 Global_Seen => Global_Seen);
1853
1854 -- Verify that every input or output of the subprogram appear in a
1855 -- dependency.
1856
1857 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1858 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1859 Check_Function_Return;
1860
1861 -- Dependency clauses appear as component associations of an aggregate
1862
1863 elsif Nkind (Deps) = N_Aggregate then
1864
1865 -- Do not attempt to perform analysis of a syntactically illegal
1866 -- clause as this will lead to misleading errors.
1867
1868 if Has_Extra_Parentheses (Deps) then
1869 return;
1870 end if;
1871
1872 if Present (Component_Associations (Deps)) then
1873 Last_Clause := Last (Component_Associations (Deps));
1874
1875 -- Gather all states, objects and formal parameters that the
1876 -- subprogram may depend on. These items are obtained from the
1877 -- parameter profile or pragma [Refined_]Global (if available).
1878
1879 Collect_Subprogram_Inputs_Outputs
1880 (Subp_Id => Subp_Id,
1881 Subp_Inputs => Subp_Inputs,
1882 Subp_Outputs => Subp_Outputs,
1883 Global_Seen => Global_Seen);
1884
1885 -- When pragma [Refined_]Depends appears on a single concurrent
1886 -- type, it is relocated to the anonymous object.
1887
1888 if Is_Single_Concurrent_Object (Spec_Id) then
1889 null;
1890
1891 -- Ensure that the formal parameters are visible when analyzing
1892 -- all clauses. This falls out of the general rule of aspects
1893 -- pertaining to subprogram declarations.
1894
1895 elsif not In_Open_Scopes (Spec_Id) then
1896 Restore_Scope := True;
1897 Push_Scope (Spec_Id);
1898
1899 if Ekind (Spec_Id) = E_Task_Type then
1900 if Has_Discriminants (Spec_Id) then
1901 Install_Discriminants (Spec_Id);
1902 end if;
1903
1904 elsif Is_Generic_Subprogram (Spec_Id) then
1905 Install_Generic_Formals (Spec_Id);
1906
1907 else
1908 Install_Formals (Spec_Id);
1909 end if;
1910 end if;
1911
1912 Clause := First (Component_Associations (Deps));
1913 while Present (Clause) loop
1914 Errors := Serious_Errors_Detected;
1915
1916 -- The normalization mechanism may create extra clauses that
1917 -- contain replicated input and output names. There is no need
1918 -- to reanalyze them.
1919
1920 if not Analyzed (Clause) then
1921 Set_Analyzed (Clause);
1922
1923 Analyze_Dependency_Clause
1924 (Clause => Clause,
1925 Is_Last => Clause = Last_Clause);
1926 end if;
1927
1928 -- Do not normalize a clause if errors were detected (count
1929 -- of Serious_Errors has increased) because the inputs and/or
1930 -- outputs may denote illegal items. Normalization is disabled
1931 -- in ASIS mode as it alters the tree by introducing new nodes
1932 -- similar to expansion.
1933
1934 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1935 Normalize_Clause (Clause);
1936 end if;
1937
1938 Next (Clause);
1939 end loop;
1940
1941 if Restore_Scope then
1942 End_Scope;
1943 end if;
1944
1945 -- Verify that every input or output of the subprogram appear in a
1946 -- dependency.
1947
1948 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1949 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1950 Check_Function_Return;
1951
1952 -- The dependency list is malformed. This is a syntax error, always
1953 -- report.
1954
1955 else
1956 Error_Msg_N ("malformed dependency relation", Deps);
1957 return;
1958 end if;
1959
1960 -- The top level dependency relation is malformed. This is a syntax
1961 -- error, always report.
1962
1963 else
1964 Error_Msg_N ("malformed dependency relation", Deps);
1965 goto Leave;
1966 end if;
1967
1968 -- Ensure that a state and a corresponding constituent do not appear
1969 -- together in pragma [Refined_]Depends.
1970
1971 Check_State_And_Constituent_Use
1972 (States => States_Seen,
1973 Constits => Constits_Seen,
1974 Context => N);
1975
1976 <<Leave>>
1977 Set_Is_Analyzed_Pragma (N);
1978 end Analyze_Depends_In_Decl_Part;
1979
1980 --------------------------------------------
1981 -- Analyze_External_Property_In_Decl_Part --
1982 --------------------------------------------
1983
1984 procedure Analyze_External_Property_In_Decl_Part
1985 (N : Node_Id;
1986 Expr_Val : out Boolean)
1987 is
1988 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1989 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1990 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1991 Expr : Node_Id;
1992
1993 begin
1994 Expr_Val := False;
1995
1996 -- Do not analyze the pragma multiple times
1997
1998 if Is_Analyzed_Pragma (N) then
1999 return;
2000 end if;
2001
2002 Error_Msg_Name_1 := Pragma_Name (N);
2003
2004 -- An external property pragma must apply to an effectively volatile
2005 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2006 -- The check is performed at the end of the declarative region due to a
2007 -- possible out-of-order arrangement of pragmas:
2008
2009 -- Obj : ...;
2010 -- pragma Async_Readers (Obj);
2011 -- pragma Volatile (Obj);
2012
2013 if not Is_Effectively_Volatile (Obj_Id) then
2014 SPARK_Msg_N
2015 ("external property % must apply to a volatile object", N);
2016 end if;
2017
2018 -- Ensure that the Boolean expression (if present) is static. A missing
2019 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2020
2021 Expr_Val := True;
2022
2023 if Present (Arg1) then
2024 Expr := Get_Pragma_Arg (Arg1);
2025
2026 if Is_OK_Static_Expression (Expr) then
2027 Expr_Val := Is_True (Expr_Value (Expr));
2028 end if;
2029 end if;
2030
2031 Set_Is_Analyzed_Pragma (N);
2032 end Analyze_External_Property_In_Decl_Part;
2033
2034 ---------------------------------
2035 -- Analyze_Global_In_Decl_Part --
2036 ---------------------------------
2037
2038 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2039 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2040 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2041 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2042
2043 Constits_Seen : Elist_Id := No_Elist;
2044 -- A list containing the entities of all constituents processed so far.
2045 -- It aids in detecting illegal usage of a state and a corresponding
2046 -- constituent in pragma [Refinde_]Global.
2047
2048 Seen : Elist_Id := No_Elist;
2049 -- A list containing the entities of all the items processed so far. It
2050 -- plays a role in detecting distinct entities.
2051
2052 States_Seen : Elist_Id := No_Elist;
2053 -- A list containing the entities of all states processed so far. It
2054 -- helps in detecting illegal usage of a state and a corresponding
2055 -- constituent in pragma [Refined_]Global.
2056
2057 In_Out_Seen : Boolean := False;
2058 Input_Seen : Boolean := False;
2059 Output_Seen : Boolean := False;
2060 Proof_Seen : Boolean := False;
2061 -- Flags used to verify the consistency of modes
2062
2063 procedure Analyze_Global_List
2064 (List : Node_Id;
2065 Global_Mode : Name_Id := Name_Input);
2066 -- Verify the legality of a single global list declaration. Global_Mode
2067 -- denotes the current mode in effect.
2068
2069 -------------------------
2070 -- Analyze_Global_List --
2071 -------------------------
2072
2073 procedure Analyze_Global_List
2074 (List : Node_Id;
2075 Global_Mode : Name_Id := Name_Input)
2076 is
2077 procedure Analyze_Global_Item
2078 (Item : Node_Id;
2079 Global_Mode : Name_Id);
2080 -- Verify the legality of a single global item declaration denoted by
2081 -- Item. Global_Mode denotes the current mode in effect.
2082
2083 procedure Check_Duplicate_Mode
2084 (Mode : Node_Id;
2085 Status : in out Boolean);
2086 -- Flag Status denotes whether a particular mode has been seen while
2087 -- processing a global list. This routine verifies that Mode is not a
2088 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2089
2090 procedure Check_Mode_Restriction_In_Enclosing_Context
2091 (Item : Node_Id;
2092 Item_Id : Entity_Id);
2093 -- Verify that an item of mode In_Out or Output does not appear as an
2094 -- input in the Global aspect of an enclosing subprogram. If this is
2095 -- the case, emit an error. Item and Item_Id are respectively the
2096 -- item and its entity.
2097
2098 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2099 -- Mode denotes either In_Out or Output. Depending on the kind of the
2100 -- related subprogram, emit an error if those two modes apply to a
2101 -- function (SPARK RM 6.1.4(10)).
2102
2103 -------------------------
2104 -- Analyze_Global_Item --
2105 -------------------------
2106
2107 procedure Analyze_Global_Item
2108 (Item : Node_Id;
2109 Global_Mode : Name_Id)
2110 is
2111 Item_Id : Entity_Id;
2112
2113 begin
2114 -- Detect one of the following cases
2115
2116 -- with Global => (null, Name)
2117 -- with Global => (Name_1, null, Name_2)
2118 -- with Global => (Name, null)
2119
2120 if Nkind (Item) = N_Null then
2121 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2122 return;
2123 end if;
2124
2125 Analyze (Item);
2126 Resolve_State (Item);
2127
2128 -- Find the entity of the item. If this is a renaming, climb the
2129 -- renaming chain to reach the root object. Renamings of non-
2130 -- entire objects do not yield an entity (Empty).
2131
2132 Item_Id := Entity_Of (Item);
2133
2134 if Present (Item_Id) then
2135
2136 -- A global item may denote a formal parameter of an enclosing
2137 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2138 -- provide a better error diagnostic.
2139
2140 if Is_Formal (Item_Id) then
2141 if Scope (Item_Id) = Spec_Id then
2142 SPARK_Msg_NE
2143 (Fix_Msg (Spec_Id, "global item cannot reference "
2144 & "parameter of subprogram &"), Item, Spec_Id);
2145 return;
2146 end if;
2147
2148 -- A global item may denote a concurrent type as long as it is
2149 -- the current instance of an enclosing protected or task type
2150 -- (SPARK RM 6.1.4).
2151
2152 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2153 if Is_CCT_Instance (Item_Id, Spec_Id) then
2154
2155 -- Pragma [Refined_]Global associated with a protected
2156 -- subprogram cannot mention the current instance of a
2157 -- protected type because the instance behaves as a
2158 -- formal parameter.
2159
2160 if Ekind (Item_Id) = E_Protected_Type then
2161 Error_Msg_Name_1 := Chars (Item_Id);
2162 SPARK_Msg_NE
2163 (Fix_Msg (Spec_Id, "global item of subprogram & "
2164 & "cannot reference current instance of protected "
2165 & "type %"), Item, Spec_Id);
2166 return;
2167
2168 -- Pragma [Refined_]Global associated with a task type
2169 -- cannot mention the current instance of a task type
2170 -- because the instance behaves as a formal parameter.
2171
2172 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2173 Error_Msg_Name_1 := Chars (Item_Id);
2174 SPARK_Msg_NE
2175 (Fix_Msg (Spec_Id, "global item of subprogram & "
2176 & "cannot reference current instance of task type "
2177 & "%"), Item, Spec_Id);
2178 return;
2179 end if;
2180
2181 -- Otherwise the global item denotes a subtype mark that is
2182 -- not a current instance.
2183
2184 else
2185 SPARK_Msg_N
2186 ("invalid use of subtype mark in global list", Item);
2187 return;
2188 end if;
2189
2190 -- A global item may denote the anonymous object created for a
2191 -- single protected/task type as long as the current instance
2192 -- is the same single type (SPARK RM 6.1.4).
2193
2194 elsif Is_Single_Concurrent_Object (Item_Id)
2195 and then Is_CCT_Instance (Item_Id, Spec_Id)
2196 then
2197 -- Pragma [Refined_]Global associated with a protected
2198 -- subprogram cannot mention the current instance of a
2199 -- protected type because the instance behaves as a formal
2200 -- parameter.
2201
2202 if Is_Single_Protected_Object (Item_Id) then
2203 Error_Msg_Name_1 := Chars (Item_Id);
2204 SPARK_Msg_NE
2205 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2206 & "reference current instance of protected type %"),
2207 Item, Spec_Id);
2208 return;
2209
2210 -- Pragma [Refined_]Global associated with a task type
2211 -- cannot mention the current instance of a task type
2212 -- because the instance behaves as a formal parameter.
2213
2214 else pragma Assert (Is_Single_Task_Object (Item_Id));
2215 Error_Msg_Name_1 := Chars (Item_Id);
2216 SPARK_Msg_NE
2217 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2218 & "reference current instance of task type %"),
2219 Item, Spec_Id);
2220 return;
2221 end if;
2222
2223 -- A formal object may act as a global item inside a generic
2224
2225 elsif Is_Formal_Object (Item_Id) then
2226 null;
2227
2228 -- The only legal references are those to abstract states,
2229 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2230
2231 elsif not Ekind_In (Item_Id, E_Abstract_State,
2232 E_Constant,
2233 E_Discriminant,
2234 E_Loop_Parameter,
2235 E_Variable)
2236 then
2237 SPARK_Msg_N
2238 ("global item must denote object, state or current "
2239 & "instance of concurrent type", Item);
2240 return;
2241 end if;
2242
2243 -- State related checks
2244
2245 if Ekind (Item_Id) = E_Abstract_State then
2246
2247 -- Package and subprogram bodies are instantiated
2248 -- individually in a separate compiler pass. Due to this
2249 -- mode of instantiation, the refinement of a state may
2250 -- no longer be visible when a subprogram body contract
2251 -- is instantiated. Since the generic template is legal,
2252 -- do not perform this check in the instance to circumvent
2253 -- this oddity.
2254
2255 if Is_Generic_Instance (Spec_Id) then
2256 null;
2257
2258 -- An abstract state with visible refinement cannot appear
2259 -- in pragma [Refined_]Global as its place must be taken by
2260 -- some of its constituents (SPARK RM 6.1.4(7)).
2261
2262 elsif Has_Visible_Refinement (Item_Id) then
2263 SPARK_Msg_NE
2264 ("cannot mention state & in global refinement",
2265 Item, Item_Id);
2266 SPARK_Msg_N ("\use its constituents instead", Item);
2267 return;
2268
2269 -- An external state cannot appear as a global item of a
2270 -- nonvolatile function (SPARK RM 7.1.3(8)).
2271
2272 elsif Is_External_State (Item_Id)
2273 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2274 and then not Is_Volatile_Function (Spec_Id)
2275 then
2276 SPARK_Msg_NE
2277 ("external state & cannot act as global item of "
2278 & "nonvolatile function", Item, Item_Id);
2279 return;
2280
2281 -- If the reference to the abstract state appears in an
2282 -- enclosing package body that will eventually refine the
2283 -- state, record the reference for future checks.
2284
2285 else
2286 Record_Possible_Body_Reference
2287 (State_Id => Item_Id,
2288 Ref => Item);
2289 end if;
2290
2291 -- Constant related checks
2292
2293 elsif Ekind (Item_Id) = E_Constant then
2294
2295 -- A constant is a read-only item, therefore it cannot act
2296 -- as an output.
2297
2298 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2299 SPARK_Msg_NE
2300 ("constant & cannot act as output", Item, Item_Id);
2301 return;
2302 end if;
2303
2304 -- Discriminant related checks
2305
2306 elsif Ekind (Item_Id) = E_Discriminant then
2307
2308 -- A discriminant is a read-only item, therefore it cannot
2309 -- act as an output.
2310
2311 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2312 SPARK_Msg_NE
2313 ("discriminant & cannot act as output", Item, Item_Id);
2314 return;
2315 end if;
2316
2317 -- Loop parameter related checks
2318
2319 elsif Ekind (Item_Id) = E_Loop_Parameter then
2320
2321 -- A loop parameter is a read-only item, therefore it cannot
2322 -- act as an output.
2323
2324 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2325 SPARK_Msg_NE
2326 ("loop parameter & cannot act as output",
2327 Item, Item_Id);
2328 return;
2329 end if;
2330
2331 -- Variable related checks. These are only relevant when
2332 -- SPARK_Mode is on as they are not standard Ada legality
2333 -- rules.
2334
2335 elsif SPARK_Mode = On
2336 and then Ekind (Item_Id) = E_Variable
2337 and then Is_Effectively_Volatile (Item_Id)
2338 then
2339 -- An effectively volatile object cannot appear as a global
2340 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2341
2342 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2343 and then not Is_Volatile_Function (Spec_Id)
2344 then
2345 Error_Msg_NE
2346 ("volatile object & cannot act as global item of a "
2347 & "function", Item, Item_Id);
2348 return;
2349
2350 -- An effectively volatile object with external property
2351 -- Effective_Reads set to True must have mode Output or
2352 -- In_Out (SPARK RM 7.1.3(10)).
2353
2354 elsif Effective_Reads_Enabled (Item_Id)
2355 and then Global_Mode = Name_Input
2356 then
2357 Error_Msg_NE
2358 ("volatile object & with property Effective_Reads must "
2359 & "have mode In_Out or Output", Item, Item_Id);
2360 return;
2361 end if;
2362 end if;
2363
2364 -- When the item renames an entire object, replace the item
2365 -- with a reference to the object.
2366
2367 if Entity (Item) /= Item_Id then
2368 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2369 Analyze (Item);
2370 end if;
2371
2372 -- Some form of illegal construct masquerading as a name
2373 -- (SPARK RM 6.1.4(4)).
2374
2375 else
2376 Error_Msg_N
2377 ("global item must denote object, state or current instance "
2378 & "of concurrent type", Item);
2379 return;
2380 end if;
2381
2382 -- Verify that an output does not appear as an input in an
2383 -- enclosing subprogram.
2384
2385 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2386 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2387 end if;
2388
2389 -- The same entity might be referenced through various way.
2390 -- Check the entity of the item rather than the item itself
2391 -- (SPARK RM 6.1.4(10)).
2392
2393 if Contains (Seen, Item_Id) then
2394 SPARK_Msg_N ("duplicate global item", Item);
2395
2396 -- Add the entity of the current item to the list of processed
2397 -- items.
2398
2399 else
2400 Append_New_Elmt (Item_Id, Seen);
2401
2402 if Ekind (Item_Id) = E_Abstract_State then
2403 Append_New_Elmt (Item_Id, States_Seen);
2404
2405 -- The variable may eventually become a constituent of a single
2406 -- protected/task type. Record the reference now and verify its
2407 -- legality when analyzing the contract of the variable
2408 -- (SPARK RM 9.3).
2409
2410 elsif Ekind (Item_Id) = E_Variable then
2411 Record_Possible_Part_Of_Reference
2412 (Var_Id => Item_Id,
2413 Ref => Item);
2414 end if;
2415
2416 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2417 and then Present (Encapsulating_State (Item_Id))
2418 then
2419 Append_New_Elmt (Item_Id, Constits_Seen);
2420 end if;
2421 end if;
2422 end Analyze_Global_Item;
2423
2424 --------------------------
2425 -- Check_Duplicate_Mode --
2426 --------------------------
2427
2428 procedure Check_Duplicate_Mode
2429 (Mode : Node_Id;
2430 Status : in out Boolean)
2431 is
2432 begin
2433 if Status then
2434 SPARK_Msg_N ("duplicate global mode", Mode);
2435 end if;
2436
2437 Status := True;
2438 end Check_Duplicate_Mode;
2439
2440 -------------------------------------------------
2441 -- Check_Mode_Restriction_In_Enclosing_Context --
2442 -------------------------------------------------
2443
2444 procedure Check_Mode_Restriction_In_Enclosing_Context
2445 (Item : Node_Id;
2446 Item_Id : Entity_Id)
2447 is
2448 Context : Entity_Id;
2449 Dummy : Boolean;
2450 Inputs : Elist_Id := No_Elist;
2451 Outputs : Elist_Id := No_Elist;
2452
2453 begin
2454 -- Traverse the scope stack looking for enclosing subprograms
2455 -- subject to pragma [Refined_]Global.
2456
2457 Context := Scope (Subp_Id);
2458 while Present (Context) and then Context /= Standard_Standard loop
2459 if Is_Subprogram (Context)
2460 and then
2461 (Present (Get_Pragma (Context, Pragma_Global))
2462 or else
2463 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2464 then
2465 Collect_Subprogram_Inputs_Outputs
2466 (Subp_Id => Context,
2467 Subp_Inputs => Inputs,
2468 Subp_Outputs => Outputs,
2469 Global_Seen => Dummy);
2470
2471 -- The item is classified as In_Out or Output but appears as
2472 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2473
2474 if Appears_In (Inputs, Item_Id)
2475 and then not Appears_In (Outputs, Item_Id)
2476 then
2477 SPARK_Msg_NE
2478 ("global item & cannot have mode In_Out or Output",
2479 Item, Item_Id);
2480
2481 SPARK_Msg_NE
2482 (Fix_Msg (Subp_Id, "\item already appears as input of "
2483 & "subprogram &"), Item, Context);
2484
2485 -- Stop the traversal once an error has been detected
2486
2487 exit;
2488 end if;
2489 end if;
2490
2491 Context := Scope (Context);
2492 end loop;
2493 end Check_Mode_Restriction_In_Enclosing_Context;
2494
2495 ----------------------------------------
2496 -- Check_Mode_Restriction_In_Function --
2497 ----------------------------------------
2498
2499 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2500 begin
2501 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2502 SPARK_Msg_N
2503 ("global mode & is not applicable to functions", Mode);
2504 end if;
2505 end Check_Mode_Restriction_In_Function;
2506
2507 -- Local variables
2508
2509 Assoc : Node_Id;
2510 Item : Node_Id;
2511 Mode : Node_Id;
2512
2513 -- Start of processing for Analyze_Global_List
2514
2515 begin
2516 if Nkind (List) = N_Null then
2517 Set_Analyzed (List);
2518
2519 -- Single global item declaration
2520
2521 elsif Nkind_In (List, N_Expanded_Name,
2522 N_Identifier,
2523 N_Selected_Component)
2524 then
2525 Analyze_Global_Item (List, Global_Mode);
2526
2527 -- Simple global list or moded global list declaration
2528
2529 elsif Nkind (List) = N_Aggregate then
2530 Set_Analyzed (List);
2531
2532 -- The declaration of a simple global list appear as a collection
2533 -- of expressions.
2534
2535 if Present (Expressions (List)) then
2536 if Present (Component_Associations (List)) then
2537 SPARK_Msg_N
2538 ("cannot mix moded and non-moded global lists", List);
2539 end if;
2540
2541 Item := First (Expressions (List));
2542 while Present (Item) loop
2543 Analyze_Global_Item (Item, Global_Mode);
2544 Next (Item);
2545 end loop;
2546
2547 -- The declaration of a moded global list appears as a collection
2548 -- of component associations where individual choices denote
2549 -- modes.
2550
2551 elsif Present (Component_Associations (List)) then
2552 if Present (Expressions (List)) then
2553 SPARK_Msg_N
2554 ("cannot mix moded and non-moded global lists", List);
2555 end if;
2556
2557 Assoc := First (Component_Associations (List));
2558 while Present (Assoc) loop
2559 Mode := First (Choices (Assoc));
2560
2561 if Nkind (Mode) = N_Identifier then
2562 if Chars (Mode) = Name_In_Out then
2563 Check_Duplicate_Mode (Mode, In_Out_Seen);
2564 Check_Mode_Restriction_In_Function (Mode);
2565
2566 elsif Chars (Mode) = Name_Input then
2567 Check_Duplicate_Mode (Mode, Input_Seen);
2568
2569 elsif Chars (Mode) = Name_Output then
2570 Check_Duplicate_Mode (Mode, Output_Seen);
2571 Check_Mode_Restriction_In_Function (Mode);
2572
2573 elsif Chars (Mode) = Name_Proof_In then
2574 Check_Duplicate_Mode (Mode, Proof_Seen);
2575
2576 else
2577 SPARK_Msg_N ("invalid mode selector", Mode);
2578 end if;
2579
2580 else
2581 SPARK_Msg_N ("invalid mode selector", Mode);
2582 end if;
2583
2584 -- Items in a moded list appear as a collection of
2585 -- expressions. Reuse the existing machinery to analyze
2586 -- them.
2587
2588 Analyze_Global_List
2589 (List => Expression (Assoc),
2590 Global_Mode => Chars (Mode));
2591
2592 Next (Assoc);
2593 end loop;
2594
2595 -- Invalid tree
2596
2597 else
2598 raise Program_Error;
2599 end if;
2600
2601 -- Any other attempt to declare a global item is illegal. This is a
2602 -- syntax error, always report.
2603
2604 else
2605 Error_Msg_N ("malformed global list", List);
2606 end if;
2607 end Analyze_Global_List;
2608
2609 -- Local variables
2610
2611 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2612
2613 Restore_Scope : Boolean := False;
2614
2615 -- Start of processing for Analyze_Global_In_Decl_Part
2616
2617 begin
2618 -- Do not analyze the pragma multiple times
2619
2620 if Is_Analyzed_Pragma (N) then
2621 return;
2622 end if;
2623
2624 -- There is nothing to be done for a null global list
2625
2626 if Nkind (Items) = N_Null then
2627 Set_Analyzed (Items);
2628
2629 -- Analyze the various forms of global lists and items. Note that some
2630 -- of these may be malformed in which case the analysis emits error
2631 -- messages.
2632
2633 else
2634 -- When pragma [Refined_]Global appears on a single concurrent type,
2635 -- it is relocated to the anonymous object.
2636
2637 if Is_Single_Concurrent_Object (Spec_Id) then
2638 null;
2639
2640 -- Ensure that the formal parameters are visible when processing an
2641 -- item. This falls out of the general rule of aspects pertaining to
2642 -- subprogram declarations.
2643
2644 elsif not In_Open_Scopes (Spec_Id) then
2645 Restore_Scope := True;
2646 Push_Scope (Spec_Id);
2647
2648 if Ekind (Spec_Id) = E_Task_Type then
2649 if Has_Discriminants (Spec_Id) then
2650 Install_Discriminants (Spec_Id);
2651 end if;
2652
2653 elsif Is_Generic_Subprogram (Spec_Id) then
2654 Install_Generic_Formals (Spec_Id);
2655
2656 else
2657 Install_Formals (Spec_Id);
2658 end if;
2659 end if;
2660
2661 Analyze_Global_List (Items);
2662
2663 if Restore_Scope then
2664 End_Scope;
2665 end if;
2666 end if;
2667
2668 -- Ensure that a state and a corresponding constituent do not appear
2669 -- together in pragma [Refined_]Global.
2670
2671 Check_State_And_Constituent_Use
2672 (States => States_Seen,
2673 Constits => Constits_Seen,
2674 Context => N);
2675
2676 Set_Is_Analyzed_Pragma (N);
2677 end Analyze_Global_In_Decl_Part;
2678
2679 --------------------------------------------
2680 -- Analyze_Initial_Condition_In_Decl_Part --
2681 --------------------------------------------
2682
2683 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2684 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2685 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2686 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2687
2688 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
2689
2690 begin
2691 -- Do not analyze the pragma multiple times
2692
2693 if Is_Analyzed_Pragma (N) then
2694 return;
2695 end if;
2696
2697 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2698 -- analysis of the pragma, the Ghost mode at point of declaration and
2699 -- point of analysis may not necessarily be the same. Use the mode in
2700 -- effect at the point of declaration.
2701
2702 Set_Ghost_Mode (N);
2703
2704 -- The expression is preanalyzed because it has not been moved to its
2705 -- final place yet. A direct analysis may generate side effects and this
2706 -- is not desired at this point.
2707
2708 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2709 Ghost_Mode := Save_Ghost_Mode;
2710
2711 Set_Is_Analyzed_Pragma (N);
2712 end Analyze_Initial_Condition_In_Decl_Part;
2713
2714 --------------------------------------
2715 -- Analyze_Initializes_In_Decl_Part --
2716 --------------------------------------
2717
2718 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2719 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2720 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2721
2722 Constits_Seen : Elist_Id := No_Elist;
2723 -- A list containing the entities of all constituents processed so far.
2724 -- It aids in detecting illegal usage of a state and a corresponding
2725 -- constituent in pragma Initializes.
2726
2727 Items_Seen : Elist_Id := No_Elist;
2728 -- A list of all initialization items processed so far. This list is
2729 -- used to detect duplicate items.
2730
2731 Non_Null_Seen : Boolean := False;
2732 Null_Seen : Boolean := False;
2733 -- Flags used to check the legality of a null initialization list
2734
2735 States_And_Objs : Elist_Id := No_Elist;
2736 -- A list of all abstract states and objects declared in the visible
2737 -- declarations of the related package. This list is used to detect the
2738 -- legality of initialization items.
2739
2740 States_Seen : Elist_Id := No_Elist;
2741 -- A list containing the entities of all states processed so far. It
2742 -- helps in detecting illegal usage of a state and a corresponding
2743 -- constituent in pragma Initializes.
2744
2745 procedure Analyze_Initialization_Item (Item : Node_Id);
2746 -- Verify the legality of a single initialization item
2747
2748 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2749 -- Verify the legality of a single initialization item followed by a
2750 -- list of input items.
2751
2752 procedure Collect_States_And_Objects;
2753 -- Inspect the visible declarations of the related package and gather
2754 -- the entities of all abstract states and objects in States_And_Objs.
2755
2756 ---------------------------------
2757 -- Analyze_Initialization_Item --
2758 ---------------------------------
2759
2760 procedure Analyze_Initialization_Item (Item : Node_Id) is
2761 Item_Id : Entity_Id;
2762
2763 begin
2764 -- Null initialization list
2765
2766 if Nkind (Item) = N_Null then
2767 if Null_Seen then
2768 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2769
2770 elsif Non_Null_Seen then
2771 SPARK_Msg_N
2772 ("cannot mix null and non-null initialization items", Item);
2773 else
2774 Null_Seen := True;
2775 end if;
2776
2777 -- Initialization item
2778
2779 else
2780 Non_Null_Seen := True;
2781
2782 if Null_Seen then
2783 SPARK_Msg_N
2784 ("cannot mix null and non-null initialization items", Item);
2785 end if;
2786
2787 Analyze (Item);
2788 Resolve_State (Item);
2789
2790 if Is_Entity_Name (Item) then
2791 Item_Id := Entity_Of (Item);
2792
2793 if Ekind_In (Item_Id, E_Abstract_State,
2794 E_Constant,
2795 E_Variable)
2796 then
2797 -- The state or variable must be declared in the visible
2798 -- declarations of the package (SPARK RM 7.1.5(7)).
2799
2800 if not Contains (States_And_Objs, Item_Id) then
2801 Error_Msg_Name_1 := Chars (Pack_Id);
2802 SPARK_Msg_NE
2803 ("initialization item & must appear in the visible "
2804 & "declarations of package %", Item, Item_Id);
2805
2806 -- Detect a duplicate use of the same initialization item
2807 -- (SPARK RM 7.1.5(5)).
2808
2809 elsif Contains (Items_Seen, Item_Id) then
2810 SPARK_Msg_N ("duplicate initialization item", Item);
2811
2812 -- The item is legal, add it to the list of processed states
2813 -- and variables.
2814
2815 else
2816 Append_New_Elmt (Item_Id, Items_Seen);
2817
2818 if Ekind (Item_Id) = E_Abstract_State then
2819 Append_New_Elmt (Item_Id, States_Seen);
2820 end if;
2821
2822 if Present (Encapsulating_State (Item_Id)) then
2823 Append_New_Elmt (Item_Id, Constits_Seen);
2824 end if;
2825 end if;
2826
2827 -- The item references something that is not a state or object
2828 -- (SPARK RM 7.1.5(3)).
2829
2830 else
2831 SPARK_Msg_N
2832 ("initialization item must denote object or state", Item);
2833 end if;
2834
2835 -- Some form of illegal construct masquerading as a name
2836 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2837
2838 else
2839 Error_Msg_N
2840 ("initialization item must denote object or state", Item);
2841 end if;
2842 end if;
2843 end Analyze_Initialization_Item;
2844
2845 ---------------------------------------------
2846 -- Analyze_Initialization_Item_With_Inputs --
2847 ---------------------------------------------
2848
2849 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2850 Inputs_Seen : Elist_Id := No_Elist;
2851 -- A list of all inputs processed so far. This list is used to detect
2852 -- duplicate uses of an input.
2853
2854 Non_Null_Seen : Boolean := False;
2855 Null_Seen : Boolean := False;
2856 -- Flags used to check the legality of an input list
2857
2858 procedure Analyze_Input_Item (Input : Node_Id);
2859 -- Verify the legality of a single input item
2860
2861 ------------------------
2862 -- Analyze_Input_Item --
2863 ------------------------
2864
2865 procedure Analyze_Input_Item (Input : Node_Id) is
2866 Input_Id : Entity_Id;
2867 Input_OK : Boolean := True;
2868
2869 begin
2870 -- Null input list
2871
2872 if Nkind (Input) = N_Null then
2873 if Null_Seen then
2874 SPARK_Msg_N
2875 ("multiple null initializations not allowed", Item);
2876
2877 elsif Non_Null_Seen then
2878 SPARK_Msg_N
2879 ("cannot mix null and non-null initialization item", Item);
2880 else
2881 Null_Seen := True;
2882 end if;
2883
2884 -- Input item
2885
2886 else
2887 Non_Null_Seen := True;
2888
2889 if Null_Seen then
2890 SPARK_Msg_N
2891 ("cannot mix null and non-null initialization item", Item);
2892 end if;
2893
2894 Analyze (Input);
2895 Resolve_State (Input);
2896
2897 if Is_Entity_Name (Input) then
2898 Input_Id := Entity_Of (Input);
2899
2900 if Ekind_In (Input_Id, E_Abstract_State,
2901 E_Constant,
2902 E_Generic_In_Out_Parameter,
2903 E_Generic_In_Parameter,
2904 E_In_Parameter,
2905 E_In_Out_Parameter,
2906 E_Out_Parameter,
2907 E_Variable)
2908 then
2909 -- The input cannot denote states or objects declared
2910 -- within the related package (SPARK RM 7.1.5(4)).
2911
2912 if Within_Scope (Input_Id, Current_Scope) then
2913
2914 -- Do not consider generic formal parameters or their
2915 -- respective mappings to generic formals. Even though
2916 -- the formals appear within the scope of the package,
2917 -- it is allowed for an initialization item to depend
2918 -- on an input item.
2919
2920 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2921 E_Generic_In_Parameter)
2922 then
2923 null;
2924
2925 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2926 and then Present (Corresponding_Generic_Association
2927 (Declaration_Node (Input_Id)))
2928 then
2929 null;
2930
2931 else
2932 Input_OK := False;
2933 Error_Msg_Name_1 := Chars (Pack_Id);
2934 SPARK_Msg_NE
2935 ("input item & cannot denote a visible object or "
2936 & "state of package %", Input, Input_Id);
2937 end if;
2938 end if;
2939
2940 -- Detect a duplicate use of the same input item
2941 -- (SPARK RM 7.1.5(5)).
2942
2943 if Contains (Inputs_Seen, Input_Id) then
2944 Input_OK := False;
2945 SPARK_Msg_N ("duplicate input item", Input);
2946 end if;
2947
2948 -- Input is legal, add it to the list of processed inputs
2949
2950 if Input_OK then
2951 Append_New_Elmt (Input_Id, Inputs_Seen);
2952
2953 if Ekind (Input_Id) = E_Abstract_State then
2954 Append_New_Elmt (Input_Id, States_Seen);
2955 end if;
2956
2957 if Ekind_In (Input_Id, E_Abstract_State,
2958 E_Constant,
2959 E_Variable)
2960 and then Present (Encapsulating_State (Input_Id))
2961 then
2962 Append_New_Elmt (Input_Id, Constits_Seen);
2963 end if;
2964 end if;
2965
2966 -- The input references something that is not a state or an
2967 -- object (SPARK RM 7.1.5(3)).
2968
2969 else
2970 SPARK_Msg_N
2971 ("input item must denote object or state", Input);
2972 end if;
2973
2974 -- Some form of illegal construct masquerading as a name
2975 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2976
2977 else
2978 Error_Msg_N
2979 ("input item must denote object or state", Input);
2980 end if;
2981 end if;
2982 end Analyze_Input_Item;
2983
2984 -- Local variables
2985
2986 Inputs : constant Node_Id := Expression (Item);
2987 Elmt : Node_Id;
2988 Input : Node_Id;
2989
2990 Name_Seen : Boolean := False;
2991 -- A flag used to detect multiple item names
2992
2993 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2994
2995 begin
2996 -- Inspect the name of an item with inputs
2997
2998 Elmt := First (Choices (Item));
2999 while Present (Elmt) loop
3000 if Name_Seen then
3001 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3002 else
3003 Name_Seen := True;
3004 Analyze_Initialization_Item (Elmt);
3005 end if;
3006
3007 Next (Elmt);
3008 end loop;
3009
3010 -- Multiple input items appear as an aggregate
3011
3012 if Nkind (Inputs) = N_Aggregate then
3013 if Present (Expressions (Inputs)) then
3014 Input := First (Expressions (Inputs));
3015 while Present (Input) loop
3016 Analyze_Input_Item (Input);
3017 Next (Input);
3018 end loop;
3019 end if;
3020
3021 if Present (Component_Associations (Inputs)) then
3022 SPARK_Msg_N
3023 ("inputs must appear in named association form", Inputs);
3024 end if;
3025
3026 -- Single input item
3027
3028 else
3029 Analyze_Input_Item (Inputs);
3030 end if;
3031 end Analyze_Initialization_Item_With_Inputs;
3032
3033 --------------------------------
3034 -- Collect_States_And_Objects --
3035 --------------------------------
3036
3037 procedure Collect_States_And_Objects is
3038 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3039 Decl : Node_Id;
3040
3041 begin
3042 -- Collect the abstract states defined in the package (if any)
3043
3044 if Present (Abstract_States (Pack_Id)) then
3045 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3046 end if;
3047
3048 -- Collect all objects the appear in the visible declarations of the
3049 -- related package.
3050
3051 if Present (Visible_Declarations (Pack_Spec)) then
3052 Decl := First (Visible_Declarations (Pack_Spec));
3053 while Present (Decl) loop
3054 if Comes_From_Source (Decl)
3055 and then Nkind (Decl) = N_Object_Declaration
3056 then
3057 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3058 end if;
3059
3060 Next (Decl);
3061 end loop;
3062 end if;
3063 end Collect_States_And_Objects;
3064
3065 -- Local variables
3066
3067 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3068 Init : Node_Id;
3069
3070 -- Start of processing for Analyze_Initializes_In_Decl_Part
3071
3072 begin
3073 -- Do not analyze the pragma multiple times
3074
3075 if Is_Analyzed_Pragma (N) then
3076 return;
3077 end if;
3078
3079 -- Nothing to do when the initialization list is empty
3080
3081 if Nkind (Inits) = N_Null then
3082 return;
3083 end if;
3084
3085 -- Single and multiple initialization clauses appear as an aggregate. If
3086 -- this is not the case, then either the parser or the analysis of the
3087 -- pragma failed to produce an aggregate.
3088
3089 pragma Assert (Nkind (Inits) = N_Aggregate);
3090
3091 -- Initialize the various lists used during analysis
3092
3093 Collect_States_And_Objects;
3094
3095 if Present (Expressions (Inits)) then
3096 Init := First (Expressions (Inits));
3097 while Present (Init) loop
3098 Analyze_Initialization_Item (Init);
3099 Next (Init);
3100 end loop;
3101 end if;
3102
3103 if Present (Component_Associations (Inits)) then
3104 Init := First (Component_Associations (Inits));
3105 while Present (Init) loop
3106 Analyze_Initialization_Item_With_Inputs (Init);
3107 Next (Init);
3108 end loop;
3109 end if;
3110
3111 -- Ensure that a state and a corresponding constituent do not appear
3112 -- together in pragma Initializes.
3113
3114 Check_State_And_Constituent_Use
3115 (States => States_Seen,
3116 Constits => Constits_Seen,
3117 Context => N);
3118
3119 Set_Is_Analyzed_Pragma (N);
3120 end Analyze_Initializes_In_Decl_Part;
3121
3122 ---------------------
3123 -- Analyze_Part_Of --
3124 ---------------------
3125
3126 procedure Analyze_Part_Of
3127 (Indic : Node_Id;
3128 Item_Id : Entity_Id;
3129 Encap : Node_Id;
3130 Encap_Id : out Entity_Id;
3131 Legal : out Boolean)
3132 is
3133 Encap_Typ : Entity_Id;
3134 Item_Decl : Node_Id;
3135 Pack_Id : Entity_Id;
3136 Placement : State_Space_Kind;
3137 Parent_Unit : Entity_Id;
3138
3139 begin
3140 -- Assume that the indicator is illegal
3141
3142 Encap_Id := Empty;
3143 Legal := False;
3144
3145 if Nkind_In (Encap, N_Expanded_Name,
3146 N_Identifier,
3147 N_Selected_Component)
3148 then
3149 Analyze (Encap);
3150 Resolve_State (Encap);
3151
3152 Encap_Id := Entity (Encap);
3153
3154 -- The encapsulator is an abstract state
3155
3156 if Ekind (Encap_Id) = E_Abstract_State then
3157 null;
3158
3159 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3160
3161 elsif Is_Single_Concurrent_Object (Encap_Id) then
3162 null;
3163
3164 -- Otherwise the encapsulator is not a legal choice
3165
3166 else
3167 SPARK_Msg_N
3168 ("indicator Part_Of must denote abstract state, single "
3169 & "protected type or single task type", Encap);
3170 return;
3171 end if;
3172
3173 -- This is a syntax error, always report
3174
3175 else
3176 Error_Msg_N
3177 ("indicator Part_Of must denote abstract state, single protected "
3178 & "type or single task type", Encap);
3179 return;
3180 end if;
3181
3182 -- Catch a case where indicator Part_Of denotes the abstract view of a
3183 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3184
3185 if From_Limited_With (Encap_Id)
3186 and then Present (Non_Limited_View (Encap_Id))
3187 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3188 then
3189 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3190 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3191 return;
3192 end if;
3193
3194 -- The encapsulator is an abstract state
3195
3196 if Ekind (Encap_Id) = E_Abstract_State then
3197
3198 -- Determine where the object, package instantiation or state lives
3199 -- with respect to the enclosing packages or package bodies.
3200
3201 Find_Placement_In_State_Space
3202 (Item_Id => Item_Id,
3203 Placement => Placement,
3204 Pack_Id => Pack_Id);
3205
3206 -- The item appears in a non-package construct with a declarative
3207 -- part (subprogram, block, etc). As such, the item is not allowed
3208 -- to be a part of an encapsulating state because the item is not
3209 -- visible.
3210
3211 if Placement = Not_In_Package then
3212 SPARK_Msg_N
3213 ("indicator Part_Of cannot appear in this context "
3214 & "(SPARK RM 7.2.6(5))", Indic);
3215 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3216 SPARK_Msg_NE
3217 ("\& is not part of the hidden state of package %",
3218 Indic, Item_Id);
3219
3220 -- The item appears in the visible state space of some package. In
3221 -- general this scenario does not warrant Part_Of except when the
3222 -- package is a private child unit and the encapsulating state is
3223 -- declared in a parent unit or a public descendant of that parent
3224 -- unit.
3225
3226 elsif Placement = Visible_State_Space then
3227 if Is_Child_Unit (Pack_Id)
3228 and then Is_Private_Descendant (Pack_Id)
3229 then
3230 -- A variable or state abstraction which is part of the visible
3231 -- state of a private child unit (or one of its public
3232 -- descendants) must have its Part_Of indicator specified. The
3233 -- Part_Of indicator must denote a state abstraction declared
3234 -- by either the parent unit of the private unit or by a public
3235 -- descendant of that parent unit.
3236
3237 -- Find nearest private ancestor (which can be the current unit
3238 -- itself).
3239
3240 Parent_Unit := Pack_Id;
3241 while Present (Parent_Unit) loop
3242 exit when
3243 Private_Present
3244 (Parent (Unit_Declaration_Node (Parent_Unit)));
3245 Parent_Unit := Scope (Parent_Unit);
3246 end loop;
3247
3248 Parent_Unit := Scope (Parent_Unit);
3249
3250 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3251 SPARK_Msg_NE
3252 ("indicator Part_Of must denote abstract state or public "
3253 & "descendant of & (SPARK RM 7.2.6(3))",
3254 Indic, Parent_Unit);
3255
3256 elsif Scope (Encap_Id) = Parent_Unit
3257 or else
3258 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3259 and then not Is_Private_Descendant (Scope (Encap_Id)))
3260 then
3261 null;
3262
3263 else
3264 SPARK_Msg_NE
3265 ("indicator Part_Of must denote abstract state or public "
3266 & "descendant of & (SPARK RM 7.2.6(3))",
3267 Indic, Parent_Unit);
3268 end if;
3269
3270 -- Indicator Part_Of is not needed when the related package is not
3271 -- a private child unit or a public descendant thereof.
3272
3273 else
3274 SPARK_Msg_N
3275 ("indicator Part_Of cannot appear in this context "
3276 & "(SPARK RM 7.2.6(5))", Indic);
3277 Error_Msg_Name_1 := Chars (Pack_Id);
3278 SPARK_Msg_NE
3279 ("\& is declared in the visible part of package %",
3280 Indic, Item_Id);
3281 end if;
3282
3283 -- When the item appears in the private state space of a package, the
3284 -- encapsulating state must be declared in the same package.
3285
3286 elsif Placement = Private_State_Space then
3287 if Scope (Encap_Id) /= Pack_Id then
3288 SPARK_Msg_NE
3289 ("indicator Part_Of must designate an abstract state of "
3290 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3291 Error_Msg_Name_1 := Chars (Pack_Id);
3292 SPARK_Msg_NE
3293 ("\& is declared in the private part of package %",
3294 Indic, Item_Id);
3295 end if;
3296
3297 -- Items declared in the body state space of a package do not need
3298 -- Part_Of indicators as the refinement has already been seen.
3299
3300 else
3301 SPARK_Msg_N
3302 ("indicator Part_Of cannot appear in this context "
3303 & "(SPARK RM 7.2.6(5))", Indic);
3304
3305 if Scope (Encap_Id) = Pack_Id then
3306 Error_Msg_Name_1 := Chars (Pack_Id);
3307 SPARK_Msg_NE
3308 ("\& is declared in the body of package %", Indic, Item_Id);
3309 end if;
3310 end if;
3311
3312 -- The encapsulator is a single concurrent type
3313
3314 else
3315 Encap_Typ := Etype (Encap_Id);
3316
3317 -- Only abstract states and variables can act as constituents of an
3318 -- encapsulating single concurrent type.
3319
3320 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3321 null;
3322
3323 -- The constituent is a constant
3324
3325 elsif Ekind (Item_Id) = E_Constant then
3326 Error_Msg_Name_1 := Chars (Encap_Id);
3327 SPARK_Msg_NE
3328 (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of "
3329 & "single protected type %"), Indic, Item_Id);
3330
3331 -- The constituent is a package instantiation
3332
3333 else
3334 Error_Msg_Name_1 := Chars (Encap_Id);
3335 SPARK_Msg_NE
3336 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3337 & "constituent of single protected type %"), Indic, Item_Id);
3338 end if;
3339
3340 -- When the item denotes an abstract state of a nested package, use
3341 -- the declaration of the package to detect proper placement.
3342
3343 -- package Pack is
3344 -- task T;
3345 -- package Nested
3346 -- with Abstract_State => (State with Part_Of => T)
3347
3348 if Ekind (Item_Id) = E_Abstract_State then
3349 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3350 else
3351 Item_Decl := Declaration_Node (Item_Id);
3352 end if;
3353
3354 -- Both the item and its encapsulating single concurrent type must
3355 -- appear in the same declarative region (SPARK RM 9.3). Note that
3356 -- privacy is ignored.
3357
3358 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3359 Error_Msg_Name_1 := Chars (Encap_Id);
3360 SPARK_Msg_NE
3361 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3362 & "immediately within the same region as single protected "
3363 & "type %"), Indic, Item_Id);
3364 end if;
3365 end if;
3366
3367 Legal := True;
3368 end Analyze_Part_Of;
3369
3370 ----------------------------------
3371 -- Analyze_Part_Of_In_Decl_Part --
3372 ----------------------------------
3373
3374 procedure Analyze_Part_Of_In_Decl_Part
3375 (N : Node_Id;
3376 Freeze_Id : Entity_Id := Empty)
3377 is
3378 Encap : constant Node_Id :=
3379 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3380 Errors : constant Nat := Serious_Errors_Detected;
3381 Var_Decl : constant Node_Id := Find_Related_Context (N);
3382 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3383 Constits : Elist_Id;
3384 Encap_Id : Entity_Id;
3385 Legal : Boolean;
3386
3387 begin
3388 -- Detect any discrepancies between the placement of the variable with
3389 -- respect to general state space and the encapsulating state or single
3390 -- concurrent type.
3391
3392 Analyze_Part_Of
3393 (Indic => N,
3394 Item_Id => Var_Id,
3395 Encap => Encap,
3396 Encap_Id => Encap_Id,
3397 Legal => Legal);
3398
3399 -- The Part_Of indicator turns the variable into a constituent of the
3400 -- encapsulating state or single concurrent type.
3401
3402 if Legal then
3403 pragma Assert (Present (Encap_Id));
3404 Constits := Part_Of_Constituents (Encap_Id);
3405
3406 if No (Constits) then
3407 Constits := New_Elmt_List;
3408 Set_Part_Of_Constituents (Encap_Id, Constits);
3409 end if;
3410
3411 Append_Elmt (Var_Id, Constits);
3412 Set_Encapsulating_State (Var_Id, Encap_Id);
3413 end if;
3414
3415 -- Emit a clarification message when the encapsulator is undefined,
3416 -- possibly due to contract "freezing".
3417
3418 if Errors /= Serious_Errors_Detected
3419 and then Present (Freeze_Id)
3420 and then Has_Undefined_Reference (Encap)
3421 then
3422 Contract_Freeze_Error (Var_Id, Freeze_Id);
3423 end if;
3424 end Analyze_Part_Of_In_Decl_Part;
3425
3426 --------------------
3427 -- Analyze_Pragma --
3428 --------------------
3429
3430 procedure Analyze_Pragma (N : Node_Id) is
3431 Loc : constant Source_Ptr := Sloc (N);
3432 Prag_Id : Pragma_Id;
3433
3434 Pname : Name_Id;
3435 -- Name of the source pragma, or name of the corresponding aspect for
3436 -- pragmas which originate in a source aspect. In the latter case, the
3437 -- name may be different from the pragma name.
3438
3439 Pragma_Exit : exception;
3440 -- This exception is used to exit pragma processing completely. It
3441 -- is used when an error is detected, and no further processing is
3442 -- required. It is also used if an earlier error has left the tree in
3443 -- a state where the pragma should not be processed.
3444
3445 Arg_Count : Nat;
3446 -- Number of pragma argument associations
3447
3448 Arg1 : Node_Id;
3449 Arg2 : Node_Id;
3450 Arg3 : Node_Id;
3451 Arg4 : Node_Id;
3452 -- First four pragma arguments (pragma argument association nodes, or
3453 -- Empty if the corresponding argument does not exist).
3454
3455 type Name_List is array (Natural range <>) of Name_Id;
3456 type Args_List is array (Natural range <>) of Node_Id;
3457 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3458
3459 -----------------------
3460 -- Local Subprograms --
3461 -----------------------
3462
3463 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3464 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3465 -- get the given string argument, and place it in Name_Buffer, adding
3466 -- leading and trailing asterisks if they are not already present. The
3467 -- caller has already checked that Arg is a static string expression.
3468
3469 procedure Ada_2005_Pragma;
3470 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3471 -- Ada 95 mode, these are implementation defined pragmas, so should be
3472 -- caught by the No_Implementation_Pragmas restriction.
3473
3474 procedure Ada_2012_Pragma;
3475 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3476 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3477 -- should be caught by the No_Implementation_Pragmas restriction.
3478
3479 procedure Analyze_Depends_Global
3480 (Spec_Id : out Entity_Id;
3481 Subp_Decl : out Node_Id;
3482 Legal : out Boolean);
3483 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3484 -- legality of the placement and related context of the pragma. Spec_Id
3485 -- is the entity of the related subprogram. Subp_Decl is the declaration
3486 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3487
3488 procedure Analyze_If_Present (Id : Pragma_Id);
3489 -- Inspect the remainder of the list containing pragma N and look for
3490 -- a pragma that matches Id. If found, analyze the pragma.
3491
3492 procedure Analyze_Pre_Post_Condition;
3493 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3494
3495 procedure Analyze_Refined_Depends_Global_Post
3496 (Spec_Id : out Entity_Id;
3497 Body_Id : out Entity_Id;
3498 Legal : out Boolean);
3499 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3500 -- Refined_Global and Refined_Post. Verify the legality of the placement
3501 -- and related context of the pragma. Spec_Id is the entity of the
3502 -- related subprogram. Body_Id is the entity of the subprogram body.
3503 -- Flag Legal is set when the pragma is legal.
3504
3505 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3506 -- Perform full analysis of pragma Unmodified and the write aspect of
3507 -- pragma Unused. Flag Is_Unused should be set when verifying the
3508 -- semantics of pragma Unused.
3509
3510 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3511 -- Perform full analysis of pragma Unreferenced and the read aspect of
3512 -- pragma Unused. Flag Is_Unused should be set when verifying the
3513 -- semantics of pragma Unused.
3514
3515 procedure Check_Ada_83_Warning;
3516 -- Issues a warning message for the current pragma if operating in Ada
3517 -- 83 mode (used for language pragmas that are not a standard part of
3518 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3519 -- of 95 pragma.
3520
3521 procedure Check_Arg_Count (Required : Nat);
3522 -- Check argument count for pragma is equal to given parameter. If not,
3523 -- then issue an error message and raise Pragma_Exit.
3524
3525 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3526 -- Arg which can either be a pragma argument association, in which case
3527 -- the check is applied to the expression of the association or an
3528 -- expression directly.
3529
3530 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3531 -- Check that an argument has the right form for an EXTERNAL_NAME
3532 -- parameter of an extended import/export pragma. The rule is that the
3533 -- name must be an identifier or string literal (in Ada 83 mode) or a
3534 -- static string expression (in Ada 95 mode).
3535
3536 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3537 -- Check the specified argument Arg to make sure that it is an
3538 -- identifier. If not give error and raise Pragma_Exit.
3539
3540 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3541 -- Check the specified argument Arg to make sure that it is an integer
3542 -- literal. If not give error and raise Pragma_Exit.
3543
3544 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3545 -- Check the specified argument Arg to make sure that it has the proper
3546 -- syntactic form for a local name and meets the semantic requirements
3547 -- for a local name. The local name is analyzed as part of the
3548 -- processing for this call. In addition, the local name is required
3549 -- to represent an entity at the library level.
3550
3551 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3552 -- Check the specified argument Arg to make sure that it has the proper
3553 -- syntactic form for a local name and meets the semantic requirements
3554 -- for a local name. The local name is analyzed as part of the
3555 -- processing for this call.
3556
3557 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3558 -- Check the specified argument Arg to make sure that it is a valid
3559 -- locking policy name. If not give error and raise Pragma_Exit.
3560
3561 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3562 -- Check the specified argument Arg to make sure that it is a valid
3563 -- elaboration policy name. If not give error and raise Pragma_Exit.
3564
3565 procedure Check_Arg_Is_One_Of
3566 (Arg : Node_Id;
3567 N1, N2 : Name_Id);
3568 procedure Check_Arg_Is_One_Of
3569 (Arg : Node_Id;
3570 N1, N2, N3 : Name_Id);
3571 procedure Check_Arg_Is_One_Of
3572 (Arg : Node_Id;
3573 N1, N2, N3, N4 : Name_Id);
3574 procedure Check_Arg_Is_One_Of
3575 (Arg : Node_Id;
3576 N1, N2, N3, N4, N5 : Name_Id);
3577 -- Check the specified argument Arg to make sure that it is an
3578 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3579 -- present). If not then give error and raise Pragma_Exit.
3580
3581 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3582 -- Check the specified argument Arg to make sure that it is a valid
3583 -- queuing policy name. If not give error and raise Pragma_Exit.
3584
3585 procedure Check_Arg_Is_OK_Static_Expression
3586 (Arg : Node_Id;
3587 Typ : Entity_Id := Empty);
3588 -- Check the specified argument Arg to make sure that it is a static
3589 -- expression of the given type (i.e. it will be analyzed and resolved
3590 -- using this type, which can be any valid argument to Resolve, e.g.
3591 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3592 -- Typ is left Empty, then any static expression is allowed. Includes
3593 -- checking that the argument does not raise Constraint_Error.
3594
3595 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3596 -- Check the specified argument Arg to make sure that it is a valid task
3597 -- dispatching policy name. If not give error and raise Pragma_Exit.
3598
3599 procedure Check_Arg_Order (Names : Name_List);
3600 -- Checks for an instance of two arguments with identifiers for the
3601 -- current pragma which are not in the sequence indicated by Names,
3602 -- and if so, generates a fatal message about bad order of arguments.
3603
3604 procedure Check_At_Least_N_Arguments (N : Nat);
3605 -- Check there are at least N arguments present
3606
3607 procedure Check_At_Most_N_Arguments (N : Nat);
3608 -- Check there are no more than N arguments present
3609
3610 procedure Check_Component
3611 (Comp : Node_Id;
3612 UU_Typ : Entity_Id;
3613 In_Variant_Part : Boolean := False);
3614 -- Examine an Unchecked_Union component for correct use of per-object
3615 -- constrained subtypes, and for restrictions on finalizable components.
3616 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3617 -- should be set when Comp comes from a record variant.
3618
3619 procedure Check_Duplicate_Pragma (E : Entity_Id);
3620 -- Check if a rep item of the same name as the current pragma is already
3621 -- chained as a rep pragma to the given entity. If so give a message
3622 -- about the duplicate, and then raise Pragma_Exit so does not return.
3623 -- Note that if E is a type, then this routine avoids flagging a pragma
3624 -- which applies to a parent type from which E is derived.
3625
3626 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3627 -- Nam is an N_String_Literal node containing the external name set by
3628 -- an Import or Export pragma (or extended Import or Export pragma).
3629 -- This procedure checks for possible duplications if this is the export
3630 -- case, and if found, issues an appropriate error message.
3631
3632 procedure Check_Expr_Is_OK_Static_Expression
3633 (Expr : Node_Id;
3634 Typ : Entity_Id := Empty);
3635 -- Check the specified expression Expr to make sure that it is a static
3636 -- expression of the given type (i.e. it will be analyzed and resolved
3637 -- using this type, which can be any valid argument to Resolve, e.g.
3638 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3639 -- Typ is left Empty, then any static expression is allowed. Includes
3640 -- checking that the expression does not raise Constraint_Error.
3641
3642 procedure Check_First_Subtype (Arg : Node_Id);
3643 -- Checks that Arg, whose expression is an entity name, references a
3644 -- first subtype.
3645
3646 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3647 -- Checks that the given argument has an identifier, and if so, requires
3648 -- it to match the given identifier name. If there is no identifier, or
3649 -- a non-matching identifier, then an error message is given and
3650 -- Pragma_Exit is raised.
3651
3652 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3653 -- Checks that the given argument has an identifier, and if so, requires
3654 -- it to match one of the given identifier names. If there is no
3655 -- identifier, or a non-matching identifier, then an error message is
3656 -- given and Pragma_Exit is raised.
3657
3658 procedure Check_In_Main_Program;
3659 -- Common checks for pragmas that appear within a main program
3660 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3661
3662 procedure Check_Interrupt_Or_Attach_Handler;
3663 -- Common processing for first argument of pragma Interrupt_Handler or
3664 -- pragma Attach_Handler.
3665
3666 procedure Check_Loop_Pragma_Placement;
3667 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3668 -- appear immediately within a construct restricted to loops, and that
3669 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3670
3671 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3672 -- Check that pragma appears in a declarative part, or in a package
3673 -- specification, i.e. that it does not occur in a statement sequence
3674 -- in a body.
3675
3676 procedure Check_No_Identifier (Arg : Node_Id);
3677 -- Checks that the given argument does not have an identifier. If
3678 -- an identifier is present, then an error message is issued, and
3679 -- Pragma_Exit is raised.
3680
3681 procedure Check_No_Identifiers;
3682 -- Checks that none of the arguments to the pragma has an identifier.
3683 -- If any argument has an identifier, then an error message is issued,
3684 -- and Pragma_Exit is raised.
3685
3686 procedure Check_No_Link_Name;
3687 -- Checks that no link name is specified
3688
3689 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3690 -- Checks if the given argument has an identifier, and if so, requires
3691 -- it to match the given identifier name. If there is a non-matching
3692 -- identifier, then an error message is given and Pragma_Exit is raised.
3693
3694 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3695 -- Checks if the given argument has an identifier, and if so, requires
3696 -- it to match the given identifier name. If there is a non-matching
3697 -- identifier, then an error message is given and Pragma_Exit is raised.
3698 -- In this version of the procedure, the identifier name is given as
3699 -- a string with lower case letters.
3700
3701 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3702 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3703 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3704 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3705 -- is an OK static boolean expression. Emit an error if this is not the
3706 -- case.
3707
3708 procedure Check_Static_Constraint (Constr : Node_Id);
3709 -- Constr is a constraint from an N_Subtype_Indication node from a
3710 -- component constraint in an Unchecked_Union type. This routine checks
3711 -- that the constraint is static as required by the restrictions for
3712 -- Unchecked_Union.
3713
3714 procedure Check_Valid_Configuration_Pragma;
3715 -- Legality checks for placement of a configuration pragma
3716
3717 procedure Check_Valid_Library_Unit_Pragma;
3718 -- Legality checks for library unit pragmas. A special case arises for
3719 -- pragmas in generic instances that come from copies of the original
3720 -- library unit pragmas in the generic templates. In the case of other
3721 -- than library level instantiations these can appear in contexts which
3722 -- would normally be invalid (they only apply to the original template
3723 -- and to library level instantiations), and they are simply ignored,
3724 -- which is implemented by rewriting them as null statements.
3725
3726 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3727 -- Check an Unchecked_Union variant for lack of nested variants and
3728 -- presence of at least one component. UU_Typ is the related Unchecked_
3729 -- Union type.
3730
3731 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3732 -- Subsidiary routine to the processing of pragmas Abstract_State,
3733 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3734 -- Refined_Global and Refined_State. Transform argument Arg into
3735 -- an aggregate if not one already. N_Null is never transformed.
3736 -- Arg may denote an aspect specification or a pragma argument
3737 -- association.
3738
3739 procedure Error_Pragma (Msg : String);
3740 pragma No_Return (Error_Pragma);
3741 -- Outputs error message for current pragma. The message contains a %
3742 -- that will be replaced with the pragma name, and the flag is placed
3743 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3744 -- calls Fix_Error (see spec of that procedure for details).
3745
3746 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3747 pragma No_Return (Error_Pragma_Arg);
3748 -- Outputs error message for current pragma. The message may contain
3749 -- a % that will be replaced with the pragma name. The parameter Arg
3750 -- may either be a pragma argument association, in which case the flag
3751 -- is placed on the expression of this association, or an expression,
3752 -- in which case the flag is placed directly on the expression. The
3753 -- message is placed using Error_Msg_N, so the message may also contain
3754 -- an & insertion character which will reference the given Arg value.
3755 -- After placing the message, Pragma_Exit is raised. Note: this routine
3756 -- calls Fix_Error (see spec of that procedure for details).
3757
3758 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3759 pragma No_Return (Error_Pragma_Arg);
3760 -- Similar to above form of Error_Pragma_Arg except that two messages
3761 -- are provided, the second is a continuation comment starting with \.
3762
3763 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3764 pragma No_Return (Error_Pragma_Arg_Ident);
3765 -- Outputs error message for current pragma. The message may contain a %
3766 -- that will be replaced with the pragma name. The parameter Arg must be
3767 -- a pragma argument association with a non-empty identifier (i.e. its
3768 -- Chars field must be set), and the error message is placed on the
3769 -- identifier. The message is placed using Error_Msg_N so the message
3770 -- may also contain an & insertion character which will reference
3771 -- the identifier. After placing the message, Pragma_Exit is raised.
3772 -- Note: this routine calls Fix_Error (see spec of that procedure for
3773 -- details).
3774
3775 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3776 pragma No_Return (Error_Pragma_Ref);
3777 -- Outputs error message for current pragma. The message may contain
3778 -- a % that will be replaced with the pragma name. The parameter Ref
3779 -- must be an entity whose name can be referenced by & and sloc by #.
3780 -- After placing the message, Pragma_Exit is raised. Note: this routine
3781 -- calls Fix_Error (see spec of that procedure for details).
3782
3783 function Find_Lib_Unit_Name return Entity_Id;
3784 -- Used for a library unit pragma to find the entity to which the
3785 -- library unit pragma applies, returns the entity found.
3786
3787 procedure Find_Program_Unit_Name (Id : Node_Id);
3788 -- If the pragma is a compilation unit pragma, the id must denote the
3789 -- compilation unit in the same compilation, and the pragma must appear
3790 -- in the list of preceding or trailing pragmas. If it is a program
3791 -- unit pragma that is not a compilation unit pragma, then the
3792 -- identifier must be visible.
3793
3794 function Find_Unique_Parameterless_Procedure
3795 (Name : Entity_Id;
3796 Arg : Node_Id) return Entity_Id;
3797 -- Used for a procedure pragma to find the unique parameterless
3798 -- procedure identified by Name, returns it if it exists, otherwise
3799 -- errors out and uses Arg as the pragma argument for the message.
3800
3801 function Fix_Error (Msg : String) return String;
3802 -- This is called prior to issuing an error message. Msg is the normal
3803 -- error message issued in the pragma case. This routine checks for the
3804 -- case of a pragma coming from an aspect in the source, and returns a
3805 -- message suitable for the aspect case as follows:
3806 --
3807 -- Each substring "pragma" is replaced by "aspect"
3808 --
3809 -- If "argument of" is at the start of the error message text, it is
3810 -- replaced by "entity for".
3811 --
3812 -- If "argument" is at the start of the error message text, it is
3813 -- replaced by "entity".
3814 --
3815 -- So for example, "argument of pragma X must be discrete type"
3816 -- returns "entity for aspect X must be a discrete type".
3817
3818 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3819 -- be different from the pragma name). If the current pragma results
3820 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3821 -- original pragma name.
3822
3823 procedure Gather_Associations
3824 (Names : Name_List;
3825 Args : out Args_List);
3826 -- This procedure is used to gather the arguments for a pragma that
3827 -- permits arbitrary ordering of parameters using the normal rules
3828 -- for named and positional parameters. The Names argument is a list
3829 -- of Name_Id values that corresponds to the allowed pragma argument
3830 -- association identifiers in order. The result returned in Args is
3831 -- a list of corresponding expressions that are the pragma arguments.
3832 -- Note that this is a list of expressions, not of pragma argument
3833 -- associations (Gather_Associations has completely checked all the
3834 -- optional identifiers when it returns). An entry in Args is Empty
3835 -- on return if the corresponding argument is not present.
3836
3837 procedure GNAT_Pragma;
3838 -- Called for all GNAT defined pragmas to check the relevant restriction
3839 -- (No_Implementation_Pragmas).
3840
3841 function Is_Before_First_Decl
3842 (Pragma_Node : Node_Id;
3843 Decls : List_Id) return Boolean;
3844 -- Return True if Pragma_Node is before the first declarative item in
3845 -- Decls where Decls is the list of declarative items.
3846
3847 function Is_Configuration_Pragma return Boolean;
3848 -- Determines if the placement of the current pragma is appropriate
3849 -- for a configuration pragma.
3850
3851 function Is_In_Context_Clause return Boolean;
3852 -- Returns True if pragma appears within the context clause of a unit,
3853 -- and False for any other placement (does not generate any messages).
3854
3855 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3856 -- Analyzes the argument, and determines if it is a static string
3857 -- expression, returns True if so, False if non-static or not String.
3858 -- A special case is that a string literal returns True in Ada 83 mode
3859 -- (which has no such thing as static string expressions). Note that
3860 -- the call analyzes its argument, so this cannot be used for the case
3861 -- where an identifier might not be declared.
3862
3863 procedure Pragma_Misplaced;
3864 pragma No_Return (Pragma_Misplaced);
3865 -- Issue fatal error message for misplaced pragma
3866
3867 procedure Process_Atomic_Independent_Shared_Volatile;
3868 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3869 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3870 -- and treated as being identical in effect to pragma Atomic.
3871
3872 procedure Process_Compile_Time_Warning_Or_Error;
3873 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3874
3875 procedure Process_Convention
3876 (C : out Convention_Id;
3877 Ent : out Entity_Id);
3878 -- Common processing for Convention, Interface, Import and Export.
3879 -- Checks first two arguments of pragma, and sets the appropriate
3880 -- convention value in the specified entity or entities. On return
3881 -- C is the convention, Ent is the referenced entity.
3882
3883 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3884 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3885 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3886
3887 procedure Process_Extended_Import_Export_Object_Pragma
3888 (Arg_Internal : Node_Id;
3889 Arg_External : Node_Id;
3890 Arg_Size : Node_Id);
3891 -- Common processing for the pragmas Import/Export_Object. The three
3892 -- arguments correspond to the three named parameters of the pragmas. An
3893 -- argument is empty if the corresponding parameter is not present in
3894 -- the pragma.
3895
3896 procedure Process_Extended_Import_Export_Internal_Arg
3897 (Arg_Internal : Node_Id := Empty);
3898 -- Common processing for all extended Import and Export pragmas. The
3899 -- argument is the pragma parameter for the Internal argument. If
3900 -- Arg_Internal is empty or inappropriate, an error message is posted.
3901 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3902 -- set to identify the referenced entity.
3903
3904 procedure Process_Extended_Import_Export_Subprogram_Pragma
3905 (Arg_Internal : Node_Id;
3906 Arg_External : Node_Id;
3907 Arg_Parameter_Types : Node_Id;
3908 Arg_Result_Type : Node_Id := Empty;
3909 Arg_Mechanism : Node_Id;
3910 Arg_Result_Mechanism : Node_Id := Empty);
3911 -- Common processing for all extended Import and Export pragmas applying
3912 -- to subprograms. The caller omits any arguments that do not apply to
3913 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3914 -- only in the Import_Function and Export_Function cases). The argument
3915 -- names correspond to the allowed pragma association identifiers.
3916
3917 procedure Process_Generic_List;
3918 -- Common processing for Share_Generic and Inline_Generic
3919
3920 procedure Process_Import_Or_Interface;
3921 -- Common processing for Import or Interface
3922
3923 procedure Process_Import_Predefined_Type;
3924 -- Processing for completing a type with pragma Import. This is used
3925 -- to declare types that match predefined C types, especially for cases
3926 -- without corresponding Ada predefined type.
3927
3928 type Inline_Status is (Suppressed, Disabled, Enabled);
3929 -- Inline status of a subprogram, indicated as follows:
3930 -- Suppressed: inlining is suppressed for the subprogram
3931 -- Disabled: no inlining is requested for the subprogram
3932 -- Enabled: inlining is requested/required for the subprogram
3933
3934 procedure Process_Inline (Status : Inline_Status);
3935 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3936 -- indicates the inline status specified by the pragma.
3937
3938 procedure Process_Interface_Name
3939 (Subprogram_Def : Entity_Id;
3940 Ext_Arg : Node_Id;
3941 Link_Arg : Node_Id);
3942 -- Given the last two arguments of pragma Import, pragma Export, or
3943 -- pragma Interface_Name, performs validity checks and sets the
3944 -- Interface_Name field of the given subprogram entity to the
3945 -- appropriate external or link name, depending on the arguments given.
3946 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3947 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3948 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3949 -- nor Link_Arg is present, the interface name is set to the default
3950 -- from the subprogram name.
3951
3952 procedure Process_Interrupt_Or_Attach_Handler;
3953 -- Common processing for Interrupt and Attach_Handler pragmas
3954
3955 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3956 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3957 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3958 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3959 -- is not set in the Restrictions case.
3960
3961 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3962 -- Common processing for Suppress and Unsuppress. The boolean parameter
3963 -- Suppress_Case is True for the Suppress case, and False for the
3964 -- Unsuppress case.
3965
3966 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3967 -- Subsidiary to the analysis of pragmas Independent[_Components].
3968 -- Record such a pragma N applied to entity E for future checks.
3969
3970 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3971 -- This procedure sets the Is_Exported flag for the given entity,
3972 -- checking that the entity was not previously imported. Arg is
3973 -- the argument that specified the entity. A check is also made
3974 -- for exporting inappropriate entities.
3975
3976 procedure Set_Extended_Import_Export_External_Name
3977 (Internal_Ent : Entity_Id;
3978 Arg_External : Node_Id);
3979 -- Common processing for all extended import export pragmas. The first
3980 -- argument, Internal_Ent, is the internal entity, which has already
3981 -- been checked for validity by the caller. Arg_External is from the
3982 -- Import or Export pragma, and may be null if no External parameter
3983 -- was present. If Arg_External is present and is a non-null string
3984 -- (a null string is treated as the default), then the Interface_Name
3985 -- field of Internal_Ent is set appropriately.
3986
3987 procedure Set_Imported (E : Entity_Id);
3988 -- This procedure sets the Is_Imported flag for the given entity,
3989 -- checking that it is not previously exported or imported.
3990
3991 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3992 -- Mech is a parameter passing mechanism (see Import_Function syntax
3993 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3994 -- has the right form, and if not issues an error message. If the
3995 -- argument has the right form then the Mechanism field of Ent is
3996 -- set appropriately.
3997
3998 procedure Set_Rational_Profile;
3999 -- Activate the set of configuration pragmas and permissions that make
4000 -- up the Rational profile.
4001
4002 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4003 -- Activate the set of configuration pragmas and restrictions that make
4004 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
4005 -- Ravenscar. N is the corresponding pragma node, which is used for
4006 -- error messages on any constructs violating the profile.
4007
4008 ----------------------------------
4009 -- Acquire_Warning_Match_String --
4010 ----------------------------------
4011
4012 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
4013 begin
4014 String_To_Name_Buffer
4015 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
4016
4017 -- Add asterisk at start if not already there
4018
4019 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
4020 Name_Buffer (2 .. Name_Len + 1) :=
4021 Name_Buffer (1 .. Name_Len);
4022 Name_Buffer (1) := '*';
4023 Name_Len := Name_Len + 1;
4024 end if;
4025
4026 -- Add asterisk at end if not already there
4027
4028 if Name_Buffer (Name_Len) /= '*' then
4029 Name_Len := Name_Len + 1;
4030 Name_Buffer (Name_Len) := '*';
4031 end if;
4032 end Acquire_Warning_Match_String;
4033
4034 ---------------------
4035 -- Ada_2005_Pragma --
4036 ---------------------
4037
4038 procedure Ada_2005_Pragma is
4039 begin
4040 if Ada_Version <= Ada_95 then
4041 Check_Restriction (No_Implementation_Pragmas, N);
4042 end if;
4043 end Ada_2005_Pragma;
4044
4045 ---------------------
4046 -- Ada_2012_Pragma --
4047 ---------------------
4048
4049 procedure Ada_2012_Pragma is
4050 begin
4051 if Ada_Version <= Ada_2005 then
4052 Check_Restriction (No_Implementation_Pragmas, N);
4053 end if;
4054 end Ada_2012_Pragma;
4055
4056 ----------------------------
4057 -- Analyze_Depends_Global --
4058 ----------------------------
4059
4060 procedure Analyze_Depends_Global
4061 (Spec_Id : out Entity_Id;
4062 Subp_Decl : out Node_Id;
4063 Legal : out Boolean)
4064 is
4065 begin
4066 -- Assume that the pragma is illegal
4067
4068 Spec_Id := Empty;
4069 Subp_Decl := Empty;
4070 Legal := False;
4071
4072 GNAT_Pragma;
4073 Check_Arg_Count (1);
4074
4075 -- Ensure the proper placement of the pragma. Depends/Global must be
4076 -- associated with a subprogram declaration or a body that acts as a
4077 -- spec.
4078
4079 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4080
4081 -- Entry
4082
4083 if Nkind (Subp_Decl) = N_Entry_Declaration then
4084 null;
4085
4086 -- Generic subprogram
4087
4088 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4089 null;
4090
4091 -- Object declaration of a single concurrent type
4092
4093 elsif Nkind (Subp_Decl) = N_Object_Declaration then
4094 null;
4095
4096 -- Single task type
4097
4098 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4099 null;
4100
4101 -- Subprogram body acts as spec
4102
4103 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4104 and then No (Corresponding_Spec (Subp_Decl))
4105 then
4106 null;
4107
4108 -- Subprogram body stub acts as spec
4109
4110 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4111 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4112 then
4113 null;
4114
4115 -- Subprogram declaration
4116
4117 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4118 null;
4119
4120 -- Task type
4121
4122 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4123 null;
4124
4125 else
4126 Pragma_Misplaced;
4127 return;
4128 end if;
4129
4130 -- If we get here, then the pragma is legal
4131
4132 Legal := True;
4133 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4134
4135 -- When the related context is an entry, the entry must belong to a
4136 -- protected unit (SPARK RM 6.1.4(6)).
4137
4138 if Is_Entry_Declaration (Spec_Id)
4139 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4140 then
4141 Pragma_Misplaced;
4142 return;
4143
4144 -- When the related context is an anonymous object created for a
4145 -- simple concurrent type, the type must be a task
4146 -- (SPARK RM 6.1.4(6)).
4147
4148 elsif Is_Single_Concurrent_Object (Spec_Id)
4149 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4150 then
4151 Pragma_Misplaced;
4152 return;
4153 end if;
4154
4155 -- A pragma that applies to a Ghost entity becomes Ghost for the
4156 -- purposes of legality checks and removal of ignored Ghost code.
4157
4158 Mark_Pragma_As_Ghost (N, Spec_Id);
4159 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4160 end Analyze_Depends_Global;
4161
4162 ------------------------
4163 -- Analyze_If_Present --
4164 ------------------------
4165
4166 procedure Analyze_If_Present (Id : Pragma_Id) is
4167 Stmt : Node_Id;
4168
4169 begin
4170 pragma Assert (Is_List_Member (N));
4171
4172 -- Inspect the declarations or statements following pragma N looking
4173 -- for another pragma whose Id matches the caller's request. If it is
4174 -- available, analyze it.
4175
4176 Stmt := Next (N);
4177 while Present (Stmt) loop
4178 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4179 Analyze_Pragma (Stmt);
4180 exit;
4181
4182 -- The first source declaration or statement immediately following
4183 -- N ends the region where a pragma may appear.
4184
4185 elsif Comes_From_Source (Stmt) then
4186 exit;
4187 end if;
4188
4189 Next (Stmt);
4190 end loop;
4191 end Analyze_If_Present;
4192
4193 --------------------------------
4194 -- Analyze_Pre_Post_Condition --
4195 --------------------------------
4196
4197 procedure Analyze_Pre_Post_Condition is
4198 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4199 Subp_Decl : Node_Id;
4200 Subp_Id : Entity_Id;
4201
4202 Duplicates_OK : Boolean := False;
4203 -- Flag set when a pre/postcondition allows multiple pragmas of the
4204 -- same kind.
4205
4206 In_Body_OK : Boolean := False;
4207 -- Flag set when a pre/postcondition is allowed to appear on a body
4208 -- even though the subprogram may have a spec.
4209
4210 Is_Pre_Post : Boolean := False;
4211 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4212 -- Post_Class.
4213
4214 begin
4215 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4216 -- offer uniformity among the various kinds of pre/postconditions by
4217 -- rewriting the pragma identifier. This allows the retrieval of the
4218 -- original pragma name by routine Original_Aspect_Pragma_Name.
4219
4220 if Comes_From_Source (N) then
4221 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4222 Is_Pre_Post := True;
4223 Set_Class_Present (N, Pname = Name_Pre_Class);
4224 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4225
4226 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4227 Is_Pre_Post := True;
4228 Set_Class_Present (N, Pname = Name_Post_Class);
4229 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4230 end if;
4231 end if;
4232
4233 -- Determine the semantics with respect to duplicates and placement
4234 -- in a body. Pragmas Precondition and Postcondition were introduced
4235 -- before aspects and are not subject to the same aspect-like rules.
4236
4237 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4238 Duplicates_OK := True;
4239 In_Body_OK := True;
4240 end if;
4241
4242 GNAT_Pragma;
4243
4244 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4245 -- argument without an identifier.
4246
4247 if Is_Pre_Post then
4248 Check_Arg_Count (1);
4249 Check_No_Identifiers;
4250
4251 -- Pragmas Precondition and Postcondition have complex argument
4252 -- profile.
4253
4254 else
4255 Check_At_Least_N_Arguments (1);
4256 Check_At_Most_N_Arguments (2);
4257 Check_Optional_Identifier (Arg1, Name_Check);
4258
4259 if Present (Arg2) then
4260 Check_Optional_Identifier (Arg2, Name_Message);
4261 Preanalyze_Spec_Expression
4262 (Get_Pragma_Arg (Arg2), Standard_String);
4263 end if;
4264 end if;
4265
4266 -- For a pragma PPC in the extended main source unit, record enabled
4267 -- status in SCO.
4268 -- ??? nothing checks that the pragma is in the main source unit
4269
4270 if Is_Checked (N) and then not Split_PPC (N) then
4271 Set_SCO_Pragma_Enabled (Loc);
4272 end if;
4273
4274 -- Ensure the proper placement of the pragma
4275
4276 Subp_Decl :=
4277 Find_Related_Declaration_Or_Body
4278 (N, Do_Checks => not Duplicates_OK);
4279
4280 -- When a pre/postcondition pragma applies to an abstract subprogram,
4281 -- its original form must be an aspect with 'Class.
4282
4283 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4284 if not From_Aspect_Specification (N) then
4285 Error_Pragma
4286 ("pragma % cannot be applied to abstract subprogram");
4287
4288 elsif not Class_Present (N) then
4289 Error_Pragma
4290 ("aspect % requires ''Class for abstract subprogram");
4291 end if;
4292
4293 -- Entry declaration
4294
4295 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4296 null;
4297
4298 -- Generic subprogram declaration
4299
4300 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4301 null;
4302
4303 -- Subprogram body
4304
4305 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4306 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4307 then
4308 null;
4309
4310 -- Subprogram body stub
4311
4312 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4313 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4314 then
4315 null;
4316
4317 -- Subprogram declaration
4318
4319 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4320
4321 -- AI05-0230: When a pre/postcondition pragma applies to a null
4322 -- procedure, its original form must be an aspect with 'Class.
4323
4324 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4325 and then Null_Present (Specification (Subp_Decl))
4326 and then From_Aspect_Specification (N)
4327 and then not Class_Present (N)
4328 then
4329 Error_Pragma ("aspect % requires ''Class for null procedure");
4330 end if;
4331
4332 -- Otherwise the placement is illegal
4333
4334 else
4335 Pragma_Misplaced;
4336 return;
4337 end if;
4338
4339 Subp_Id := Defining_Entity (Subp_Decl);
4340
4341 -- Chain the pragma on the contract for further processing by
4342 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4343
4344 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4345
4346 -- A pragma that applies to a Ghost entity becomes Ghost for the
4347 -- purposes of legality checks and removal of ignored Ghost code.
4348
4349 Mark_Pragma_As_Ghost (N, Subp_Id);
4350
4351 -- Fully analyze the pragma when it appears inside an entry or
4352 -- subprogram body because it cannot benefit from forward references.
4353
4354 if Nkind_In (Subp_Decl, N_Entry_Body,
4355 N_Subprogram_Body,
4356 N_Subprogram_Body_Stub)
4357 then
4358 -- The legality checks of pragmas Precondition and Postcondition
4359 -- are affected by the SPARK mode in effect and the volatility of
4360 -- the context. Analyze all pragmas in a specific order.
4361
4362 Analyze_If_Present (Pragma_SPARK_Mode);
4363 Analyze_If_Present (Pragma_Volatile_Function);
4364 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4365 end if;
4366 end Analyze_Pre_Post_Condition;
4367
4368 -----------------------------------------
4369 -- Analyze_Refined_Depends_Global_Post --
4370 -----------------------------------------
4371
4372 procedure Analyze_Refined_Depends_Global_Post
4373 (Spec_Id : out Entity_Id;
4374 Body_Id : out Entity_Id;
4375 Legal : out Boolean)
4376 is
4377 Body_Decl : Node_Id;
4378 Spec_Decl : Node_Id;
4379
4380 begin
4381 -- Assume that the pragma is illegal
4382
4383 Spec_Id := Empty;
4384 Body_Id := Empty;
4385 Legal := False;
4386
4387 GNAT_Pragma;
4388 Check_Arg_Count (1);
4389 Check_No_Identifiers;
4390
4391 -- Verify the placement of the pragma and check for duplicates. The
4392 -- pragma must apply to a subprogram body [stub].
4393
4394 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4395
4396 -- Entry body
4397
4398 if Nkind (Body_Decl) = N_Entry_Body then
4399 null;
4400
4401 -- Subprogram body
4402
4403 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4404 null;
4405
4406 -- Subprogram body stub
4407
4408 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4409 null;
4410
4411 -- Task body
4412
4413 elsif Nkind (Body_Decl) = N_Task_Body then
4414 null;
4415
4416 else
4417 Pragma_Misplaced;
4418 return;
4419 end if;
4420
4421 Body_Id := Defining_Entity (Body_Decl);
4422 Spec_Id := Unique_Defining_Entity (Body_Decl);
4423
4424 -- The pragma must apply to the second declaration of a subprogram.
4425 -- In other words, the body [stub] cannot acts as a spec.
4426
4427 if No (Spec_Id) then
4428 Error_Pragma ("pragma % cannot apply to a stand alone body");
4429 return;
4430
4431 -- Catch the case where the subprogram body is a subunit and acts as
4432 -- the third declaration of the subprogram.
4433
4434 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4435 Error_Pragma ("pragma % cannot apply to a subunit");
4436 return;
4437 end if;
4438
4439 -- A refined pragma can only apply to the body [stub] of a subprogram
4440 -- declared in the visible part of a package. Retrieve the context of
4441 -- the subprogram declaration.
4442
4443 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4444
4445 -- When dealing with protected entries or protected subprograms, use
4446 -- the enclosing protected type as the proper context.
4447
4448 if Ekind_In (Spec_Id, E_Entry,
4449 E_Entry_Family,
4450 E_Function,
4451 E_Procedure)
4452 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4453 then
4454 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4455 end if;
4456
4457 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4458 Error_Pragma
4459 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4460 & "subprogram declared in a package specification"));
4461 return;
4462 end if;
4463
4464 -- If we get here, then the pragma is legal
4465
4466 Legal := True;
4467
4468 -- A pragma that applies to a Ghost entity becomes Ghost for the
4469 -- purposes of legality checks and removal of ignored Ghost code.
4470
4471 Mark_Pragma_As_Ghost (N, Spec_Id);
4472
4473 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4474 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4475 end if;
4476 end Analyze_Refined_Depends_Global_Post;
4477
4478 ----------------------------------
4479 -- Analyze_Unmodified_Or_Unused --
4480 ----------------------------------
4481
4482 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4483 Arg : Node_Id;
4484 Arg_Expr : Node_Id;
4485 Arg_Id : Entity_Id;
4486
4487 Ghost_Error_Posted : Boolean := False;
4488 -- Flag set when an error concerning the illegal mix of Ghost and
4489 -- non-Ghost variables is emitted.
4490
4491 Ghost_Id : Entity_Id := Empty;
4492 -- The entity of the first Ghost variable encountered while
4493 -- processing the arguments of the pragma.
4494
4495 begin
4496 GNAT_Pragma;
4497 Check_At_Least_N_Arguments (1);
4498
4499 -- Loop through arguments
4500
4501 Arg := Arg1;
4502 while Present (Arg) loop
4503 Check_No_Identifier (Arg);
4504
4505 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4506 -- in fact generate reference, so that the entity will have a
4507 -- reference, which will inhibit any warnings about it not
4508 -- being referenced, and also properly show up in the ali file
4509 -- as a reference. But this reference is recorded before the
4510 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4511 -- generated for this reference.
4512
4513 Check_Arg_Is_Local_Name (Arg);
4514 Arg_Expr := Get_Pragma_Arg (Arg);
4515
4516 if Is_Entity_Name (Arg_Expr) then
4517 Arg_Id := Entity (Arg_Expr);
4518
4519 -- Skip processing the argument if already flagged
4520
4521 if Is_Assignable (Arg_Id)
4522 and then not Has_Pragma_Unmodified (Arg_Id)
4523 and then not Has_Pragma_Unused (Arg_Id)
4524 then
4525 Set_Has_Pragma_Unmodified (Arg_Id);
4526
4527 if Is_Unused then
4528 Set_Has_Pragma_Unused (Arg_Id);
4529 end if;
4530
4531 -- A pragma that applies to a Ghost entity becomes Ghost for
4532 -- the purposes of legality checks and removal of ignored
4533 -- Ghost code.
4534
4535 Mark_Pragma_As_Ghost (N, Arg_Id);
4536
4537 -- Capture the entity of the first Ghost variable being
4538 -- processed for error detection purposes.
4539
4540 if Is_Ghost_Entity (Arg_Id) then
4541 if No (Ghost_Id) then
4542 Ghost_Id := Arg_Id;
4543 end if;
4544
4545 -- Otherwise the variable is non-Ghost. It is illegal to mix
4546 -- references to Ghost and non-Ghost entities
4547 -- (SPARK RM 6.9).
4548
4549 elsif Present (Ghost_Id)
4550 and then not Ghost_Error_Posted
4551 then
4552 Ghost_Error_Posted := True;
4553
4554 Error_Msg_Name_1 := Pname;
4555 Error_Msg_N
4556 ("pragma % cannot mention ghost and non-ghost "
4557 & "variables", N);
4558
4559 Error_Msg_Sloc := Sloc (Ghost_Id);
4560 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4561
4562 Error_Msg_Sloc := Sloc (Arg_Id);
4563 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
4564 end if;
4565
4566 -- Warn if already flagged as Unused or Unmodified
4567
4568 elsif Has_Pragma_Unmodified (Arg_Id) then
4569 if Has_Pragma_Unused (Arg_Id) then
4570 Error_Msg_NE
4571 ("??pragma Unused already given for &!", Arg_Expr,
4572 Arg_Id);
4573 else
4574 Error_Msg_NE
4575 ("??pragma Unmodified already given for &!", Arg_Expr,
4576 Arg_Id);
4577 end if;
4578
4579 -- Otherwise the pragma referenced an illegal entity
4580
4581 else
4582 Error_Pragma_Arg
4583 ("pragma% can only be applied to a variable", Arg_Expr);
4584 end if;
4585 end if;
4586
4587 Next (Arg);
4588 end loop;
4589 end Analyze_Unmodified_Or_Unused;
4590
4591 -----------------------------------
4592 -- Analyze_Unreference_Or_Unused --
4593 -----------------------------------
4594
4595 procedure Analyze_Unreferenced_Or_Unused
4596 (Is_Unused : Boolean := False)
4597 is
4598 Arg : Node_Id;
4599 Arg_Expr : Node_Id;
4600 Arg_Id : Entity_Id;
4601 Citem : Node_Id;
4602
4603 Ghost_Error_Posted : Boolean := False;
4604 -- Flag set when an error concerning the illegal mix of Ghost and
4605 -- non-Ghost names is emitted.
4606
4607 Ghost_Id : Entity_Id := Empty;
4608 -- The entity of the first Ghost name encountered while processing
4609 -- the arguments of the pragma.
4610
4611 begin
4612 GNAT_Pragma;
4613 Check_At_Least_N_Arguments (1);
4614
4615 -- Check case of appearing within context clause
4616
4617 if not Is_Unused and then Is_In_Context_Clause then
4618
4619 -- The arguments must all be units mentioned in a with clause in
4620 -- the same context clause. Note that Par.Prag already checked
4621 -- that the arguments are either identifiers or selected
4622 -- components.
4623
4624 Arg := Arg1;
4625 while Present (Arg) loop
4626 Citem := First (List_Containing (N));
4627 while Citem /= N loop
4628 Arg_Expr := Get_Pragma_Arg (Arg);
4629
4630 if Nkind (Citem) = N_With_Clause
4631 and then Same_Name (Name (Citem), Arg_Expr)
4632 then
4633 Set_Has_Pragma_Unreferenced
4634 (Cunit_Entity
4635 (Get_Source_Unit
4636 (Library_Unit (Citem))));
4637 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
4638 exit;
4639 end if;
4640
4641 Next (Citem);
4642 end loop;
4643
4644 if Citem = N then
4645 Error_Pragma_Arg
4646 ("argument of pragma% is not withed unit", Arg);
4647 end if;
4648
4649 Next (Arg);
4650 end loop;
4651
4652 -- Case of not in list of context items
4653
4654 else
4655 Arg := Arg1;
4656 while Present (Arg) loop
4657 Check_No_Identifier (Arg);
4658
4659 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4660 -- in fact generate reference, so that the entity will have a
4661 -- reference, which will inhibit any warnings about it not
4662 -- being referenced, and also properly show up in the ali file
4663 -- as a reference. But this reference is recorded before the
4664 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4665 -- generated for this reference.
4666
4667 Check_Arg_Is_Local_Name (Arg);
4668 Arg_Expr := Get_Pragma_Arg (Arg);
4669
4670 if Is_Entity_Name (Arg_Expr) then
4671 Arg_Id := Entity (Arg_Expr);
4672
4673 -- Warn if already flagged as Unused or Unreferenced and
4674 -- skip processing the argument.
4675
4676 if Has_Pragma_Unreferenced (Arg_Id) then
4677 if Has_Pragma_Unused (Arg_Id) then
4678 Error_Msg_NE
4679 ("??pragma Unused already given for &!", Arg_Expr,
4680 Arg_Id);
4681 else
4682 Error_Msg_NE
4683 ("??pragma Unreferenced already given for &!",
4684 Arg_Expr, Arg_Id);
4685 end if;
4686
4687 -- Apply Unreferenced to the entity
4688
4689 else
4690 -- If the entity is overloaded, the pragma applies to the
4691 -- most recent overloading, as documented. In this case,
4692 -- name resolution does not generate a reference, so it
4693 -- must be done here explicitly.
4694
4695 if Is_Overloaded (Arg_Expr) then
4696 Generate_Reference (Arg_Id, N);
4697 end if;
4698
4699 Set_Has_Pragma_Unreferenced (Arg_Id);
4700
4701 if Is_Unused then
4702 Set_Has_Pragma_Unused (Arg_Id);
4703 end if;
4704
4705 -- A pragma that applies to a Ghost entity becomes Ghost
4706 -- for the purposes of legality checks and removal of
4707 -- ignored Ghost code.
4708
4709 Mark_Pragma_As_Ghost (N, Arg_Id);
4710
4711 -- Capture the entity of the first Ghost name being
4712 -- processed for error detection purposes.
4713
4714 if Is_Ghost_Entity (Arg_Id) then
4715 if No (Ghost_Id) then
4716 Ghost_Id := Arg_Id;
4717 end if;
4718
4719 -- Otherwise the name is non-Ghost. It is illegal to mix
4720 -- references to Ghost and non-Ghost entities
4721 -- (SPARK RM 6.9).
4722
4723 elsif Present (Ghost_Id)
4724 and then not Ghost_Error_Posted
4725 then
4726 Ghost_Error_Posted := True;
4727
4728 Error_Msg_Name_1 := Pname;
4729 Error_Msg_N
4730 ("pragma % cannot mention ghost and non-ghost "
4731 & "names", N);
4732
4733 Error_Msg_Sloc := Sloc (Ghost_Id);
4734 Error_Msg_NE
4735 ("\& # declared as ghost", N, Ghost_Id);
4736
4737 Error_Msg_Sloc := Sloc (Arg_Id);
4738 Error_Msg_NE
4739 ("\& # declared as non-ghost", N, Arg_Id);
4740 end if;
4741 end if;
4742 end if;
4743
4744 Next (Arg);
4745 end loop;
4746 end if;
4747 end Analyze_Unreferenced_Or_Unused;
4748
4749 --------------------------
4750 -- Check_Ada_83_Warning --
4751 --------------------------
4752
4753 procedure Check_Ada_83_Warning is
4754 begin
4755 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4756 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4757 end if;
4758 end Check_Ada_83_Warning;
4759
4760 ---------------------
4761 -- Check_Arg_Count --
4762 ---------------------
4763
4764 procedure Check_Arg_Count (Required : Nat) is
4765 begin
4766 if Arg_Count /= Required then
4767 Error_Pragma ("wrong number of arguments for pragma%");
4768 end if;
4769 end Check_Arg_Count;
4770
4771 --------------------------------
4772 -- Check_Arg_Is_External_Name --
4773 --------------------------------
4774
4775 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4776 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4777
4778 begin
4779 if Nkind (Argx) = N_Identifier then
4780 return;
4781
4782 else
4783 Analyze_And_Resolve (Argx, Standard_String);
4784
4785 if Is_OK_Static_Expression (Argx) then
4786 return;
4787
4788 elsif Etype (Argx) = Any_Type then
4789 raise Pragma_Exit;
4790
4791 -- An interesting special case, if we have a string literal and
4792 -- we are in Ada 83 mode, then we allow it even though it will
4793 -- not be flagged as static. This allows expected Ada 83 mode
4794 -- use of external names which are string literals, even though
4795 -- technically these are not static in Ada 83.
4796
4797 elsif Ada_Version = Ada_83
4798 and then Nkind (Argx) = N_String_Literal
4799 then
4800 return;
4801
4802 -- Static expression that raises Constraint_Error. This has
4803 -- already been flagged, so just exit from pragma processing.
4804
4805 elsif Is_OK_Static_Expression (Argx) then
4806 raise Pragma_Exit;
4807
4808 -- Here we have a real error (non-static expression)
4809
4810 else
4811 Error_Msg_Name_1 := Pname;
4812
4813 declare
4814 Msg : constant String :=
4815 "argument for pragma% must be a identifier or "
4816 & "static string expression!";
4817 begin
4818 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4819 raise Pragma_Exit;
4820 end;
4821 end if;
4822 end if;
4823 end Check_Arg_Is_External_Name;
4824
4825 -----------------------------
4826 -- Check_Arg_Is_Identifier --
4827 -----------------------------
4828
4829 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4830 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4831 begin
4832 if Nkind (Argx) /= N_Identifier then
4833 Error_Pragma_Arg
4834 ("argument for pragma% must be identifier", Argx);
4835 end if;
4836 end Check_Arg_Is_Identifier;
4837
4838 ----------------------------------
4839 -- Check_Arg_Is_Integer_Literal --
4840 ----------------------------------
4841
4842 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4843 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4844 begin
4845 if Nkind (Argx) /= N_Integer_Literal then
4846 Error_Pragma_Arg
4847 ("argument for pragma% must be integer literal", Argx);
4848 end if;
4849 end Check_Arg_Is_Integer_Literal;
4850
4851 -------------------------------------------
4852 -- Check_Arg_Is_Library_Level_Local_Name --
4853 -------------------------------------------
4854
4855 -- LOCAL_NAME ::=
4856 -- DIRECT_NAME
4857 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4858 -- | library_unit_NAME
4859
4860 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4861 begin
4862 Check_Arg_Is_Local_Name (Arg);
4863
4864 -- If it came from an aspect, we want to give the error just as if it
4865 -- came from source.
4866
4867 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4868 and then (Comes_From_Source (N)
4869 or else Present (Corresponding_Aspect (Parent (Arg))))
4870 then
4871 Error_Pragma_Arg
4872 ("argument for pragma% must be library level entity", Arg);
4873 end if;
4874 end Check_Arg_Is_Library_Level_Local_Name;
4875
4876 -----------------------------
4877 -- Check_Arg_Is_Local_Name --
4878 -----------------------------
4879
4880 -- LOCAL_NAME ::=
4881 -- DIRECT_NAME
4882 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4883 -- | library_unit_NAME
4884
4885 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4886 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4887
4888 begin
4889 -- If this pragma came from an aspect specification, we don't want to
4890 -- check for this error, because that would cause spurious errors, in
4891 -- case a type is frozen in a scope more nested than the type. The
4892 -- aspect itself of course can't be anywhere but on the declaration
4893 -- itself.
4894
4895 if Nkind (Arg) = N_Pragma_Argument_Association then
4896 if From_Aspect_Specification (Parent (Arg)) then
4897 return;
4898 end if;
4899
4900 -- Arg is the Expression of an N_Pragma_Argument_Association
4901
4902 else
4903 if From_Aspect_Specification (Parent (Parent (Arg))) then
4904 return;
4905 end if;
4906 end if;
4907
4908 Analyze (Argx);
4909
4910 if Nkind (Argx) not in N_Direct_Name
4911 and then (Nkind (Argx) /= N_Attribute_Reference
4912 or else Present (Expressions (Argx))
4913 or else Nkind (Prefix (Argx)) /= N_Identifier)
4914 and then (not Is_Entity_Name (Argx)
4915 or else not Is_Compilation_Unit (Entity (Argx)))
4916 then
4917 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
4918 end if;
4919
4920 -- No further check required if not an entity name
4921
4922 if not Is_Entity_Name (Argx) then
4923 null;
4924
4925 else
4926 declare
4927 OK : Boolean;
4928 Ent : constant Entity_Id := Entity (Argx);
4929 Scop : constant Entity_Id := Scope (Ent);
4930
4931 begin
4932 -- Case of a pragma applied to a compilation unit: pragma must
4933 -- occur immediately after the program unit in the compilation.
4934
4935 if Is_Compilation_Unit (Ent) then
4936 declare
4937 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
4938
4939 begin
4940 -- Case of pragma placed immediately after spec
4941
4942 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
4943 OK := True;
4944
4945 -- Case of pragma placed immediately after body
4946
4947 elsif Nkind (Decl) = N_Subprogram_Declaration
4948 and then Present (Corresponding_Body (Decl))
4949 then
4950 OK := Parent (N) =
4951 Aux_Decls_Node
4952 (Parent (Unit_Declaration_Node
4953 (Corresponding_Body (Decl))));
4954
4955 -- All other cases are illegal
4956
4957 else
4958 OK := False;
4959 end if;
4960 end;
4961
4962 -- Special restricted placement rule from 10.2.1(11.8/2)
4963
4964 elsif Is_Generic_Formal (Ent)
4965 and then Prag_Id = Pragma_Preelaborable_Initialization
4966 then
4967 OK := List_Containing (N) =
4968 Generic_Formal_Declarations
4969 (Unit_Declaration_Node (Scop));
4970
4971 -- If this is an aspect applied to a subprogram body, the
4972 -- pragma is inserted in its declarative part.
4973
4974 elsif From_Aspect_Specification (N)
4975 and then Ent = Current_Scope
4976 and then
4977 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
4978 then
4979 OK := True;
4980
4981 -- If the aspect is a predicate (possibly others ???) and the
4982 -- context is a record type, this is a discriminant expression
4983 -- within a type declaration, that freezes the predicated
4984 -- subtype.
4985
4986 elsif From_Aspect_Specification (N)
4987 and then Prag_Id = Pragma_Predicate
4988 and then Ekind (Current_Scope) = E_Record_Type
4989 and then Scop = Scope (Current_Scope)
4990 then
4991 OK := True;
4992
4993 -- Default case, just check that the pragma occurs in the scope
4994 -- of the entity denoted by the name.
4995
4996 else
4997 OK := Current_Scope = Scop;
4998 end if;
4999
5000 if not OK then
5001 Error_Pragma_Arg
5002 ("pragma% argument must be in same declarative part", Arg);
5003 end if;
5004 end;
5005 end if;
5006 end Check_Arg_Is_Local_Name;
5007
5008 ---------------------------------
5009 -- Check_Arg_Is_Locking_Policy --
5010 ---------------------------------
5011
5012 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5013 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5014
5015 begin
5016 Check_Arg_Is_Identifier (Argx);
5017
5018 if not Is_Locking_Policy_Name (Chars (Argx)) then
5019 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5020 end if;
5021 end Check_Arg_Is_Locking_Policy;
5022
5023 -----------------------------------------------
5024 -- Check_Arg_Is_Partition_Elaboration_Policy --
5025 -----------------------------------------------
5026
5027 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5028 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5029
5030 begin
5031 Check_Arg_Is_Identifier (Argx);
5032
5033 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5034 Error_Pragma_Arg
5035 ("& is not a valid partition elaboration policy name", Argx);
5036 end if;
5037 end Check_Arg_Is_Partition_Elaboration_Policy;
5038
5039 -------------------------
5040 -- Check_Arg_Is_One_Of --
5041 -------------------------
5042
5043 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5044 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5045
5046 begin
5047 Check_Arg_Is_Identifier (Argx);
5048
5049 if not Nam_In (Chars (Argx), N1, N2) then
5050 Error_Msg_Name_2 := N1;
5051 Error_Msg_Name_3 := N2;
5052 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5053 end if;
5054 end Check_Arg_Is_One_Of;
5055
5056 procedure Check_Arg_Is_One_Of
5057 (Arg : Node_Id;
5058 N1, N2, N3 : Name_Id)
5059 is
5060 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5061
5062 begin
5063 Check_Arg_Is_Identifier (Argx);
5064
5065 if not Nam_In (Chars (Argx), N1, N2, N3) then
5066 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5067 end if;
5068 end Check_Arg_Is_One_Of;
5069
5070 procedure Check_Arg_Is_One_Of
5071 (Arg : Node_Id;
5072 N1, N2, N3, N4 : Name_Id)
5073 is
5074 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5075
5076 begin
5077 Check_Arg_Is_Identifier (Argx);
5078
5079 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5080 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5081 end if;
5082 end Check_Arg_Is_One_Of;
5083
5084 procedure Check_Arg_Is_One_Of
5085 (Arg : Node_Id;
5086 N1, N2, N3, N4, N5 : Name_Id)
5087 is
5088 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5089
5090 begin
5091 Check_Arg_Is_Identifier (Argx);
5092
5093 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5094 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5095 end if;
5096 end Check_Arg_Is_One_Of;
5097
5098 ---------------------------------
5099 -- Check_Arg_Is_Queuing_Policy --
5100 ---------------------------------
5101
5102 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5103 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5104
5105 begin
5106 Check_Arg_Is_Identifier (Argx);
5107
5108 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5109 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5110 end if;
5111 end Check_Arg_Is_Queuing_Policy;
5112
5113 ---------------------------------------
5114 -- Check_Arg_Is_OK_Static_Expression --
5115 ---------------------------------------
5116
5117 procedure Check_Arg_Is_OK_Static_Expression
5118 (Arg : Node_Id;
5119 Typ : Entity_Id := Empty)
5120 is
5121 begin
5122 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5123 end Check_Arg_Is_OK_Static_Expression;
5124
5125 ------------------------------------------
5126 -- Check_Arg_Is_Task_Dispatching_Policy --
5127 ------------------------------------------
5128
5129 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5130 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5131
5132 begin
5133 Check_Arg_Is_Identifier (Argx);
5134
5135 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5136 Error_Pragma_Arg
5137 ("& is not an allowed task dispatching policy name", Argx);
5138 end if;
5139 end Check_Arg_Is_Task_Dispatching_Policy;
5140
5141 ---------------------
5142 -- Check_Arg_Order --
5143 ---------------------
5144
5145 procedure Check_Arg_Order (Names : Name_List) is
5146 Arg : Node_Id;
5147
5148 Highest_So_Far : Natural := 0;
5149 -- Highest index in Names seen do far
5150
5151 begin
5152 Arg := Arg1;
5153 for J in 1 .. Arg_Count loop
5154 if Chars (Arg) /= No_Name then
5155 for K in Names'Range loop
5156 if Chars (Arg) = Names (K) then
5157 if K < Highest_So_Far then
5158 Error_Msg_Name_1 := Pname;
5159 Error_Msg_N
5160 ("parameters out of order for pragma%", Arg);
5161 Error_Msg_Name_1 := Names (K);
5162 Error_Msg_Name_2 := Names (Highest_So_Far);
5163 Error_Msg_N ("\% must appear before %", Arg);
5164 raise Pragma_Exit;
5165
5166 else
5167 Highest_So_Far := K;
5168 end if;
5169 end if;
5170 end loop;
5171 end if;
5172
5173 Arg := Next (Arg);
5174 end loop;
5175 end Check_Arg_Order;
5176
5177 --------------------------------
5178 -- Check_At_Least_N_Arguments --
5179 --------------------------------
5180
5181 procedure Check_At_Least_N_Arguments (N : Nat) is
5182 begin
5183 if Arg_Count < N then
5184 Error_Pragma ("too few arguments for pragma%");
5185 end if;
5186 end Check_At_Least_N_Arguments;
5187
5188 -------------------------------
5189 -- Check_At_Most_N_Arguments --
5190 -------------------------------
5191
5192 procedure Check_At_Most_N_Arguments (N : Nat) is
5193 Arg : Node_Id;
5194 begin
5195 if Arg_Count > N then
5196 Arg := Arg1;
5197 for J in 1 .. N loop
5198 Next (Arg);
5199 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5200 end loop;
5201 end if;
5202 end Check_At_Most_N_Arguments;
5203
5204 ---------------------
5205 -- Check_Component --
5206 ---------------------
5207
5208 procedure Check_Component
5209 (Comp : Node_Id;
5210 UU_Typ : Entity_Id;
5211 In_Variant_Part : Boolean := False)
5212 is
5213 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5214 Sindic : constant Node_Id :=
5215 Subtype_Indication (Component_Definition (Comp));
5216 Typ : constant Entity_Id := Etype (Comp_Id);
5217
5218 begin
5219 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5220 -- object constraint, then the component type shall be an Unchecked_
5221 -- Union.
5222
5223 if Nkind (Sindic) = N_Subtype_Indication
5224 and then Has_Per_Object_Constraint (Comp_Id)
5225 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5226 then
5227 Error_Msg_N
5228 ("component subtype subject to per-object constraint "
5229 & "must be an Unchecked_Union", Comp);
5230
5231 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5232 -- the body of a generic unit, or within the body of any of its
5233 -- descendant library units, no part of the type of a component
5234 -- declared in a variant_part of the unchecked union type shall be of
5235 -- a formal private type or formal private extension declared within
5236 -- the formal part of the generic unit.
5237
5238 elsif Ada_Version >= Ada_2012
5239 and then In_Generic_Body (UU_Typ)
5240 and then In_Variant_Part
5241 and then Is_Private_Type (Typ)
5242 and then Is_Generic_Type (Typ)
5243 then
5244 Error_Msg_N
5245 ("component of unchecked union cannot be of generic type", Comp);
5246
5247 elsif Needs_Finalization (Typ) then
5248 Error_Msg_N
5249 ("component of unchecked union cannot be controlled", Comp);
5250
5251 elsif Has_Task (Typ) then
5252 Error_Msg_N
5253 ("component of unchecked union cannot have tasks", Comp);
5254 end if;
5255 end Check_Component;
5256
5257 ----------------------------
5258 -- Check_Duplicate_Pragma --
5259 ----------------------------
5260
5261 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5262 Id : Entity_Id := E;
5263 P : Node_Id;
5264
5265 begin
5266 -- Nothing to do if this pragma comes from an aspect specification,
5267 -- since we could not be duplicating a pragma, and we dealt with the
5268 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5269
5270 if From_Aspect_Specification (N) then
5271 return;
5272 end if;
5273
5274 -- Otherwise current pragma may duplicate previous pragma or a
5275 -- previously given aspect specification or attribute definition
5276 -- clause for the same pragma.
5277
5278 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5279
5280 if Present (P) then
5281
5282 -- If the entity is a type, then we have to make sure that the
5283 -- ostensible duplicate is not for a parent type from which this
5284 -- type is derived.
5285
5286 if Is_Type (E) then
5287 if Nkind (P) = N_Pragma then
5288 declare
5289 Args : constant List_Id :=
5290 Pragma_Argument_Associations (P);
5291 begin
5292 if Present (Args)
5293 and then Is_Entity_Name (Expression (First (Args)))
5294 and then Is_Type (Entity (Expression (First (Args))))
5295 and then Entity (Expression (First (Args))) /= E
5296 then
5297 return;
5298 end if;
5299 end;
5300
5301 elsif Nkind (P) = N_Aspect_Specification
5302 and then Is_Type (Entity (P))
5303 and then Entity (P) /= E
5304 then
5305 return;
5306 end if;
5307 end if;
5308
5309 -- Here we have a definite duplicate
5310
5311 Error_Msg_Name_1 := Pragma_Name (N);
5312 Error_Msg_Sloc := Sloc (P);
5313
5314 -- For a single protected or a single task object, the error is
5315 -- issued on the original entity.
5316
5317 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5318 Id := Defining_Identifier (Original_Node (Parent (Id)));
5319 end if;
5320
5321 if Nkind (P) = N_Aspect_Specification
5322 or else From_Aspect_Specification (P)
5323 then
5324 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5325 else
5326 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5327 end if;
5328
5329 raise Pragma_Exit;
5330 end if;
5331 end Check_Duplicate_Pragma;
5332
5333 ----------------------------------
5334 -- Check_Duplicated_Export_Name --
5335 ----------------------------------
5336
5337 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5338 String_Val : constant String_Id := Strval (Nam);
5339
5340 begin
5341 -- We are only interested in the export case, and in the case of
5342 -- generics, it is the instance, not the template, that is the
5343 -- problem (the template will generate a warning in any case).
5344
5345 if not Inside_A_Generic
5346 and then (Prag_Id = Pragma_Export
5347 or else
5348 Prag_Id = Pragma_Export_Procedure
5349 or else
5350 Prag_Id = Pragma_Export_Valued_Procedure
5351 or else
5352 Prag_Id = Pragma_Export_Function)
5353 then
5354 for J in Externals.First .. Externals.Last loop
5355 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5356 Error_Msg_Sloc := Sloc (Externals.Table (J));
5357 Error_Msg_N ("external name duplicates name given#", Nam);
5358 exit;
5359 end if;
5360 end loop;
5361
5362 Externals.Append (Nam);
5363 end if;
5364 end Check_Duplicated_Export_Name;
5365
5366 ----------------------------------------
5367 -- Check_Expr_Is_OK_Static_Expression --
5368 ----------------------------------------
5369
5370 procedure Check_Expr_Is_OK_Static_Expression
5371 (Expr : Node_Id;
5372 Typ : Entity_Id := Empty)
5373 is
5374 begin
5375 if Present (Typ) then
5376 Analyze_And_Resolve (Expr, Typ);
5377 else
5378 Analyze_And_Resolve (Expr);
5379 end if;
5380
5381 -- An expression cannot be considered static if its resolution failed
5382 -- or if it's erroneous. Stop the analysis of the related pragma.
5383
5384 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5385 raise Pragma_Exit;
5386
5387 elsif Is_OK_Static_Expression (Expr) then
5388 return;
5389
5390 -- An interesting special case, if we have a string literal and we
5391 -- are in Ada 83 mode, then we allow it even though it will not be
5392 -- flagged as static. This allows the use of Ada 95 pragmas like
5393 -- Import in Ada 83 mode. They will of course be flagged with
5394 -- warnings as usual, but will not cause errors.
5395
5396 elsif Ada_Version = Ada_83
5397 and then Nkind (Expr) = N_String_Literal
5398 then
5399 return;
5400
5401 -- Finally, we have a real error
5402
5403 else
5404 Error_Msg_Name_1 := Pname;
5405 Flag_Non_Static_Expr
5406 (Fix_Error ("argument for pragma% must be a static expression!"),
5407 Expr);
5408 raise Pragma_Exit;
5409 end if;
5410 end Check_Expr_Is_OK_Static_Expression;
5411
5412 -------------------------
5413 -- Check_First_Subtype --
5414 -------------------------
5415
5416 procedure Check_First_Subtype (Arg : Node_Id) is
5417 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5418 Ent : constant Entity_Id := Entity (Argx);
5419
5420 begin
5421 if Is_First_Subtype (Ent) then
5422 null;
5423
5424 elsif Is_Type (Ent) then
5425 Error_Pragma_Arg
5426 ("pragma% cannot apply to subtype", Argx);
5427
5428 elsif Is_Object (Ent) then
5429 Error_Pragma_Arg
5430 ("pragma% cannot apply to object, requires a type", Argx);
5431
5432 else
5433 Error_Pragma_Arg
5434 ("pragma% cannot apply to&, requires a type", Argx);
5435 end if;
5436 end Check_First_Subtype;
5437
5438 ----------------------
5439 -- Check_Identifier --
5440 ----------------------
5441
5442 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5443 begin
5444 if Present (Arg)
5445 and then Nkind (Arg) = N_Pragma_Argument_Association
5446 then
5447 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5448 Error_Msg_Name_1 := Pname;
5449 Error_Msg_Name_2 := Id;
5450 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5451 raise Pragma_Exit;
5452 end if;
5453 end if;
5454 end Check_Identifier;
5455
5456 --------------------------------
5457 -- Check_Identifier_Is_One_Of --
5458 --------------------------------
5459
5460 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5461 begin
5462 if Present (Arg)
5463 and then Nkind (Arg) = N_Pragma_Argument_Association
5464 then
5465 if Chars (Arg) = No_Name then
5466 Error_Msg_Name_1 := Pname;
5467 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5468 raise Pragma_Exit;
5469
5470 elsif Chars (Arg) /= N1
5471 and then Chars (Arg) /= N2
5472 then
5473 Error_Msg_Name_1 := Pname;
5474 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5475 raise Pragma_Exit;
5476 end if;
5477 end if;
5478 end Check_Identifier_Is_One_Of;
5479
5480 ---------------------------
5481 -- Check_In_Main_Program --
5482 ---------------------------
5483
5484 procedure Check_In_Main_Program is
5485 P : constant Node_Id := Parent (N);
5486
5487 begin
5488 -- Must be in subprogram body
5489
5490 if Nkind (P) /= N_Subprogram_Body then
5491 Error_Pragma ("% pragma allowed only in subprogram");
5492
5493 -- Otherwise warn if obviously not main program
5494
5495 elsif Present (Parameter_Specifications (Specification (P)))
5496 or else not Is_Compilation_Unit (Defining_Entity (P))
5497 then
5498 Error_Msg_Name_1 := Pname;
5499 Error_Msg_N
5500 ("??pragma% is only effective in main program", N);
5501 end if;
5502 end Check_In_Main_Program;
5503
5504 ---------------------------------------
5505 -- Check_Interrupt_Or_Attach_Handler --
5506 ---------------------------------------
5507
5508 procedure Check_Interrupt_Or_Attach_Handler is
5509 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5510 Handler_Proc, Proc_Scope : Entity_Id;
5511
5512 begin
5513 Analyze (Arg1_X);
5514
5515 if Prag_Id = Pragma_Interrupt_Handler then
5516 Check_Restriction (No_Dynamic_Attachment, N);
5517 end if;
5518
5519 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5520 Proc_Scope := Scope (Handler_Proc);
5521
5522 if Ekind (Proc_Scope) /= E_Protected_Type then
5523 Error_Pragma_Arg
5524 ("argument of pragma% must be protected procedure", Arg1);
5525 end if;
5526
5527 -- For pragma case (as opposed to access case), check placement.
5528 -- We don't need to do that for aspects, because we have the
5529 -- check that they aspect applies an appropriate procedure.
5530
5531 if not From_Aspect_Specification (N)
5532 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5533 then
5534 Error_Pragma ("pragma% must be in protected definition");
5535 end if;
5536
5537 if not Is_Library_Level_Entity (Proc_Scope) then
5538 Error_Pragma_Arg
5539 ("argument for pragma% must be library level entity", Arg1);
5540 end if;
5541
5542 -- AI05-0033: A pragma cannot appear within a generic body, because
5543 -- instance can be in a nested scope. The check that protected type
5544 -- is itself a library-level declaration is done elsewhere.
5545
5546 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5547 -- handle code prior to AI-0033. Analysis tools typically are not
5548 -- interested in this pragma in any case, so no need to worry too
5549 -- much about its placement.
5550
5551 if Inside_A_Generic then
5552 if Ekind (Scope (Current_Scope)) = E_Generic_Package
5553 and then In_Package_Body (Scope (Current_Scope))
5554 and then not Relaxed_RM_Semantics
5555 then
5556 Error_Pragma ("pragma% cannot be used inside a generic");
5557 end if;
5558 end if;
5559 end Check_Interrupt_Or_Attach_Handler;
5560
5561 ---------------------------------
5562 -- Check_Loop_Pragma_Placement --
5563 ---------------------------------
5564
5565 procedure Check_Loop_Pragma_Placement is
5566 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5567 -- Verify whether the current pragma is properly grouped with other
5568 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5569 -- related loop where the pragma appears.
5570
5571 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5572 -- Determine whether an arbitrary statement Stmt denotes pragma
5573 -- Loop_Invariant or Loop_Variant.
5574
5575 procedure Placement_Error (Constr : Node_Id);
5576 pragma No_Return (Placement_Error);
5577 -- Node Constr denotes the last loop restricted construct before we
5578 -- encountered an illegal relation between enclosing constructs. Emit
5579 -- an error depending on what Constr was.
5580
5581 --------------------------------
5582 -- Check_Loop_Pragma_Grouping --
5583 --------------------------------
5584
5585 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5586 Stop_Search : exception;
5587 -- This exception is used to terminate the recursive descent of
5588 -- routine Check_Grouping.
5589
5590 procedure Check_Grouping (L : List_Id);
5591 -- Find the first group of pragmas in list L and if successful,
5592 -- ensure that the current pragma is part of that group. The
5593 -- routine raises Stop_Search once such a check is performed to
5594 -- halt the recursive descent.
5595
5596 procedure Grouping_Error (Prag : Node_Id);
5597 pragma No_Return (Grouping_Error);
5598 -- Emit an error concerning the current pragma indicating that it
5599 -- should be placed after pragma Prag.
5600
5601 --------------------
5602 -- Check_Grouping --
5603 --------------------
5604
5605 procedure Check_Grouping (L : List_Id) is
5606 HSS : Node_Id;
5607 Prag : Node_Id;
5608 Stmt : Node_Id;
5609
5610 begin
5611 -- Inspect the list of declarations or statements looking for
5612 -- the first grouping of pragmas:
5613
5614 -- loop
5615 -- pragma Loop_Invariant ...;
5616 -- pragma Loop_Variant ...;
5617 -- . . . -- (1)
5618 -- pragma Loop_Variant ...; -- current pragma
5619
5620 -- If the current pragma is not in the grouping, then it must
5621 -- either appear in a different declarative or statement list
5622 -- or the construct at (1) is separating the pragma from the
5623 -- grouping.
5624
5625 Stmt := First (L);
5626 while Present (Stmt) loop
5627
5628 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5629 -- inside a loop or a block housed inside a loop. Inspect
5630 -- the declarations and statements of the block as they may
5631 -- contain the first grouping.
5632
5633 if Nkind (Stmt) = N_Block_Statement then
5634 HSS := Handled_Statement_Sequence (Stmt);
5635
5636 Check_Grouping (Declarations (Stmt));
5637
5638 if Present (HSS) then
5639 Check_Grouping (Statements (HSS));
5640 end if;
5641
5642 -- First pragma of the first topmost grouping has been found
5643
5644 elsif Is_Loop_Pragma (Stmt) then
5645
5646 -- The group and the current pragma are not in the same
5647 -- declarative or statement list.
5648
5649 if List_Containing (Stmt) /= List_Containing (N) then
5650 Grouping_Error (Stmt);
5651
5652 -- Try to reach the current pragma from the first pragma
5653 -- of the grouping while skipping other members:
5654
5655 -- pragma Loop_Invariant ...; -- first pragma
5656 -- pragma Loop_Variant ...; -- member
5657 -- . . .
5658 -- pragma Loop_Variant ...; -- current pragma
5659
5660 else
5661 while Present (Stmt) loop
5662
5663 -- The current pragma is either the first pragma
5664 -- of the group or is a member of the group. Stop
5665 -- the search as the placement is legal.
5666
5667 if Stmt = N then
5668 raise Stop_Search;
5669
5670 -- Skip group members, but keep track of the last
5671 -- pragma in the group.
5672
5673 elsif Is_Loop_Pragma (Stmt) then
5674 Prag := Stmt;
5675
5676 -- Skip declarations and statements generated by
5677 -- the compiler during expansion.
5678
5679 elsif not Comes_From_Source (Stmt) then
5680 null;
5681
5682 -- A non-pragma is separating the group from the
5683 -- current pragma, the placement is illegal.
5684
5685 else
5686 Grouping_Error (Prag);
5687 end if;
5688
5689 Next (Stmt);
5690 end loop;
5691
5692 -- If the traversal did not reach the current pragma,
5693 -- then the list must be malformed.
5694
5695 raise Program_Error;
5696 end if;
5697 end if;
5698
5699 Next (Stmt);
5700 end loop;
5701 end Check_Grouping;
5702
5703 --------------------
5704 -- Grouping_Error --
5705 --------------------
5706
5707 procedure Grouping_Error (Prag : Node_Id) is
5708 begin
5709 Error_Msg_Sloc := Sloc (Prag);
5710 Error_Pragma ("pragma% must appear next to pragma#");
5711 end Grouping_Error;
5712
5713 -- Start of processing for Check_Loop_Pragma_Grouping
5714
5715 begin
5716 -- Inspect the statements of the loop or nested blocks housed
5717 -- within to determine whether the current pragma is part of the
5718 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5719
5720 Check_Grouping (Statements (Loop_Stmt));
5721
5722 exception
5723 when Stop_Search => null;
5724 end Check_Loop_Pragma_Grouping;
5725
5726 --------------------
5727 -- Is_Loop_Pragma --
5728 --------------------
5729
5730 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5731 begin
5732 -- Inspect the original node as Loop_Invariant and Loop_Variant
5733 -- pragmas are rewritten to null when assertions are disabled.
5734
5735 if Nkind (Original_Node (Stmt)) = N_Pragma then
5736 return
5737 Nam_In (Pragma_Name (Original_Node (Stmt)),
5738 Name_Loop_Invariant,
5739 Name_Loop_Variant);
5740 else
5741 return False;
5742 end if;
5743 end Is_Loop_Pragma;
5744
5745 ---------------------
5746 -- Placement_Error --
5747 ---------------------
5748
5749 procedure Placement_Error (Constr : Node_Id) is
5750 LA : constant String := " with Loop_Entry";
5751
5752 begin
5753 if Prag_Id = Pragma_Assert then
5754 Error_Msg_String (1 .. LA'Length) := LA;
5755 Error_Msg_Strlen := LA'Length;
5756 else
5757 Error_Msg_Strlen := 0;
5758 end if;
5759
5760 if Nkind (Constr) = N_Pragma then
5761 Error_Pragma
5762 ("pragma %~ must appear immediately within the statements "
5763 & "of a loop");
5764 else
5765 Error_Pragma_Arg
5766 ("block containing pragma %~ must appear immediately within "
5767 & "the statements of a loop", Constr);
5768 end if;
5769 end Placement_Error;
5770
5771 -- Local declarations
5772
5773 Prev : Node_Id;
5774 Stmt : Node_Id;
5775
5776 -- Start of processing for Check_Loop_Pragma_Placement
5777
5778 begin
5779 -- Check that pragma appears immediately within a loop statement,
5780 -- ignoring intervening block statements.
5781
5782 Prev := N;
5783 Stmt := Parent (N);
5784 while Present (Stmt) loop
5785
5786 -- The pragma or previous block must appear immediately within the
5787 -- current block's declarative or statement part.
5788
5789 if Nkind (Stmt) = N_Block_Statement then
5790 if (No (Declarations (Stmt))
5791 or else List_Containing (Prev) /= Declarations (Stmt))
5792 and then
5793 List_Containing (Prev) /=
5794 Statements (Handled_Statement_Sequence (Stmt))
5795 then
5796 Placement_Error (Prev);
5797 return;
5798
5799 -- Keep inspecting the parents because we are now within a
5800 -- chain of nested blocks.
5801
5802 else
5803 Prev := Stmt;
5804 Stmt := Parent (Stmt);
5805 end if;
5806
5807 -- The pragma or previous block must appear immediately within the
5808 -- statements of the loop.
5809
5810 elsif Nkind (Stmt) = N_Loop_Statement then
5811 if List_Containing (Prev) /= Statements (Stmt) then
5812 Placement_Error (Prev);
5813 end if;
5814
5815 -- Stop the traversal because we reached the innermost loop
5816 -- regardless of whether we encountered an error or not.
5817
5818 exit;
5819
5820 -- Ignore a handled statement sequence. Note that this node may
5821 -- be related to a subprogram body in which case we will emit an
5822 -- error on the next iteration of the search.
5823
5824 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5825 Stmt := Parent (Stmt);
5826
5827 -- Any other statement breaks the chain from the pragma to the
5828 -- loop.
5829
5830 else
5831 Placement_Error (Prev);
5832 return;
5833 end if;
5834 end loop;
5835
5836 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5837 -- grouped together with other such pragmas.
5838
5839 if Is_Loop_Pragma (N) then
5840
5841 -- The previous check should have located the related loop
5842
5843 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5844 Check_Loop_Pragma_Grouping (Stmt);
5845 end if;
5846 end Check_Loop_Pragma_Placement;
5847
5848 -------------------------------------------
5849 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5850 -------------------------------------------
5851
5852 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5853 P : Node_Id;
5854
5855 begin
5856 P := Parent (N);
5857 loop
5858 if No (P) then
5859 exit;
5860
5861 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5862 exit;
5863
5864 elsif Nkind_In (P, N_Package_Specification,
5865 N_Block_Statement)
5866 then
5867 return;
5868
5869 -- Note: the following tests seem a little peculiar, because
5870 -- they test for bodies, but if we were in the statement part
5871 -- of the body, we would already have hit the handled statement
5872 -- sequence, so the only way we get here is by being in the
5873 -- declarative part of the body.
5874
5875 elsif Nkind_In (P, N_Subprogram_Body,
5876 N_Package_Body,
5877 N_Task_Body,
5878 N_Entry_Body)
5879 then
5880 return;
5881 end if;
5882
5883 P := Parent (P);
5884 end loop;
5885
5886 Error_Pragma ("pragma% is not in declarative part or package spec");
5887 end Check_Is_In_Decl_Part_Or_Package_Spec;
5888
5889 -------------------------
5890 -- Check_No_Identifier --
5891 -------------------------
5892
5893 procedure Check_No_Identifier (Arg : Node_Id) is
5894 begin
5895 if Nkind (Arg) = N_Pragma_Argument_Association
5896 and then Chars (Arg) /= No_Name
5897 then
5898 Error_Pragma_Arg_Ident
5899 ("pragma% does not permit identifier& here", Arg);
5900 end if;
5901 end Check_No_Identifier;
5902
5903 --------------------------
5904 -- Check_No_Identifiers --
5905 --------------------------
5906
5907 procedure Check_No_Identifiers is
5908 Arg_Node : Node_Id;
5909 begin
5910 Arg_Node := Arg1;
5911 for J in 1 .. Arg_Count loop
5912 Check_No_Identifier (Arg_Node);
5913 Next (Arg_Node);
5914 end loop;
5915 end Check_No_Identifiers;
5916
5917 ------------------------
5918 -- Check_No_Link_Name --
5919 ------------------------
5920
5921 procedure Check_No_Link_Name is
5922 begin
5923 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
5924 Arg4 := Arg3;
5925 end if;
5926
5927 if Present (Arg4) then
5928 Error_Pragma_Arg
5929 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
5930 end if;
5931 end Check_No_Link_Name;
5932
5933 -------------------------------
5934 -- Check_Optional_Identifier --
5935 -------------------------------
5936
5937 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
5938 begin
5939 if Present (Arg)
5940 and then Nkind (Arg) = N_Pragma_Argument_Association
5941 and then Chars (Arg) /= No_Name
5942 then
5943 if Chars (Arg) /= Id then
5944 Error_Msg_Name_1 := Pname;
5945 Error_Msg_Name_2 := Id;
5946 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5947 raise Pragma_Exit;
5948 end if;
5949 end if;
5950 end Check_Optional_Identifier;
5951
5952 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
5953 begin
5954 Name_Buffer (1 .. Id'Length) := Id;
5955 Name_Len := Id'Length;
5956 Check_Optional_Identifier (Arg, Name_Find);
5957 end Check_Optional_Identifier;
5958
5959 -------------------------------------
5960 -- Check_Static_Boolean_Expression --
5961 -------------------------------------
5962
5963 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
5964 begin
5965 if Present (Expr) then
5966 Analyze_And_Resolve (Expr, Standard_Boolean);
5967
5968 if not Is_OK_Static_Expression (Expr) then
5969 Error_Pragma_Arg
5970 ("expression of pragma % must be static", Expr);
5971 end if;
5972 end if;
5973 end Check_Static_Boolean_Expression;
5974
5975 -----------------------------
5976 -- Check_Static_Constraint --
5977 -----------------------------
5978
5979 -- Note: for convenience in writing this procedure, in addition to
5980 -- the officially (i.e. by spec) allowed argument which is always a
5981 -- constraint, it also allows ranges and discriminant associations.
5982 -- Above is not clear ???
5983
5984 procedure Check_Static_Constraint (Constr : Node_Id) is
5985
5986 procedure Require_Static (E : Node_Id);
5987 -- Require given expression to be static expression
5988
5989 --------------------
5990 -- Require_Static --
5991 --------------------
5992
5993 procedure Require_Static (E : Node_Id) is
5994 begin
5995 if not Is_OK_Static_Expression (E) then
5996 Flag_Non_Static_Expr
5997 ("non-static constraint not allowed in Unchecked_Union!", E);
5998 raise Pragma_Exit;
5999 end if;
6000 end Require_Static;
6001
6002 -- Start of processing for Check_Static_Constraint
6003
6004 begin
6005 case Nkind (Constr) is
6006 when N_Discriminant_Association =>
6007 Require_Static (Expression (Constr));
6008
6009 when N_Range =>
6010 Require_Static (Low_Bound (Constr));
6011 Require_Static (High_Bound (Constr));
6012
6013 when N_Attribute_Reference =>
6014 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6015 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6016
6017 when N_Range_Constraint =>
6018 Check_Static_Constraint (Range_Expression (Constr));
6019
6020 when N_Index_Or_Discriminant_Constraint =>
6021 declare
6022 IDC : Entity_Id;
6023 begin
6024 IDC := First (Constraints (Constr));
6025 while Present (IDC) loop
6026 Check_Static_Constraint (IDC);
6027 Next (IDC);
6028 end loop;
6029 end;
6030
6031 when others =>
6032 null;
6033 end case;
6034 end Check_Static_Constraint;
6035
6036 --------------------------------------
6037 -- Check_Valid_Configuration_Pragma --
6038 --------------------------------------
6039
6040 -- A configuration pragma must appear in the context clause of a
6041 -- compilation unit, and only other pragmas may precede it. Note that
6042 -- the test also allows use in a configuration pragma file.
6043
6044 procedure Check_Valid_Configuration_Pragma is
6045 begin
6046 if not Is_Configuration_Pragma then
6047 Error_Pragma ("incorrect placement for configuration pragma%");
6048 end if;
6049 end Check_Valid_Configuration_Pragma;
6050
6051 -------------------------------------
6052 -- Check_Valid_Library_Unit_Pragma --
6053 -------------------------------------
6054
6055 procedure Check_Valid_Library_Unit_Pragma is
6056 Plist : List_Id;
6057 Parent_Node : Node_Id;
6058 Unit_Name : Entity_Id;
6059 Unit_Kind : Node_Kind;
6060 Unit_Node : Node_Id;
6061 Sindex : Source_File_Index;
6062
6063 begin
6064 if not Is_List_Member (N) then
6065 Pragma_Misplaced;
6066
6067 else
6068 Plist := List_Containing (N);
6069 Parent_Node := Parent (Plist);
6070
6071 if Parent_Node = Empty then
6072 Pragma_Misplaced;
6073
6074 -- Case of pragma appearing after a compilation unit. In this case
6075 -- it must have an argument with the corresponding name and must
6076 -- be part of the following pragmas of its parent.
6077
6078 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6079 if Plist /= Pragmas_After (Parent_Node) then
6080 Pragma_Misplaced;
6081
6082 elsif Arg_Count = 0 then
6083 Error_Pragma
6084 ("argument required if outside compilation unit");
6085
6086 else
6087 Check_No_Identifiers;
6088 Check_Arg_Count (1);
6089 Unit_Node := Unit (Parent (Parent_Node));
6090 Unit_Kind := Nkind (Unit_Node);
6091
6092 Analyze (Get_Pragma_Arg (Arg1));
6093
6094 if Unit_Kind = N_Generic_Subprogram_Declaration
6095 or else Unit_Kind = N_Subprogram_Declaration
6096 then
6097 Unit_Name := Defining_Entity (Unit_Node);
6098
6099 elsif Unit_Kind in N_Generic_Instantiation then
6100 Unit_Name := Defining_Entity (Unit_Node);
6101
6102 else
6103 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6104 end if;
6105
6106 if Chars (Unit_Name) /=
6107 Chars (Entity (Get_Pragma_Arg (Arg1)))
6108 then
6109 Error_Pragma_Arg
6110 ("pragma% argument is not current unit name", Arg1);
6111 end if;
6112
6113 if Ekind (Unit_Name) = E_Package
6114 and then Present (Renamed_Entity (Unit_Name))
6115 then
6116 Error_Pragma ("pragma% not allowed for renamed package");
6117 end if;
6118 end if;
6119
6120 -- Pragma appears other than after a compilation unit
6121
6122 else
6123 -- Here we check for the generic instantiation case and also
6124 -- for the case of processing a generic formal package. We
6125 -- detect these cases by noting that the Sloc on the node
6126 -- does not belong to the current compilation unit.
6127
6128 Sindex := Source_Index (Current_Sem_Unit);
6129
6130 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6131 Rewrite (N, Make_Null_Statement (Loc));
6132 return;
6133
6134 -- If before first declaration, the pragma applies to the
6135 -- enclosing unit, and the name if present must be this name.
6136
6137 elsif Is_Before_First_Decl (N, Plist) then
6138 Unit_Node := Unit_Declaration_Node (Current_Scope);
6139 Unit_Kind := Nkind (Unit_Node);
6140
6141 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6142 Pragma_Misplaced;
6143
6144 elsif Unit_Kind = N_Subprogram_Body
6145 and then not Acts_As_Spec (Unit_Node)
6146 then
6147 Pragma_Misplaced;
6148
6149 elsif Nkind (Parent_Node) = N_Package_Body then
6150 Pragma_Misplaced;
6151
6152 elsif Nkind (Parent_Node) = N_Package_Specification
6153 and then Plist = Private_Declarations (Parent_Node)
6154 then
6155 Pragma_Misplaced;
6156
6157 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6158 or else Nkind (Parent_Node) =
6159 N_Generic_Subprogram_Declaration)
6160 and then Plist = Generic_Formal_Declarations (Parent_Node)
6161 then
6162 Pragma_Misplaced;
6163
6164 elsif Arg_Count > 0 then
6165 Analyze (Get_Pragma_Arg (Arg1));
6166
6167 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6168 Error_Pragma_Arg
6169 ("name in pragma% must be enclosing unit", Arg1);
6170 end if;
6171
6172 -- It is legal to have no argument in this context
6173
6174 else
6175 return;
6176 end if;
6177
6178 -- Error if not before first declaration. This is because a
6179 -- library unit pragma argument must be the name of a library
6180 -- unit (RM 10.1.5(7)), but the only names permitted in this
6181 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6182 -- generic subprogram declarations or generic instantiations.
6183
6184 else
6185 Error_Pragma
6186 ("pragma% misplaced, must be before first declaration");
6187 end if;
6188 end if;
6189 end if;
6190 end Check_Valid_Library_Unit_Pragma;
6191
6192 -------------------
6193 -- Check_Variant --
6194 -------------------
6195
6196 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6197 Clist : constant Node_Id := Component_List (Variant);
6198 Comp : Node_Id;
6199
6200 begin
6201 Comp := First (Component_Items (Clist));
6202 while Present (Comp) loop
6203 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6204 Next (Comp);
6205 end loop;
6206 end Check_Variant;
6207
6208 ---------------------------
6209 -- Ensure_Aggregate_Form --
6210 ---------------------------
6211
6212 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6213 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6214 Expr : constant Node_Id := Expression (Arg);
6215 Loc : constant Source_Ptr := Sloc (Expr);
6216 Comps : List_Id := No_List;
6217 Exprs : List_Id := No_List;
6218 Nam : Name_Id := No_Name;
6219 Nam_Loc : Source_Ptr;
6220
6221 begin
6222 -- The pragma argument is in positional form:
6223
6224 -- pragma Depends (Nam => ...)
6225 -- ^
6226 -- Chars field
6227
6228 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6229 -- argument association.
6230
6231 if Nkind (Arg) = N_Pragma_Argument_Association then
6232 Nam := Chars (Arg);
6233 Nam_Loc := Sloc (Arg);
6234
6235 -- Remove the pragma argument name as this will be captured in the
6236 -- aggregate.
6237
6238 Set_Chars (Arg, No_Name);
6239 end if;
6240
6241 -- The argument is already in aggregate form, but the presence of a
6242 -- name causes this to be interpreted as named association which in
6243 -- turn must be converted into an aggregate.
6244
6245 -- pragma Global (In_Out => (A, B, C))
6246 -- ^ ^
6247 -- name aggregate
6248
6249 -- pragma Global ((In_Out => (A, B, C)))
6250 -- ^ ^
6251 -- aggregate aggregate
6252
6253 if Nkind (Expr) = N_Aggregate then
6254 if Nam = No_Name then
6255 return;
6256 end if;
6257
6258 -- Do not transform a null argument into an aggregate as N_Null has
6259 -- special meaning in formal verification pragmas.
6260
6261 elsif Nkind (Expr) = N_Null then
6262 return;
6263 end if;
6264
6265 -- Everything comes from source if the original comes from source
6266
6267 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6268
6269 -- Positional argument is transformed into an aggregate with an
6270 -- Expressions list.
6271
6272 if Nam = No_Name then
6273 Exprs := New_List (Relocate_Node (Expr));
6274
6275 -- An associative argument is transformed into an aggregate with
6276 -- Component_Associations.
6277
6278 else
6279 Comps := New_List (
6280 Make_Component_Association (Loc,
6281 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6282 Expression => Relocate_Node (Expr)));
6283 end if;
6284
6285 Set_Expression (Arg,
6286 Make_Aggregate (Loc,
6287 Component_Associations => Comps,
6288 Expressions => Exprs));
6289
6290 -- Restore Comes_From_Source default
6291
6292 Set_Comes_From_Source_Default (CFSD);
6293 end Ensure_Aggregate_Form;
6294
6295 ------------------
6296 -- Error_Pragma --
6297 ------------------
6298
6299 procedure Error_Pragma (Msg : String) is
6300 begin
6301 Error_Msg_Name_1 := Pname;
6302 Error_Msg_N (Fix_Error (Msg), N);
6303 raise Pragma_Exit;
6304 end Error_Pragma;
6305
6306 ----------------------
6307 -- Error_Pragma_Arg --
6308 ----------------------
6309
6310 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6311 begin
6312 Error_Msg_Name_1 := Pname;
6313 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6314 raise Pragma_Exit;
6315 end Error_Pragma_Arg;
6316
6317 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6318 begin
6319 Error_Msg_Name_1 := Pname;
6320 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6321 Error_Pragma_Arg (Msg2, Arg);
6322 end Error_Pragma_Arg;
6323
6324 ----------------------------
6325 -- Error_Pragma_Arg_Ident --
6326 ----------------------------
6327
6328 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6329 begin
6330 Error_Msg_Name_1 := Pname;
6331 Error_Msg_N (Fix_Error (Msg), Arg);
6332 raise Pragma_Exit;
6333 end Error_Pragma_Arg_Ident;
6334
6335 ----------------------
6336 -- Error_Pragma_Ref --
6337 ----------------------
6338
6339 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6340 begin
6341 Error_Msg_Name_1 := Pname;
6342 Error_Msg_Sloc := Sloc (Ref);
6343 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6344 raise Pragma_Exit;
6345 end Error_Pragma_Ref;
6346
6347 ------------------------
6348 -- Find_Lib_Unit_Name --
6349 ------------------------
6350
6351 function Find_Lib_Unit_Name return Entity_Id is
6352 begin
6353 -- Return inner compilation unit entity, for case of nested
6354 -- categorization pragmas. This happens in generic unit.
6355
6356 if Nkind (Parent (N)) = N_Package_Specification
6357 and then Defining_Entity (Parent (N)) /= Current_Scope
6358 then
6359 return Defining_Entity (Parent (N));
6360 else
6361 return Current_Scope;
6362 end if;
6363 end Find_Lib_Unit_Name;
6364
6365 ----------------------------
6366 -- Find_Program_Unit_Name --
6367 ----------------------------
6368
6369 procedure Find_Program_Unit_Name (Id : Node_Id) is
6370 Unit_Name : Entity_Id;
6371 Unit_Kind : Node_Kind;
6372 P : constant Node_Id := Parent (N);
6373
6374 begin
6375 if Nkind (P) = N_Compilation_Unit then
6376 Unit_Kind := Nkind (Unit (P));
6377
6378 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6379 N_Package_Declaration)
6380 or else Unit_Kind in N_Generic_Declaration
6381 then
6382 Unit_Name := Defining_Entity (Unit (P));
6383
6384 if Chars (Id) = Chars (Unit_Name) then
6385 Set_Entity (Id, Unit_Name);
6386 Set_Etype (Id, Etype (Unit_Name));
6387 else
6388 Set_Etype (Id, Any_Type);
6389 Error_Pragma
6390 ("cannot find program unit referenced by pragma%");
6391 end if;
6392
6393 else
6394 Set_Etype (Id, Any_Type);
6395 Error_Pragma ("pragma% inapplicable to this unit");
6396 end if;
6397
6398 else
6399 Analyze (Id);
6400 end if;
6401 end Find_Program_Unit_Name;
6402
6403 -----------------------------------------
6404 -- Find_Unique_Parameterless_Procedure --
6405 -----------------------------------------
6406
6407 function Find_Unique_Parameterless_Procedure
6408 (Name : Entity_Id;
6409 Arg : Node_Id) return Entity_Id
6410 is
6411 Proc : Entity_Id := Empty;
6412
6413 begin
6414 -- The body of this procedure needs some comments ???
6415
6416 if not Is_Entity_Name (Name) then
6417 Error_Pragma_Arg
6418 ("argument of pragma% must be entity name", Arg);
6419
6420 elsif not Is_Overloaded (Name) then
6421 Proc := Entity (Name);
6422
6423 if Ekind (Proc) /= E_Procedure
6424 or else Present (First_Formal (Proc))
6425 then
6426 Error_Pragma_Arg
6427 ("argument of pragma% must be parameterless procedure", Arg);
6428 end if;
6429
6430 else
6431 declare
6432 Found : Boolean := False;
6433 It : Interp;
6434 Index : Interp_Index;
6435
6436 begin
6437 Get_First_Interp (Name, Index, It);
6438 while Present (It.Nam) loop
6439 Proc := It.Nam;
6440
6441 if Ekind (Proc) = E_Procedure
6442 and then No (First_Formal (Proc))
6443 then
6444 if not Found then
6445 Found := True;
6446 Set_Entity (Name, Proc);
6447 Set_Is_Overloaded (Name, False);
6448 else
6449 Error_Pragma_Arg
6450 ("ambiguous handler name for pragma% ", Arg);
6451 end if;
6452 end if;
6453
6454 Get_Next_Interp (Index, It);
6455 end loop;
6456
6457 if not Found then
6458 Error_Pragma_Arg
6459 ("argument of pragma% must be parameterless procedure",
6460 Arg);
6461 else
6462 Proc := Entity (Name);
6463 end if;
6464 end;
6465 end if;
6466
6467 return Proc;
6468 end Find_Unique_Parameterless_Procedure;
6469
6470 ---------------
6471 -- Fix_Error --
6472 ---------------
6473
6474 function Fix_Error (Msg : String) return String is
6475 Res : String (Msg'Range) := Msg;
6476 Res_Last : Natural := Msg'Last;
6477 J : Natural;
6478
6479 begin
6480 -- If we have a rewriting of another pragma, go to that pragma
6481
6482 if Is_Rewrite_Substitution (N)
6483 and then Nkind (Original_Node (N)) = N_Pragma
6484 then
6485 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6486 end if;
6487
6488 -- Case where pragma comes from an aspect specification
6489
6490 if From_Aspect_Specification (N) then
6491
6492 -- Change appearence of "pragma" in message to "aspect"
6493
6494 J := Res'First;
6495 while J <= Res_Last - 5 loop
6496 if Res (J .. J + 5) = "pragma" then
6497 Res (J .. J + 5) := "aspect";
6498 J := J + 6;
6499
6500 else
6501 J := J + 1;
6502 end if;
6503 end loop;
6504
6505 -- Change "argument of" at start of message to "entity for"
6506
6507 if Res'Length > 11
6508 and then Res (Res'First .. Res'First + 10) = "argument of"
6509 then
6510 Res (Res'First .. Res'First + 9) := "entity for";
6511 Res (Res'First + 10 .. Res_Last - 1) :=
6512 Res (Res'First + 11 .. Res_Last);
6513 Res_Last := Res_Last - 1;
6514 end if;
6515
6516 -- Change "argument" at start of message to "entity"
6517
6518 if Res'Length > 8
6519 and then Res (Res'First .. Res'First + 7) = "argument"
6520 then
6521 Res (Res'First .. Res'First + 5) := "entity";
6522 Res (Res'First + 6 .. Res_Last - 2) :=
6523 Res (Res'First + 8 .. Res_Last);
6524 Res_Last := Res_Last - 2;
6525 end if;
6526
6527 -- Get name from corresponding aspect
6528
6529 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6530 end if;
6531
6532 -- Return possibly modified message
6533
6534 return Res (Res'First .. Res_Last);
6535 end Fix_Error;
6536
6537 -------------------------
6538 -- Gather_Associations --
6539 -------------------------
6540
6541 procedure Gather_Associations
6542 (Names : Name_List;
6543 Args : out Args_List)
6544 is
6545 Arg : Node_Id;
6546
6547 begin
6548 -- Initialize all parameters to Empty
6549
6550 for J in Args'Range loop
6551 Args (J) := Empty;
6552 end loop;
6553
6554 -- That's all we have to do if there are no argument associations
6555
6556 if No (Pragma_Argument_Associations (N)) then
6557 return;
6558 end if;
6559
6560 -- Otherwise first deal with any positional parameters present
6561
6562 Arg := First (Pragma_Argument_Associations (N));
6563 for Index in Args'Range loop
6564 exit when No (Arg) or else Chars (Arg) /= No_Name;
6565 Args (Index) := Get_Pragma_Arg (Arg);
6566 Next (Arg);
6567 end loop;
6568
6569 -- Positional parameters all processed, if any left, then we
6570 -- have too many positional parameters.
6571
6572 if Present (Arg) and then Chars (Arg) = No_Name then
6573 Error_Pragma_Arg
6574 ("too many positional associations for pragma%", Arg);
6575 end if;
6576
6577 -- Process named parameters if any are present
6578
6579 while Present (Arg) loop
6580 if Chars (Arg) = No_Name then
6581 Error_Pragma_Arg
6582 ("positional association cannot follow named association",
6583 Arg);
6584
6585 else
6586 for Index in Names'Range loop
6587 if Names (Index) = Chars (Arg) then
6588 if Present (Args (Index)) then
6589 Error_Pragma_Arg
6590 ("duplicate argument association for pragma%", Arg);
6591 else
6592 Args (Index) := Get_Pragma_Arg (Arg);
6593 exit;
6594 end if;
6595 end if;
6596
6597 if Index = Names'Last then
6598 Error_Msg_Name_1 := Pname;
6599 Error_Msg_N ("pragma% does not allow & argument", Arg);
6600
6601 -- Check for possible misspelling
6602
6603 for Index1 in Names'Range loop
6604 if Is_Bad_Spelling_Of
6605 (Chars (Arg), Names (Index1))
6606 then
6607 Error_Msg_Name_1 := Names (Index1);
6608 Error_Msg_N -- CODEFIX
6609 ("\possible misspelling of%", Arg);
6610 exit;
6611 end if;
6612 end loop;
6613
6614 raise Pragma_Exit;
6615 end if;
6616 end loop;
6617 end if;
6618
6619 Next (Arg);
6620 end loop;
6621 end Gather_Associations;
6622
6623 -----------------
6624 -- GNAT_Pragma --
6625 -----------------
6626
6627 procedure GNAT_Pragma is
6628 begin
6629 -- We need to check the No_Implementation_Pragmas restriction for
6630 -- the case of a pragma from source. Note that the case of aspects
6631 -- generating corresponding pragmas marks these pragmas as not being
6632 -- from source, so this test also catches that case.
6633
6634 if Comes_From_Source (N) then
6635 Check_Restriction (No_Implementation_Pragmas, N);
6636 end if;
6637 end GNAT_Pragma;
6638
6639 --------------------------
6640 -- Is_Before_First_Decl --
6641 --------------------------
6642
6643 function Is_Before_First_Decl
6644 (Pragma_Node : Node_Id;
6645 Decls : List_Id) return Boolean
6646 is
6647 Item : Node_Id := First (Decls);
6648
6649 begin
6650 -- Only other pragmas can come before this pragma
6651
6652 loop
6653 if No (Item) or else Nkind (Item) /= N_Pragma then
6654 return False;
6655
6656 elsif Item = Pragma_Node then
6657 return True;
6658 end if;
6659
6660 Next (Item);
6661 end loop;
6662 end Is_Before_First_Decl;
6663
6664 -----------------------------
6665 -- Is_Configuration_Pragma --
6666 -----------------------------
6667
6668 -- A configuration pragma must appear in the context clause of a
6669 -- compilation unit, and only other pragmas may precede it. Note that
6670 -- the test below also permits use in a configuration pragma file.
6671
6672 function Is_Configuration_Pragma return Boolean is
6673 Lis : constant List_Id := List_Containing (N);
6674 Par : constant Node_Id := Parent (N);
6675 Prg : Node_Id;
6676
6677 begin
6678 -- If no parent, then we are in the configuration pragma file,
6679 -- so the placement is definitely appropriate.
6680
6681 if No (Par) then
6682 return True;
6683
6684 -- Otherwise we must be in the context clause of a compilation unit
6685 -- and the only thing allowed before us in the context list is more
6686 -- configuration pragmas.
6687
6688 elsif Nkind (Par) = N_Compilation_Unit
6689 and then Context_Items (Par) = Lis
6690 then
6691 Prg := First (Lis);
6692
6693 loop
6694 if Prg = N then
6695 return True;
6696 elsif Nkind (Prg) /= N_Pragma then
6697 return False;
6698 end if;
6699
6700 Next (Prg);
6701 end loop;
6702
6703 else
6704 return False;
6705 end if;
6706 end Is_Configuration_Pragma;
6707
6708 --------------------------
6709 -- Is_In_Context_Clause --
6710 --------------------------
6711
6712 function Is_In_Context_Clause return Boolean is
6713 Plist : List_Id;
6714 Parent_Node : Node_Id;
6715
6716 begin
6717 if not Is_List_Member (N) then
6718 return False;
6719
6720 else
6721 Plist := List_Containing (N);
6722 Parent_Node := Parent (Plist);
6723
6724 if Parent_Node = Empty
6725 or else Nkind (Parent_Node) /= N_Compilation_Unit
6726 or else Context_Items (Parent_Node) /= Plist
6727 then
6728 return False;
6729 end if;
6730 end if;
6731
6732 return True;
6733 end Is_In_Context_Clause;
6734
6735 ---------------------------------
6736 -- Is_Static_String_Expression --
6737 ---------------------------------
6738
6739 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6740 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6741 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6742
6743 begin
6744 Analyze_And_Resolve (Argx);
6745
6746 -- Special case Ada 83, where the expression will never be static,
6747 -- but we will return true if we had a string literal to start with.
6748
6749 if Ada_Version = Ada_83 then
6750 return Lit;
6751
6752 -- Normal case, true only if we end up with a string literal that
6753 -- is marked as being the result of evaluating a static expression.
6754
6755 else
6756 return Is_OK_Static_Expression (Argx)
6757 and then Nkind (Argx) = N_String_Literal;
6758 end if;
6759
6760 end Is_Static_String_Expression;
6761
6762 ----------------------
6763 -- Pragma_Misplaced --
6764 ----------------------
6765
6766 procedure Pragma_Misplaced is
6767 begin
6768 Error_Pragma ("incorrect placement of pragma%");
6769 end Pragma_Misplaced;
6770
6771 ------------------------------------------------
6772 -- Process_Atomic_Independent_Shared_Volatile --
6773 ------------------------------------------------
6774
6775 procedure Process_Atomic_Independent_Shared_Volatile is
6776 procedure Set_Atomic_VFA (E : Entity_Id);
6777 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6778 -- no explicit alignment was given, set alignment to unknown, since
6779 -- back end knows what the alignment requirements are for atomic and
6780 -- full access arrays. Note: this is necessary for derived types.
6781
6782 --------------------
6783 -- Set_Atomic_VFA --
6784 --------------------
6785
6786 procedure Set_Atomic_VFA (E : Entity_Id) is
6787 begin
6788 if Prag_Id = Pragma_Volatile_Full_Access then
6789 Set_Is_Volatile_Full_Access (E);
6790 else
6791 Set_Is_Atomic (E);
6792 end if;
6793
6794 if not Has_Alignment_Clause (E) then
6795 Set_Alignment (E, Uint_0);
6796 end if;
6797 end Set_Atomic_VFA;
6798
6799 -- Local variables
6800
6801 Decl : Node_Id;
6802 E : Entity_Id;
6803 E_Arg : Node_Id;
6804
6805 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6806
6807 begin
6808 Check_Ada_83_Warning;
6809 Check_No_Identifiers;
6810 Check_Arg_Count (1);
6811 Check_Arg_Is_Local_Name (Arg1);
6812 E_Arg := Get_Pragma_Arg (Arg1);
6813
6814 if Etype (E_Arg) = Any_Type then
6815 return;
6816 end if;
6817
6818 E := Entity (E_Arg);
6819 Decl := Declaration_Node (E);
6820
6821 -- A pragma that applies to a Ghost entity becomes Ghost for the
6822 -- purposes of legality checks and removal of ignored Ghost code.
6823
6824 Mark_Pragma_As_Ghost (N, E);
6825
6826 -- Check duplicate before we chain ourselves
6827
6828 Check_Duplicate_Pragma (E);
6829
6830 -- Check Atomic and VFA used together
6831
6832 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6833 or else (Is_Volatile_Full_Access (E)
6834 and then (Prag_Id = Pragma_Atomic
6835 or else
6836 Prag_Id = Pragma_Shared))
6837 then
6838 Error_Pragma
6839 ("cannot have Volatile_Full_Access and Atomic for same entity");
6840 end if;
6841
6842 -- Check for applying VFA to an entity which has aliased component
6843
6844 if Prag_Id = Pragma_Volatile_Full_Access then
6845 declare
6846 Comp : Entity_Id;
6847 Aliased_Comp : Boolean := False;
6848 -- Set True if aliased component present
6849
6850 begin
6851 if Is_Array_Type (Etype (E)) then
6852 Aliased_Comp := Has_Aliased_Components (Etype (E));
6853
6854 -- Record case, too bad Has_Aliased_Components is not also
6855 -- set for records, should it be ???
6856
6857 elsif Is_Record_Type (Etype (E)) then
6858 Comp := First_Component_Or_Discriminant (Etype (E));
6859 while Present (Comp) loop
6860 if Is_Aliased (Comp)
6861 or else Is_Aliased (Etype (Comp))
6862 then
6863 Aliased_Comp := True;
6864 exit;
6865 end if;
6866
6867 Next_Component_Or_Discriminant (Comp);
6868 end loop;
6869 end if;
6870
6871 if Aliased_Comp then
6872 Error_Pragma
6873 ("cannot apply Volatile_Full_Access (aliased component "
6874 & "present)");
6875 end if;
6876 end;
6877 end if;
6878
6879 -- Now check appropriateness of the entity
6880
6881 if Is_Type (E) then
6882 if Rep_Item_Too_Early (E, N)
6883 or else
6884 Rep_Item_Too_Late (E, N)
6885 then
6886 return;
6887 else
6888 Check_First_Subtype (Arg1);
6889 end if;
6890
6891 -- Attribute belongs on the base type. If the view of the type is
6892 -- currently private, it also belongs on the underlying type.
6893
6894 if Prag_Id = Pragma_Atomic
6895 or else
6896 Prag_Id = Pragma_Shared
6897 or else
6898 Prag_Id = Pragma_Volatile_Full_Access
6899 then
6900 Set_Atomic_VFA (E);
6901 Set_Atomic_VFA (Base_Type (E));
6902 Set_Atomic_VFA (Underlying_Type (E));
6903 end if;
6904
6905 -- Atomic/Shared/Volatile_Full_Access imply Independent
6906
6907 if Prag_Id /= Pragma_Volatile then
6908 Set_Is_Independent (E);
6909 Set_Is_Independent (Base_Type (E));
6910 Set_Is_Independent (Underlying_Type (E));
6911
6912 if Prag_Id = Pragma_Independent then
6913 Record_Independence_Check (N, Base_Type (E));
6914 end if;
6915 end if;
6916
6917 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6918
6919 if Prag_Id /= Pragma_Independent then
6920 Set_Is_Volatile (E);
6921 Set_Is_Volatile (Base_Type (E));
6922 Set_Is_Volatile (Underlying_Type (E));
6923
6924 Set_Treat_As_Volatile (E);
6925 Set_Treat_As_Volatile (Underlying_Type (E));
6926 end if;
6927
6928 elsif Nkind (Decl) = N_Object_Declaration
6929 or else (Nkind (Decl) = N_Component_Declaration
6930 and then Original_Record_Component (E) = E)
6931 then
6932 if Rep_Item_Too_Late (E, N) then
6933 return;
6934 end if;
6935
6936 if Prag_Id = Pragma_Atomic
6937 or else
6938 Prag_Id = Pragma_Shared
6939 or else
6940 Prag_Id = Pragma_Volatile_Full_Access
6941 then
6942 if Prag_Id = Pragma_Volatile_Full_Access then
6943 Set_Is_Volatile_Full_Access (E);
6944 else
6945 Set_Is_Atomic (E);
6946 end if;
6947
6948 -- If the object declaration has an explicit initialization, a
6949 -- temporary may have to be created to hold the expression, to
6950 -- ensure that access to the object remain atomic.
6951
6952 if Nkind (Parent (E)) = N_Object_Declaration
6953 and then Present (Expression (Parent (E)))
6954 then
6955 Set_Has_Delayed_Freeze (E);
6956 end if;
6957 end if;
6958
6959 -- Atomic/Shared/Volatile_Full_Access imply Independent
6960
6961 if Prag_Id /= Pragma_Volatile then
6962 Set_Is_Independent (E);
6963
6964 if Prag_Id = Pragma_Independent then
6965 Record_Independence_Check (N, E);
6966 end if;
6967 end if;
6968
6969 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6970
6971 if Prag_Id /= Pragma_Independent then
6972 Set_Is_Volatile (E);
6973 Set_Treat_As_Volatile (E);
6974 end if;
6975
6976 else
6977 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6978 end if;
6979
6980 -- The following check is only relevant when SPARK_Mode is on as
6981 -- this is not a standard Ada legality rule. Pragma Volatile can
6982 -- only apply to a full type declaration or an object declaration
6983 -- (SPARK RM C.6(1)). Original_Node is necessary to account for
6984 -- untagged derived types that are rewritten as subtypes of their
6985 -- respective root types.
6986
6987 if SPARK_Mode = On
6988 and then Prag_Id = Pragma_Volatile
6989 and then
6990 not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
6991 N_Object_Declaration)
6992 then
6993 Error_Pragma_Arg
6994 ("argument of pragma % must denote a full type or object "
6995 & "declaration", Arg1);
6996 end if;
6997 end Process_Atomic_Independent_Shared_Volatile;
6998
6999 -------------------------------------------
7000 -- Process_Compile_Time_Warning_Or_Error --
7001 -------------------------------------------
7002
7003 procedure Process_Compile_Time_Warning_Or_Error is
7004 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7005
7006 begin
7007 Check_Arg_Count (2);
7008 Check_No_Identifiers;
7009 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7010 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7011
7012 if Compile_Time_Known_Value (Arg1x) then
7013 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
7014 declare
7015 Str : constant String_Id :=
7016 Strval (Get_Pragma_Arg (Arg2));
7017 Len : constant Nat := String_Length (Str);
7018 Cont : Boolean;
7019 Ptr : Nat;
7020 CC : Char_Code;
7021 C : Character;
7022 Cent : constant Entity_Id :=
7023 Cunit_Entity (Current_Sem_Unit);
7024
7025 Force : constant Boolean :=
7026 Prag_Id = Pragma_Compile_Time_Warning
7027 and then
7028 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
7029 and then (Ekind (Cent) /= E_Package
7030 or else not In_Private_Part (Cent));
7031 -- Set True if this is the warning case, and we are in the
7032 -- visible part of a package spec, or in a subprogram spec,
7033 -- in which case we want to force the client to see the
7034 -- warning, even though it is not in the main unit.
7035
7036 begin
7037 -- Loop through segments of message separated by line feeds.
7038 -- We output these segments as separate messages with
7039 -- continuation marks for all but the first.
7040
7041 Cont := False;
7042 Ptr := 1;
7043 loop
7044 Error_Msg_Strlen := 0;
7045
7046 -- Loop to copy characters from argument to error message
7047 -- string buffer.
7048
7049 loop
7050 exit when Ptr > Len;
7051 CC := Get_String_Char (Str, Ptr);
7052 Ptr := Ptr + 1;
7053
7054 -- Ignore wide chars ??? else store character
7055
7056 if In_Character_Range (CC) then
7057 C := Get_Character (CC);
7058 exit when C = ASCII.LF;
7059 Error_Msg_Strlen := Error_Msg_Strlen + 1;
7060 Error_Msg_String (Error_Msg_Strlen) := C;
7061 end if;
7062 end loop;
7063
7064 -- Here with one line ready to go
7065
7066 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
7067
7068 -- If this is a warning in a spec, then we want clients
7069 -- to see the warning, so mark the message with the
7070 -- special sequence !! to force the warning. In the case
7071 -- of a package spec, we do not force this if we are in
7072 -- the private part of the spec.
7073
7074 if Force then
7075 if Cont = False then
7076 Error_Msg_N ("<<~!!", Arg1);
7077 Cont := True;
7078 else
7079 Error_Msg_N ("\<<~!!", Arg1);
7080 end if;
7081
7082 -- Error, rather than warning, or in a body, so we do not
7083 -- need to force visibility for client (error will be
7084 -- output in any case, and this is the situation in which
7085 -- we do not want a client to get a warning, since the
7086 -- warning is in the body or the spec private part).
7087
7088 else
7089 if Cont = False then
7090 Error_Msg_N ("<<~", Arg1);
7091 Cont := True;
7092 else
7093 Error_Msg_N ("\<<~", Arg1);
7094 end if;
7095 end if;
7096
7097 exit when Ptr > Len;
7098 end loop;
7099 end;
7100 end if;
7101 end if;
7102 end Process_Compile_Time_Warning_Or_Error;
7103
7104 ------------------------
7105 -- Process_Convention --
7106 ------------------------
7107
7108 procedure Process_Convention
7109 (C : out Convention_Id;
7110 Ent : out Entity_Id)
7111 is
7112 Cname : Name_Id;
7113
7114 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7115 -- Called if we have more than one Export/Import/Convention pragma.
7116 -- This is generally illegal, but we have a special case of allowing
7117 -- Import and Interface to coexist if they specify the convention in
7118 -- a consistent manner. We are allowed to do this, since Interface is
7119 -- an implementation defined pragma, and we choose to do it since we
7120 -- know Rational allows this combination. S is the entity id of the
7121 -- subprogram in question. This procedure also sets the special flag
7122 -- Import_Interface_Present in both pragmas in the case where we do
7123 -- have matching Import and Interface pragmas.
7124
7125 procedure Set_Convention_From_Pragma (E : Entity_Id);
7126 -- Set convention in entity E, and also flag that the entity has a
7127 -- convention pragma. If entity is for a private or incomplete type,
7128 -- also set convention and flag on underlying type. This procedure
7129 -- also deals with the special case of C_Pass_By_Copy convention,
7130 -- and error checks for inappropriate convention specification.
7131
7132 -------------------------------
7133 -- Diagnose_Multiple_Pragmas --
7134 -------------------------------
7135
7136 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7137 Pdec : constant Node_Id := Declaration_Node (S);
7138 Decl : Node_Id;
7139 Err : Boolean;
7140
7141 function Same_Convention (Decl : Node_Id) return Boolean;
7142 -- Decl is a pragma node. This function returns True if this
7143 -- pragma has a first argument that is an identifier with a
7144 -- Chars field corresponding to the Convention_Id C.
7145
7146 function Same_Name (Decl : Node_Id) return Boolean;
7147 -- Decl is a pragma node. This function returns True if this
7148 -- pragma has a second argument that is an identifier with a
7149 -- Chars field that matches the Chars of the current subprogram.
7150
7151 ---------------------
7152 -- Same_Convention --
7153 ---------------------
7154
7155 function Same_Convention (Decl : Node_Id) return Boolean is
7156 Arg1 : constant Node_Id :=
7157 First (Pragma_Argument_Associations (Decl));
7158
7159 begin
7160 if Present (Arg1) then
7161 declare
7162 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7163 begin
7164 if Nkind (Arg) = N_Identifier
7165 and then Is_Convention_Name (Chars (Arg))
7166 and then Get_Convention_Id (Chars (Arg)) = C
7167 then
7168 return True;
7169 end if;
7170 end;
7171 end if;
7172
7173 return False;
7174 end Same_Convention;
7175
7176 ---------------
7177 -- Same_Name --
7178 ---------------
7179
7180 function Same_Name (Decl : Node_Id) return Boolean is
7181 Arg1 : constant Node_Id :=
7182 First (Pragma_Argument_Associations (Decl));
7183 Arg2 : Node_Id;
7184
7185 begin
7186 if No (Arg1) then
7187 return False;
7188 end if;
7189
7190 Arg2 := Next (Arg1);
7191
7192 if No (Arg2) then
7193 return False;
7194 end if;
7195
7196 declare
7197 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7198 begin
7199 if Nkind (Arg) = N_Identifier
7200 and then Chars (Arg) = Chars (S)
7201 then
7202 return True;
7203 end if;
7204 end;
7205
7206 return False;
7207 end Same_Name;
7208
7209 -- Start of processing for Diagnose_Multiple_Pragmas
7210
7211 begin
7212 Err := True;
7213
7214 -- Definitely give message if we have Convention/Export here
7215
7216 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7217 null;
7218
7219 -- If we have an Import or Export, scan back from pragma to
7220 -- find any previous pragma applying to the same procedure.
7221 -- The scan will be terminated by the start of the list, or
7222 -- hitting the subprogram declaration. This won't allow one
7223 -- pragma to appear in the public part and one in the private
7224 -- part, but that seems very unlikely in practice.
7225
7226 else
7227 Decl := Prev (N);
7228 while Present (Decl) and then Decl /= Pdec loop
7229
7230 -- Look for pragma with same name as us
7231
7232 if Nkind (Decl) = N_Pragma
7233 and then Same_Name (Decl)
7234 then
7235 -- Give error if same as our pragma or Export/Convention
7236
7237 if Nam_In (Pragma_Name (Decl), Name_Export,
7238 Name_Convention,
7239 Pragma_Name (N))
7240 then
7241 exit;
7242
7243 -- Case of Import/Interface or the other way round
7244
7245 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
7246 Name_Import)
7247 then
7248 -- Here we know that we have Import and Interface. It
7249 -- doesn't matter which way round they are. See if
7250 -- they specify the same convention. If so, all OK,
7251 -- and set special flags to stop other messages
7252
7253 if Same_Convention (Decl) then
7254 Set_Import_Interface_Present (N);
7255 Set_Import_Interface_Present (Decl);
7256 Err := False;
7257
7258 -- If different conventions, special message
7259
7260 else
7261 Error_Msg_Sloc := Sloc (Decl);
7262 Error_Pragma_Arg
7263 ("convention differs from that given#", Arg1);
7264 return;
7265 end if;
7266 end if;
7267 end if;
7268
7269 Next (Decl);
7270 end loop;
7271 end if;
7272
7273 -- Give message if needed if we fall through those tests
7274 -- except on Relaxed_RM_Semantics where we let go: either this
7275 -- is a case accepted/ignored by other Ada compilers (e.g.
7276 -- a mix of Convention and Import), or another error will be
7277 -- generated later (e.g. using both Import and Export).
7278
7279 if Err and not Relaxed_RM_Semantics then
7280 Error_Pragma_Arg
7281 ("at most one Convention/Export/Import pragma is allowed",
7282 Arg2);
7283 end if;
7284 end Diagnose_Multiple_Pragmas;
7285
7286 --------------------------------
7287 -- Set_Convention_From_Pragma --
7288 --------------------------------
7289
7290 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7291 begin
7292 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7293 -- for an overridden dispatching operation. Technically this is
7294 -- an amendment and should only be done in Ada 2005 mode. However,
7295 -- this is clearly a mistake, since the problem that is addressed
7296 -- by this AI is that there is a clear gap in the RM.
7297
7298 if Is_Dispatching_Operation (E)
7299 and then Present (Overridden_Operation (E))
7300 and then C /= Convention (Overridden_Operation (E))
7301 then
7302 Error_Pragma_Arg
7303 ("cannot change convention for overridden dispatching "
7304 & "operation", Arg1);
7305 end if;
7306
7307 -- Special checks for Convention_Stdcall
7308
7309 if C = Convention_Stdcall then
7310
7311 -- A dispatching call is not allowed. A dispatching subprogram
7312 -- cannot be used to interface to the Win32 API, so in fact
7313 -- this check does not impose any effective restriction.
7314
7315 if Is_Dispatching_Operation (E) then
7316 Error_Msg_Sloc := Sloc (E);
7317
7318 -- Note: make this unconditional so that if there is more
7319 -- than one call to which the pragma applies, we get a
7320 -- message for each call. Also don't use Error_Pragma,
7321 -- so that we get multiple messages.
7322
7323 Error_Msg_N
7324 ("dispatching subprogram# cannot use Stdcall convention!",
7325 Arg1);
7326
7327 -- Subprograms are not allowed
7328
7329 elsif not Is_Subprogram_Or_Generic_Subprogram (E)
7330
7331 -- A variable is OK
7332
7333 and then Ekind (E) /= E_Variable
7334
7335 -- An access to subprogram is also allowed
7336
7337 and then not
7338 (Is_Access_Type (E)
7339 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7340
7341 -- Allow internal call to set convention of subprogram type
7342
7343 and then not (Ekind (E) = E_Subprogram_Type)
7344 then
7345 Error_Pragma_Arg
7346 ("second argument of pragma% must be subprogram (type)",
7347 Arg2);
7348 end if;
7349 end if;
7350
7351 -- Set the convention
7352
7353 Set_Convention (E, C);
7354 Set_Has_Convention_Pragma (E);
7355
7356 -- For the case of a record base type, also set the convention of
7357 -- any anonymous access types declared in the record which do not
7358 -- currently have a specified convention.
7359
7360 if Is_Record_Type (E) and then Is_Base_Type (E) then
7361 declare
7362 Comp : Node_Id;
7363
7364 begin
7365 Comp := First_Component (E);
7366 while Present (Comp) loop
7367 if Present (Etype (Comp))
7368 and then Ekind_In (Etype (Comp),
7369 E_Anonymous_Access_Type,
7370 E_Anonymous_Access_Subprogram_Type)
7371 and then not Has_Convention_Pragma (Comp)
7372 then
7373 Set_Convention (Comp, C);
7374 end if;
7375
7376 Next_Component (Comp);
7377 end loop;
7378 end;
7379 end if;
7380
7381 -- Deal with incomplete/private type case, where underlying type
7382 -- is available, so set convention of that underlying type.
7383
7384 if Is_Incomplete_Or_Private_Type (E)
7385 and then Present (Underlying_Type (E))
7386 then
7387 Set_Convention (Underlying_Type (E), C);
7388 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7389 end if;
7390
7391 -- A class-wide type should inherit the convention of the specific
7392 -- root type (although this isn't specified clearly by the RM).
7393
7394 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7395 Set_Convention (Class_Wide_Type (E), C);
7396 end if;
7397
7398 -- If the entity is a record type, then check for special case of
7399 -- C_Pass_By_Copy, which is treated the same as C except that the
7400 -- special record flag is set. This convention is only permitted
7401 -- on record types (see AI95-00131).
7402
7403 if Cname = Name_C_Pass_By_Copy then
7404 if Is_Record_Type (E) then
7405 Set_C_Pass_By_Copy (Base_Type (E));
7406 elsif Is_Incomplete_Or_Private_Type (E)
7407 and then Is_Record_Type (Underlying_Type (E))
7408 then
7409 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7410 else
7411 Error_Pragma_Arg
7412 ("C_Pass_By_Copy convention allowed only for record type",
7413 Arg2);
7414 end if;
7415 end if;
7416
7417 -- If the entity is a derived boolean type, check for the special
7418 -- case of convention C, C++, or Fortran, where we consider any
7419 -- nonzero value to represent true.
7420
7421 if Is_Discrete_Type (E)
7422 and then Root_Type (Etype (E)) = Standard_Boolean
7423 and then
7424 (C = Convention_C
7425 or else
7426 C = Convention_CPP
7427 or else
7428 C = Convention_Fortran)
7429 then
7430 Set_Nonzero_Is_True (Base_Type (E));
7431 end if;
7432 end Set_Convention_From_Pragma;
7433
7434 -- Local variables
7435
7436 Comp_Unit : Unit_Number_Type;
7437 E : Entity_Id;
7438 E1 : Entity_Id;
7439 Id : Node_Id;
7440
7441 -- Start of processing for Process_Convention
7442
7443 begin
7444 Check_At_Least_N_Arguments (2);
7445 Check_Optional_Identifier (Arg1, Name_Convention);
7446 Check_Arg_Is_Identifier (Arg1);
7447 Cname := Chars (Get_Pragma_Arg (Arg1));
7448
7449 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7450 -- tested again below to set the critical flag).
7451
7452 if Cname = Name_C_Pass_By_Copy then
7453 C := Convention_C;
7454
7455 -- Otherwise we must have something in the standard convention list
7456
7457 elsif Is_Convention_Name (Cname) then
7458 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7459
7460 -- Otherwise warn on unrecognized convention
7461
7462 else
7463 if Warn_On_Export_Import then
7464 Error_Msg_N
7465 ("??unrecognized convention name, C assumed",
7466 Get_Pragma_Arg (Arg1));
7467 end if;
7468
7469 C := Convention_C;
7470 end if;
7471
7472 Check_Optional_Identifier (Arg2, Name_Entity);
7473 Check_Arg_Is_Local_Name (Arg2);
7474
7475 Id := Get_Pragma_Arg (Arg2);
7476 Analyze (Id);
7477
7478 if not Is_Entity_Name (Id) then
7479 Error_Pragma_Arg ("entity name required", Arg2);
7480 end if;
7481
7482 E := Entity (Id);
7483
7484 -- Set entity to return
7485
7486 Ent := E;
7487
7488 -- Ada_Pass_By_Copy special checking
7489
7490 if C = Convention_Ada_Pass_By_Copy then
7491 if not Is_First_Subtype (E) then
7492 Error_Pragma_Arg
7493 ("convention `Ada_Pass_By_Copy` only allowed for types",
7494 Arg2);
7495 end if;
7496
7497 if Is_By_Reference_Type (E) then
7498 Error_Pragma_Arg
7499 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7500 & "type", Arg1);
7501 end if;
7502
7503 -- Ada_Pass_By_Reference special checking
7504
7505 elsif C = Convention_Ada_Pass_By_Reference then
7506 if not Is_First_Subtype (E) then
7507 Error_Pragma_Arg
7508 ("convention `Ada_Pass_By_Reference` only allowed for types",
7509 Arg2);
7510 end if;
7511
7512 if Is_By_Copy_Type (E) then
7513 Error_Pragma_Arg
7514 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7515 & "type", Arg1);
7516 end if;
7517 end if;
7518
7519 -- Go to renamed subprogram if present, since convention applies to
7520 -- the actual renamed entity, not to the renaming entity. If the
7521 -- subprogram is inherited, go to parent subprogram.
7522
7523 if Is_Subprogram (E)
7524 and then Present (Alias (E))
7525 then
7526 if Nkind (Parent (Declaration_Node (E))) =
7527 N_Subprogram_Renaming_Declaration
7528 then
7529 if Scope (E) /= Scope (Alias (E)) then
7530 Error_Pragma_Ref
7531 ("cannot apply pragma% to non-local entity&#", E);
7532 end if;
7533
7534 E := Alias (E);
7535
7536 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7537 N_Private_Extension_Declaration)
7538 and then Scope (E) = Scope (Alias (E))
7539 then
7540 E := Alias (E);
7541
7542 -- Return the parent subprogram the entity was inherited from
7543
7544 Ent := E;
7545 end if;
7546 end if;
7547
7548 -- Check that we are not applying this to a specless body. Relax this
7549 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7550
7551 if Is_Subprogram (E)
7552 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7553 and then not Relaxed_RM_Semantics
7554 then
7555 Error_Pragma
7556 ("pragma% requires separate spec and must come before body");
7557 end if;
7558
7559 -- Check that we are not applying this to a named constant
7560
7561 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7562 Error_Msg_Name_1 := Pname;
7563 Error_Msg_N
7564 ("cannot apply pragma% to named constant!",
7565 Get_Pragma_Arg (Arg2));
7566 Error_Pragma_Arg
7567 ("\supply appropriate type for&!", Arg2);
7568 end if;
7569
7570 if Ekind (E) = E_Enumeration_Literal then
7571 Error_Pragma ("enumeration literal not allowed for pragma%");
7572 end if;
7573
7574 -- Check for rep item appearing too early or too late
7575
7576 if Etype (E) = Any_Type
7577 or else Rep_Item_Too_Early (E, N)
7578 then
7579 raise Pragma_Exit;
7580
7581 elsif Present (Underlying_Type (E)) then
7582 E := Underlying_Type (E);
7583 end if;
7584
7585 if Rep_Item_Too_Late (E, N) then
7586 raise Pragma_Exit;
7587 end if;
7588
7589 if Has_Convention_Pragma (E) then
7590 Diagnose_Multiple_Pragmas (E);
7591
7592 elsif Convention (E) = Convention_Protected
7593 or else Ekind (Scope (E)) = E_Protected_Type
7594 then
7595 Error_Pragma_Arg
7596 ("a protected operation cannot be given a different convention",
7597 Arg2);
7598 end if;
7599
7600 -- For Intrinsic, a subprogram is required
7601
7602 if C = Convention_Intrinsic
7603 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7604 then
7605 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7606
7607 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7608 Error_Pragma_Arg
7609 ("second argument of pragma% must be a subprogram", Arg2);
7610 end if;
7611 end if;
7612
7613 -- Deal with non-subprogram cases
7614
7615 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7616 Set_Convention_From_Pragma (E);
7617
7618 if Is_Type (E) then
7619
7620 -- The pragma must apply to a first subtype, but it can also
7621 -- apply to a generic type in a generic formal part, in which
7622 -- case it will also appear in the corresponding instance.
7623
7624 if Is_Generic_Type (E) or else In_Instance then
7625 null;
7626 else
7627 Check_First_Subtype (Arg2);
7628 end if;
7629
7630 Set_Convention_From_Pragma (Base_Type (E));
7631
7632 -- For access subprograms, we must set the convention on the
7633 -- internally generated directly designated type as well.
7634
7635 if Ekind (E) = E_Access_Subprogram_Type then
7636 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7637 end if;
7638 end if;
7639
7640 -- For the subprogram case, set proper convention for all homonyms
7641 -- in same scope and the same declarative part, i.e. the same
7642 -- compilation unit.
7643
7644 else
7645 Comp_Unit := Get_Source_Unit (E);
7646 Set_Convention_From_Pragma (E);
7647
7648 -- Treat a pragma Import as an implicit body, and pragma import
7649 -- as implicit reference (for navigation in GPS).
7650
7651 if Prag_Id = Pragma_Import then
7652 Generate_Reference (E, Id, 'b');
7653
7654 -- For exported entities we restrict the generation of references
7655 -- to entities exported to foreign languages since entities
7656 -- exported to Ada do not provide further information to GPS and
7657 -- add undesired references to the output of the gnatxref tool.
7658
7659 elsif Prag_Id = Pragma_Export
7660 and then Convention (E) /= Convention_Ada
7661 then
7662 Generate_Reference (E, Id, 'i');
7663 end if;
7664
7665 -- If the pragma comes from from an aspect, it only applies to the
7666 -- given entity, not its homonyms.
7667
7668 if From_Aspect_Specification (N) then
7669 return;
7670 end if;
7671
7672 -- Otherwise Loop through the homonyms of the pragma argument's
7673 -- entity, an apply convention to those in the current scope.
7674
7675 E1 := Ent;
7676
7677 loop
7678 E1 := Homonym (E1);
7679 exit when No (E1) or else Scope (E1) /= Current_Scope;
7680
7681 -- Ignore entry for which convention is already set
7682
7683 if Has_Convention_Pragma (E1) then
7684 goto Continue;
7685 end if;
7686
7687 -- Do not set the pragma on inherited operations or on formal
7688 -- subprograms.
7689
7690 if Comes_From_Source (E1)
7691 and then Comp_Unit = Get_Source_Unit (E1)
7692 and then not Is_Formal_Subprogram (E1)
7693 and then Nkind (Original_Node (Parent (E1))) /=
7694 N_Full_Type_Declaration
7695 then
7696 if Present (Alias (E1))
7697 and then Scope (E1) /= Scope (Alias (E1))
7698 then
7699 Error_Pragma_Ref
7700 ("cannot apply pragma% to non-local entity& declared#",
7701 E1);
7702 end if;
7703
7704 Set_Convention_From_Pragma (E1);
7705
7706 if Prag_Id = Pragma_Import then
7707 Generate_Reference (E1, Id, 'b');
7708 end if;
7709 end if;
7710
7711 <<Continue>>
7712 null;
7713 end loop;
7714 end if;
7715 end Process_Convention;
7716
7717 ----------------------------------------
7718 -- Process_Disable_Enable_Atomic_Sync --
7719 ----------------------------------------
7720
7721 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7722 begin
7723 Check_No_Identifiers;
7724 Check_At_Most_N_Arguments (1);
7725
7726 -- Modeled internally as
7727 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7728
7729 Rewrite (N,
7730 Make_Pragma (Loc,
7731 Pragma_Identifier =>
7732 Make_Identifier (Loc, Nam),
7733 Pragma_Argument_Associations => New_List (
7734 Make_Pragma_Argument_Association (Loc,
7735 Expression =>
7736 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7737
7738 if Present (Arg1) then
7739 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7740 end if;
7741
7742 Analyze (N);
7743 end Process_Disable_Enable_Atomic_Sync;
7744
7745 -------------------------------------------------
7746 -- Process_Extended_Import_Export_Internal_Arg --
7747 -------------------------------------------------
7748
7749 procedure Process_Extended_Import_Export_Internal_Arg
7750 (Arg_Internal : Node_Id := Empty)
7751 is
7752 begin
7753 if No (Arg_Internal) then
7754 Error_Pragma ("Internal parameter required for pragma%");
7755 end if;
7756
7757 if Nkind (Arg_Internal) = N_Identifier then
7758 null;
7759
7760 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7761 and then (Prag_Id = Pragma_Import_Function
7762 or else
7763 Prag_Id = Pragma_Export_Function)
7764 then
7765 null;
7766
7767 else
7768 Error_Pragma_Arg
7769 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7770 end if;
7771
7772 Check_Arg_Is_Local_Name (Arg_Internal);
7773 end Process_Extended_Import_Export_Internal_Arg;
7774
7775 --------------------------------------------------
7776 -- Process_Extended_Import_Export_Object_Pragma --
7777 --------------------------------------------------
7778
7779 procedure Process_Extended_Import_Export_Object_Pragma
7780 (Arg_Internal : Node_Id;
7781 Arg_External : Node_Id;
7782 Arg_Size : Node_Id)
7783 is
7784 Def_Id : Entity_Id;
7785
7786 begin
7787 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7788 Def_Id := Entity (Arg_Internal);
7789
7790 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7791 Error_Pragma_Arg
7792 ("pragma% must designate an object", Arg_Internal);
7793 end if;
7794
7795 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7796 or else
7797 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7798 then
7799 Error_Pragma_Arg
7800 ("previous Common/Psect_Object applies, pragma % not permitted",
7801 Arg_Internal);
7802 end if;
7803
7804 if Rep_Item_Too_Late (Def_Id, N) then
7805 raise Pragma_Exit;
7806 end if;
7807
7808 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7809
7810 if Present (Arg_Size) then
7811 Check_Arg_Is_External_Name (Arg_Size);
7812 end if;
7813
7814 -- Export_Object case
7815
7816 if Prag_Id = Pragma_Export_Object then
7817 if not Is_Library_Level_Entity (Def_Id) then
7818 Error_Pragma_Arg
7819 ("argument for pragma% must be library level entity",
7820 Arg_Internal);
7821 end if;
7822
7823 if Ekind (Current_Scope) = E_Generic_Package then
7824 Error_Pragma ("pragma& cannot appear in a generic unit");
7825 end if;
7826
7827 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7828 Error_Pragma_Arg
7829 ("exported object must have compile time known size",
7830 Arg_Internal);
7831 end if;
7832
7833 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7834 Error_Msg_N ("??duplicate Export_Object pragma", N);
7835 else
7836 Set_Exported (Def_Id, Arg_Internal);
7837 end if;
7838
7839 -- Import_Object case
7840
7841 else
7842 if Is_Concurrent_Type (Etype (Def_Id)) then
7843 Error_Pragma_Arg
7844 ("cannot use pragma% for task/protected object",
7845 Arg_Internal);
7846 end if;
7847
7848 if Ekind (Def_Id) = E_Constant then
7849 Error_Pragma_Arg
7850 ("cannot import a constant", Arg_Internal);
7851 end if;
7852
7853 if Warn_On_Export_Import
7854 and then Has_Discriminants (Etype (Def_Id))
7855 then
7856 Error_Msg_N
7857 ("imported value must be initialized??", Arg_Internal);
7858 end if;
7859
7860 if Warn_On_Export_Import
7861 and then Is_Access_Type (Etype (Def_Id))
7862 then
7863 Error_Pragma_Arg
7864 ("cannot import object of an access type??", Arg_Internal);
7865 end if;
7866
7867 if Warn_On_Export_Import
7868 and then Is_Imported (Def_Id)
7869 then
7870 Error_Msg_N ("??duplicate Import_Object pragma", N);
7871
7872 -- Check for explicit initialization present. Note that an
7873 -- initialization generated by the code generator, e.g. for an
7874 -- access type, does not count here.
7875
7876 elsif Present (Expression (Parent (Def_Id)))
7877 and then
7878 Comes_From_Source
7879 (Original_Node (Expression (Parent (Def_Id))))
7880 then
7881 Error_Msg_Sloc := Sloc (Def_Id);
7882 Error_Pragma_Arg
7883 ("imported entities cannot be initialized (RM B.1(24))",
7884 "\no initialization allowed for & declared#", Arg1);
7885 else
7886 Set_Imported (Def_Id);
7887 Note_Possible_Modification (Arg_Internal, Sure => False);
7888 end if;
7889 end if;
7890 end Process_Extended_Import_Export_Object_Pragma;
7891
7892 ------------------------------------------------------
7893 -- Process_Extended_Import_Export_Subprogram_Pragma --
7894 ------------------------------------------------------
7895
7896 procedure Process_Extended_Import_Export_Subprogram_Pragma
7897 (Arg_Internal : Node_Id;
7898 Arg_External : Node_Id;
7899 Arg_Parameter_Types : Node_Id;
7900 Arg_Result_Type : Node_Id := Empty;
7901 Arg_Mechanism : Node_Id;
7902 Arg_Result_Mechanism : Node_Id := Empty)
7903 is
7904 Ent : Entity_Id;
7905 Def_Id : Entity_Id;
7906 Hom_Id : Entity_Id;
7907 Formal : Entity_Id;
7908 Ambiguous : Boolean;
7909 Match : Boolean;
7910
7911 function Same_Base_Type
7912 (Ptype : Node_Id;
7913 Formal : Entity_Id) return Boolean;
7914 -- Determines if Ptype references the type of Formal. Note that only
7915 -- the base types need to match according to the spec. Ptype here is
7916 -- the argument from the pragma, which is either a type name, or an
7917 -- access attribute.
7918
7919 --------------------
7920 -- Same_Base_Type --
7921 --------------------
7922
7923 function Same_Base_Type
7924 (Ptype : Node_Id;
7925 Formal : Entity_Id) return Boolean
7926 is
7927 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7928 Pref : Node_Id;
7929
7930 begin
7931 -- Case where pragma argument is typ'Access
7932
7933 if Nkind (Ptype) = N_Attribute_Reference
7934 and then Attribute_Name (Ptype) = Name_Access
7935 then
7936 Pref := Prefix (Ptype);
7937 Find_Type (Pref);
7938
7939 if not Is_Entity_Name (Pref)
7940 or else Entity (Pref) = Any_Type
7941 then
7942 raise Pragma_Exit;
7943 end if;
7944
7945 -- We have a match if the corresponding argument is of an
7946 -- anonymous access type, and its designated type matches the
7947 -- type of the prefix of the access attribute
7948
7949 return Ekind (Ftyp) = E_Anonymous_Access_Type
7950 and then Base_Type (Entity (Pref)) =
7951 Base_Type (Etype (Designated_Type (Ftyp)));
7952
7953 -- Case where pragma argument is a type name
7954
7955 else
7956 Find_Type (Ptype);
7957
7958 if not Is_Entity_Name (Ptype)
7959 or else Entity (Ptype) = Any_Type
7960 then
7961 raise Pragma_Exit;
7962 end if;
7963
7964 -- We have a match if the corresponding argument is of the type
7965 -- given in the pragma (comparing base types)
7966
7967 return Base_Type (Entity (Ptype)) = Ftyp;
7968 end if;
7969 end Same_Base_Type;
7970
7971 -- Start of processing for
7972 -- Process_Extended_Import_Export_Subprogram_Pragma
7973
7974 begin
7975 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7976 Ent := Empty;
7977 Ambiguous := False;
7978
7979 -- Loop through homonyms (overloadings) of the entity
7980
7981 Hom_Id := Entity (Arg_Internal);
7982 while Present (Hom_Id) loop
7983 Def_Id := Get_Base_Subprogram (Hom_Id);
7984
7985 -- We need a subprogram in the current scope
7986
7987 if not Is_Subprogram (Def_Id)
7988 or else Scope (Def_Id) /= Current_Scope
7989 then
7990 null;
7991
7992 else
7993 Match := True;
7994
7995 -- Pragma cannot apply to subprogram body
7996
7997 if Is_Subprogram (Def_Id)
7998 and then Nkind (Parent (Declaration_Node (Def_Id))) =
7999 N_Subprogram_Body
8000 then
8001 Error_Pragma
8002 ("pragma% requires separate spec"
8003 & " and must come before body");
8004 end if;
8005
8006 -- Test result type if given, note that the result type
8007 -- parameter can only be present for the function cases.
8008
8009 if Present (Arg_Result_Type)
8010 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8011 then
8012 Match := False;
8013
8014 elsif Etype (Def_Id) /= Standard_Void_Type
8015 and then
8016 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
8017 then
8018 Match := False;
8019
8020 -- Test parameter types if given. Note that this parameter
8021 -- has not been analyzed (and must not be, since it is
8022 -- semantic nonsense), so we get it as the parser left it.
8023
8024 elsif Present (Arg_Parameter_Types) then
8025 Check_Matching_Types : declare
8026 Formal : Entity_Id;
8027 Ptype : Node_Id;
8028
8029 begin
8030 Formal := First_Formal (Def_Id);
8031
8032 if Nkind (Arg_Parameter_Types) = N_Null then
8033 if Present (Formal) then
8034 Match := False;
8035 end if;
8036
8037 -- A list of one type, e.g. (List) is parsed as
8038 -- a parenthesized expression.
8039
8040 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8041 and then Paren_Count (Arg_Parameter_Types) = 1
8042 then
8043 if No (Formal)
8044 or else Present (Next_Formal (Formal))
8045 then
8046 Match := False;
8047 else
8048 Match :=
8049 Same_Base_Type (Arg_Parameter_Types, Formal);
8050 end if;
8051
8052 -- A list of more than one type is parsed as a aggregate
8053
8054 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8055 and then Paren_Count (Arg_Parameter_Types) = 0
8056 then
8057 Ptype := First (Expressions (Arg_Parameter_Types));
8058 while Present (Ptype) or else Present (Formal) loop
8059 if No (Ptype)
8060 or else No (Formal)
8061 or else not Same_Base_Type (Ptype, Formal)
8062 then
8063 Match := False;
8064 exit;
8065 else
8066 Next_Formal (Formal);
8067 Next (Ptype);
8068 end if;
8069 end loop;
8070
8071 -- Anything else is of the wrong form
8072
8073 else
8074 Error_Pragma_Arg
8075 ("wrong form for Parameter_Types parameter",
8076 Arg_Parameter_Types);
8077 end if;
8078 end Check_Matching_Types;
8079 end if;
8080
8081 -- Match is now False if the entry we found did not match
8082 -- either a supplied Parameter_Types or Result_Types argument
8083
8084 if Match then
8085 if No (Ent) then
8086 Ent := Def_Id;
8087
8088 -- Ambiguous case, the flag Ambiguous shows if we already
8089 -- detected this and output the initial messages.
8090
8091 else
8092 if not Ambiguous then
8093 Ambiguous := True;
8094 Error_Msg_Name_1 := Pname;
8095 Error_Msg_N
8096 ("pragma% does not uniquely identify subprogram!",
8097 N);
8098 Error_Msg_Sloc := Sloc (Ent);
8099 Error_Msg_N ("matching subprogram #!", N);
8100 Ent := Empty;
8101 end if;
8102
8103 Error_Msg_Sloc := Sloc (Def_Id);
8104 Error_Msg_N ("matching subprogram #!", N);
8105 end if;
8106 end if;
8107 end if;
8108
8109 Hom_Id := Homonym (Hom_Id);
8110 end loop;
8111
8112 -- See if we found an entry
8113
8114 if No (Ent) then
8115 if not Ambiguous then
8116 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8117 Error_Pragma
8118 ("pragma% cannot be given for generic subprogram");
8119 else
8120 Error_Pragma
8121 ("pragma% does not identify local subprogram");
8122 end if;
8123 end if;
8124
8125 return;
8126 end if;
8127
8128 -- Import pragmas must be for imported entities
8129
8130 if Prag_Id = Pragma_Import_Function
8131 or else
8132 Prag_Id = Pragma_Import_Procedure
8133 or else
8134 Prag_Id = Pragma_Import_Valued_Procedure
8135 then
8136 if not Is_Imported (Ent) then
8137 Error_Pragma
8138 ("pragma Import or Interface must precede pragma%");
8139 end if;
8140
8141 -- Here we have the Export case which can set the entity as exported
8142
8143 -- But does not do so if the specified external name is null, since
8144 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8145 -- compatible) to request no external name.
8146
8147 elsif Nkind (Arg_External) = N_String_Literal
8148 and then String_Length (Strval (Arg_External)) = 0
8149 then
8150 null;
8151
8152 -- In all other cases, set entity as exported
8153
8154 else
8155 Set_Exported (Ent, Arg_Internal);
8156 end if;
8157
8158 -- Special processing for Valued_Procedure cases
8159
8160 if Prag_Id = Pragma_Import_Valued_Procedure
8161 or else
8162 Prag_Id = Pragma_Export_Valued_Procedure
8163 then
8164 Formal := First_Formal (Ent);
8165
8166 if No (Formal) then
8167 Error_Pragma ("at least one parameter required for pragma%");
8168
8169 elsif Ekind (Formal) /= E_Out_Parameter then
8170 Error_Pragma ("first parameter must have mode out for pragma%");
8171
8172 else
8173 Set_Is_Valued_Procedure (Ent);
8174 end if;
8175 end if;
8176
8177 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8178
8179 -- Process Result_Mechanism argument if present. We have already
8180 -- checked that this is only allowed for the function case.
8181
8182 if Present (Arg_Result_Mechanism) then
8183 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8184 end if;
8185
8186 -- Process Mechanism parameter if present. Note that this parameter
8187 -- is not analyzed, and must not be analyzed since it is semantic
8188 -- nonsense, so we get it in exactly as the parser left it.
8189
8190 if Present (Arg_Mechanism) then
8191 declare
8192 Formal : Entity_Id;
8193 Massoc : Node_Id;
8194 Mname : Node_Id;
8195 Choice : Node_Id;
8196
8197 begin
8198 -- A single mechanism association without a formal parameter
8199 -- name is parsed as a parenthesized expression. All other
8200 -- cases are parsed as aggregates, so we rewrite the single
8201 -- parameter case as an aggregate for consistency.
8202
8203 if Nkind (Arg_Mechanism) /= N_Aggregate
8204 and then Paren_Count (Arg_Mechanism) = 1
8205 then
8206 Rewrite (Arg_Mechanism,
8207 Make_Aggregate (Sloc (Arg_Mechanism),
8208 Expressions => New_List (
8209 Relocate_Node (Arg_Mechanism))));
8210 end if;
8211
8212 -- Case of only mechanism name given, applies to all formals
8213
8214 if Nkind (Arg_Mechanism) /= N_Aggregate then
8215 Formal := First_Formal (Ent);
8216 while Present (Formal) loop
8217 Set_Mechanism_Value (Formal, Arg_Mechanism);
8218 Next_Formal (Formal);
8219 end loop;
8220
8221 -- Case of list of mechanism associations given
8222
8223 else
8224 if Null_Record_Present (Arg_Mechanism) then
8225 Error_Pragma_Arg
8226 ("inappropriate form for Mechanism parameter",
8227 Arg_Mechanism);
8228 end if;
8229
8230 -- Deal with positional ones first
8231
8232 Formal := First_Formal (Ent);
8233
8234 if Present (Expressions (Arg_Mechanism)) then
8235 Mname := First (Expressions (Arg_Mechanism));
8236 while Present (Mname) loop
8237 if No (Formal) then
8238 Error_Pragma_Arg
8239 ("too many mechanism associations", Mname);
8240 end if;
8241
8242 Set_Mechanism_Value (Formal, Mname);
8243 Next_Formal (Formal);
8244 Next (Mname);
8245 end loop;
8246 end if;
8247
8248 -- Deal with named entries
8249
8250 if Present (Component_Associations (Arg_Mechanism)) then
8251 Massoc := First (Component_Associations (Arg_Mechanism));
8252 while Present (Massoc) loop
8253 Choice := First (Choices (Massoc));
8254
8255 if Nkind (Choice) /= N_Identifier
8256 or else Present (Next (Choice))
8257 then
8258 Error_Pragma_Arg
8259 ("incorrect form for mechanism association",
8260 Massoc);
8261 end if;
8262
8263 Formal := First_Formal (Ent);
8264 loop
8265 if No (Formal) then
8266 Error_Pragma_Arg
8267 ("parameter name & not present", Choice);
8268 end if;
8269
8270 if Chars (Choice) = Chars (Formal) then
8271 Set_Mechanism_Value
8272 (Formal, Expression (Massoc));
8273
8274 -- Set entity on identifier (needed by ASIS)
8275
8276 Set_Entity (Choice, Formal);
8277
8278 exit;
8279 end if;
8280
8281 Next_Formal (Formal);
8282 end loop;
8283
8284 Next (Massoc);
8285 end loop;
8286 end if;
8287 end if;
8288 end;
8289 end if;
8290 end Process_Extended_Import_Export_Subprogram_Pragma;
8291
8292 --------------------------
8293 -- Process_Generic_List --
8294 --------------------------
8295
8296 procedure Process_Generic_List is
8297 Arg : Node_Id;
8298 Exp : Node_Id;
8299
8300 begin
8301 Check_No_Identifiers;
8302 Check_At_Least_N_Arguments (1);
8303
8304 -- Check all arguments are names of generic units or instances
8305
8306 Arg := Arg1;
8307 while Present (Arg) loop
8308 Exp := Get_Pragma_Arg (Arg);
8309 Analyze (Exp);
8310
8311 if not Is_Entity_Name (Exp)
8312 or else
8313 (not Is_Generic_Instance (Entity (Exp))
8314 and then
8315 not Is_Generic_Unit (Entity (Exp)))
8316 then
8317 Error_Pragma_Arg
8318 ("pragma% argument must be name of generic unit/instance",
8319 Arg);
8320 end if;
8321
8322 Next (Arg);
8323 end loop;
8324 end Process_Generic_List;
8325
8326 ------------------------------------
8327 -- Process_Import_Predefined_Type --
8328 ------------------------------------
8329
8330 procedure Process_Import_Predefined_Type is
8331 Loc : constant Source_Ptr := Sloc (N);
8332 Elmt : Elmt_Id;
8333 Ftyp : Node_Id := Empty;
8334 Decl : Node_Id;
8335 Def : Node_Id;
8336 Nam : Name_Id;
8337
8338 begin
8339 String_To_Name_Buffer (Strval (Expression (Arg3)));
8340 Nam := Name_Find;
8341
8342 Elmt := First_Elmt (Predefined_Float_Types);
8343 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8344 Next_Elmt (Elmt);
8345 end loop;
8346
8347 Ftyp := Node (Elmt);
8348
8349 if Present (Ftyp) then
8350
8351 -- Don't build a derived type declaration, because predefined C
8352 -- types have no declaration anywhere, so cannot really be named.
8353 -- Instead build a full type declaration, starting with an
8354 -- appropriate type definition is built
8355
8356 if Is_Floating_Point_Type (Ftyp) then
8357 Def := Make_Floating_Point_Definition (Loc,
8358 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8359 Make_Real_Range_Specification (Loc,
8360 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8361 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8362
8363 -- Should never have a predefined type we cannot handle
8364
8365 else
8366 raise Program_Error;
8367 end if;
8368
8369 -- Build and insert a Full_Type_Declaration, which will be
8370 -- analyzed as soon as this list entry has been analyzed.
8371
8372 Decl := Make_Full_Type_Declaration (Loc,
8373 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8374 Type_Definition => Def);
8375
8376 Insert_After (N, Decl);
8377 Mark_Rewrite_Insertion (Decl);
8378
8379 else
8380 Error_Pragma_Arg ("no matching type found for pragma%",
8381 Arg2);
8382 end if;
8383 end Process_Import_Predefined_Type;
8384
8385 ---------------------------------
8386 -- Process_Import_Or_Interface --
8387 ---------------------------------
8388
8389 procedure Process_Import_Or_Interface is
8390 C : Convention_Id;
8391 Def_Id : Entity_Id;
8392 Hom_Id : Entity_Id;
8393
8394 begin
8395 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8396 -- pragma Import (Entity, "external name");
8397
8398 if Relaxed_RM_Semantics
8399 and then Arg_Count = 2
8400 and then Prag_Id = Pragma_Import
8401 and then Nkind (Expression (Arg2)) = N_String_Literal
8402 then
8403 C := Convention_C;
8404 Def_Id := Get_Pragma_Arg (Arg1);
8405 Analyze (Def_Id);
8406
8407 if not Is_Entity_Name (Def_Id) then
8408 Error_Pragma_Arg ("entity name required", Arg1);
8409 end if;
8410
8411 Def_Id := Entity (Def_Id);
8412 Kill_Size_Check_Code (Def_Id);
8413 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8414
8415 else
8416 Process_Convention (C, Def_Id);
8417
8418 -- A pragma that applies to a Ghost entity becomes Ghost for the
8419 -- purposes of legality checks and removal of ignored Ghost code.
8420
8421 Mark_Pragma_As_Ghost (N, Def_Id);
8422 Kill_Size_Check_Code (Def_Id);
8423 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8424 end if;
8425
8426 -- Various error checks
8427
8428 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8429
8430 -- We do not permit Import to apply to a renaming declaration
8431
8432 if Present (Renamed_Object (Def_Id)) then
8433 Error_Pragma_Arg
8434 ("pragma% not allowed for object renaming", Arg2);
8435
8436 -- User initialization is not allowed for imported object, but
8437 -- the object declaration may contain a default initialization,
8438 -- that will be discarded. Note that an explicit initialization
8439 -- only counts if it comes from source, otherwise it is simply
8440 -- the code generator making an implicit initialization explicit.
8441
8442 elsif Present (Expression (Parent (Def_Id)))
8443 and then Comes_From_Source
8444 (Original_Node (Expression (Parent (Def_Id))))
8445 then
8446 -- Set imported flag to prevent cascaded errors
8447
8448 Set_Is_Imported (Def_Id);
8449
8450 Error_Msg_Sloc := Sloc (Def_Id);
8451 Error_Pragma_Arg
8452 ("no initialization allowed for declaration of& #",
8453 "\imported entities cannot be initialized (RM B.1(24))",
8454 Arg2);
8455
8456 else
8457 -- If the pragma comes from an aspect specification the
8458 -- Is_Imported flag has already been set.
8459
8460 if not From_Aspect_Specification (N) then
8461 Set_Imported (Def_Id);
8462 end if;
8463
8464 Process_Interface_Name (Def_Id, Arg3, Arg4);
8465
8466 -- Note that we do not set Is_Public here. That's because we
8467 -- only want to set it if there is no address clause, and we
8468 -- don't know that yet, so we delay that processing till
8469 -- freeze time.
8470
8471 -- pragma Import completes deferred constants
8472
8473 if Ekind (Def_Id) = E_Constant then
8474 Set_Has_Completion (Def_Id);
8475 end if;
8476
8477 -- It is not possible to import a constant of an unconstrained
8478 -- array type (e.g. string) because there is no simple way to
8479 -- write a meaningful subtype for it.
8480
8481 if Is_Array_Type (Etype (Def_Id))
8482 and then not Is_Constrained (Etype (Def_Id))
8483 then
8484 Error_Msg_NE
8485 ("imported constant& must have a constrained subtype",
8486 N, Def_Id);
8487 end if;
8488 end if;
8489
8490 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8491
8492 -- If the name is overloaded, pragma applies to all of the denoted
8493 -- entities in the same declarative part, unless the pragma comes
8494 -- from an aspect specification or was generated by the compiler
8495 -- (such as for pragma Provide_Shift_Operators).
8496
8497 Hom_Id := Def_Id;
8498 while Present (Hom_Id) loop
8499
8500 Def_Id := Get_Base_Subprogram (Hom_Id);
8501
8502 -- Ignore inherited subprograms because the pragma will apply
8503 -- to the parent operation, which is the one called.
8504
8505 if Is_Overloadable (Def_Id)
8506 and then Present (Alias (Def_Id))
8507 then
8508 null;
8509
8510 -- If it is not a subprogram, it must be in an outer scope and
8511 -- pragma does not apply.
8512
8513 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8514 null;
8515
8516 -- The pragma does not apply to primitives of interfaces
8517
8518 elsif Is_Dispatching_Operation (Def_Id)
8519 and then Present (Find_Dispatching_Type (Def_Id))
8520 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8521 then
8522 null;
8523
8524 -- Verify that the homonym is in the same declarative part (not
8525 -- just the same scope). If the pragma comes from an aspect
8526 -- specification we know that it is part of the declaration.
8527
8528 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8529 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8530 and then not From_Aspect_Specification (N)
8531 then
8532 exit;
8533
8534 else
8535 -- If the pragma comes from an aspect specification the
8536 -- Is_Imported flag has already been set.
8537
8538 if not From_Aspect_Specification (N) then
8539 Set_Imported (Def_Id);
8540 end if;
8541
8542 -- Reject an Import applied to an abstract subprogram
8543
8544 if Is_Subprogram (Def_Id)
8545 and then Is_Abstract_Subprogram (Def_Id)
8546 then
8547 Error_Msg_Sloc := Sloc (Def_Id);
8548 Error_Msg_NE
8549 ("cannot import abstract subprogram& declared#",
8550 Arg2, Def_Id);
8551 end if;
8552
8553 -- Special processing for Convention_Intrinsic
8554
8555 if C = Convention_Intrinsic then
8556
8557 -- Link_Name argument not allowed for intrinsic
8558
8559 Check_No_Link_Name;
8560
8561 Set_Is_Intrinsic_Subprogram (Def_Id);
8562
8563 -- If no external name is present, then check that this
8564 -- is a valid intrinsic subprogram. If an external name
8565 -- is present, then this is handled by the back end.
8566
8567 if No (Arg3) then
8568 Check_Intrinsic_Subprogram
8569 (Def_Id, Get_Pragma_Arg (Arg2));
8570 end if;
8571 end if;
8572
8573 -- Verify that the subprogram does not have a completion
8574 -- through a renaming declaration. For other completions the
8575 -- pragma appears as a too late representation.
8576
8577 declare
8578 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8579
8580 begin
8581 if Present (Decl)
8582 and then Nkind (Decl) = N_Subprogram_Declaration
8583 and then Present (Corresponding_Body (Decl))
8584 and then Nkind (Unit_Declaration_Node
8585 (Corresponding_Body (Decl))) =
8586 N_Subprogram_Renaming_Declaration
8587 then
8588 Error_Msg_Sloc := Sloc (Def_Id);
8589 Error_Msg_NE
8590 ("cannot import&, renaming already provided for "
8591 & "declaration #", N, Def_Id);
8592 end if;
8593 end;
8594
8595 -- If the pragma comes from an aspect specification, there
8596 -- must be an Import aspect specified as well. In the rare
8597 -- case where Import is set to False, the suprogram needs to
8598 -- have a local completion.
8599
8600 declare
8601 Imp_Aspect : constant Node_Id :=
8602 Find_Aspect (Def_Id, Aspect_Import);
8603 Expr : Node_Id;
8604
8605 begin
8606 if Present (Imp_Aspect)
8607 and then Present (Expression (Imp_Aspect))
8608 then
8609 Expr := Expression (Imp_Aspect);
8610 Analyze_And_Resolve (Expr, Standard_Boolean);
8611
8612 if Is_Entity_Name (Expr)
8613 and then Entity (Expr) = Standard_True
8614 then
8615 Set_Has_Completion (Def_Id);
8616 end if;
8617
8618 -- If there is no expression, the default is True, as for
8619 -- all boolean aspects. Same for the older pragma.
8620
8621 else
8622 Set_Has_Completion (Def_Id);
8623 end if;
8624 end;
8625
8626 Process_Interface_Name (Def_Id, Arg3, Arg4);
8627 end if;
8628
8629 if Is_Compilation_Unit (Hom_Id) then
8630
8631 -- Its possible homonyms are not affected by the pragma.
8632 -- Such homonyms might be present in the context of other
8633 -- units being compiled.
8634
8635 exit;
8636
8637 elsif From_Aspect_Specification (N) then
8638 exit;
8639
8640 -- If the pragma was created by the compiler, then we don't
8641 -- want it to apply to other homonyms. This kind of case can
8642 -- occur when using pragma Provide_Shift_Operators, which
8643 -- generates implicit shift and rotate operators with Import
8644 -- pragmas that might apply to earlier explicit or implicit
8645 -- declarations marked with Import (for example, coming from
8646 -- an earlier pragma Provide_Shift_Operators for another type),
8647 -- and we don't generally want other homonyms being treated
8648 -- as imported or the pragma flagged as an illegal duplicate.
8649
8650 elsif not Comes_From_Source (N) then
8651 exit;
8652
8653 else
8654 Hom_Id := Homonym (Hom_Id);
8655 end if;
8656 end loop;
8657
8658 -- Import a CPP class
8659
8660 elsif C = Convention_CPP
8661 and then (Is_Record_Type (Def_Id)
8662 or else Ekind (Def_Id) = E_Incomplete_Type)
8663 then
8664 if Ekind (Def_Id) = E_Incomplete_Type then
8665 if Present (Full_View (Def_Id)) then
8666 Def_Id := Full_View (Def_Id);
8667
8668 else
8669 Error_Msg_N
8670 ("cannot import 'C'P'P type before full declaration seen",
8671 Get_Pragma_Arg (Arg2));
8672
8673 -- Although we have reported the error we decorate it as
8674 -- CPP_Class to avoid reporting spurious errors
8675
8676 Set_Is_CPP_Class (Def_Id);
8677 return;
8678 end if;
8679 end if;
8680
8681 -- Types treated as CPP classes must be declared limited (note:
8682 -- this used to be a warning but there is no real benefit to it
8683 -- since we did effectively intend to treat the type as limited
8684 -- anyway).
8685
8686 if not Is_Limited_Type (Def_Id) then
8687 Error_Msg_N
8688 ("imported 'C'P'P type must be limited",
8689 Get_Pragma_Arg (Arg2));
8690 end if;
8691
8692 if Etype (Def_Id) /= Def_Id
8693 and then not Is_CPP_Class (Root_Type (Def_Id))
8694 then
8695 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8696 end if;
8697
8698 Set_Is_CPP_Class (Def_Id);
8699
8700 -- Imported CPP types must not have discriminants (because C++
8701 -- classes do not have discriminants).
8702
8703 if Has_Discriminants (Def_Id) then
8704 Error_Msg_N
8705 ("imported 'C'P'P type cannot have discriminants",
8706 First (Discriminant_Specifications
8707 (Declaration_Node (Def_Id))));
8708 end if;
8709
8710 -- Check that components of imported CPP types do not have default
8711 -- expressions. For private types this check is performed when the
8712 -- full view is analyzed (see Process_Full_View).
8713
8714 if not Is_Private_Type (Def_Id) then
8715 Check_CPP_Type_Has_No_Defaults (Def_Id);
8716 end if;
8717
8718 -- Import a CPP exception
8719
8720 elsif C = Convention_CPP
8721 and then Ekind (Def_Id) = E_Exception
8722 then
8723 if No (Arg3) then
8724 Error_Pragma_Arg
8725 ("'External_'Name arguments is required for 'Cpp exception",
8726 Arg3);
8727 else
8728 -- As only a string is allowed, Check_Arg_Is_External_Name
8729 -- isn't called.
8730
8731 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8732 end if;
8733
8734 if Present (Arg4) then
8735 Error_Pragma_Arg
8736 ("Link_Name argument not allowed for imported Cpp exception",
8737 Arg4);
8738 end if;
8739
8740 -- Do not call Set_Interface_Name as the name of the exception
8741 -- shouldn't be modified (and in particular it shouldn't be
8742 -- the External_Name). For exceptions, the External_Name is the
8743 -- name of the RTTI structure.
8744
8745 -- ??? Emit an error if pragma Import/Export_Exception is present
8746
8747 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8748 Check_No_Link_Name;
8749 Check_Arg_Count (3);
8750 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8751
8752 Process_Import_Predefined_Type;
8753
8754 else
8755 Error_Pragma_Arg
8756 ("second argument of pragma% must be object, subprogram "
8757 & "or incomplete type",
8758 Arg2);
8759 end if;
8760
8761 -- If this pragma applies to a compilation unit, then the unit, which
8762 -- is a subprogram, does not require (or allow) a body. We also do
8763 -- not need to elaborate imported procedures.
8764
8765 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8766 declare
8767 Cunit : constant Node_Id := Parent (Parent (N));
8768 begin
8769 Set_Body_Required (Cunit, False);
8770 end;
8771 end if;
8772 end Process_Import_Or_Interface;
8773
8774 --------------------
8775 -- Process_Inline --
8776 --------------------
8777
8778 procedure Process_Inline (Status : Inline_Status) is
8779 Applies : Boolean;
8780 Assoc : Node_Id;
8781 Decl : Node_Id;
8782 Subp : Entity_Id;
8783 Subp_Id : Node_Id;
8784
8785 Ghost_Error_Posted : Boolean := False;
8786 -- Flag set when an error concerning the illegal mix of Ghost and
8787 -- non-Ghost subprograms is emitted.
8788
8789 Ghost_Id : Entity_Id := Empty;
8790 -- The entity of the first Ghost subprogram encountered while
8791 -- processing the arguments of the pragma.
8792
8793 procedure Make_Inline (Subp : Entity_Id);
8794 -- Subp is the defining unit name of the subprogram declaration. Set
8795 -- the flag, as well as the flag in the corresponding body, if there
8796 -- is one present.
8797
8798 procedure Set_Inline_Flags (Subp : Entity_Id);
8799 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8800 -- Has_Pragma_Inline_Always for the Inline_Always case.
8801
8802 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8803 -- Returns True if it can be determined at this stage that inlining
8804 -- is not possible, for example if the body is available and contains
8805 -- exception handlers, we prevent inlining, since otherwise we can
8806 -- get undefined symbols at link time. This function also emits a
8807 -- warning if front-end inlining is enabled and the pragma appears
8808 -- too late.
8809 --
8810 -- ??? is business with link symbols still valid, or does it relate
8811 -- to front end ZCX which is being phased out ???
8812
8813 ---------------------------
8814 -- Inlining_Not_Possible --
8815 ---------------------------
8816
8817 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8818 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8819 Stats : Node_Id;
8820
8821 begin
8822 if Nkind (Decl) = N_Subprogram_Body then
8823 Stats := Handled_Statement_Sequence (Decl);
8824 return Present (Exception_Handlers (Stats))
8825 or else Present (At_End_Proc (Stats));
8826
8827 elsif Nkind (Decl) = N_Subprogram_Declaration
8828 and then Present (Corresponding_Body (Decl))
8829 then
8830 if Front_End_Inlining
8831 and then Analyzed (Corresponding_Body (Decl))
8832 then
8833 Error_Msg_N ("pragma appears too late, ignored??", N);
8834 return True;
8835
8836 -- If the subprogram is a renaming as body, the body is just a
8837 -- call to the renamed subprogram, and inlining is trivially
8838 -- possible.
8839
8840 elsif
8841 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8842 N_Subprogram_Renaming_Declaration
8843 then
8844 return False;
8845
8846 else
8847 Stats :=
8848 Handled_Statement_Sequence
8849 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8850
8851 return
8852 Present (Exception_Handlers (Stats))
8853 or else Present (At_End_Proc (Stats));
8854 end if;
8855
8856 else
8857 -- If body is not available, assume the best, the check is
8858 -- performed again when compiling enclosing package bodies.
8859
8860 return False;
8861 end if;
8862 end Inlining_Not_Possible;
8863
8864 -----------------
8865 -- Make_Inline --
8866 -----------------
8867
8868 procedure Make_Inline (Subp : Entity_Id) is
8869 Kind : constant Entity_Kind := Ekind (Subp);
8870 Inner_Subp : Entity_Id := Subp;
8871
8872 begin
8873 -- Ignore if bad type, avoid cascaded error
8874
8875 if Etype (Subp) = Any_Type then
8876 Applies := True;
8877 return;
8878
8879 -- If inlining is not possible, for now do not treat as an error
8880
8881 elsif Status /= Suppressed
8882 and then Inlining_Not_Possible (Subp)
8883 then
8884 Applies := True;
8885 return;
8886
8887 -- Here we have a candidate for inlining, but we must exclude
8888 -- derived operations. Otherwise we would end up trying to inline
8889 -- a phantom declaration, and the result would be to drag in a
8890 -- body which has no direct inlining associated with it. That
8891 -- would not only be inefficient but would also result in the
8892 -- backend doing cross-unit inlining in cases where it was
8893 -- definitely inappropriate to do so.
8894
8895 -- However, a simple Comes_From_Source test is insufficient, since
8896 -- we do want to allow inlining of generic instances which also do
8897 -- not come from source. We also need to recognize specs generated
8898 -- by the front-end for bodies that carry the pragma. Finally,
8899 -- predefined operators do not come from source but are not
8900 -- inlineable either.
8901
8902 elsif Is_Generic_Instance (Subp)
8903 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8904 then
8905 null;
8906
8907 elsif not Comes_From_Source (Subp)
8908 and then Scope (Subp) /= Standard_Standard
8909 then
8910 Applies := True;
8911 return;
8912 end if;
8913
8914 -- The referenced entity must either be the enclosing entity, or
8915 -- an entity declared within the current open scope.
8916
8917 if Present (Scope (Subp))
8918 and then Scope (Subp) /= Current_Scope
8919 and then Subp /= Current_Scope
8920 then
8921 Error_Pragma_Arg
8922 ("argument of% must be entity in current scope", Assoc);
8923 return;
8924 end if;
8925
8926 -- Processing for procedure, operator or function. If subprogram
8927 -- is aliased (as for an instance) indicate that the renamed
8928 -- entity (if declared in the same unit) is inlined.
8929 -- If this is the anonymous subprogram created for a subprogram
8930 -- instance, the inlining applies to it directly. Otherwise we
8931 -- retrieve it as the alias of the visible subprogram instance.
8932
8933 if Is_Subprogram (Subp) then
8934 if Is_Wrapper_Package (Scope (Subp)) then
8935 Inner_Subp := Subp;
8936 else
8937 Inner_Subp := Ultimate_Alias (Inner_Subp);
8938 end if;
8939
8940 if In_Same_Source_Unit (Subp, Inner_Subp) then
8941 Set_Inline_Flags (Inner_Subp);
8942
8943 Decl := Parent (Parent (Inner_Subp));
8944
8945 if Nkind (Decl) = N_Subprogram_Declaration
8946 and then Present (Corresponding_Body (Decl))
8947 then
8948 Set_Inline_Flags (Corresponding_Body (Decl));
8949
8950 elsif Is_Generic_Instance (Subp)
8951 and then Comes_From_Source (Subp)
8952 then
8953 -- Indicate that the body needs to be created for
8954 -- inlining subsequent calls. The instantiation node
8955 -- follows the declaration of the wrapper package
8956 -- created for it. The subprogram that requires the
8957 -- body is the anonymous one in the wrapper package.
8958
8959 if Scope (Subp) /= Standard_Standard
8960 and then
8961 Need_Subprogram_Instance_Body
8962 (Next (Unit_Declaration_Node
8963 (Scope (Alias (Subp)))), Subp)
8964 then
8965 null;
8966 end if;
8967
8968 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8969 -- appear in a formal part to apply to a formal subprogram.
8970 -- Do not apply check within an instance or a formal package
8971 -- the test will have been applied to the original generic.
8972
8973 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8974 and then List_Containing (Decl) = List_Containing (N)
8975 and then not In_Instance
8976 then
8977 Error_Msg_N
8978 ("Inline cannot apply to a formal subprogram", N);
8979
8980 -- If Subp is a renaming, it is the renamed entity that
8981 -- will appear in any call, and be inlined. However, for
8982 -- ASIS uses it is convenient to indicate that the renaming
8983 -- itself is an inlined subprogram, so that some gnatcheck
8984 -- rules can be applied in the absence of expansion.
8985
8986 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8987 Set_Inline_Flags (Subp);
8988 end if;
8989 end if;
8990
8991 Applies := True;
8992
8993 -- For a generic subprogram set flag as well, for use at the point
8994 -- of instantiation, to determine whether the body should be
8995 -- generated.
8996
8997 elsif Is_Generic_Subprogram (Subp) then
8998 Set_Inline_Flags (Subp);
8999 Applies := True;
9000
9001 -- Literals are by definition inlined
9002
9003 elsif Kind = E_Enumeration_Literal then
9004 null;
9005
9006 -- Anything else is an error
9007
9008 else
9009 Error_Pragma_Arg
9010 ("expect subprogram name for pragma%", Assoc);
9011 end if;
9012 end Make_Inline;
9013
9014 ----------------------
9015 -- Set_Inline_Flags --
9016 ----------------------
9017
9018 procedure Set_Inline_Flags (Subp : Entity_Id) is
9019 begin
9020 -- First set the Has_Pragma_XXX flags and issue the appropriate
9021 -- errors and warnings for suspicious combinations.
9022
9023 if Prag_Id = Pragma_No_Inline then
9024 if Has_Pragma_Inline_Always (Subp) then
9025 Error_Msg_N
9026 ("Inline_Always and No_Inline are mutually exclusive", N);
9027 elsif Has_Pragma_Inline (Subp) then
9028 Error_Msg_NE
9029 ("Inline and No_Inline both specified for& ??",
9030 N, Entity (Subp_Id));
9031 end if;
9032
9033 Set_Has_Pragma_No_Inline (Subp);
9034 else
9035 if Prag_Id = Pragma_Inline_Always then
9036 if Has_Pragma_No_Inline (Subp) then
9037 Error_Msg_N
9038 ("Inline_Always and No_Inline are mutually exclusive",
9039 N);
9040 end if;
9041
9042 Set_Has_Pragma_Inline_Always (Subp);
9043 else
9044 if Has_Pragma_No_Inline (Subp) then
9045 Error_Msg_NE
9046 ("Inline and No_Inline both specified for& ??",
9047 N, Entity (Subp_Id));
9048 end if;
9049 end if;
9050
9051 if not Has_Pragma_Inline (Subp) then
9052 Set_Has_Pragma_Inline (Subp);
9053 end if;
9054 end if;
9055
9056 -- Then adjust the Is_Inlined flag. It can never be set if the
9057 -- subprogram is subject to pragma No_Inline.
9058
9059 case Status is
9060 when Suppressed =>
9061 Set_Is_Inlined (Subp, False);
9062 when Disabled =>
9063 null;
9064 when Enabled =>
9065 if not Has_Pragma_No_Inline (Subp) then
9066 Set_Is_Inlined (Subp, True);
9067 end if;
9068 end case;
9069
9070 -- A pragma that applies to a Ghost entity becomes Ghost for the
9071 -- purposes of legality checks and removal of ignored Ghost code.
9072
9073 Mark_Pragma_As_Ghost (N, Subp);
9074
9075 -- Capture the entity of the first Ghost subprogram being
9076 -- processed for error detection purposes.
9077
9078 if Is_Ghost_Entity (Subp) then
9079 if No (Ghost_Id) then
9080 Ghost_Id := Subp;
9081 end if;
9082
9083 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9084 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9085
9086 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9087 Ghost_Error_Posted := True;
9088
9089 Error_Msg_Name_1 := Pname;
9090 Error_Msg_N
9091 ("pragma % cannot mention ghost and non-ghost subprograms",
9092 N);
9093
9094 Error_Msg_Sloc := Sloc (Ghost_Id);
9095 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9096
9097 Error_Msg_Sloc := Sloc (Subp);
9098 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9099 end if;
9100 end Set_Inline_Flags;
9101
9102 -- Start of processing for Process_Inline
9103
9104 begin
9105 Check_No_Identifiers;
9106 Check_At_Least_N_Arguments (1);
9107
9108 if Status = Enabled then
9109 Inline_Processing_Required := True;
9110 end if;
9111
9112 Assoc := Arg1;
9113 while Present (Assoc) loop
9114 Subp_Id := Get_Pragma_Arg (Assoc);
9115 Analyze (Subp_Id);
9116 Applies := False;
9117
9118 if Is_Entity_Name (Subp_Id) then
9119 Subp := Entity (Subp_Id);
9120
9121 if Subp = Any_Id then
9122
9123 -- If previous error, avoid cascaded errors
9124
9125 Check_Error_Detected;
9126 Applies := True;
9127
9128 else
9129 Make_Inline (Subp);
9130
9131 -- For the pragma case, climb homonym chain. This is
9132 -- what implements allowing the pragma in the renaming
9133 -- case, with the result applying to the ancestors, and
9134 -- also allows Inline to apply to all previous homonyms.
9135
9136 if not From_Aspect_Specification (N) then
9137 while Present (Homonym (Subp))
9138 and then Scope (Homonym (Subp)) = Current_Scope
9139 loop
9140 Make_Inline (Homonym (Subp));
9141 Subp := Homonym (Subp);
9142 end loop;
9143 end if;
9144 end if;
9145 end if;
9146
9147 if not Applies then
9148 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9149 end if;
9150
9151 Next (Assoc);
9152 end loop;
9153 end Process_Inline;
9154
9155 ----------------------------
9156 -- Process_Interface_Name --
9157 ----------------------------
9158
9159 procedure Process_Interface_Name
9160 (Subprogram_Def : Entity_Id;
9161 Ext_Arg : Node_Id;
9162 Link_Arg : Node_Id)
9163 is
9164 Ext_Nam : Node_Id;
9165 Link_Nam : Node_Id;
9166 String_Val : String_Id;
9167
9168 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
9169 -- SN is a string literal node for an interface name. This routine
9170 -- performs some minimal checks that the name is reasonable. In
9171 -- particular that no spaces or other obviously incorrect characters
9172 -- appear. This is only a warning, since any characters are allowed.
9173
9174 ----------------------------------
9175 -- Check_Form_Of_Interface_Name --
9176 ----------------------------------
9177
9178 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
9179 S : constant String_Id := Strval (Expr_Value_S (SN));
9180 SL : constant Nat := String_Length (S);
9181 C : Char_Code;
9182
9183 begin
9184 if SL = 0 then
9185 Error_Msg_N ("interface name cannot be null string", SN);
9186 end if;
9187
9188 for J in 1 .. SL loop
9189 C := Get_String_Char (S, J);
9190
9191 -- Look for dubious character and issue unconditional warning.
9192 -- Definitely dubious if not in character range.
9193
9194 if not In_Character_Range (C)
9195
9196 -- Commas, spaces and (back)slashes are dubious
9197
9198 or else Get_Character (C) = ','
9199 or else Get_Character (C) = '\'
9200 or else Get_Character (C) = ' '
9201 or else Get_Character (C) = '/'
9202 then
9203 Error_Msg
9204 ("??interface name contains illegal character",
9205 Sloc (SN) + Source_Ptr (J));
9206 end if;
9207 end loop;
9208 end Check_Form_Of_Interface_Name;
9209
9210 -- Start of processing for Process_Interface_Name
9211
9212 begin
9213 if No (Link_Arg) then
9214 if No (Ext_Arg) then
9215 return;
9216
9217 elsif Chars (Ext_Arg) = Name_Link_Name then
9218 Ext_Nam := Empty;
9219 Link_Nam := Expression (Ext_Arg);
9220
9221 else
9222 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9223 Ext_Nam := Expression (Ext_Arg);
9224 Link_Nam := Empty;
9225 end if;
9226
9227 else
9228 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9229 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
9230 Ext_Nam := Expression (Ext_Arg);
9231 Link_Nam := Expression (Link_Arg);
9232 end if;
9233
9234 -- Check expressions for external name and link name are static
9235
9236 if Present (Ext_Nam) then
9237 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
9238 Check_Form_Of_Interface_Name (Ext_Nam);
9239
9240 -- Verify that external name is not the name of a local entity,
9241 -- which would hide the imported one and could lead to run-time
9242 -- surprises. The problem can only arise for entities declared in
9243 -- a package body (otherwise the external name is fully qualified
9244 -- and will not conflict).
9245
9246 declare
9247 Nam : Name_Id;
9248 E : Entity_Id;
9249 Par : Node_Id;
9250
9251 begin
9252 if Prag_Id = Pragma_Import then
9253 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
9254 Nam := Name_Find;
9255 E := Entity_Id (Get_Name_Table_Int (Nam));
9256
9257 if Nam /= Chars (Subprogram_Def)
9258 and then Present (E)
9259 and then not Is_Overloadable (E)
9260 and then Is_Immediately_Visible (E)
9261 and then not Is_Imported (E)
9262 and then Ekind (Scope (E)) = E_Package
9263 then
9264 Par := Parent (E);
9265 while Present (Par) loop
9266 if Nkind (Par) = N_Package_Body then
9267 Error_Msg_Sloc := Sloc (E);
9268 Error_Msg_NE
9269 ("imported entity is hidden by & declared#",
9270 Ext_Arg, E);
9271 exit;
9272 end if;
9273
9274 Par := Parent (Par);
9275 end loop;
9276 end if;
9277 end if;
9278 end;
9279 end if;
9280
9281 if Present (Link_Nam) then
9282 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
9283 Check_Form_Of_Interface_Name (Link_Nam);
9284 end if;
9285
9286 -- If there is no link name, just set the external name
9287
9288 if No (Link_Nam) then
9289 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
9290
9291 -- For the Link_Name case, the given literal is preceded by an
9292 -- asterisk, which indicates to GCC that the given name should be
9293 -- taken literally, and in particular that no prepending of
9294 -- underlines should occur, even in systems where this is the
9295 -- normal default.
9296
9297 else
9298 Start_String;
9299 Store_String_Char (Get_Char_Code ('*'));
9300 String_Val := Strval (Expr_Value_S (Link_Nam));
9301 Store_String_Chars (String_Val);
9302 Link_Nam :=
9303 Make_String_Literal (Sloc (Link_Nam),
9304 Strval => End_String);
9305 end if;
9306
9307 -- Set the interface name. If the entity is a generic instance, use
9308 -- its alias, which is the callable entity.
9309
9310 if Is_Generic_Instance (Subprogram_Def) then
9311 Set_Encoded_Interface_Name
9312 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
9313 else
9314 Set_Encoded_Interface_Name
9315 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9316 end if;
9317
9318 Check_Duplicated_Export_Name (Link_Nam);
9319 end Process_Interface_Name;
9320
9321 -----------------------------------------
9322 -- Process_Interrupt_Or_Attach_Handler --
9323 -----------------------------------------
9324
9325 procedure Process_Interrupt_Or_Attach_Handler is
9326 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9327 Prot_Typ : constant Entity_Id := Scope (Handler);
9328
9329 begin
9330 -- A pragma that applies to a Ghost entity becomes Ghost for the
9331 -- purposes of legality checks and removal of ignored Ghost code.
9332
9333 Mark_Pragma_As_Ghost (N, Handler);
9334 Set_Is_Interrupt_Handler (Handler);
9335
9336 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9337
9338 Record_Rep_Item (Prot_Typ, N);
9339
9340 -- Chain the pragma on the contract for completeness
9341
9342 Add_Contract_Item (N, Handler);
9343 end Process_Interrupt_Or_Attach_Handler;
9344
9345 --------------------------------------------------
9346 -- Process_Restrictions_Or_Restriction_Warnings --
9347 --------------------------------------------------
9348
9349 -- Note: some of the simple identifier cases were handled in par-prag,
9350 -- but it is harmless (and more straightforward) to simply handle all
9351 -- cases here, even if it means we repeat a bit of work in some cases.
9352
9353 procedure Process_Restrictions_Or_Restriction_Warnings
9354 (Warn : Boolean)
9355 is
9356 Arg : Node_Id;
9357 R_Id : Restriction_Id;
9358 Id : Name_Id;
9359 Expr : Node_Id;
9360 Val : Uint;
9361
9362 begin
9363 -- Ignore all Restrictions pragmas in CodePeer mode
9364
9365 if CodePeer_Mode then
9366 return;
9367 end if;
9368
9369 Check_Ada_83_Warning;
9370 Check_At_Least_N_Arguments (1);
9371 Check_Valid_Configuration_Pragma;
9372
9373 Arg := Arg1;
9374 while Present (Arg) loop
9375 Id := Chars (Arg);
9376 Expr := Get_Pragma_Arg (Arg);
9377
9378 -- Case of no restriction identifier present
9379
9380 if Id = No_Name then
9381 if Nkind (Expr) /= N_Identifier then
9382 Error_Pragma_Arg
9383 ("invalid form for restriction", Arg);
9384 end if;
9385
9386 R_Id :=
9387 Get_Restriction_Id
9388 (Process_Restriction_Synonyms (Expr));
9389
9390 if R_Id not in All_Boolean_Restrictions then
9391 Error_Msg_Name_1 := Pname;
9392 Error_Msg_N
9393 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9394
9395 -- Check for possible misspelling
9396
9397 for J in Restriction_Id loop
9398 declare
9399 Rnm : constant String := Restriction_Id'Image (J);
9400
9401 begin
9402 Name_Buffer (1 .. Rnm'Length) := Rnm;
9403 Name_Len := Rnm'Length;
9404 Set_Casing (All_Lower_Case);
9405
9406 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9407 Set_Casing
9408 (Identifier_Casing (Current_Source_File));
9409 Error_Msg_String (1 .. Rnm'Length) :=
9410 Name_Buffer (1 .. Name_Len);
9411 Error_Msg_Strlen := Rnm'Length;
9412 Error_Msg_N -- CODEFIX
9413 ("\possible misspelling of ""~""",
9414 Get_Pragma_Arg (Arg));
9415 exit;
9416 end if;
9417 end;
9418 end loop;
9419
9420 raise Pragma_Exit;
9421 end if;
9422
9423 if Implementation_Restriction (R_Id) then
9424 Check_Restriction (No_Implementation_Restrictions, Arg);
9425 end if;
9426
9427 -- Special processing for No_Elaboration_Code restriction
9428
9429 if R_Id = No_Elaboration_Code then
9430
9431 -- Restriction is only recognized within a configuration
9432 -- pragma file, or within a unit of the main extended
9433 -- program. Note: the test for Main_Unit is needed to
9434 -- properly include the case of configuration pragma files.
9435
9436 if not (Current_Sem_Unit = Main_Unit
9437 or else In_Extended_Main_Source_Unit (N))
9438 then
9439 return;
9440
9441 -- Don't allow in a subunit unless already specified in
9442 -- body or spec.
9443
9444 elsif Nkind (Parent (N)) = N_Compilation_Unit
9445 and then Nkind (Unit (Parent (N))) = N_Subunit
9446 and then not Restriction_Active (No_Elaboration_Code)
9447 then
9448 Error_Msg_N
9449 ("invalid specification of ""No_Elaboration_Code""",
9450 N);
9451 Error_Msg_N
9452 ("\restriction cannot be specified in a subunit", N);
9453 Error_Msg_N
9454 ("\unless also specified in body or spec", N);
9455 return;
9456
9457 -- If we accept a No_Elaboration_Code restriction, then it
9458 -- needs to be added to the configuration restriction set so
9459 -- that we get proper application to other units in the main
9460 -- extended source as required.
9461
9462 else
9463 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9464 end if;
9465 end if;
9466
9467 -- If this is a warning, then set the warning unless we already
9468 -- have a real restriction active (we never want a warning to
9469 -- override a real restriction).
9470
9471 if Warn then
9472 if not Restriction_Active (R_Id) then
9473 Set_Restriction (R_Id, N);
9474 Restriction_Warnings (R_Id) := True;
9475 end if;
9476
9477 -- If real restriction case, then set it and make sure that the
9478 -- restriction warning flag is off, since a real restriction
9479 -- always overrides a warning.
9480
9481 else
9482 Set_Restriction (R_Id, N);
9483 Restriction_Warnings (R_Id) := False;
9484 end if;
9485
9486 -- Check for obsolescent restrictions in Ada 2005 mode
9487
9488 if not Warn
9489 and then Ada_Version >= Ada_2005
9490 and then (R_Id = No_Asynchronous_Control
9491 or else
9492 R_Id = No_Unchecked_Deallocation
9493 or else
9494 R_Id = No_Unchecked_Conversion)
9495 then
9496 Check_Restriction (No_Obsolescent_Features, N);
9497 end if;
9498
9499 -- A very special case that must be processed here: pragma
9500 -- Restrictions (No_Exceptions) turns off all run-time
9501 -- checking. This is a bit dubious in terms of the formal
9502 -- language definition, but it is what is intended by RM
9503 -- H.4(12). Restriction_Warnings never affects generated code
9504 -- so this is done only in the real restriction case.
9505
9506 -- Atomic_Synchronization is not a real check, so it is not
9507 -- affected by this processing).
9508
9509 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9510 -- run-time checks in CodePeer and GNATprove modes: we want to
9511 -- generate checks for analysis purposes, as set respectively
9512 -- by -gnatC and -gnatd.F
9513
9514 if not Warn
9515 and then not (CodePeer_Mode or GNATprove_Mode)
9516 and then R_Id = No_Exceptions
9517 then
9518 for J in Scope_Suppress.Suppress'Range loop
9519 if J /= Atomic_Synchronization then
9520 Scope_Suppress.Suppress (J) := True;
9521 end if;
9522 end loop;
9523 end if;
9524
9525 -- Case of No_Dependence => unit-name. Note that the parser
9526 -- already made the necessary entry in the No_Dependence table.
9527
9528 elsif Id = Name_No_Dependence then
9529 if not OK_No_Dependence_Unit_Name (Expr) then
9530 raise Pragma_Exit;
9531 end if;
9532
9533 -- Case of No_Specification_Of_Aspect => aspect-identifier
9534
9535 elsif Id = Name_No_Specification_Of_Aspect then
9536 declare
9537 A_Id : Aspect_Id;
9538
9539 begin
9540 if Nkind (Expr) /= N_Identifier then
9541 A_Id := No_Aspect;
9542 else
9543 A_Id := Get_Aspect_Id (Chars (Expr));
9544 end if;
9545
9546 if A_Id = No_Aspect then
9547 Error_Pragma_Arg ("invalid restriction name", Arg);
9548 else
9549 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9550 end if;
9551 end;
9552
9553 -- Case of No_Use_Of_Attribute => attribute-identifier
9554
9555 elsif Id = Name_No_Use_Of_Attribute then
9556 if Nkind (Expr) /= N_Identifier
9557 or else not Is_Attribute_Name (Chars (Expr))
9558 then
9559 Error_Msg_N ("unknown attribute name??", Expr);
9560
9561 else
9562 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9563 end if;
9564
9565 -- Case of No_Use_Of_Entity => fully-qualified-name
9566
9567 elsif Id = Name_No_Use_Of_Entity then
9568
9569 -- Restriction is only recognized within a configuration
9570 -- pragma file, or within a unit of the main extended
9571 -- program. Note: the test for Main_Unit is needed to
9572 -- properly include the case of configuration pragma files.
9573
9574 if Current_Sem_Unit = Main_Unit
9575 or else In_Extended_Main_Source_Unit (N)
9576 then
9577 if not OK_No_Dependence_Unit_Name (Expr) then
9578 Error_Msg_N ("wrong form for entity name", Expr);
9579 else
9580 Set_Restriction_No_Use_Of_Entity
9581 (Expr, Warn, No_Profile);
9582 end if;
9583 end if;
9584
9585 -- Case of No_Use_Of_Pragma => pragma-identifier
9586
9587 elsif Id = Name_No_Use_Of_Pragma then
9588 if Nkind (Expr) /= N_Identifier
9589 or else not Is_Pragma_Name (Chars (Expr))
9590 then
9591 Error_Msg_N ("unknown pragma name??", Expr);
9592 else
9593 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9594 end if;
9595
9596 -- All other cases of restriction identifier present
9597
9598 else
9599 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9600 Analyze_And_Resolve (Expr, Any_Integer);
9601
9602 if R_Id not in All_Parameter_Restrictions then
9603 Error_Pragma_Arg
9604 ("invalid restriction parameter identifier", Arg);
9605
9606 elsif not Is_OK_Static_Expression (Expr) then
9607 Flag_Non_Static_Expr
9608 ("value must be static expression!", Expr);
9609 raise Pragma_Exit;
9610
9611 elsif not Is_Integer_Type (Etype (Expr))
9612 or else Expr_Value (Expr) < 0
9613 then
9614 Error_Pragma_Arg
9615 ("value must be non-negative integer", Arg);
9616 end if;
9617
9618 -- Restriction pragma is active
9619
9620 Val := Expr_Value (Expr);
9621
9622 if not UI_Is_In_Int_Range (Val) then
9623 Error_Pragma_Arg
9624 ("pragma ignored, value too large??", Arg);
9625 end if;
9626
9627 -- Warning case. If the real restriction is active, then we
9628 -- ignore the request, since warning never overrides a real
9629 -- restriction. Otherwise we set the proper warning. Note that
9630 -- this circuit sets the warning again if it is already set,
9631 -- which is what we want, since the constant may have changed.
9632
9633 if Warn then
9634 if not Restriction_Active (R_Id) then
9635 Set_Restriction
9636 (R_Id, N, Integer (UI_To_Int (Val)));
9637 Restriction_Warnings (R_Id) := True;
9638 end if;
9639
9640 -- Real restriction case, set restriction and make sure warning
9641 -- flag is off since real restriction always overrides warning.
9642
9643 else
9644 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9645 Restriction_Warnings (R_Id) := False;
9646 end if;
9647 end if;
9648
9649 Next (Arg);
9650 end loop;
9651 end Process_Restrictions_Or_Restriction_Warnings;
9652
9653 ---------------------------------
9654 -- Process_Suppress_Unsuppress --
9655 ---------------------------------
9656
9657 -- Note: this procedure makes entries in the check suppress data
9658 -- structures managed by Sem. See spec of package Sem for full
9659 -- details on how we handle recording of check suppression.
9660
9661 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9662 C : Check_Id;
9663 E : Entity_Id;
9664 E_Id : Node_Id;
9665
9666 In_Package_Spec : constant Boolean :=
9667 Is_Package_Or_Generic_Package (Current_Scope)
9668 and then not In_Package_Body (Current_Scope);
9669
9670 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9671 -- Used to suppress a single check on the given entity
9672
9673 --------------------------------
9674 -- Suppress_Unsuppress_Echeck --
9675 --------------------------------
9676
9677 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9678 begin
9679 -- Check for error of trying to set atomic synchronization for
9680 -- a non-atomic variable.
9681
9682 if C = Atomic_Synchronization
9683 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9684 then
9685 Error_Msg_N
9686 ("pragma & requires atomic type or variable",
9687 Pragma_Identifier (Original_Node (N)));
9688 end if;
9689
9690 Set_Checks_May_Be_Suppressed (E);
9691
9692 if In_Package_Spec then
9693 Push_Global_Suppress_Stack_Entry
9694 (Entity => E,
9695 Check => C,
9696 Suppress => Suppress_Case);
9697 else
9698 Push_Local_Suppress_Stack_Entry
9699 (Entity => E,
9700 Check => C,
9701 Suppress => Suppress_Case);
9702 end if;
9703
9704 -- If this is a first subtype, and the base type is distinct,
9705 -- then also set the suppress flags on the base type.
9706
9707 if Is_First_Subtype (E) and then Etype (E) /= E then
9708 Suppress_Unsuppress_Echeck (Etype (E), C);
9709 end if;
9710 end Suppress_Unsuppress_Echeck;
9711
9712 -- Start of processing for Process_Suppress_Unsuppress
9713
9714 begin
9715 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9716 -- on user code: we want to generate checks for analysis purposes, as
9717 -- set respectively by -gnatC and -gnatd.F
9718
9719 if Comes_From_Source (N)
9720 and then (CodePeer_Mode or GNATprove_Mode)
9721 then
9722 return;
9723 end if;
9724
9725 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9726 -- declarative part or a package spec (RM 11.5(5)).
9727
9728 if not Is_Configuration_Pragma then
9729 Check_Is_In_Decl_Part_Or_Package_Spec;
9730 end if;
9731
9732 Check_At_Least_N_Arguments (1);
9733 Check_At_Most_N_Arguments (2);
9734 Check_No_Identifier (Arg1);
9735 Check_Arg_Is_Identifier (Arg1);
9736
9737 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9738
9739 if C = No_Check_Id then
9740 Error_Pragma_Arg
9741 ("argument of pragma% is not valid check name", Arg1);
9742 end if;
9743
9744 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9745
9746 if C = Elaboration_Check and then SPARK_Mode = On then
9747 Error_Pragma_Arg
9748 ("Suppress of Elaboration_Check ignored in SPARK??",
9749 "\elaboration checking rules are statically enforced "
9750 & "(SPARK RM 7.7)", Arg1);
9751 end if;
9752
9753 -- One-argument case
9754
9755 if Arg_Count = 1 then
9756
9757 -- Make an entry in the local scope suppress table. This is the
9758 -- table that directly shows the current value of the scope
9759 -- suppress check for any check id value.
9760
9761 if C = All_Checks then
9762
9763 -- For All_Checks, we set all specific predefined checks with
9764 -- the exception of Elaboration_Check, which is handled
9765 -- specially because of not wanting All_Checks to have the
9766 -- effect of deactivating static elaboration order processing.
9767 -- Atomic_Synchronization is also not affected, since this is
9768 -- not a real check.
9769
9770 for J in Scope_Suppress.Suppress'Range loop
9771 if J /= Elaboration_Check
9772 and then
9773 J /= Atomic_Synchronization
9774 then
9775 Scope_Suppress.Suppress (J) := Suppress_Case;
9776 end if;
9777 end loop;
9778
9779 -- If not All_Checks, and predefined check, then set appropriate
9780 -- scope entry. Note that we will set Elaboration_Check if this
9781 -- is explicitly specified. Atomic_Synchronization is allowed
9782 -- only if internally generated and entity is atomic.
9783
9784 elsif C in Predefined_Check_Id
9785 and then (not Comes_From_Source (N)
9786 or else C /= Atomic_Synchronization)
9787 then
9788 Scope_Suppress.Suppress (C) := Suppress_Case;
9789 end if;
9790
9791 -- Also make an entry in the Local_Entity_Suppress table
9792
9793 Push_Local_Suppress_Stack_Entry
9794 (Entity => Empty,
9795 Check => C,
9796 Suppress => Suppress_Case);
9797
9798 -- Case of two arguments present, where the check is suppressed for
9799 -- a specified entity (given as the second argument of the pragma)
9800
9801 else
9802 -- This is obsolescent in Ada 2005 mode
9803
9804 if Ada_Version >= Ada_2005 then
9805 Check_Restriction (No_Obsolescent_Features, Arg2);
9806 end if;
9807
9808 Check_Optional_Identifier (Arg2, Name_On);
9809 E_Id := Get_Pragma_Arg (Arg2);
9810 Analyze (E_Id);
9811
9812 if not Is_Entity_Name (E_Id) then
9813 Error_Pragma_Arg
9814 ("second argument of pragma% must be entity name", Arg2);
9815 end if;
9816
9817 E := Entity (E_Id);
9818
9819 if E = Any_Id then
9820 return;
9821 end if;
9822
9823 -- A pragma that applies to a Ghost entity becomes Ghost for the
9824 -- purposes of legality checks and removal of ignored Ghost code.
9825
9826 Mark_Pragma_As_Ghost (N, E);
9827
9828 -- Enforce RM 11.5(7) which requires that for a pragma that
9829 -- appears within a package spec, the named entity must be
9830 -- within the package spec. We allow the package name itself
9831 -- to be mentioned since that makes sense, although it is not
9832 -- strictly allowed by 11.5(7).
9833
9834 if In_Package_Spec
9835 and then E /= Current_Scope
9836 and then Scope (E) /= Current_Scope
9837 then
9838 Error_Pragma_Arg
9839 ("entity in pragma% is not in package spec (RM 11.5(7))",
9840 Arg2);
9841 end if;
9842
9843 -- Loop through homonyms. As noted below, in the case of a package
9844 -- spec, only homonyms within the package spec are considered.
9845
9846 loop
9847 Suppress_Unsuppress_Echeck (E, C);
9848
9849 if Is_Generic_Instance (E)
9850 and then Is_Subprogram (E)
9851 and then Present (Alias (E))
9852 then
9853 Suppress_Unsuppress_Echeck (Alias (E), C);
9854 end if;
9855
9856 -- Move to next homonym if not aspect spec case
9857
9858 exit when From_Aspect_Specification (N);
9859 E := Homonym (E);
9860 exit when No (E);
9861
9862 -- If we are within a package specification, the pragma only
9863 -- applies to homonyms in the same scope.
9864
9865 exit when In_Package_Spec
9866 and then Scope (E) /= Current_Scope;
9867 end loop;
9868 end if;
9869 end Process_Suppress_Unsuppress;
9870
9871 -------------------------------
9872 -- Record_Independence_Check --
9873 -------------------------------
9874
9875 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9876 begin
9877 -- For GCC back ends the validation is done a priori
9878
9879 if not AAMP_On_Target then
9880 return;
9881 end if;
9882
9883 Independence_Checks.Append ((N, E));
9884 end Record_Independence_Check;
9885
9886 ------------------
9887 -- Set_Exported --
9888 ------------------
9889
9890 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9891 begin
9892 if Is_Imported (E) then
9893 Error_Pragma_Arg
9894 ("cannot export entity& that was previously imported", Arg);
9895
9896 elsif Present (Address_Clause (E))
9897 and then not Relaxed_RM_Semantics
9898 then
9899 Error_Pragma_Arg
9900 ("cannot export entity& that has an address clause", Arg);
9901 end if;
9902
9903 Set_Is_Exported (E);
9904
9905 -- Generate a reference for entity explicitly, because the
9906 -- identifier may be overloaded and name resolution will not
9907 -- generate one.
9908
9909 Generate_Reference (E, Arg);
9910
9911 -- Deal with exporting non-library level entity
9912
9913 if not Is_Library_Level_Entity (E) then
9914
9915 -- Not allowed at all for subprograms
9916
9917 if Is_Subprogram (E) then
9918 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9919
9920 -- Otherwise set public and statically allocated
9921
9922 else
9923 Set_Is_Public (E);
9924 Set_Is_Statically_Allocated (E);
9925
9926 -- Warn if the corresponding W flag is set
9927
9928 if Warn_On_Export_Import
9929
9930 -- Only do this for something that was in the source. Not
9931 -- clear if this can be False now (there used for sure to be
9932 -- cases on some systems where it was False), but anyway the
9933 -- test is harmless if not needed, so it is retained.
9934
9935 and then Comes_From_Source (Arg)
9936 then
9937 Error_Msg_NE
9938 ("?x?& has been made static as a result of Export",
9939 Arg, E);
9940 Error_Msg_N
9941 ("\?x?this usage is non-standard and non-portable",
9942 Arg);
9943 end if;
9944 end if;
9945 end if;
9946
9947 if Warn_On_Export_Import and then Is_Type (E) then
9948 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9949 end if;
9950
9951 if Warn_On_Export_Import and Inside_A_Generic then
9952 Error_Msg_NE
9953 ("all instances of& will have the same external name?x?",
9954 Arg, E);
9955 end if;
9956 end Set_Exported;
9957
9958 ----------------------------------------------
9959 -- Set_Extended_Import_Export_External_Name --
9960 ----------------------------------------------
9961
9962 procedure Set_Extended_Import_Export_External_Name
9963 (Internal_Ent : Entity_Id;
9964 Arg_External : Node_Id)
9965 is
9966 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9967 New_Name : Node_Id;
9968
9969 begin
9970 if No (Arg_External) then
9971 return;
9972 end if;
9973
9974 Check_Arg_Is_External_Name (Arg_External);
9975
9976 if Nkind (Arg_External) = N_String_Literal then
9977 if String_Length (Strval (Arg_External)) = 0 then
9978 return;
9979 else
9980 New_Name := Adjust_External_Name_Case (Arg_External);
9981 end if;
9982
9983 elsif Nkind (Arg_External) = N_Identifier then
9984 New_Name := Get_Default_External_Name (Arg_External);
9985
9986 -- Check_Arg_Is_External_Name should let through only identifiers and
9987 -- string literals or static string expressions (which are folded to
9988 -- string literals).
9989
9990 else
9991 raise Program_Error;
9992 end if;
9993
9994 -- If we already have an external name set (by a prior normal Import
9995 -- or Export pragma), then the external names must match
9996
9997 if Present (Interface_Name (Internal_Ent)) then
9998
9999 -- Ignore mismatching names in CodePeer mode, to support some
10000 -- old compilers which would export the same procedure under
10001 -- different names, e.g:
10002 -- procedure P;
10003 -- pragma Export_Procedure (P, "a");
10004 -- pragma Export_Procedure (P, "b");
10005
10006 if CodePeer_Mode then
10007 return;
10008 end if;
10009
10010 Check_Matching_Internal_Names : declare
10011 S1 : constant String_Id := Strval (Old_Name);
10012 S2 : constant String_Id := Strval (New_Name);
10013
10014 procedure Mismatch;
10015 pragma No_Return (Mismatch);
10016 -- Called if names do not match
10017
10018 --------------
10019 -- Mismatch --
10020 --------------
10021
10022 procedure Mismatch is
10023 begin
10024 Error_Msg_Sloc := Sloc (Old_Name);
10025 Error_Pragma_Arg
10026 ("external name does not match that given #",
10027 Arg_External);
10028 end Mismatch;
10029
10030 -- Start of processing for Check_Matching_Internal_Names
10031
10032 begin
10033 if String_Length (S1) /= String_Length (S2) then
10034 Mismatch;
10035
10036 else
10037 for J in 1 .. String_Length (S1) loop
10038 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10039 Mismatch;
10040 end if;
10041 end loop;
10042 end if;
10043 end Check_Matching_Internal_Names;
10044
10045 -- Otherwise set the given name
10046
10047 else
10048 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10049 Check_Duplicated_Export_Name (New_Name);
10050 end if;
10051 end Set_Extended_Import_Export_External_Name;
10052
10053 ------------------
10054 -- Set_Imported --
10055 ------------------
10056
10057 procedure Set_Imported (E : Entity_Id) is
10058 begin
10059 -- Error message if already imported or exported
10060
10061 if Is_Exported (E) or else Is_Imported (E) then
10062
10063 -- Error if being set Exported twice
10064
10065 if Is_Exported (E) then
10066 Error_Msg_NE ("entity& was previously exported", N, E);
10067
10068 -- Ignore error in CodePeer mode where we treat all imported
10069 -- subprograms as unknown.
10070
10071 elsif CodePeer_Mode then
10072 goto OK;
10073
10074 -- OK if Import/Interface case
10075
10076 elsif Import_Interface_Present (N) then
10077 goto OK;
10078
10079 -- Error if being set Imported twice
10080
10081 else
10082 Error_Msg_NE ("entity& was previously imported", N, E);
10083 end if;
10084
10085 Error_Msg_Name_1 := Pname;
10086 Error_Msg_N
10087 ("\(pragma% applies to all previous entities)", N);
10088
10089 Error_Msg_Sloc := Sloc (E);
10090 Error_Msg_NE ("\import not allowed for& declared#", N, E);
10091
10092 -- Here if not previously imported or exported, OK to import
10093
10094 else
10095 Set_Is_Imported (E);
10096
10097 -- For subprogram, set Import_Pragma field
10098
10099 if Is_Subprogram (E) then
10100 Set_Import_Pragma (E, N);
10101 end if;
10102
10103 -- If the entity is an object that is not at the library level,
10104 -- then it is statically allocated. We do not worry about objects
10105 -- with address clauses in this context since they are not really
10106 -- imported in the linker sense.
10107
10108 if Is_Object (E)
10109 and then not Is_Library_Level_Entity (E)
10110 and then No (Address_Clause (E))
10111 then
10112 Set_Is_Statically_Allocated (E);
10113 end if;
10114 end if;
10115
10116 <<OK>> null;
10117 end Set_Imported;
10118
10119 -------------------------
10120 -- Set_Mechanism_Value --
10121 -------------------------
10122
10123 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10124 -- analyzed, since it is semantic nonsense), so we get it in the exact
10125 -- form created by the parser.
10126
10127 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
10128 procedure Bad_Mechanism;
10129 pragma No_Return (Bad_Mechanism);
10130 -- Signal bad mechanism name
10131
10132 -------------------------
10133 -- Bad_Mechanism_Value --
10134 -------------------------
10135
10136 procedure Bad_Mechanism is
10137 begin
10138 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
10139 end Bad_Mechanism;
10140
10141 -- Start of processing for Set_Mechanism_Value
10142
10143 begin
10144 if Mechanism (Ent) /= Default_Mechanism then
10145 Error_Msg_NE
10146 ("mechanism for & has already been set", Mech_Name, Ent);
10147 end if;
10148
10149 -- MECHANISM_NAME ::= value | reference
10150
10151 if Nkind (Mech_Name) = N_Identifier then
10152 if Chars (Mech_Name) = Name_Value then
10153 Set_Mechanism (Ent, By_Copy);
10154 return;
10155
10156 elsif Chars (Mech_Name) = Name_Reference then
10157 Set_Mechanism (Ent, By_Reference);
10158 return;
10159
10160 elsif Chars (Mech_Name) = Name_Copy then
10161 Error_Pragma_Arg
10162 ("bad mechanism name, Value assumed", Mech_Name);
10163
10164 else
10165 Bad_Mechanism;
10166 end if;
10167
10168 else
10169 Bad_Mechanism;
10170 end if;
10171 end Set_Mechanism_Value;
10172
10173 --------------------------
10174 -- Set_Rational_Profile --
10175 --------------------------
10176
10177 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10178 -- extension to the semantics of renaming declarations.
10179
10180 procedure Set_Rational_Profile is
10181 begin
10182 Implicit_Packing := True;
10183 Overriding_Renamings := True;
10184 Use_VADS_Size := True;
10185 end Set_Rational_Profile;
10186
10187 ---------------------------
10188 -- Set_Ravenscar_Profile --
10189 ---------------------------
10190
10191 -- The tasks to be done here are
10192
10193 -- Set required policies
10194
10195 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10196 -- pragma Locking_Policy (Ceiling_Locking)
10197
10198 -- Set Detect_Blocking mode
10199
10200 -- Set required restrictions (see System.Rident for detailed list)
10201
10202 -- Set the No_Dependence rules
10203 -- No_Dependence => Ada.Asynchronous_Task_Control
10204 -- No_Dependence => Ada.Calendar
10205 -- No_Dependence => Ada.Execution_Time.Group_Budget
10206 -- No_Dependence => Ada.Execution_Time.Timers
10207 -- No_Dependence => Ada.Task_Attributes
10208 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10209
10210 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
10211 procedure Set_Error_Msg_To_Profile_Name;
10212 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10213 -- profile.
10214
10215 -----------------------------------
10216 -- Set_Error_Msg_To_Profile_Name --
10217 -----------------------------------
10218
10219 procedure Set_Error_Msg_To_Profile_Name is
10220 Prof_Nam : constant Node_Id :=
10221 Get_Pragma_Arg
10222 (First (Pragma_Argument_Associations (N)));
10223
10224 begin
10225 Get_Name_String (Chars (Prof_Nam));
10226 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
10227 Error_Msg_Strlen := Name_Len;
10228 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
10229 end Set_Error_Msg_To_Profile_Name;
10230
10231 -- Local variables
10232
10233 Nod : Node_Id;
10234 Pref : Node_Id;
10235 Pref_Id : Node_Id;
10236 Sel_Id : Node_Id;
10237
10238 -- Start of processing for Set_Ravenscar_Profile
10239
10240 begin
10241 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10242
10243 if Task_Dispatching_Policy /= ' '
10244 and then Task_Dispatching_Policy /= 'F'
10245 then
10246 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10247 Set_Error_Msg_To_Profile_Name;
10248 Error_Pragma ("Profile (~) incompatible with policy#");
10249
10250 -- Set the FIFO_Within_Priorities policy, but always preserve
10251 -- System_Location since we like the error message with the run time
10252 -- name.
10253
10254 else
10255 Task_Dispatching_Policy := 'F';
10256
10257 if Task_Dispatching_Policy_Sloc /= System_Location then
10258 Task_Dispatching_Policy_Sloc := Loc;
10259 end if;
10260 end if;
10261
10262 -- pragma Locking_Policy (Ceiling_Locking)
10263
10264 if Locking_Policy /= ' '
10265 and then Locking_Policy /= 'C'
10266 then
10267 Error_Msg_Sloc := Locking_Policy_Sloc;
10268 Set_Error_Msg_To_Profile_Name;
10269 Error_Pragma ("Profile (~) incompatible with policy#");
10270
10271 -- Set the Ceiling_Locking policy, but preserve System_Location since
10272 -- we like the error message with the run time name.
10273
10274 else
10275 Locking_Policy := 'C';
10276
10277 if Locking_Policy_Sloc /= System_Location then
10278 Locking_Policy_Sloc := Loc;
10279 end if;
10280 end if;
10281
10282 -- pragma Detect_Blocking
10283
10284 Detect_Blocking := True;
10285
10286 -- Set the corresponding restrictions
10287
10288 Set_Profile_Restrictions
10289 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
10290
10291 -- Set the No_Dependence restrictions
10292
10293 -- The following No_Dependence restrictions:
10294 -- No_Dependence => Ada.Asynchronous_Task_Control
10295 -- No_Dependence => Ada.Calendar
10296 -- No_Dependence => Ada.Task_Attributes
10297 -- are already set by previous call to Set_Profile_Restrictions.
10298
10299 -- Set the following restrictions which were added to Ada 2005:
10300 -- No_Dependence => Ada.Execution_Time.Group_Budget
10301 -- No_Dependence => Ada.Execution_Time.Timers
10302
10303 -- ??? The use of Name_Buffer here is suspicious. The names should
10304 -- be registered in snames.ads-tmpl and used to build the qualified
10305 -- names of units.
10306
10307 if Ada_Version >= Ada_2005 then
10308 Name_Buffer (1 .. 3) := "ada";
10309 Name_Len := 3;
10310
10311 Pref_Id := Make_Identifier (Loc, Name_Find);
10312
10313 Name_Buffer (1 .. 14) := "execution_time";
10314 Name_Len := 14;
10315
10316 Sel_Id := Make_Identifier (Loc, Name_Find);
10317
10318 Pref :=
10319 Make_Selected_Component
10320 (Sloc => Loc,
10321 Prefix => Pref_Id,
10322 Selector_Name => Sel_Id);
10323
10324 Name_Buffer (1 .. 13) := "group_budgets";
10325 Name_Len := 13;
10326
10327 Sel_Id := Make_Identifier (Loc, Name_Find);
10328
10329 Nod :=
10330 Make_Selected_Component
10331 (Sloc => Loc,
10332 Prefix => Pref,
10333 Selector_Name => Sel_Id);
10334
10335 Set_Restriction_No_Dependence
10336 (Unit => Nod,
10337 Warn => Treat_Restrictions_As_Warnings,
10338 Profile => Ravenscar);
10339
10340 Name_Buffer (1 .. 6) := "timers";
10341 Name_Len := 6;
10342
10343 Sel_Id := Make_Identifier (Loc, Name_Find);
10344
10345 Nod :=
10346 Make_Selected_Component
10347 (Sloc => Loc,
10348 Prefix => Pref,
10349 Selector_Name => Sel_Id);
10350
10351 Set_Restriction_No_Dependence
10352 (Unit => Nod,
10353 Warn => Treat_Restrictions_As_Warnings,
10354 Profile => Ravenscar);
10355 end if;
10356
10357 -- Set the following restriction which was added to Ada 2012 (see
10358 -- AI-0171):
10359 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10360
10361 if Ada_Version >= Ada_2012 then
10362 Name_Buffer (1 .. 6) := "system";
10363 Name_Len := 6;
10364
10365 Pref_Id := Make_Identifier (Loc, Name_Find);
10366
10367 Name_Buffer (1 .. 15) := "multiprocessors";
10368 Name_Len := 15;
10369
10370 Sel_Id := Make_Identifier (Loc, Name_Find);
10371
10372 Pref :=
10373 Make_Selected_Component
10374 (Sloc => Loc,
10375 Prefix => Pref_Id,
10376 Selector_Name => Sel_Id);
10377
10378 Name_Buffer (1 .. 19) := "dispatching_domains";
10379 Name_Len := 19;
10380
10381 Sel_Id := Make_Identifier (Loc, Name_Find);
10382
10383 Nod :=
10384 Make_Selected_Component
10385 (Sloc => Loc,
10386 Prefix => Pref,
10387 Selector_Name => Sel_Id);
10388
10389 Set_Restriction_No_Dependence
10390 (Unit => Nod,
10391 Warn => Treat_Restrictions_As_Warnings,
10392 Profile => Ravenscar);
10393 end if;
10394 end Set_Ravenscar_Profile;
10395
10396 -- Start of processing for Analyze_Pragma
10397
10398 begin
10399 -- The following code is a defense against recursion. Not clear that
10400 -- this can happen legitimately, but perhaps some error situations can
10401 -- cause it, and we did see this recursion during testing.
10402
10403 if Analyzed (N) then
10404 return;
10405 else
10406 Set_Analyzed (N);
10407 end if;
10408
10409 Check_Restriction_No_Use_Of_Pragma (N);
10410
10411 -- Deal with unrecognized pragma
10412
10413 Pname := Pragma_Name (N);
10414
10415 if not Is_Pragma_Name (Pname) then
10416 if Warn_On_Unrecognized_Pragma then
10417 Error_Msg_Name_1 := Pname;
10418 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10419
10420 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10421 if Is_Bad_Spelling_Of (Pname, PN) then
10422 Error_Msg_Name_1 := PN;
10423 Error_Msg_N -- CODEFIX
10424 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10425 exit;
10426 end if;
10427 end loop;
10428 end if;
10429
10430 return;
10431 end if;
10432
10433 -- Ignore pragma if Ignore_Pragma applies
10434
10435 if Get_Name_Table_Boolean3 (Pname) then
10436 return;
10437 end if;
10438
10439 -- Here to start processing for recognized pragma
10440
10441 Prag_Id := Get_Pragma_Id (Pname);
10442 Pname := Original_Aspect_Pragma_Name (N);
10443
10444 -- Capture setting of Opt.Uneval_Old
10445
10446 case Opt.Uneval_Old is
10447 when 'A' =>
10448 Set_Uneval_Old_Accept (N);
10449 when 'E' =>
10450 null;
10451 when 'W' =>
10452 Set_Uneval_Old_Warn (N);
10453 when others =>
10454 raise Program_Error;
10455 end case;
10456
10457 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10458 -- is already set, indicating that we have already checked the policy
10459 -- at the right point. This happens for example in the case of a pragma
10460 -- that is derived from an Aspect.
10461
10462 if Is_Ignored (N) or else Is_Checked (N) then
10463 null;
10464
10465 -- For a pragma that is a rewriting of another pragma, copy the
10466 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10467
10468 elsif Is_Rewrite_Substitution (N)
10469 and then Nkind (Original_Node (N)) = N_Pragma
10470 and then Original_Node (N) /= N
10471 then
10472 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10473 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10474
10475 -- Otherwise query the applicable policy at this point
10476
10477 else
10478 Check_Applicable_Policy (N);
10479
10480 -- If pragma is disabled, rewrite as NULL and skip analysis
10481
10482 if Is_Disabled (N) then
10483 Rewrite (N, Make_Null_Statement (Loc));
10484 Analyze (N);
10485 raise Pragma_Exit;
10486 end if;
10487 end if;
10488
10489 -- Preset arguments
10490
10491 Arg_Count := 0;
10492 Arg1 := Empty;
10493 Arg2 := Empty;
10494 Arg3 := Empty;
10495 Arg4 := Empty;
10496
10497 if Present (Pragma_Argument_Associations (N)) then
10498 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10499 Arg1 := First (Pragma_Argument_Associations (N));
10500
10501 if Present (Arg1) then
10502 Arg2 := Next (Arg1);
10503
10504 if Present (Arg2) then
10505 Arg3 := Next (Arg2);
10506
10507 if Present (Arg3) then
10508 Arg4 := Next (Arg3);
10509 end if;
10510 end if;
10511 end if;
10512 end if;
10513
10514 -- An enumeration type defines the pragmas that are supported by the
10515 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10516 -- into the corresponding enumeration value for the following case.
10517
10518 case Prag_Id is
10519
10520 -----------------
10521 -- Abort_Defer --
10522 -----------------
10523
10524 -- pragma Abort_Defer;
10525
10526 when Pragma_Abort_Defer =>
10527 GNAT_Pragma;
10528 Check_Arg_Count (0);
10529
10530 -- The only required semantic processing is to check the
10531 -- placement. This pragma must appear at the start of the
10532 -- statement sequence of a handled sequence of statements.
10533
10534 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10535 or else N /= First (Statements (Parent (N)))
10536 then
10537 Pragma_Misplaced;
10538 end if;
10539
10540 --------------------
10541 -- Abstract_State --
10542 --------------------
10543
10544 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10545
10546 -- ABSTRACT_STATE_LIST ::=
10547 -- null
10548 -- | STATE_NAME_WITH_OPTIONS
10549 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10550
10551 -- STATE_NAME_WITH_OPTIONS ::=
10552 -- STATE_NAME
10553 -- | (STATE_NAME with OPTION_LIST)
10554
10555 -- OPTION_LIST ::= OPTION {, OPTION}
10556
10557 -- OPTION ::=
10558 -- SIMPLE_OPTION
10559 -- | NAME_VALUE_OPTION
10560
10561 -- SIMPLE_OPTION ::= Ghost | Synchronous
10562
10563 -- NAME_VALUE_OPTION ::=
10564 -- Part_Of => ABSTRACT_STATE
10565 -- | External [=> EXTERNAL_PROPERTY_LIST]
10566
10567 -- EXTERNAL_PROPERTY_LIST ::=
10568 -- EXTERNAL_PROPERTY
10569 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10570
10571 -- EXTERNAL_PROPERTY ::=
10572 -- Async_Readers [=> boolean_EXPRESSION]
10573 -- | Async_Writers [=> boolean_EXPRESSION]
10574 -- | Effective_Reads [=> boolean_EXPRESSION]
10575 -- | Effective_Writes [=> boolean_EXPRESSION]
10576 -- others => boolean_EXPRESSION
10577
10578 -- STATE_NAME ::= defining_identifier
10579
10580 -- ABSTRACT_STATE ::= name
10581
10582 -- Characteristics:
10583
10584 -- * Analysis - The annotation is fully analyzed immediately upon
10585 -- elaboration as it cannot forward reference entities.
10586
10587 -- * Expansion - None.
10588
10589 -- * Template - The annotation utilizes the generic template of the
10590 -- related package declaration.
10591
10592 -- * Globals - The annotation cannot reference global entities.
10593
10594 -- * Instance - The annotation is instantiated automatically when
10595 -- the related generic package is instantiated.
10596
10597 when Pragma_Abstract_State => Abstract_State : declare
10598 Missing_Parentheses : Boolean := False;
10599 -- Flag set when a state declaration with options is not properly
10600 -- parenthesized.
10601
10602 -- Flags used to verify the consistency of states
10603
10604 Non_Null_Seen : Boolean := False;
10605 Null_Seen : Boolean := False;
10606
10607 procedure Analyze_Abstract_State
10608 (State : Node_Id;
10609 Pack_Id : Entity_Id);
10610 -- Verify the legality of a single state declaration. Create and
10611 -- decorate a state abstraction entity and introduce it into the
10612 -- visibility chain. Pack_Id denotes the entity or the related
10613 -- package where pragma Abstract_State appears.
10614
10615 procedure Malformed_State_Error (State : Node_Id);
10616 -- Emit an error concerning the illegal declaration of abstract
10617 -- state State. This routine diagnoses syntax errors that lead to
10618 -- a different parse tree. The error is issued regardless of the
10619 -- SPARK mode in effect.
10620
10621 ----------------------------
10622 -- Analyze_Abstract_State --
10623 ----------------------------
10624
10625 procedure Analyze_Abstract_State
10626 (State : Node_Id;
10627 Pack_Id : Entity_Id)
10628 is
10629 -- Flags used to verify the consistency of options
10630
10631 AR_Seen : Boolean := False;
10632 AW_Seen : Boolean := False;
10633 ER_Seen : Boolean := False;
10634 EW_Seen : Boolean := False;
10635 External_Seen : Boolean := False;
10636 Ghost_Seen : Boolean := False;
10637 Others_Seen : Boolean := False;
10638 Part_Of_Seen : Boolean := False;
10639 Synchronous_Seen : Boolean := False;
10640
10641 -- Flags used to store the static value of all external states'
10642 -- expressions.
10643
10644 AR_Val : Boolean := False;
10645 AW_Val : Boolean := False;
10646 ER_Val : Boolean := False;
10647 EW_Val : Boolean := False;
10648
10649 State_Id : Entity_Id := Empty;
10650 -- The entity to be generated for the current state declaration
10651
10652 procedure Analyze_External_Option (Opt : Node_Id);
10653 -- Verify the legality of option External
10654
10655 procedure Analyze_External_Property
10656 (Prop : Node_Id;
10657 Expr : Node_Id := Empty);
10658 -- Verify the legailty of a single external property. Prop
10659 -- denotes the external property. Expr is the expression used
10660 -- to set the property.
10661
10662 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10663 -- Verify the legality of option Part_Of
10664
10665 procedure Check_Duplicate_Option
10666 (Opt : Node_Id;
10667 Status : in out Boolean);
10668 -- Flag Status denotes whether a particular option has been
10669 -- seen while processing a state. This routine verifies that
10670 -- Opt is not a duplicate option and sets the flag Status
10671 -- (SPARK RM 7.1.4(1)).
10672
10673 procedure Check_Duplicate_Property
10674 (Prop : Node_Id;
10675 Status : in out Boolean);
10676 -- Flag Status denotes whether a particular property has been
10677 -- seen while processing option External. This routine verifies
10678 -- that Prop is not a duplicate property and sets flag Status.
10679 -- Opt is not a duplicate property and sets the flag Status.
10680 -- (SPARK RM 7.1.4(2))
10681
10682 procedure Check_Ghost_Synchronous;
10683 -- Ensure that the abstract state is not subject to both Ghost
10684 -- and Synchronous simple options. Emit an error if this is the
10685 -- case.
10686
10687 procedure Create_Abstract_State
10688 (Nam : Name_Id;
10689 Decl : Node_Id;
10690 Loc : Source_Ptr;
10691 Is_Null : Boolean);
10692 -- Generate an abstract state entity with name Nam and enter it
10693 -- into visibility. Decl is the "declaration" of the state as
10694 -- it appears in pragma Abstract_State. Loc is the location of
10695 -- the related state "declaration". Flag Is_Null should be set
10696 -- when the associated Abstract_State pragma defines a null
10697 -- state.
10698
10699 -----------------------------
10700 -- Analyze_External_Option --
10701 -----------------------------
10702
10703 procedure Analyze_External_Option (Opt : Node_Id) is
10704 Errors : constant Nat := Serious_Errors_Detected;
10705 Prop : Node_Id;
10706 Props : Node_Id := Empty;
10707
10708 begin
10709 if Nkind (Opt) = N_Component_Association then
10710 Props := Expression (Opt);
10711 end if;
10712
10713 -- External state with properties
10714
10715 if Present (Props) then
10716
10717 -- Multiple properties appear as an aggregate
10718
10719 if Nkind (Props) = N_Aggregate then
10720
10721 -- Simple property form
10722
10723 Prop := First (Expressions (Props));
10724 while Present (Prop) loop
10725 Analyze_External_Property (Prop);
10726 Next (Prop);
10727 end loop;
10728
10729 -- Property with expression form
10730
10731 Prop := First (Component_Associations (Props));
10732 while Present (Prop) loop
10733 Analyze_External_Property
10734 (Prop => First (Choices (Prop)),
10735 Expr => Expression (Prop));
10736
10737 Next (Prop);
10738 end loop;
10739
10740 -- Single property
10741
10742 else
10743 Analyze_External_Property (Props);
10744 end if;
10745
10746 -- An external state defined without any properties defaults
10747 -- all properties to True.
10748
10749 else
10750 AR_Val := True;
10751 AW_Val := True;
10752 ER_Val := True;
10753 EW_Val := True;
10754 end if;
10755
10756 -- Once all external properties have been processed, verify
10757 -- their mutual interaction. Do not perform the check when
10758 -- at least one of the properties is illegal as this will
10759 -- produce a bogus error.
10760
10761 if Errors = Serious_Errors_Detected then
10762 Check_External_Properties
10763 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10764 end if;
10765 end Analyze_External_Option;
10766
10767 -------------------------------
10768 -- Analyze_External_Property --
10769 -------------------------------
10770
10771 procedure Analyze_External_Property
10772 (Prop : Node_Id;
10773 Expr : Node_Id := Empty)
10774 is
10775 Expr_Val : Boolean;
10776
10777 begin
10778 -- Check the placement of "others" (if available)
10779
10780 if Nkind (Prop) = N_Others_Choice then
10781 if Others_Seen then
10782 SPARK_Msg_N
10783 ("only one others choice allowed in option External",
10784 Prop);
10785 else
10786 Others_Seen := True;
10787 end if;
10788
10789 elsif Others_Seen then
10790 SPARK_Msg_N
10791 ("others must be the last property in option External",
10792 Prop);
10793
10794 -- The only remaining legal options are the four predefined
10795 -- external properties.
10796
10797 elsif Nkind (Prop) = N_Identifier
10798 and then Nam_In (Chars (Prop), Name_Async_Readers,
10799 Name_Async_Writers,
10800 Name_Effective_Reads,
10801 Name_Effective_Writes)
10802 then
10803 null;
10804
10805 -- Otherwise the construct is not a valid property
10806
10807 else
10808 SPARK_Msg_N ("invalid external state property", Prop);
10809 return;
10810 end if;
10811
10812 -- Ensure that the expression of the external state property
10813 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10814
10815 if Present (Expr) then
10816 Analyze_And_Resolve (Expr, Standard_Boolean);
10817
10818 if Is_OK_Static_Expression (Expr) then
10819 Expr_Val := Is_True (Expr_Value (Expr));
10820 else
10821 SPARK_Msg_N
10822 ("expression of external state property must be "
10823 & "static", Expr);
10824 end if;
10825
10826 -- The lack of expression defaults the property to True
10827
10828 else
10829 Expr_Val := True;
10830 end if;
10831
10832 -- Named properties
10833
10834 if Nkind (Prop) = N_Identifier then
10835 if Chars (Prop) = Name_Async_Readers then
10836 Check_Duplicate_Property (Prop, AR_Seen);
10837 AR_Val := Expr_Val;
10838
10839 elsif Chars (Prop) = Name_Async_Writers then
10840 Check_Duplicate_Property (Prop, AW_Seen);
10841 AW_Val := Expr_Val;
10842
10843 elsif Chars (Prop) = Name_Effective_Reads then
10844 Check_Duplicate_Property (Prop, ER_Seen);
10845 ER_Val := Expr_Val;
10846
10847 else
10848 Check_Duplicate_Property (Prop, EW_Seen);
10849 EW_Val := Expr_Val;
10850 end if;
10851
10852 -- The handling of property "others" must take into account
10853 -- all other named properties that have been encountered so
10854 -- far. Only those that have not been seen are affected by
10855 -- "others".
10856
10857 else
10858 if not AR_Seen then
10859 AR_Val := Expr_Val;
10860 end if;
10861
10862 if not AW_Seen then
10863 AW_Val := Expr_Val;
10864 end if;
10865
10866 if not ER_Seen then
10867 ER_Val := Expr_Val;
10868 end if;
10869
10870 if not EW_Seen then
10871 EW_Val := Expr_Val;
10872 end if;
10873 end if;
10874 end Analyze_External_Property;
10875
10876 ----------------------------
10877 -- Analyze_Part_Of_Option --
10878 ----------------------------
10879
10880 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10881 Encap : constant Node_Id := Expression (Opt);
10882 Constits : Elist_Id;
10883 Encap_Id : Entity_Id;
10884 Legal : Boolean;
10885
10886 begin
10887 Check_Duplicate_Option (Opt, Part_Of_Seen);
10888
10889 Analyze_Part_Of
10890 (Indic => First (Choices (Opt)),
10891 Item_Id => State_Id,
10892 Encap => Encap,
10893 Encap_Id => Encap_Id,
10894 Legal => Legal);
10895
10896 -- The Part_Of indicator transforms the abstract state into
10897 -- a constituent of the encapsulating state or single
10898 -- concurrent type.
10899
10900 if Legal then
10901 pragma Assert (Present (Encap_Id));
10902 Constits := Part_Of_Constituents (Encap_Id);
10903
10904 if No (Constits) then
10905 Constits := New_Elmt_List;
10906 Set_Part_Of_Constituents (Encap_Id, Constits);
10907 end if;
10908
10909 Append_Elmt (State_Id, Constits);
10910 Set_Encapsulating_State (State_Id, Encap_Id);
10911 end if;
10912 end Analyze_Part_Of_Option;
10913
10914 ----------------------------
10915 -- Check_Duplicate_Option --
10916 ----------------------------
10917
10918 procedure Check_Duplicate_Option
10919 (Opt : Node_Id;
10920 Status : in out Boolean)
10921 is
10922 begin
10923 if Status then
10924 SPARK_Msg_N ("duplicate state option", Opt);
10925 end if;
10926
10927 Status := True;
10928 end Check_Duplicate_Option;
10929
10930 ------------------------------
10931 -- Check_Duplicate_Property --
10932 ------------------------------
10933
10934 procedure Check_Duplicate_Property
10935 (Prop : Node_Id;
10936 Status : in out Boolean)
10937 is
10938 begin
10939 if Status then
10940 SPARK_Msg_N ("duplicate external property", Prop);
10941 end if;
10942
10943 Status := True;
10944 end Check_Duplicate_Property;
10945
10946 -----------------------------
10947 -- Check_Ghost_Synchronous --
10948 -----------------------------
10949
10950 procedure Check_Ghost_Synchronous is
10951 begin
10952 -- A synchronized abstract state cannot be Ghost and vice
10953 -- versa (SPARK RM 6.9(19)).
10954
10955 if Ghost_Seen and Synchronous_Seen then
10956 SPARK_Msg_N ("synchronized state cannot be ghost", State);
10957 end if;
10958 end Check_Ghost_Synchronous;
10959
10960 ---------------------------
10961 -- Create_Abstract_State --
10962 ---------------------------
10963
10964 procedure Create_Abstract_State
10965 (Nam : Name_Id;
10966 Decl : Node_Id;
10967 Loc : Source_Ptr;
10968 Is_Null : Boolean)
10969 is
10970 begin
10971 -- The abstract state may be semi-declared when the related
10972 -- package was withed through a limited with clause. In that
10973 -- case reuse the entity to fully declare the state.
10974
10975 if Present (Decl) and then Present (Entity (Decl)) then
10976 State_Id := Entity (Decl);
10977
10978 -- Otherwise the elaboration of pragma Abstract_State
10979 -- declares the state.
10980
10981 else
10982 State_Id := Make_Defining_Identifier (Loc, Nam);
10983
10984 if Present (Decl) then
10985 Set_Entity (Decl, State_Id);
10986 end if;
10987 end if;
10988
10989 -- Null states never come from source
10990
10991 Set_Comes_From_Source (State_Id, not Is_Null);
10992 Set_Parent (State_Id, State);
10993 Set_Ekind (State_Id, E_Abstract_State);
10994 Set_Etype (State_Id, Standard_Void_Type);
10995 Set_Encapsulating_State (State_Id, Empty);
10996
10997 -- An abstract state declared within a Ghost region becomes
10998 -- Ghost (SPARK RM 6.9(2)).
10999
11000 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11001 Set_Is_Ghost_Entity (State_Id);
11002 end if;
11003
11004 -- Establish a link between the state declaration and the
11005 -- abstract state entity. Note that a null state remains as
11006 -- N_Null and does not carry any linkages.
11007
11008 if not Is_Null then
11009 if Present (Decl) then
11010 Set_Entity (Decl, State_Id);
11011 Set_Etype (Decl, Standard_Void_Type);
11012 end if;
11013
11014 -- Every non-null state must be defined, nameable and
11015 -- resolvable.
11016
11017 Push_Scope (Pack_Id);
11018 Generate_Definition (State_Id);
11019 Enter_Name (State_Id);
11020 Pop_Scope;
11021 end if;
11022 end Create_Abstract_State;
11023
11024 -- Local variables
11025
11026 Opt : Node_Id;
11027 Opt_Nam : Node_Id;
11028
11029 -- Start of processing for Analyze_Abstract_State
11030
11031 begin
11032 -- A package with a null abstract state is not allowed to
11033 -- declare additional states.
11034
11035 if Null_Seen then
11036 SPARK_Msg_NE
11037 ("package & has null abstract state", State, Pack_Id);
11038
11039 -- Null states appear as internally generated entities
11040
11041 elsif Nkind (State) = N_Null then
11042 Create_Abstract_State
11043 (Nam => New_Internal_Name ('S'),
11044 Decl => Empty,
11045 Loc => Sloc (State),
11046 Is_Null => True);
11047 Null_Seen := True;
11048
11049 -- Catch a case where a null state appears in a list of
11050 -- non-null states.
11051
11052 if Non_Null_Seen then
11053 SPARK_Msg_NE
11054 ("package & has non-null abstract state",
11055 State, Pack_Id);
11056 end if;
11057
11058 -- Simple state declaration
11059
11060 elsif Nkind (State) = N_Identifier then
11061 Create_Abstract_State
11062 (Nam => Chars (State),
11063 Decl => State,
11064 Loc => Sloc (State),
11065 Is_Null => False);
11066 Non_Null_Seen := True;
11067
11068 -- State declaration with various options. This construct
11069 -- appears as an extension aggregate in the tree.
11070
11071 elsif Nkind (State) = N_Extension_Aggregate then
11072 if Nkind (Ancestor_Part (State)) = N_Identifier then
11073 Create_Abstract_State
11074 (Nam => Chars (Ancestor_Part (State)),
11075 Decl => Ancestor_Part (State),
11076 Loc => Sloc (Ancestor_Part (State)),
11077 Is_Null => False);
11078 Non_Null_Seen := True;
11079 else
11080 SPARK_Msg_N
11081 ("state name must be an identifier",
11082 Ancestor_Part (State));
11083 end if;
11084
11085 -- Options External, Ghost and Synchronous appear as
11086 -- expressions.
11087
11088 Opt := First (Expressions (State));
11089 while Present (Opt) loop
11090 if Nkind (Opt) = N_Identifier then
11091
11092 -- External
11093
11094 if Chars (Opt) = Name_External then
11095 Check_Duplicate_Option (Opt, External_Seen);
11096 Analyze_External_Option (Opt);
11097
11098 -- Ghost
11099
11100 elsif Chars (Opt) = Name_Ghost then
11101 Check_Duplicate_Option (Opt, Ghost_Seen);
11102 Check_Ghost_Synchronous;
11103
11104 if Present (State_Id) then
11105 Set_Is_Ghost_Entity (State_Id);
11106 end if;
11107
11108 -- Synchronous
11109
11110 elsif Chars (Opt) = Name_Synchronous then
11111 Check_Duplicate_Option (Opt, Synchronous_Seen);
11112 Check_Ghost_Synchronous;
11113
11114 -- Option Part_Of without an encapsulating state is
11115 -- illegal (SPARK RM 7.1.4(9)).
11116
11117 elsif Chars (Opt) = Name_Part_Of then
11118 SPARK_Msg_N
11119 ("indicator Part_Of must denote abstract state, "
11120 & "single protected type or single task type",
11121 Opt);
11122
11123 -- Do not emit an error message when a previous state
11124 -- declaration with options was not parenthesized as
11125 -- the option is actually another state declaration.
11126 --
11127 -- with Abstract_State
11128 -- (State_1 with ..., -- missing parentheses
11129 -- (State_2 with ...),
11130 -- State_3) -- ok state declaration
11131
11132 elsif Missing_Parentheses then
11133 null;
11134
11135 -- Otherwise the option is not allowed. Note that it
11136 -- is not possible to distinguish between an option
11137 -- and a state declaration when a previous state with
11138 -- options not properly parentheses.
11139 --
11140 -- with Abstract_State
11141 -- (State_1 with ..., -- missing parentheses
11142 -- State_2); -- could be an option
11143
11144 else
11145 SPARK_Msg_N
11146 ("simple option not allowed in state declaration",
11147 Opt);
11148 end if;
11149
11150 -- Catch a case where missing parentheses around a state
11151 -- declaration with options cause a subsequent state
11152 -- declaration with options to be treated as an option.
11153 --
11154 -- with Abstract_State
11155 -- (State_1 with ..., -- missing parentheses
11156 -- (State_2 with ...))
11157
11158 elsif Nkind (Opt) = N_Extension_Aggregate then
11159 Missing_Parentheses := True;
11160 SPARK_Msg_N
11161 ("state declaration must be parenthesized",
11162 Ancestor_Part (State));
11163
11164 -- Otherwise the option is malformed
11165
11166 else
11167 SPARK_Msg_N ("malformed option", Opt);
11168 end if;
11169
11170 Next (Opt);
11171 end loop;
11172
11173 -- Options External and Part_Of appear as component
11174 -- associations.
11175
11176 Opt := First (Component_Associations (State));
11177 while Present (Opt) loop
11178 Opt_Nam := First (Choices (Opt));
11179
11180 if Nkind (Opt_Nam) = N_Identifier then
11181 if Chars (Opt_Nam) = Name_External then
11182 Analyze_External_Option (Opt);
11183
11184 elsif Chars (Opt_Nam) = Name_Part_Of then
11185 Analyze_Part_Of_Option (Opt);
11186
11187 else
11188 SPARK_Msg_N ("invalid state option", Opt);
11189 end if;
11190 else
11191 SPARK_Msg_N ("invalid state option", Opt);
11192 end if;
11193
11194 Next (Opt);
11195 end loop;
11196
11197 -- Any other attempt to declare a state is illegal
11198
11199 else
11200 Malformed_State_Error (State);
11201 return;
11202 end if;
11203
11204 -- Guard against a junk state. In such cases no entity is
11205 -- generated and the subsequent checks cannot be applied.
11206
11207 if Present (State_Id) then
11208
11209 -- Verify whether the state does not introduce an illegal
11210 -- hidden state within a package subject to a null abstract
11211 -- state.
11212
11213 Check_No_Hidden_State (State_Id);
11214
11215 -- Check whether the lack of option Part_Of agrees with the
11216 -- placement of the abstract state with respect to the state
11217 -- space.
11218
11219 if not Part_Of_Seen then
11220 Check_Missing_Part_Of (State_Id);
11221 end if;
11222
11223 -- Associate the state with its related package
11224
11225 if No (Abstract_States (Pack_Id)) then
11226 Set_Abstract_States (Pack_Id, New_Elmt_List);
11227 end if;
11228
11229 Append_Elmt (State_Id, Abstract_States (Pack_Id));
11230 end if;
11231 end Analyze_Abstract_State;
11232
11233 ---------------------------
11234 -- Malformed_State_Error --
11235 ---------------------------
11236
11237 procedure Malformed_State_Error (State : Node_Id) is
11238 begin
11239 Error_Msg_N ("malformed abstract state declaration", State);
11240
11241 -- An abstract state with a simple option is being declared
11242 -- with "=>" rather than the legal "with". The state appears
11243 -- as a component association.
11244
11245 if Nkind (State) = N_Component_Association then
11246 Error_Msg_N ("\use WITH to specify simple option", State);
11247 end if;
11248 end Malformed_State_Error;
11249
11250 -- Local variables
11251
11252 Pack_Decl : Node_Id;
11253 Pack_Id : Entity_Id;
11254 State : Node_Id;
11255 States : Node_Id;
11256
11257 -- Start of processing for Abstract_State
11258
11259 begin
11260 GNAT_Pragma;
11261 Check_No_Identifiers;
11262 Check_Arg_Count (1);
11263
11264 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
11265
11266 -- Ensure the proper placement of the pragma. Abstract states must
11267 -- be associated with a package declaration.
11268
11269 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
11270 N_Package_Declaration)
11271 then
11272 null;
11273
11274 -- Otherwise the pragma is associated with an illegal construct
11275
11276 else
11277 Pragma_Misplaced;
11278 return;
11279 end if;
11280
11281 Pack_Id := Defining_Entity (Pack_Decl);
11282
11283 -- Chain the pragma on the contract for completeness
11284
11285 Add_Contract_Item (N, Pack_Id);
11286
11287 -- The legality checks of pragmas Abstract_State, Initializes, and
11288 -- Initial_Condition are affected by the SPARK mode in effect. In
11289 -- addition, these three pragmas are subject to an inherent order:
11290
11291 -- 1) Abstract_State
11292 -- 2) Initializes
11293 -- 3) Initial_Condition
11294
11295 -- Analyze all these pragmas in the order outlined above
11296
11297 Analyze_If_Present (Pragma_SPARK_Mode);
11298
11299 -- A pragma that applies to a Ghost entity becomes Ghost for the
11300 -- purposes of legality checks and removal of ignored Ghost code.
11301
11302 Mark_Pragma_As_Ghost (N, Pack_Id);
11303 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
11304
11305 States := Expression (Get_Argument (N, Pack_Id));
11306
11307 -- Multiple non-null abstract states appear as an aggregate
11308
11309 if Nkind (States) = N_Aggregate then
11310 State := First (Expressions (States));
11311 while Present (State) loop
11312 Analyze_Abstract_State (State, Pack_Id);
11313 Next (State);
11314 end loop;
11315
11316 -- An abstract state with a simple option is being illegaly
11317 -- declared with "=>" rather than "with". In this case the
11318 -- state declaration appears as a component association.
11319
11320 if Present (Component_Associations (States)) then
11321 State := First (Component_Associations (States));
11322 while Present (State) loop
11323 Malformed_State_Error (State);
11324 Next (State);
11325 end loop;
11326 end if;
11327
11328 -- Various forms of a single abstract state. Note that these may
11329 -- include malformed state declarations.
11330
11331 else
11332 Analyze_Abstract_State (States, Pack_Id);
11333 end if;
11334
11335 Analyze_If_Present (Pragma_Initializes);
11336 Analyze_If_Present (Pragma_Initial_Condition);
11337 end Abstract_State;
11338
11339 ------------
11340 -- Ada_83 --
11341 ------------
11342
11343 -- pragma Ada_83;
11344
11345 -- Note: this pragma also has some specific processing in Par.Prag
11346 -- because we want to set the Ada version mode during parsing.
11347
11348 when Pragma_Ada_83 =>
11349 GNAT_Pragma;
11350 Check_Arg_Count (0);
11351
11352 -- We really should check unconditionally for proper configuration
11353 -- pragma placement, since we really don't want mixed Ada modes
11354 -- within a single unit, and the GNAT reference manual has always
11355 -- said this was a configuration pragma, but we did not check and
11356 -- are hesitant to add the check now.
11357
11358 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11359 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11360 -- or Ada 2012 mode.
11361
11362 if Ada_Version >= Ada_2005 then
11363 Check_Valid_Configuration_Pragma;
11364 end if;
11365
11366 -- Now set Ada 83 mode
11367
11368 if not Latest_Ada_Only then
11369 Ada_Version := Ada_83;
11370 Ada_Version_Explicit := Ada_83;
11371 Ada_Version_Pragma := N;
11372 end if;
11373
11374 ------------
11375 -- Ada_95 --
11376 ------------
11377
11378 -- pragma Ada_95;
11379
11380 -- Note: this pragma also has some specific processing in Par.Prag
11381 -- because we want to set the Ada 83 version mode during parsing.
11382
11383 when Pragma_Ada_95 =>
11384 GNAT_Pragma;
11385 Check_Arg_Count (0);
11386
11387 -- We really should check unconditionally for proper configuration
11388 -- pragma placement, since we really don't want mixed Ada modes
11389 -- within a single unit, and the GNAT reference manual has always
11390 -- said this was a configuration pragma, but we did not check and
11391 -- are hesitant to add the check now.
11392
11393 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11394 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11395
11396 if Ada_Version >= Ada_2005 then
11397 Check_Valid_Configuration_Pragma;
11398 end if;
11399
11400 -- Now set Ada 95 mode
11401
11402 if not Latest_Ada_Only then
11403 Ada_Version := Ada_95;
11404 Ada_Version_Explicit := Ada_95;
11405 Ada_Version_Pragma := N;
11406 end if;
11407
11408 ---------------------
11409 -- Ada_05/Ada_2005 --
11410 ---------------------
11411
11412 -- pragma Ada_05;
11413 -- pragma Ada_05 (LOCAL_NAME);
11414
11415 -- pragma Ada_2005;
11416 -- pragma Ada_2005 (LOCAL_NAME):
11417
11418 -- Note: these pragmas also have some specific processing in Par.Prag
11419 -- because we want to set the Ada 2005 version mode during parsing.
11420
11421 -- The one argument form is used for managing the transition from
11422 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11423 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11424 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11425 -- mode, a preference rule is established which does not choose
11426 -- such an entity unless it is unambiguously specified. This avoids
11427 -- extra subprograms marked this way from generating ambiguities in
11428 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11429 -- intended for exclusive use in the GNAT run-time library.
11430
11431 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
11432 E_Id : Node_Id;
11433
11434 begin
11435 GNAT_Pragma;
11436
11437 if Arg_Count = 1 then
11438 Check_Arg_Is_Local_Name (Arg1);
11439 E_Id := Get_Pragma_Arg (Arg1);
11440
11441 if Etype (E_Id) = Any_Type then
11442 return;
11443 end if;
11444
11445 Set_Is_Ada_2005_Only (Entity (E_Id));
11446 Record_Rep_Item (Entity (E_Id), N);
11447
11448 else
11449 Check_Arg_Count (0);
11450
11451 -- For Ada_2005 we unconditionally enforce the documented
11452 -- configuration pragma placement, since we do not want to
11453 -- tolerate mixed modes in a unit involving Ada 2005. That
11454 -- would cause real difficulties for those cases where there
11455 -- are incompatibilities between Ada 95 and Ada 2005.
11456
11457 Check_Valid_Configuration_Pragma;
11458
11459 -- Now set appropriate Ada mode
11460
11461 if not Latest_Ada_Only then
11462 Ada_Version := Ada_2005;
11463 Ada_Version_Explicit := Ada_2005;
11464 Ada_Version_Pragma := N;
11465 end if;
11466 end if;
11467 end;
11468
11469 ---------------------
11470 -- Ada_12/Ada_2012 --
11471 ---------------------
11472
11473 -- pragma Ada_12;
11474 -- pragma Ada_12 (LOCAL_NAME);
11475
11476 -- pragma Ada_2012;
11477 -- pragma Ada_2012 (LOCAL_NAME):
11478
11479 -- Note: these pragmas also have some specific processing in Par.Prag
11480 -- because we want to set the Ada 2012 version mode during parsing.
11481
11482 -- The one argument form is used for managing the transition from Ada
11483 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11484 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11485 -- mode will generate a warning. In addition, in any pre-Ada_2012
11486 -- mode, a preference rule is established which does not choose
11487 -- such an entity unless it is unambiguously specified. This avoids
11488 -- extra subprograms marked this way from generating ambiguities in
11489 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11490 -- intended for exclusive use in the GNAT run-time library.
11491
11492 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
11493 E_Id : Node_Id;
11494
11495 begin
11496 GNAT_Pragma;
11497
11498 if Arg_Count = 1 then
11499 Check_Arg_Is_Local_Name (Arg1);
11500 E_Id := Get_Pragma_Arg (Arg1);
11501
11502 if Etype (E_Id) = Any_Type then
11503 return;
11504 end if;
11505
11506 Set_Is_Ada_2012_Only (Entity (E_Id));
11507 Record_Rep_Item (Entity (E_Id), N);
11508
11509 else
11510 Check_Arg_Count (0);
11511
11512 -- For Ada_2012 we unconditionally enforce the documented
11513 -- configuration pragma placement, since we do not want to
11514 -- tolerate mixed modes in a unit involving Ada 2012. That
11515 -- would cause real difficulties for those cases where there
11516 -- are incompatibilities between Ada 95 and Ada 2012. We could
11517 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11518
11519 Check_Valid_Configuration_Pragma;
11520
11521 -- Now set appropriate Ada mode
11522
11523 Ada_Version := Ada_2012;
11524 Ada_Version_Explicit := Ada_2012;
11525 Ada_Version_Pragma := N;
11526 end if;
11527 end;
11528
11529 ----------------------
11530 -- All_Calls_Remote --
11531 ----------------------
11532
11533 -- pragma All_Calls_Remote [(library_package_NAME)];
11534
11535 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11536 Lib_Entity : Entity_Id;
11537
11538 begin
11539 Check_Ada_83_Warning;
11540 Check_Valid_Library_Unit_Pragma;
11541
11542 if Nkind (N) = N_Null_Statement then
11543 return;
11544 end if;
11545
11546 Lib_Entity := Find_Lib_Unit_Name;
11547
11548 -- A pragma that applies to a Ghost entity becomes Ghost for the
11549 -- purposes of legality checks and removal of ignored Ghost code.
11550
11551 Mark_Pragma_As_Ghost (N, Lib_Entity);
11552
11553 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11554
11555 if Present (Lib_Entity) and then not Debug_Flag_U then
11556 if not Is_Remote_Call_Interface (Lib_Entity) then
11557 Error_Pragma ("pragma% only apply to rci unit");
11558
11559 -- Set flag for entity of the library unit
11560
11561 else
11562 Set_Has_All_Calls_Remote (Lib_Entity);
11563 end if;
11564 end if;
11565 end All_Calls_Remote;
11566
11567 ---------------------------
11568 -- Allow_Integer_Address --
11569 ---------------------------
11570
11571 -- pragma Allow_Integer_Address;
11572
11573 when Pragma_Allow_Integer_Address =>
11574 GNAT_Pragma;
11575 Check_Valid_Configuration_Pragma;
11576 Check_Arg_Count (0);
11577
11578 -- If Address is a private type, then set the flag to allow
11579 -- integer address values. If Address is not private, then this
11580 -- pragma has no purpose, so it is simply ignored. Not clear if
11581 -- there are any such targets now.
11582
11583 if Opt.Address_Is_Private then
11584 Opt.Allow_Integer_Address := True;
11585 end if;
11586
11587 --------------
11588 -- Annotate --
11589 --------------
11590
11591 -- pragma Annotate
11592 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11593 -- ARG ::= NAME | EXPRESSION
11594
11595 -- The first two arguments are by convention intended to refer to an
11596 -- external tool and a tool-specific function. These arguments are
11597 -- not analyzed.
11598
11599 when Pragma_Annotate => Annotate : declare
11600 Arg : Node_Id;
11601 Expr : Node_Id;
11602 Nam_Arg : Node_Id;
11603
11604 begin
11605 GNAT_Pragma;
11606 Check_At_Least_N_Arguments (1);
11607
11608 Nam_Arg := Last (Pragma_Argument_Associations (N));
11609
11610 -- Determine whether the last argument is "Entity => local_NAME"
11611 -- and if it is, perform the required semantic checks. Remove the
11612 -- argument from further processing.
11613
11614 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11615 and then Chars (Nam_Arg) = Name_Entity
11616 then
11617 Check_Arg_Is_Local_Name (Nam_Arg);
11618 Arg_Count := Arg_Count - 1;
11619
11620 -- A pragma that applies to a Ghost entity becomes Ghost for
11621 -- the purposes of legality checks and removal of ignored Ghost
11622 -- code.
11623
11624 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11625 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11626 then
11627 Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11628 end if;
11629
11630 -- Not allowed in compiler units (bootstrap issues)
11631
11632 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11633 end if;
11634
11635 -- Continue the processing with last argument removed for now
11636
11637 Check_Arg_Is_Identifier (Arg1);
11638 Check_No_Identifiers;
11639 Store_Note (N);
11640
11641 -- The second parameter is optional, it is never analyzed
11642
11643 if No (Arg2) then
11644 null;
11645
11646 -- Otherwise there is a second parameter
11647
11648 else
11649 -- The second parameter must be an identifier
11650
11651 Check_Arg_Is_Identifier (Arg2);
11652
11653 -- Process the remaining parameters (if any)
11654
11655 Arg := Next (Arg2);
11656 while Present (Arg) loop
11657 Expr := Get_Pragma_Arg (Arg);
11658 Analyze (Expr);
11659
11660 if Is_Entity_Name (Expr) then
11661 null;
11662
11663 -- For string literals, we assume Standard_String as the
11664 -- type, unless the string contains wide or wide_wide
11665 -- characters.
11666
11667 elsif Nkind (Expr) = N_String_Literal then
11668 if Has_Wide_Wide_Character (Expr) then
11669 Resolve (Expr, Standard_Wide_Wide_String);
11670 elsif Has_Wide_Character (Expr) then
11671 Resolve (Expr, Standard_Wide_String);
11672 else
11673 Resolve (Expr, Standard_String);
11674 end if;
11675
11676 elsif Is_Overloaded (Expr) then
11677 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11678
11679 else
11680 Resolve (Expr);
11681 end if;
11682
11683 Next (Arg);
11684 end loop;
11685 end if;
11686 end Annotate;
11687
11688 -------------------------------------------------
11689 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11690 -------------------------------------------------
11691
11692 -- pragma Assert
11693 -- ( [Check => ] Boolean_EXPRESSION
11694 -- [, [Message =>] Static_String_EXPRESSION]);
11695
11696 -- pragma Assert_And_Cut
11697 -- ( [Check => ] Boolean_EXPRESSION
11698 -- [, [Message =>] Static_String_EXPRESSION]);
11699
11700 -- pragma Assume
11701 -- ( [Check => ] Boolean_EXPRESSION
11702 -- [, [Message =>] Static_String_EXPRESSION]);
11703
11704 -- pragma Loop_Invariant
11705 -- ( [Check => ] Boolean_EXPRESSION
11706 -- [, [Message =>] Static_String_EXPRESSION]);
11707
11708 when Pragma_Assert |
11709 Pragma_Assert_And_Cut |
11710 Pragma_Assume |
11711 Pragma_Loop_Invariant =>
11712 Assert : declare
11713 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11714 -- Determine whether expression Expr contains a Loop_Entry
11715 -- attribute reference.
11716
11717 -------------------------
11718 -- Contains_Loop_Entry --
11719 -------------------------
11720
11721 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11722 Has_Loop_Entry : Boolean := False;
11723
11724 function Process (N : Node_Id) return Traverse_Result;
11725 -- Process function for traversal to look for Loop_Entry
11726
11727 -------------
11728 -- Process --
11729 -------------
11730
11731 function Process (N : Node_Id) return Traverse_Result is
11732 begin
11733 if Nkind (N) = N_Attribute_Reference
11734 and then Attribute_Name (N) = Name_Loop_Entry
11735 then
11736 Has_Loop_Entry := True;
11737 return Abandon;
11738 else
11739 return OK;
11740 end if;
11741 end Process;
11742
11743 procedure Traverse is new Traverse_Proc (Process);
11744
11745 -- Start of processing for Contains_Loop_Entry
11746
11747 begin
11748 Traverse (Expr);
11749 return Has_Loop_Entry;
11750 end Contains_Loop_Entry;
11751
11752 -- Local variables
11753
11754 Expr : Node_Id;
11755 New_Args : List_Id;
11756
11757 -- Start of processing for Assert
11758
11759 begin
11760 -- Assert is an Ada 2005 RM-defined pragma
11761
11762 if Prag_Id = Pragma_Assert then
11763 Ada_2005_Pragma;
11764
11765 -- The remaining ones are GNAT pragmas
11766
11767 else
11768 GNAT_Pragma;
11769 end if;
11770
11771 Check_At_Least_N_Arguments (1);
11772 Check_At_Most_N_Arguments (2);
11773 Check_Arg_Order ((Name_Check, Name_Message));
11774 Check_Optional_Identifier (Arg1, Name_Check);
11775 Expr := Get_Pragma_Arg (Arg1);
11776
11777 -- Special processing for Loop_Invariant, Loop_Variant or for
11778 -- other cases where a Loop_Entry attribute is present. If the
11779 -- assertion pragma contains attribute Loop_Entry, ensure that
11780 -- the related pragma is within a loop.
11781
11782 if Prag_Id = Pragma_Loop_Invariant
11783 or else Prag_Id = Pragma_Loop_Variant
11784 or else Contains_Loop_Entry (Expr)
11785 then
11786 Check_Loop_Pragma_Placement;
11787
11788 -- Perform preanalysis to deal with embedded Loop_Entry
11789 -- attributes.
11790
11791 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11792 end if;
11793
11794 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11795 -- a corresponding Check pragma:
11796
11797 -- pragma Check (name, condition [, msg]);
11798
11799 -- Where name is the identifier matching the pragma name. So
11800 -- rewrite pragma in this manner, transfer the message argument
11801 -- if present, and analyze the result
11802
11803 -- Note: When dealing with a semantically analyzed tree, the
11804 -- information that a Check node N corresponds to a source Assert,
11805 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11806 -- pragma kind of Original_Node(N).
11807
11808 New_Args := New_List (
11809 Make_Pragma_Argument_Association (Loc,
11810 Expression => Make_Identifier (Loc, Pname)),
11811 Make_Pragma_Argument_Association (Sloc (Expr),
11812 Expression => Expr));
11813
11814 if Arg_Count > 1 then
11815 Check_Optional_Identifier (Arg2, Name_Message);
11816
11817 -- Provide semantic annnotations for optional argument, for
11818 -- ASIS use, before rewriting.
11819
11820 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11821 Append_To (New_Args, New_Copy_Tree (Arg2));
11822 end if;
11823
11824 -- Rewrite as Check pragma
11825
11826 Rewrite (N,
11827 Make_Pragma (Loc,
11828 Chars => Name_Check,
11829 Pragma_Argument_Associations => New_Args));
11830
11831 Analyze (N);
11832 end Assert;
11833
11834 ----------------------
11835 -- Assertion_Policy --
11836 ----------------------
11837
11838 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11839
11840 -- The following form is Ada 2012 only, but we allow it in all modes
11841
11842 -- Pragma Assertion_Policy (
11843 -- ASSERTION_KIND => POLICY_IDENTIFIER
11844 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11845
11846 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11847
11848 -- RM_ASSERTION_KIND ::= Assert |
11849 -- Static_Predicate |
11850 -- Dynamic_Predicate |
11851 -- Pre |
11852 -- Pre'Class |
11853 -- Post |
11854 -- Post'Class |
11855 -- Type_Invariant |
11856 -- Type_Invariant'Class
11857
11858 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11859 -- Assume |
11860 -- Contract_Cases |
11861 -- Debug |
11862 -- Default_Initial_Condition |
11863 -- Ghost |
11864 -- Initial_Condition |
11865 -- Loop_Invariant |
11866 -- Loop_Variant |
11867 -- Postcondition |
11868 -- Precondition |
11869 -- Predicate |
11870 -- Refined_Post |
11871 -- Statement_Assertions
11872
11873 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11874 -- ID_ASSERTION_KIND list contains implementation-defined additions
11875 -- recognized by GNAT. The effect is to control the behavior of
11876 -- identically named aspects and pragmas, depending on the specified
11877 -- policy identifier:
11878
11879 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11880
11881 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11882 -- implementation-defined addition that results in totally ignoring
11883 -- the corresponding assertion. If Disable is specified, then the
11884 -- argument of the assertion is not even analyzed. This is useful
11885 -- when the aspect/pragma argument references entities in a with'ed
11886 -- package that is replaced by a dummy package in the final build.
11887
11888 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11889 -- and Type_Invariant'Class were recognized by the parser and
11890 -- transformed into references to the special internal identifiers
11891 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11892 -- processing is required here.
11893
11894 when Pragma_Assertion_Policy => Assertion_Policy : declare
11895 Arg : Node_Id;
11896 Kind : Name_Id;
11897 LocP : Source_Ptr;
11898 Policy : Node_Id;
11899
11900 begin
11901 Ada_2005_Pragma;
11902
11903 -- This can always appear as a configuration pragma
11904
11905 if Is_Configuration_Pragma then
11906 null;
11907
11908 -- It can also appear in a declarative part or package spec in Ada
11909 -- 2012 mode. We allow this in other modes, but in that case we
11910 -- consider that we have an Ada 2012 pragma on our hands.
11911
11912 else
11913 Check_Is_In_Decl_Part_Or_Package_Spec;
11914 Ada_2012_Pragma;
11915 end if;
11916
11917 -- One argument case with no identifier (first form above)
11918
11919 if Arg_Count = 1
11920 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11921 or else Chars (Arg1) = No_Name)
11922 then
11923 Check_Arg_Is_One_Of
11924 (Arg1, Name_Check, Name_Disable, Name_Ignore);
11925
11926 -- Treat one argument Assertion_Policy as equivalent to:
11927
11928 -- pragma Check_Policy (Assertion, policy)
11929
11930 -- So rewrite pragma in that manner and link on to the chain
11931 -- of Check_Policy pragmas, marking the pragma as analyzed.
11932
11933 Policy := Get_Pragma_Arg (Arg1);
11934
11935 Rewrite (N,
11936 Make_Pragma (Loc,
11937 Chars => Name_Check_Policy,
11938 Pragma_Argument_Associations => New_List (
11939 Make_Pragma_Argument_Association (Loc,
11940 Expression => Make_Identifier (Loc, Name_Assertion)),
11941
11942 Make_Pragma_Argument_Association (Loc,
11943 Expression =>
11944 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11945 Analyze (N);
11946
11947 -- Here if we have two or more arguments
11948
11949 else
11950 Check_At_Least_N_Arguments (1);
11951 Ada_2012_Pragma;
11952
11953 -- Loop through arguments
11954
11955 Arg := Arg1;
11956 while Present (Arg) loop
11957 LocP := Sloc (Arg);
11958
11959 -- Kind must be specified
11960
11961 if Nkind (Arg) /= N_Pragma_Argument_Association
11962 or else Chars (Arg) = No_Name
11963 then
11964 Error_Pragma_Arg
11965 ("missing assertion kind for pragma%", Arg);
11966 end if;
11967
11968 -- Check Kind and Policy have allowed forms
11969
11970 Kind := Chars (Arg);
11971 Policy := Get_Pragma_Arg (Arg);
11972
11973 if not Is_Valid_Assertion_Kind (Kind) then
11974 Error_Pragma_Arg
11975 ("invalid assertion kind for pragma%", Arg);
11976 end if;
11977
11978 Check_Arg_Is_One_Of
11979 (Arg, Name_Check, Name_Disable, Name_Ignore);
11980
11981 if Kind = Name_Ghost then
11982
11983 -- The Ghost policy must be either Check or Ignore
11984 -- (SPARK RM 6.9(6)).
11985
11986 if not Nam_In (Chars (Policy), Name_Check,
11987 Name_Ignore)
11988 then
11989 Error_Pragma_Arg
11990 ("argument of pragma % Ghost must be Check or "
11991 & "Ignore", Policy);
11992 end if;
11993
11994 -- Pragma Assertion_Policy specifying a Ghost policy
11995 -- cannot occur within a Ghost subprogram or package
11996 -- (SPARK RM 6.9(14)).
11997
11998 if Ghost_Mode > None then
11999 Error_Pragma
12000 ("pragma % cannot appear within ghost subprogram or "
12001 & "package");
12002 end if;
12003 end if;
12004
12005 -- Rewrite the Assertion_Policy pragma as a series of
12006 -- Check_Policy pragmas of the form:
12007
12008 -- Check_Policy (Kind, Policy);
12009
12010 -- Note: the insertion of the pragmas cannot be done with
12011 -- Insert_Action because in the configuration case, there
12012 -- are no scopes on the scope stack and the mechanism will
12013 -- fail.
12014
12015 Insert_Before_And_Analyze (N,
12016 Make_Pragma (LocP,
12017 Chars => Name_Check_Policy,
12018 Pragma_Argument_Associations => New_List (
12019 Make_Pragma_Argument_Association (LocP,
12020 Expression => Make_Identifier (LocP, Kind)),
12021 Make_Pragma_Argument_Association (LocP,
12022 Expression => Policy))));
12023
12024 Arg := Next (Arg);
12025 end loop;
12026
12027 -- Rewrite the Assertion_Policy pragma as null since we have
12028 -- now inserted all the equivalent Check pragmas.
12029
12030 Rewrite (N, Make_Null_Statement (Loc));
12031 Analyze (N);
12032 end if;
12033 end Assertion_Policy;
12034
12035 ------------------------------
12036 -- Assume_No_Invalid_Values --
12037 ------------------------------
12038
12039 -- pragma Assume_No_Invalid_Values (On | Off);
12040
12041 when Pragma_Assume_No_Invalid_Values =>
12042 GNAT_Pragma;
12043 Check_Valid_Configuration_Pragma;
12044 Check_Arg_Count (1);
12045 Check_No_Identifiers;
12046 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12047
12048 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12049 Assume_No_Invalid_Values := True;
12050 else
12051 Assume_No_Invalid_Values := False;
12052 end if;
12053
12054 --------------------------
12055 -- Attribute_Definition --
12056 --------------------------
12057
12058 -- pragma Attribute_Definition
12059 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12060 -- [Entity =>] LOCAL_NAME,
12061 -- [Expression =>] EXPRESSION | NAME);
12062
12063 when Pragma_Attribute_Definition => Attribute_Definition : declare
12064 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
12065 Aname : Name_Id;
12066
12067 begin
12068 GNAT_Pragma;
12069 Check_Arg_Count (3);
12070 Check_Optional_Identifier (Arg1, "attribute");
12071 Check_Optional_Identifier (Arg2, "entity");
12072 Check_Optional_Identifier (Arg3, "expression");
12073
12074 if Nkind (Attribute_Designator) /= N_Identifier then
12075 Error_Msg_N ("attribute name expected", Attribute_Designator);
12076 return;
12077 end if;
12078
12079 Check_Arg_Is_Local_Name (Arg2);
12080
12081 -- If the attribute is not recognized, then issue a warning (not
12082 -- an error), and ignore the pragma.
12083
12084 Aname := Chars (Attribute_Designator);
12085
12086 if not Is_Attribute_Name (Aname) then
12087 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
12088 return;
12089 end if;
12090
12091 -- Otherwise, rewrite the pragma as an attribute definition clause
12092
12093 Rewrite (N,
12094 Make_Attribute_Definition_Clause (Loc,
12095 Name => Get_Pragma_Arg (Arg2),
12096 Chars => Aname,
12097 Expression => Get_Pragma_Arg (Arg3)));
12098 Analyze (N);
12099 end Attribute_Definition;
12100
12101 ------------------------------------------------------------------
12102 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12103 ------------------------------------------------------------------
12104
12105 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12106 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12107 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12108 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12109
12110 when Pragma_Async_Readers |
12111 Pragma_Async_Writers |
12112 Pragma_Effective_Reads |
12113 Pragma_Effective_Writes =>
12114 Async_Effective : declare
12115 Obj_Decl : Node_Id;
12116 Obj_Id : Entity_Id;
12117
12118 begin
12119 GNAT_Pragma;
12120 Check_No_Identifiers;
12121 Check_At_Most_N_Arguments (1);
12122
12123 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12124
12125 -- Object declaration
12126
12127 if Nkind (Obj_Decl) = N_Object_Declaration then
12128 null;
12129
12130 -- Otherwise the pragma is associated with an illegal construact
12131
12132 else
12133 Pragma_Misplaced;
12134 return;
12135 end if;
12136
12137 Obj_Id := Defining_Entity (Obj_Decl);
12138
12139 -- Perform minimal verification to ensure that the argument is at
12140 -- least a variable. Subsequent finer grained checks will be done
12141 -- at the end of the declarative region the contains the pragma.
12142
12143 if Ekind (Obj_Id) = E_Variable then
12144
12145 -- Chain the pragma on the contract for further processing by
12146 -- Analyze_External_Property_In_Decl_Part.
12147
12148 Add_Contract_Item (N, Obj_Id);
12149
12150 -- A pragma that applies to a Ghost entity becomes Ghost for
12151 -- the purposes of legality checks and removal of ignored Ghost
12152 -- code.
12153
12154 Mark_Pragma_As_Ghost (N, Obj_Id);
12155
12156 -- Analyze the Boolean expression (if any)
12157
12158 if Present (Arg1) then
12159 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12160 end if;
12161
12162 -- Otherwise the external property applies to a constant
12163
12164 else
12165 Error_Pragma ("pragma % must apply to a volatile object");
12166 end if;
12167 end Async_Effective;
12168
12169 ------------------
12170 -- Asynchronous --
12171 ------------------
12172
12173 -- pragma Asynchronous (LOCAL_NAME);
12174
12175 when Pragma_Asynchronous => Asynchronous : declare
12176 C_Ent : Entity_Id;
12177 Decl : Node_Id;
12178 Formal : Entity_Id;
12179 L : List_Id;
12180 Nm : Entity_Id;
12181 S : Node_Id;
12182
12183 procedure Process_Async_Pragma;
12184 -- Common processing for procedure and access-to-procedure case
12185
12186 --------------------------
12187 -- Process_Async_Pragma --
12188 --------------------------
12189
12190 procedure Process_Async_Pragma is
12191 begin
12192 if No (L) then
12193 Set_Is_Asynchronous (Nm);
12194 return;
12195 end if;
12196
12197 -- The formals should be of mode IN (RM E.4.1(6))
12198
12199 S := First (L);
12200 while Present (S) loop
12201 Formal := Defining_Identifier (S);
12202
12203 if Nkind (Formal) = N_Defining_Identifier
12204 and then Ekind (Formal) /= E_In_Parameter
12205 then
12206 Error_Pragma_Arg
12207 ("pragma% procedure can only have IN parameter",
12208 Arg1);
12209 end if;
12210
12211 Next (S);
12212 end loop;
12213
12214 Set_Is_Asynchronous (Nm);
12215 end Process_Async_Pragma;
12216
12217 -- Start of processing for pragma Asynchronous
12218
12219 begin
12220 Check_Ada_83_Warning;
12221 Check_No_Identifiers;
12222 Check_Arg_Count (1);
12223 Check_Arg_Is_Local_Name (Arg1);
12224
12225 if Debug_Flag_U then
12226 return;
12227 end if;
12228
12229 C_Ent := Cunit_Entity (Current_Sem_Unit);
12230 Analyze (Get_Pragma_Arg (Arg1));
12231 Nm := Entity (Get_Pragma_Arg (Arg1));
12232
12233 -- A pragma that applies to a Ghost entity becomes Ghost for the
12234 -- purposes of legality checks and removal of ignored Ghost code.
12235
12236 Mark_Pragma_As_Ghost (N, Nm);
12237
12238 if not Is_Remote_Call_Interface (C_Ent)
12239 and then not Is_Remote_Types (C_Ent)
12240 then
12241 -- This pragma should only appear in an RCI or Remote Types
12242 -- unit (RM E.4.1(4)).
12243
12244 Error_Pragma
12245 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12246 end if;
12247
12248 if Ekind (Nm) = E_Procedure
12249 and then Nkind (Parent (Nm)) = N_Procedure_Specification
12250 then
12251 if not Is_Remote_Call_Interface (Nm) then
12252 Error_Pragma_Arg
12253 ("pragma% cannot be applied on non-remote procedure",
12254 Arg1);
12255 end if;
12256
12257 L := Parameter_Specifications (Parent (Nm));
12258 Process_Async_Pragma;
12259 return;
12260
12261 elsif Ekind (Nm) = E_Function then
12262 Error_Pragma_Arg
12263 ("pragma% cannot be applied to function", Arg1);
12264
12265 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
12266 if Is_Record_Type (Nm) then
12267
12268 -- A record type that is the Equivalent_Type for a remote
12269 -- access-to-subprogram type.
12270
12271 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
12272
12273 else
12274 -- A non-expanded RAS type (distribution is not enabled)
12275
12276 Decl := Declaration_Node (Nm);
12277 end if;
12278
12279 if Nkind (Decl) = N_Full_Type_Declaration
12280 and then Nkind (Type_Definition (Decl)) =
12281 N_Access_Procedure_Definition
12282 then
12283 L := Parameter_Specifications (Type_Definition (Decl));
12284 Process_Async_Pragma;
12285
12286 if Is_Asynchronous (Nm)
12287 and then Expander_Active
12288 and then Get_PCS_Name /= Name_No_DSA
12289 then
12290 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
12291 end if;
12292
12293 else
12294 Error_Pragma_Arg
12295 ("pragma% cannot reference access-to-function type",
12296 Arg1);
12297 end if;
12298
12299 -- Only other possibility is Access-to-class-wide type
12300
12301 elsif Is_Access_Type (Nm)
12302 and then Is_Class_Wide_Type (Designated_Type (Nm))
12303 then
12304 Check_First_Subtype (Arg1);
12305 Set_Is_Asynchronous (Nm);
12306 if Expander_Active then
12307 RACW_Type_Is_Asynchronous (Nm);
12308 end if;
12309
12310 else
12311 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
12312 end if;
12313 end Asynchronous;
12314
12315 ------------
12316 -- Atomic --
12317 ------------
12318
12319 -- pragma Atomic (LOCAL_NAME);
12320
12321 when Pragma_Atomic =>
12322 Process_Atomic_Independent_Shared_Volatile;
12323
12324 -----------------------
12325 -- Atomic_Components --
12326 -----------------------
12327
12328 -- pragma Atomic_Components (array_LOCAL_NAME);
12329
12330 -- This processing is shared by Volatile_Components
12331
12332 when Pragma_Atomic_Components |
12333 Pragma_Volatile_Components =>
12334 Atomic_Components : declare
12335 D : Node_Id;
12336 E : Entity_Id;
12337 E_Id : Node_Id;
12338 K : Node_Kind;
12339
12340 begin
12341 Check_Ada_83_Warning;
12342 Check_No_Identifiers;
12343 Check_Arg_Count (1);
12344 Check_Arg_Is_Local_Name (Arg1);
12345 E_Id := Get_Pragma_Arg (Arg1);
12346
12347 if Etype (E_Id) = Any_Type then
12348 return;
12349 end if;
12350
12351 E := Entity (E_Id);
12352
12353 -- A pragma that applies to a Ghost entity becomes Ghost for the
12354 -- purposes of legality checks and removal of ignored Ghost code.
12355
12356 Mark_Pragma_As_Ghost (N, E);
12357 Check_Duplicate_Pragma (E);
12358
12359 if Rep_Item_Too_Early (E, N)
12360 or else
12361 Rep_Item_Too_Late (E, N)
12362 then
12363 return;
12364 end if;
12365
12366 D := Declaration_Node (E);
12367 K := Nkind (D);
12368
12369 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12370 or else
12371 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12372 and then Nkind (D) = N_Object_Declaration
12373 and then Nkind (Object_Definition (D)) =
12374 N_Constrained_Array_Definition)
12375 then
12376 -- The flag is set on the object, or on the base type
12377
12378 if Nkind (D) /= N_Object_Declaration then
12379 E := Base_Type (E);
12380 end if;
12381
12382 -- Atomic implies both Independent and Volatile
12383
12384 if Prag_Id = Pragma_Atomic_Components then
12385 Set_Has_Atomic_Components (E);
12386 Set_Has_Independent_Components (E);
12387 end if;
12388
12389 Set_Has_Volatile_Components (E);
12390
12391 else
12392 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12393 end if;
12394 end Atomic_Components;
12395
12396 --------------------
12397 -- Attach_Handler --
12398 --------------------
12399
12400 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12401
12402 when Pragma_Attach_Handler =>
12403 Check_Ada_83_Warning;
12404 Check_No_Identifiers;
12405 Check_Arg_Count (2);
12406
12407 if No_Run_Time_Mode then
12408 Error_Msg_CRT ("Attach_Handler pragma", N);
12409 else
12410 Check_Interrupt_Or_Attach_Handler;
12411
12412 -- The expression that designates the attribute may depend on a
12413 -- discriminant, and is therefore a per-object expression, to
12414 -- be expanded in the init proc. If expansion is enabled, then
12415 -- perform semantic checks on a copy only.
12416
12417 declare
12418 Temp : Node_Id;
12419 Typ : Node_Id;
12420 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12421
12422 begin
12423 -- In Relaxed_RM_Semantics mode, we allow any static
12424 -- integer value, for compatibility with other compilers.
12425
12426 if Relaxed_RM_Semantics
12427 and then Nkind (Parg2) = N_Integer_Literal
12428 then
12429 Typ := Standard_Integer;
12430 else
12431 Typ := RTE (RE_Interrupt_ID);
12432 end if;
12433
12434 if Expander_Active then
12435 Temp := New_Copy_Tree (Parg2);
12436 Set_Parent (Temp, N);
12437 Preanalyze_And_Resolve (Temp, Typ);
12438 else
12439 Analyze (Parg2);
12440 Resolve (Parg2, Typ);
12441 end if;
12442 end;
12443
12444 Process_Interrupt_Or_Attach_Handler;
12445 end if;
12446
12447 --------------------
12448 -- C_Pass_By_Copy --
12449 --------------------
12450
12451 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12452
12453 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12454 Arg : Node_Id;
12455 Val : Uint;
12456
12457 begin
12458 GNAT_Pragma;
12459 Check_Valid_Configuration_Pragma;
12460 Check_Arg_Count (1);
12461 Check_Optional_Identifier (Arg1, "max_size");
12462
12463 Arg := Get_Pragma_Arg (Arg1);
12464 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12465
12466 Val := Expr_Value (Arg);
12467
12468 if Val <= 0 then
12469 Error_Pragma_Arg
12470 ("maximum size for pragma% must be positive", Arg1);
12471
12472 elsif UI_Is_In_Int_Range (Val) then
12473 Default_C_Record_Mechanism := UI_To_Int (Val);
12474
12475 -- If a giant value is given, Int'Last will do well enough.
12476 -- If sometime someone complains that a record larger than
12477 -- two gigabytes is not copied, we will worry about it then.
12478
12479 else
12480 Default_C_Record_Mechanism := Mechanism_Type'Last;
12481 end if;
12482 end C_Pass_By_Copy;
12483
12484 -----------
12485 -- Check --
12486 -----------
12487
12488 -- pragma Check ([Name =>] CHECK_KIND,
12489 -- [Check =>] Boolean_EXPRESSION
12490 -- [,[Message =>] String_EXPRESSION]);
12491
12492 -- CHECK_KIND ::= IDENTIFIER |
12493 -- Pre'Class |
12494 -- Post'Class |
12495 -- Invariant'Class |
12496 -- Type_Invariant'Class
12497
12498 -- The identifiers Assertions and Statement_Assertions are not
12499 -- allowed, since they have special meaning for Check_Policy.
12500
12501 when Pragma_Check => Check : declare
12502 Cname : Name_Id;
12503 Eloc : Source_Ptr;
12504 Expr : Node_Id;
12505 Str : Node_Id;
12506
12507 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
12508
12509 begin
12510 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12511 -- the mode now to ensure that any nodes generated during analysis
12512 -- and expansion are marked as Ghost.
12513
12514 Set_Ghost_Mode (N);
12515
12516 GNAT_Pragma;
12517 Check_At_Least_N_Arguments (2);
12518 Check_At_Most_N_Arguments (3);
12519 Check_Optional_Identifier (Arg1, Name_Name);
12520 Check_Optional_Identifier (Arg2, Name_Check);
12521
12522 if Arg_Count = 3 then
12523 Check_Optional_Identifier (Arg3, Name_Message);
12524 Str := Get_Pragma_Arg (Arg3);
12525 end if;
12526
12527 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12528 Check_Arg_Is_Identifier (Arg1);
12529 Cname := Chars (Get_Pragma_Arg (Arg1));
12530
12531 -- Check forbidden name Assertions or Statement_Assertions
12532
12533 case Cname is
12534 when Name_Assertions =>
12535 Error_Pragma_Arg
12536 ("""Assertions"" is not allowed as a check kind for "
12537 & "pragma%", Arg1);
12538
12539 when Name_Statement_Assertions =>
12540 Error_Pragma_Arg
12541 ("""Statement_Assertions"" is not allowed as a check kind "
12542 & "for pragma%", Arg1);
12543
12544 when others =>
12545 null;
12546 end case;
12547
12548 -- Check applicable policy. We skip this if Checked/Ignored status
12549 -- is already set (e.g. in the case of a pragma from an aspect).
12550
12551 if Is_Checked (N) or else Is_Ignored (N) then
12552 null;
12553
12554 -- For a non-source pragma that is a rewriting of another pragma,
12555 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12556
12557 elsif Is_Rewrite_Substitution (N)
12558 and then Nkind (Original_Node (N)) = N_Pragma
12559 and then Original_Node (N) /= N
12560 then
12561 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12562 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12563
12564 -- Otherwise query the applicable policy at this point
12565
12566 else
12567 case Check_Kind (Cname) is
12568 when Name_Ignore =>
12569 Set_Is_Ignored (N, True);
12570 Set_Is_Checked (N, False);
12571
12572 when Name_Check =>
12573 Set_Is_Ignored (N, False);
12574 Set_Is_Checked (N, True);
12575
12576 -- For disable, rewrite pragma as null statement and skip
12577 -- rest of the analysis of the pragma.
12578
12579 when Name_Disable =>
12580 Rewrite (N, Make_Null_Statement (Loc));
12581 Analyze (N);
12582 raise Pragma_Exit;
12583
12584 -- No other possibilities
12585
12586 when others =>
12587 raise Program_Error;
12588 end case;
12589 end if;
12590
12591 -- If check kind was not Disable, then continue pragma analysis
12592
12593 Expr := Get_Pragma_Arg (Arg2);
12594
12595 -- Deal with SCO generation
12596
12597 case Cname is
12598
12599 -- Nothing to do for predicates as the checks occur in the
12600 -- client units. The SCO for the aspect in the declaration
12601 -- unit is conservatively always enabled.
12602
12603 when Name_Predicate =>
12604 null;
12605
12606 -- Otherwise mark aspect/pragma SCO as enabled
12607
12608 when others =>
12609 if Is_Checked (N) and then not Split_PPC (N) then
12610 Set_SCO_Pragma_Enabled (Loc);
12611 end if;
12612 end case;
12613
12614 -- Deal with analyzing the string argument
12615
12616 if Arg_Count = 3 then
12617
12618 -- If checks are not on we don't want any expansion (since
12619 -- such expansion would not get properly deleted) but
12620 -- we do want to analyze (to get proper references).
12621 -- The Preanalyze_And_Resolve routine does just what we want
12622
12623 if Is_Ignored (N) then
12624 Preanalyze_And_Resolve (Str, Standard_String);
12625
12626 -- Otherwise we need a proper analysis and expansion
12627
12628 else
12629 Analyze_And_Resolve (Str, Standard_String);
12630 end if;
12631 end if;
12632
12633 -- Now you might think we could just do the same with the Boolean
12634 -- expression if checks are off (and expansion is on) and then
12635 -- rewrite the check as a null statement. This would work but we
12636 -- would lose the useful warnings about an assertion being bound
12637 -- to fail even if assertions are turned off.
12638
12639 -- So instead we wrap the boolean expression in an if statement
12640 -- that looks like:
12641
12642 -- if False and then condition then
12643 -- null;
12644 -- end if;
12645
12646 -- The reason we do this rewriting during semantic analysis rather
12647 -- than as part of normal expansion is that we cannot analyze and
12648 -- expand the code for the boolean expression directly, or it may
12649 -- cause insertion of actions that would escape the attempt to
12650 -- suppress the check code.
12651
12652 -- Note that the Sloc for the if statement corresponds to the
12653 -- argument condition, not the pragma itself. The reason for
12654 -- this is that we may generate a warning if the condition is
12655 -- False at compile time, and we do not want to delete this
12656 -- warning when we delete the if statement.
12657
12658 if Expander_Active and Is_Ignored (N) then
12659 Eloc := Sloc (Expr);
12660
12661 Rewrite (N,
12662 Make_If_Statement (Eloc,
12663 Condition =>
12664 Make_And_Then (Eloc,
12665 Left_Opnd => Make_Identifier (Eloc, Name_False),
12666 Right_Opnd => Expr),
12667 Then_Statements => New_List (
12668 Make_Null_Statement (Eloc))));
12669
12670 -- Now go ahead and analyze the if statement
12671
12672 In_Assertion_Expr := In_Assertion_Expr + 1;
12673
12674 -- One rather special treatment. If we are now in Eliminated
12675 -- overflow mode, then suppress overflow checking since we do
12676 -- not want to drag in the bignum stuff if we are in Ignore
12677 -- mode anyway. This is particularly important if we are using
12678 -- a configurable run time that does not support bignum ops.
12679
12680 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12681 declare
12682 Svo : constant Boolean :=
12683 Scope_Suppress.Suppress (Overflow_Check);
12684 begin
12685 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12686 Scope_Suppress.Suppress (Overflow_Check) := True;
12687 Analyze (N);
12688 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12689 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12690 end;
12691
12692 -- Not that special case
12693
12694 else
12695 Analyze (N);
12696 end if;
12697
12698 -- All done with this check
12699
12700 In_Assertion_Expr := In_Assertion_Expr - 1;
12701
12702 -- Check is active or expansion not active. In these cases we can
12703 -- just go ahead and analyze the boolean with no worries.
12704
12705 else
12706 In_Assertion_Expr := In_Assertion_Expr + 1;
12707 Analyze_And_Resolve (Expr, Any_Boolean);
12708 In_Assertion_Expr := In_Assertion_Expr - 1;
12709 end if;
12710
12711 Ghost_Mode := Save_Ghost_Mode;
12712 end Check;
12713
12714 --------------------------
12715 -- Check_Float_Overflow --
12716 --------------------------
12717
12718 -- pragma Check_Float_Overflow;
12719
12720 when Pragma_Check_Float_Overflow =>
12721 GNAT_Pragma;
12722 Check_Valid_Configuration_Pragma;
12723 Check_Arg_Count (0);
12724 Check_Float_Overflow := not Machine_Overflows_On_Target;
12725
12726 ----------------
12727 -- Check_Name --
12728 ----------------
12729
12730 -- pragma Check_Name (check_IDENTIFIER);
12731
12732 when Pragma_Check_Name =>
12733 GNAT_Pragma;
12734 Check_No_Identifiers;
12735 Check_Valid_Configuration_Pragma;
12736 Check_Arg_Count (1);
12737 Check_Arg_Is_Identifier (Arg1);
12738
12739 declare
12740 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12741
12742 begin
12743 for J in Check_Names.First .. Check_Names.Last loop
12744 if Check_Names.Table (J) = Nam then
12745 return;
12746 end if;
12747 end loop;
12748
12749 Check_Names.Append (Nam);
12750 end;
12751
12752 ------------------
12753 -- Check_Policy --
12754 ------------------
12755
12756 -- This is the old style syntax, which is still allowed in all modes:
12757
12758 -- pragma Check_Policy ([Name =>] CHECK_KIND
12759 -- [Policy =>] POLICY_IDENTIFIER);
12760
12761 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12762
12763 -- CHECK_KIND ::= IDENTIFIER |
12764 -- Pre'Class |
12765 -- Post'Class |
12766 -- Type_Invariant'Class |
12767 -- Invariant'Class
12768
12769 -- This is the new style syntax, compatible with Assertion_Policy
12770 -- and also allowed in all modes.
12771
12772 -- Pragma Check_Policy (
12773 -- CHECK_KIND => POLICY_IDENTIFIER
12774 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12775
12776 -- Note: the identifiers Name and Policy are not allowed as
12777 -- Check_Kind values. This avoids ambiguities between the old and
12778 -- new form syntax.
12779
12780 when Pragma_Check_Policy => Check_Policy : declare
12781 Kind : Node_Id;
12782
12783 begin
12784 GNAT_Pragma;
12785 Check_At_Least_N_Arguments (1);
12786
12787 -- A Check_Policy pragma can appear either as a configuration
12788 -- pragma, or in a declarative part or a package spec (see RM
12789 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12790 -- followed for Check_Policy).
12791
12792 if not Is_Configuration_Pragma then
12793 Check_Is_In_Decl_Part_Or_Package_Spec;
12794 end if;
12795
12796 -- Figure out if we have the old or new syntax. We have the
12797 -- old syntax if the first argument has no identifier, or the
12798 -- identifier is Name.
12799
12800 if Nkind (Arg1) /= N_Pragma_Argument_Association
12801 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12802 then
12803 -- Old syntax
12804
12805 Check_Arg_Count (2);
12806 Check_Optional_Identifier (Arg1, Name_Name);
12807 Kind := Get_Pragma_Arg (Arg1);
12808 Rewrite_Assertion_Kind (Kind);
12809 Check_Arg_Is_Identifier (Arg1);
12810
12811 -- Check forbidden check kind
12812
12813 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12814 Error_Msg_Name_2 := Chars (Kind);
12815 Error_Pragma_Arg
12816 ("pragma% does not allow% as check name", Arg1);
12817 end if;
12818
12819 -- Check policy
12820
12821 Check_Optional_Identifier (Arg2, Name_Policy);
12822 Check_Arg_Is_One_Of
12823 (Arg2,
12824 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12825
12826 -- And chain pragma on the Check_Policy_List for search
12827
12828 Set_Next_Pragma (N, Opt.Check_Policy_List);
12829 Opt.Check_Policy_List := N;
12830
12831 -- For the new syntax, what we do is to convert each argument to
12832 -- an old syntax equivalent. We do that because we want to chain
12833 -- old style Check_Policy pragmas for the search (we don't want
12834 -- to have to deal with multiple arguments in the search).
12835
12836 else
12837 declare
12838 Arg : Node_Id;
12839 Argx : Node_Id;
12840 LocP : Source_Ptr;
12841 New_P : Node_Id;
12842
12843 begin
12844 Arg := Arg1;
12845 while Present (Arg) loop
12846 LocP := Sloc (Arg);
12847 Argx := Get_Pragma_Arg (Arg);
12848
12849 -- Kind must be specified
12850
12851 if Nkind (Arg) /= N_Pragma_Argument_Association
12852 or else Chars (Arg) = No_Name
12853 then
12854 Error_Pragma_Arg
12855 ("missing assertion kind for pragma%", Arg);
12856 end if;
12857
12858 -- Construct equivalent old form syntax Check_Policy
12859 -- pragma and insert it to get remaining checks.
12860
12861 New_P :=
12862 Make_Pragma (LocP,
12863 Chars => Name_Check_Policy,
12864 Pragma_Argument_Associations => New_List (
12865 Make_Pragma_Argument_Association (LocP,
12866 Expression =>
12867 Make_Identifier (LocP, Chars (Arg))),
12868 Make_Pragma_Argument_Association (Sloc (Argx),
12869 Expression => Argx)));
12870
12871 Arg := Next (Arg);
12872
12873 -- For a configuration pragma, insert old form in
12874 -- the corresponding file.
12875
12876 if Is_Configuration_Pragma then
12877 Insert_After (N, New_P);
12878 Analyze (New_P);
12879
12880 else
12881 Insert_Action (N, New_P);
12882 end if;
12883 end loop;
12884
12885 -- Rewrite original Check_Policy pragma to null, since we
12886 -- have converted it into a series of old syntax pragmas.
12887
12888 Rewrite (N, Make_Null_Statement (Loc));
12889 Analyze (N);
12890 end;
12891 end if;
12892 end Check_Policy;
12893
12894 -------------
12895 -- Comment --
12896 -------------
12897
12898 -- pragma Comment (static_string_EXPRESSION)
12899
12900 -- Processing for pragma Comment shares the circuitry for pragma
12901 -- Ident. The only differences are that Ident enforces a limit of 31
12902 -- characters on its argument, and also enforces limitations on
12903 -- placement for DEC compatibility. Pragma Comment shares neither of
12904 -- these restrictions.
12905
12906 -------------------
12907 -- Common_Object --
12908 -------------------
12909
12910 -- pragma Common_Object (
12911 -- [Internal =>] LOCAL_NAME
12912 -- [, [External =>] EXTERNAL_SYMBOL]
12913 -- [, [Size =>] EXTERNAL_SYMBOL]);
12914
12915 -- Processing for this pragma is shared with Psect_Object
12916
12917 ------------------------
12918 -- Compile_Time_Error --
12919 ------------------------
12920
12921 -- pragma Compile_Time_Error
12922 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12923
12924 when Pragma_Compile_Time_Error =>
12925 GNAT_Pragma;
12926 Process_Compile_Time_Warning_Or_Error;
12927
12928 --------------------------
12929 -- Compile_Time_Warning --
12930 --------------------------
12931
12932 -- pragma Compile_Time_Warning
12933 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12934
12935 when Pragma_Compile_Time_Warning =>
12936 GNAT_Pragma;
12937 Process_Compile_Time_Warning_Or_Error;
12938
12939 ---------------------------
12940 -- Compiler_Unit_Warning --
12941 ---------------------------
12942
12943 -- pragma Compiler_Unit_Warning;
12944
12945 -- Historical note
12946
12947 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12948 -- errors not warnings. This means that we had introduced a big extra
12949 -- inertia to compiler changes, since even if we implemented a new
12950 -- feature, and even if all versions to be used for bootstrapping
12951 -- implemented this new feature, we could not use it, since old
12952 -- compilers would give errors for using this feature in units
12953 -- having Compiler_Unit pragmas.
12954
12955 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12956 -- problem. We no longer have any units mentioning Compiler_Unit,
12957 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12958 -- and thus generates a warning which can be ignored. So that deals
12959 -- with the problem of old compilers not implementing the newer form
12960 -- of the pragma.
12961
12962 -- Newer compilers recognize the new pragma, but generate warning
12963 -- messages instead of errors, which again can be ignored in the
12964 -- case of an old compiler which implements a wanted new feature
12965 -- but at the time felt like warning about it for older compilers.
12966
12967 -- We retain Compiler_Unit so that new compilers can be used to build
12968 -- older run-times that use this pragma. That's an unusual case, but
12969 -- it's easy enough to handle, so why not?
12970
12971 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12972 GNAT_Pragma;
12973 Check_Arg_Count (0);
12974
12975 -- Only recognized in main unit
12976
12977 if Current_Sem_Unit = Main_Unit then
12978 Compiler_Unit := True;
12979 end if;
12980
12981 -----------------------------
12982 -- Complete_Representation --
12983 -----------------------------
12984
12985 -- pragma Complete_Representation;
12986
12987 when Pragma_Complete_Representation =>
12988 GNAT_Pragma;
12989 Check_Arg_Count (0);
12990
12991 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12992 Error_Pragma
12993 ("pragma & must appear within record representation clause");
12994 end if;
12995
12996 ----------------------------
12997 -- Complex_Representation --
12998 ----------------------------
12999
13000 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13001
13002 when Pragma_Complex_Representation => Complex_Representation : declare
13003 E_Id : Entity_Id;
13004 E : Entity_Id;
13005 Ent : Entity_Id;
13006
13007 begin
13008 GNAT_Pragma;
13009 Check_Arg_Count (1);
13010 Check_Optional_Identifier (Arg1, Name_Entity);
13011 Check_Arg_Is_Local_Name (Arg1);
13012 E_Id := Get_Pragma_Arg (Arg1);
13013
13014 if Etype (E_Id) = Any_Type then
13015 return;
13016 end if;
13017
13018 E := Entity (E_Id);
13019
13020 if not Is_Record_Type (E) then
13021 Error_Pragma_Arg
13022 ("argument for pragma% must be record type", Arg1);
13023 end if;
13024
13025 Ent := First_Entity (E);
13026
13027 if No (Ent)
13028 or else No (Next_Entity (Ent))
13029 or else Present (Next_Entity (Next_Entity (Ent)))
13030 or else not Is_Floating_Point_Type (Etype (Ent))
13031 or else Etype (Ent) /= Etype (Next_Entity (Ent))
13032 then
13033 Error_Pragma_Arg
13034 ("record for pragma% must have two fields of the same "
13035 & "floating-point type", Arg1);
13036
13037 else
13038 Set_Has_Complex_Representation (Base_Type (E));
13039
13040 -- We need to treat the type has having a non-standard
13041 -- representation, for back-end purposes, even though in
13042 -- general a complex will have the default representation
13043 -- of a record with two real components.
13044
13045 Set_Has_Non_Standard_Rep (Base_Type (E));
13046 end if;
13047 end Complex_Representation;
13048
13049 -------------------------
13050 -- Component_Alignment --
13051 -------------------------
13052
13053 -- pragma Component_Alignment (
13054 -- [Form =>] ALIGNMENT_CHOICE
13055 -- [, [Name =>] type_LOCAL_NAME]);
13056 --
13057 -- ALIGNMENT_CHOICE ::=
13058 -- Component_Size
13059 -- | Component_Size_4
13060 -- | Storage_Unit
13061 -- | Default
13062
13063 when Pragma_Component_Alignment => Component_AlignmentP : declare
13064 Args : Args_List (1 .. 2);
13065 Names : constant Name_List (1 .. 2) := (
13066 Name_Form,
13067 Name_Name);
13068
13069 Form : Node_Id renames Args (1);
13070 Name : Node_Id renames Args (2);
13071
13072 Atype : Component_Alignment_Kind;
13073 Typ : Entity_Id;
13074
13075 begin
13076 GNAT_Pragma;
13077 Gather_Associations (Names, Args);
13078
13079 if No (Form) then
13080 Error_Pragma ("missing Form argument for pragma%");
13081 end if;
13082
13083 Check_Arg_Is_Identifier (Form);
13084
13085 -- Get proper alignment, note that Default = Component_Size on all
13086 -- machines we have so far, and we want to set this value rather
13087 -- than the default value to indicate that it has been explicitly
13088 -- set (and thus will not get overridden by the default component
13089 -- alignment for the current scope)
13090
13091 if Chars (Form) = Name_Component_Size then
13092 Atype := Calign_Component_Size;
13093
13094 elsif Chars (Form) = Name_Component_Size_4 then
13095 Atype := Calign_Component_Size_4;
13096
13097 elsif Chars (Form) = Name_Default then
13098 Atype := Calign_Component_Size;
13099
13100 elsif Chars (Form) = Name_Storage_Unit then
13101 Atype := Calign_Storage_Unit;
13102
13103 else
13104 Error_Pragma_Arg
13105 ("invalid Form parameter for pragma%", Form);
13106 end if;
13107
13108 -- The pragma appears in a configuration file
13109
13110 if No (Parent (N)) then
13111 Check_Valid_Configuration_Pragma;
13112
13113 -- Capture the component alignment in a global variable when
13114 -- the pragma appears in a configuration file. Note that the
13115 -- scope stack is empty at this point and cannot be used to
13116 -- store the alignment value.
13117
13118 Configuration_Component_Alignment := Atype;
13119
13120 -- Case with no name, supplied, affects scope table entry
13121
13122 elsif No (Name) then
13123 Scope_Stack.Table
13124 (Scope_Stack.Last).Component_Alignment_Default := Atype;
13125
13126 -- Case of name supplied
13127
13128 else
13129 Check_Arg_Is_Local_Name (Name);
13130 Find_Type (Name);
13131 Typ := Entity (Name);
13132
13133 if Typ = Any_Type
13134 or else Rep_Item_Too_Early (Typ, N)
13135 then
13136 return;
13137 else
13138 Typ := Underlying_Type (Typ);
13139 end if;
13140
13141 if not Is_Record_Type (Typ)
13142 and then not Is_Array_Type (Typ)
13143 then
13144 Error_Pragma_Arg
13145 ("Name parameter of pragma% must identify record or "
13146 & "array type", Name);
13147 end if;
13148
13149 -- An explicit Component_Alignment pragma overrides an
13150 -- implicit pragma Pack, but not an explicit one.
13151
13152 if not Has_Pragma_Pack (Base_Type (Typ)) then
13153 Set_Is_Packed (Base_Type (Typ), False);
13154 Set_Component_Alignment (Base_Type (Typ), Atype);
13155 end if;
13156 end if;
13157 end Component_AlignmentP;
13158
13159 --------------------------------
13160 -- Constant_After_Elaboration --
13161 --------------------------------
13162
13163 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13164
13165 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
13166 declare
13167 Obj_Decl : Node_Id;
13168 Obj_Id : Entity_Id;
13169
13170 begin
13171 GNAT_Pragma;
13172 Check_No_Identifiers;
13173 Check_At_Most_N_Arguments (1);
13174
13175 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13176
13177 -- Object declaration
13178
13179 if Nkind (Obj_Decl) = N_Object_Declaration then
13180 null;
13181
13182 -- Otherwise the pragma is associated with an illegal construct
13183
13184 else
13185 Pragma_Misplaced;
13186 return;
13187 end if;
13188
13189 Obj_Id := Defining_Entity (Obj_Decl);
13190
13191 -- The object declaration must be a library-level variable which
13192 -- is either explicitly initialized or obtains a value during the
13193 -- elaboration of a package body (SPARK RM 3.3.1).
13194
13195 if Ekind (Obj_Id) = E_Variable then
13196 if not Is_Library_Level_Entity (Obj_Id) then
13197 Error_Pragma
13198 ("pragma % must apply to a library level variable");
13199 return;
13200 end if;
13201
13202 -- Otherwise the pragma applies to a constant, which is illegal
13203
13204 else
13205 Error_Pragma ("pragma % must apply to a variable declaration");
13206 return;
13207 end if;
13208
13209 -- Chain the pragma on the contract for completeness
13210
13211 Add_Contract_Item (N, Obj_Id);
13212
13213 -- A pragma that applies to a Ghost entity becomes Ghost for the
13214 -- purposes of legality checks and removal of ignored Ghost code.
13215
13216 Mark_Pragma_As_Ghost (N, Obj_Id);
13217
13218 -- Analyze the Boolean expression (if any)
13219
13220 if Present (Arg1) then
13221 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13222 end if;
13223 end Constant_After_Elaboration;
13224
13225 --------------------
13226 -- Contract_Cases --
13227 --------------------
13228
13229 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13230
13231 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13232
13233 -- CASE_GUARD ::= boolean_EXPRESSION | others
13234
13235 -- CONSEQUENCE ::= boolean_EXPRESSION
13236
13237 -- Characteristics:
13238
13239 -- * Analysis - The annotation undergoes initial checks to verify
13240 -- the legal placement and context. Secondary checks preanalyze the
13241 -- expressions in:
13242
13243 -- Analyze_Contract_Cases_In_Decl_Part
13244
13245 -- * Expansion - The annotation is expanded during the expansion of
13246 -- the related subprogram [body] contract as performed in:
13247
13248 -- Expand_Subprogram_Contract
13249
13250 -- * Template - The annotation utilizes the generic template of the
13251 -- related subprogram [body] when it is:
13252
13253 -- aspect on subprogram declaration
13254 -- aspect on stand alone subprogram body
13255 -- pragma on stand alone subprogram body
13256
13257 -- The annotation must prepare its own template when it is:
13258
13259 -- pragma on subprogram declaration
13260
13261 -- * Globals - Capture of global references must occur after full
13262 -- analysis.
13263
13264 -- * Instance - The annotation is instantiated automatically when
13265 -- the related generic subprogram [body] is instantiated except for
13266 -- the "pragma on subprogram declaration" case. In that scenario
13267 -- the annotation must instantiate itself.
13268
13269 when Pragma_Contract_Cases => Contract_Cases : declare
13270 Spec_Id : Entity_Id;
13271 Subp_Decl : Node_Id;
13272
13273 begin
13274 GNAT_Pragma;
13275 Check_No_Identifiers;
13276 Check_Arg_Count (1);
13277
13278 -- Ensure the proper placement of the pragma. Contract_Cases must
13279 -- be associated with a subprogram declaration or a body that acts
13280 -- as a spec.
13281
13282 Subp_Decl :=
13283 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
13284
13285 -- Entry
13286
13287 if Nkind (Subp_Decl) = N_Entry_Declaration then
13288 null;
13289
13290 -- Generic subprogram
13291
13292 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
13293 null;
13294
13295 -- Body acts as spec
13296
13297 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13298 and then No (Corresponding_Spec (Subp_Decl))
13299 then
13300 null;
13301
13302 -- Body stub acts as spec
13303
13304 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13305 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13306 then
13307 null;
13308
13309 -- Subprogram
13310
13311 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
13312 null;
13313
13314 else
13315 Pragma_Misplaced;
13316 return;
13317 end if;
13318
13319 Spec_Id := Unique_Defining_Entity (Subp_Decl);
13320
13321 -- Chain the pragma on the contract for further processing by
13322 -- Analyze_Contract_Cases_In_Decl_Part.
13323
13324 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13325
13326 -- A pragma that applies to a Ghost entity becomes Ghost for the
13327 -- purposes of legality checks and removal of ignored Ghost code.
13328
13329 Mark_Pragma_As_Ghost (N, Spec_Id);
13330 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13331
13332 -- Fully analyze the pragma when it appears inside an entry
13333 -- or subprogram body because it cannot benefit from forward
13334 -- references.
13335
13336 if Nkind_In (Subp_Decl, N_Entry_Body,
13337 N_Subprogram_Body,
13338 N_Subprogram_Body_Stub)
13339 then
13340 -- The legality checks of pragma Contract_Cases are affected by
13341 -- the SPARK mode in effect and the volatility of the context.
13342 -- Analyze all pragmas in a specific order.
13343
13344 Analyze_If_Present (Pragma_SPARK_Mode);
13345 Analyze_If_Present (Pragma_Volatile_Function);
13346 Analyze_Contract_Cases_In_Decl_Part (N);
13347 end if;
13348 end Contract_Cases;
13349
13350 ----------------
13351 -- Controlled --
13352 ----------------
13353
13354 -- pragma Controlled (first_subtype_LOCAL_NAME);
13355
13356 when Pragma_Controlled => Controlled : declare
13357 Arg : Node_Id;
13358
13359 begin
13360 Check_No_Identifiers;
13361 Check_Arg_Count (1);
13362 Check_Arg_Is_Local_Name (Arg1);
13363 Arg := Get_Pragma_Arg (Arg1);
13364
13365 if not Is_Entity_Name (Arg)
13366 or else not Is_Access_Type (Entity (Arg))
13367 then
13368 Error_Pragma_Arg ("pragma% requires access type", Arg1);
13369 else
13370 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13371 end if;
13372 end Controlled;
13373
13374 ----------------
13375 -- Convention --
13376 ----------------
13377
13378 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13379 -- [Entity =>] LOCAL_NAME);
13380
13381 when Pragma_Convention => Convention : declare
13382 C : Convention_Id;
13383 E : Entity_Id;
13384 pragma Warnings (Off, C);
13385 pragma Warnings (Off, E);
13386 begin
13387 Check_Arg_Order ((Name_Convention, Name_Entity));
13388 Check_Ada_83_Warning;
13389 Check_Arg_Count (2);
13390 Process_Convention (C, E);
13391
13392 -- A pragma that applies to a Ghost entity becomes Ghost for the
13393 -- purposes of legality checks and removal of ignored Ghost code.
13394
13395 Mark_Pragma_As_Ghost (N, E);
13396 end Convention;
13397
13398 ---------------------------
13399 -- Convention_Identifier --
13400 ---------------------------
13401
13402 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13403 -- [Convention =>] convention_IDENTIFIER);
13404
13405 when Pragma_Convention_Identifier => Convention_Identifier : declare
13406 Idnam : Name_Id;
13407 Cname : Name_Id;
13408
13409 begin
13410 GNAT_Pragma;
13411 Check_Arg_Order ((Name_Name, Name_Convention));
13412 Check_Arg_Count (2);
13413 Check_Optional_Identifier (Arg1, Name_Name);
13414 Check_Optional_Identifier (Arg2, Name_Convention);
13415 Check_Arg_Is_Identifier (Arg1);
13416 Check_Arg_Is_Identifier (Arg2);
13417 Idnam := Chars (Get_Pragma_Arg (Arg1));
13418 Cname := Chars (Get_Pragma_Arg (Arg2));
13419
13420 if Is_Convention_Name (Cname) then
13421 Record_Convention_Identifier
13422 (Idnam, Get_Convention_Id (Cname));
13423 else
13424 Error_Pragma_Arg
13425 ("second arg for % pragma must be convention", Arg2);
13426 end if;
13427 end Convention_Identifier;
13428
13429 ---------------
13430 -- CPP_Class --
13431 ---------------
13432
13433 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13434
13435 when Pragma_CPP_Class => CPP_Class : declare
13436 begin
13437 GNAT_Pragma;
13438
13439 if Warn_On_Obsolescent_Feature then
13440 Error_Msg_N
13441 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13442 & "effect; replace it by pragma import?j?", N);
13443 end if;
13444
13445 Check_Arg_Count (1);
13446
13447 Rewrite (N,
13448 Make_Pragma (Loc,
13449 Chars => Name_Import,
13450 Pragma_Argument_Associations => New_List (
13451 Make_Pragma_Argument_Association (Loc,
13452 Expression => Make_Identifier (Loc, Name_CPP)),
13453 New_Copy (First (Pragma_Argument_Associations (N))))));
13454 Analyze (N);
13455 end CPP_Class;
13456
13457 ---------------------
13458 -- CPP_Constructor --
13459 ---------------------
13460
13461 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13462 -- [, [External_Name =>] static_string_EXPRESSION ]
13463 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13464
13465 when Pragma_CPP_Constructor => CPP_Constructor : declare
13466 Elmt : Elmt_Id;
13467 Id : Entity_Id;
13468 Def_Id : Entity_Id;
13469 Tag_Typ : Entity_Id;
13470
13471 begin
13472 GNAT_Pragma;
13473 Check_At_Least_N_Arguments (1);
13474 Check_At_Most_N_Arguments (3);
13475 Check_Optional_Identifier (Arg1, Name_Entity);
13476 Check_Arg_Is_Local_Name (Arg1);
13477
13478 Id := Get_Pragma_Arg (Arg1);
13479 Find_Program_Unit_Name (Id);
13480
13481 -- If we did not find the name, we are done
13482
13483 if Etype (Id) = Any_Type then
13484 return;
13485 end if;
13486
13487 Def_Id := Entity (Id);
13488
13489 -- Check if already defined as constructor
13490
13491 if Is_Constructor (Def_Id) then
13492 Error_Msg_N
13493 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13494 return;
13495 end if;
13496
13497 if Ekind (Def_Id) = E_Function
13498 and then (Is_CPP_Class (Etype (Def_Id))
13499 or else (Is_Class_Wide_Type (Etype (Def_Id))
13500 and then
13501 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13502 then
13503 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13504 Error_Msg_N
13505 ("'C'P'P constructor must be defined in the scope of "
13506 & "its returned type", Arg1);
13507 end if;
13508
13509 if Arg_Count >= 2 then
13510 Set_Imported (Def_Id);
13511 Set_Is_Public (Def_Id);
13512 Process_Interface_Name (Def_Id, Arg2, Arg3);
13513 end if;
13514
13515 Set_Has_Completion (Def_Id);
13516 Set_Is_Constructor (Def_Id);
13517 Set_Convention (Def_Id, Convention_CPP);
13518
13519 -- Imported C++ constructors are not dispatching primitives
13520 -- because in C++ they don't have a dispatch table slot.
13521 -- However, in Ada the constructor has the profile of a
13522 -- function that returns a tagged type and therefore it has
13523 -- been treated as a primitive operation during semantic
13524 -- analysis. We now remove it from the list of primitive
13525 -- operations of the type.
13526
13527 if Is_Tagged_Type (Etype (Def_Id))
13528 and then not Is_Class_Wide_Type (Etype (Def_Id))
13529 and then Is_Dispatching_Operation (Def_Id)
13530 then
13531 Tag_Typ := Etype (Def_Id);
13532
13533 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13534 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13535 Next_Elmt (Elmt);
13536 end loop;
13537
13538 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13539 Set_Is_Dispatching_Operation (Def_Id, False);
13540 end if;
13541
13542 -- For backward compatibility, if the constructor returns a
13543 -- class wide type, and we internally change the return type to
13544 -- the corresponding root type.
13545
13546 if Is_Class_Wide_Type (Etype (Def_Id)) then
13547 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13548 end if;
13549 else
13550 Error_Pragma_Arg
13551 ("pragma% requires function returning a 'C'P'P_Class type",
13552 Arg1);
13553 end if;
13554 end CPP_Constructor;
13555
13556 -----------------
13557 -- CPP_Virtual --
13558 -----------------
13559
13560 when Pragma_CPP_Virtual => CPP_Virtual : declare
13561 begin
13562 GNAT_Pragma;
13563
13564 if Warn_On_Obsolescent_Feature then
13565 Error_Msg_N
13566 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13567 & "effect?j?", N);
13568 end if;
13569 end CPP_Virtual;
13570
13571 ----------------
13572 -- CPP_Vtable --
13573 ----------------
13574
13575 when Pragma_CPP_Vtable => CPP_Vtable : declare
13576 begin
13577 GNAT_Pragma;
13578
13579 if Warn_On_Obsolescent_Feature then
13580 Error_Msg_N
13581 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13582 & "effect?j?", N);
13583 end if;
13584 end CPP_Vtable;
13585
13586 ---------
13587 -- CPU --
13588 ---------
13589
13590 -- pragma CPU (EXPRESSION);
13591
13592 when Pragma_CPU => CPU : declare
13593 P : constant Node_Id := Parent (N);
13594 Arg : Node_Id;
13595 Ent : Entity_Id;
13596
13597 begin
13598 Ada_2012_Pragma;
13599 Check_No_Identifiers;
13600 Check_Arg_Count (1);
13601
13602 -- Subprogram case
13603
13604 if Nkind (P) = N_Subprogram_Body then
13605 Check_In_Main_Program;
13606
13607 Arg := Get_Pragma_Arg (Arg1);
13608 Analyze_And_Resolve (Arg, Any_Integer);
13609
13610 Ent := Defining_Unit_Name (Specification (P));
13611
13612 if Nkind (Ent) = N_Defining_Program_Unit_Name then
13613 Ent := Defining_Identifier (Ent);
13614 end if;
13615
13616 -- Must be static
13617
13618 if not Is_OK_Static_Expression (Arg) then
13619 Flag_Non_Static_Expr
13620 ("main subprogram affinity is not static!", Arg);
13621 raise Pragma_Exit;
13622
13623 -- If constraint error, then we already signalled an error
13624
13625 elsif Raises_Constraint_Error (Arg) then
13626 null;
13627
13628 -- Otherwise check in range
13629
13630 else
13631 declare
13632 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13633 -- This is the entity System.Multiprocessors.CPU_Range;
13634
13635 Val : constant Uint := Expr_Value (Arg);
13636
13637 begin
13638 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13639 or else
13640 Val > Expr_Value (Type_High_Bound (CPU_Id))
13641 then
13642 Error_Pragma_Arg
13643 ("main subprogram CPU is out of range", Arg1);
13644 end if;
13645 end;
13646 end if;
13647
13648 Set_Main_CPU
13649 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13650
13651 -- Task case
13652
13653 elsif Nkind (P) = N_Task_Definition then
13654 Arg := Get_Pragma_Arg (Arg1);
13655 Ent := Defining_Identifier (Parent (P));
13656
13657 -- The expression must be analyzed in the special manner
13658 -- described in "Handling of Default and Per-Object
13659 -- Expressions" in sem.ads.
13660
13661 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13662
13663 -- Anything else is incorrect
13664
13665 else
13666 Pragma_Misplaced;
13667 end if;
13668
13669 -- Check duplicate pragma before we chain the pragma in the Rep
13670 -- Item chain of Ent.
13671
13672 Check_Duplicate_Pragma (Ent);
13673 Record_Rep_Item (Ent, N);
13674 end CPU;
13675
13676 -----------
13677 -- Debug --
13678 -----------
13679
13680 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13681
13682 when Pragma_Debug => Debug : declare
13683 Cond : Node_Id;
13684 Call : Node_Id;
13685
13686 begin
13687 GNAT_Pragma;
13688
13689 -- The condition for executing the call is that the expander
13690 -- is active and that we are not ignoring this debug pragma.
13691
13692 Cond :=
13693 New_Occurrence_Of
13694 (Boolean_Literals
13695 (Expander_Active and then not Is_Ignored (N)),
13696 Loc);
13697
13698 if not Is_Ignored (N) then
13699 Set_SCO_Pragma_Enabled (Loc);
13700 end if;
13701
13702 if Arg_Count = 2 then
13703 Cond :=
13704 Make_And_Then (Loc,
13705 Left_Opnd => Relocate_Node (Cond),
13706 Right_Opnd => Get_Pragma_Arg (Arg1));
13707 Call := Get_Pragma_Arg (Arg2);
13708 else
13709 Call := Get_Pragma_Arg (Arg1);
13710 end if;
13711
13712 if Nkind_In (Call,
13713 N_Indexed_Component,
13714 N_Function_Call,
13715 N_Identifier,
13716 N_Expanded_Name,
13717 N_Selected_Component)
13718 then
13719 -- If this pragma Debug comes from source, its argument was
13720 -- parsed as a name form (which is syntactically identical).
13721 -- In a generic context a parameterless call will be left as
13722 -- an expanded name (if global) or selected_component if local.
13723 -- Change it to a procedure call statement now.
13724
13725 Change_Name_To_Procedure_Call_Statement (Call);
13726
13727 elsif Nkind (Call) = N_Procedure_Call_Statement then
13728
13729 -- Already in the form of a procedure call statement: nothing
13730 -- to do (could happen in case of an internally generated
13731 -- pragma Debug).
13732
13733 null;
13734
13735 else
13736 -- All other cases: diagnose error
13737
13738 Error_Msg
13739 ("argument of pragma ""Debug"" is not procedure call",
13740 Sloc (Call));
13741 return;
13742 end if;
13743
13744 -- Rewrite into a conditional with an appropriate condition. We
13745 -- wrap the procedure call in a block so that overhead from e.g.
13746 -- use of the secondary stack does not generate execution overhead
13747 -- for suppressed conditions.
13748
13749 -- Normally the analysis that follows will freeze the subprogram
13750 -- being called. However, if the call is to a null procedure,
13751 -- we want to freeze it before creating the block, because the
13752 -- analysis that follows may be done with expansion disabled, in
13753 -- which case the body will not be generated, leading to spurious
13754 -- errors.
13755
13756 if Nkind (Call) = N_Procedure_Call_Statement
13757 and then Is_Entity_Name (Name (Call))
13758 then
13759 Analyze (Name (Call));
13760 Freeze_Before (N, Entity (Name (Call)));
13761 end if;
13762
13763 Rewrite (N,
13764 Make_Implicit_If_Statement (N,
13765 Condition => Cond,
13766 Then_Statements => New_List (
13767 Make_Block_Statement (Loc,
13768 Handled_Statement_Sequence =>
13769 Make_Handled_Sequence_Of_Statements (Loc,
13770 Statements => New_List (Relocate_Node (Call)))))));
13771 Analyze (N);
13772
13773 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13774 -- after analysis of the normally rewritten node, to capture all
13775 -- references to entities, which avoids issuing wrong warnings
13776 -- about unused entities.
13777
13778 if GNATprove_Mode then
13779 Rewrite (N, Make_Null_Statement (Loc));
13780 end if;
13781 end Debug;
13782
13783 ------------------
13784 -- Debug_Policy --
13785 ------------------
13786
13787 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13788
13789 when Pragma_Debug_Policy =>
13790 GNAT_Pragma;
13791 Check_Arg_Count (1);
13792 Check_No_Identifiers;
13793 Check_Arg_Is_Identifier (Arg1);
13794
13795 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13796 -- rewrite it that way, and let the rest of the checking come
13797 -- from analyzing the rewritten pragma.
13798
13799 Rewrite (N,
13800 Make_Pragma (Loc,
13801 Chars => Name_Check_Policy,
13802 Pragma_Argument_Associations => New_List (
13803 Make_Pragma_Argument_Association (Loc,
13804 Expression => Make_Identifier (Loc, Name_Debug)),
13805
13806 Make_Pragma_Argument_Association (Loc,
13807 Expression => Get_Pragma_Arg (Arg1)))));
13808 Analyze (N);
13809
13810 -------------------------------
13811 -- Default_Initial_Condition --
13812 -------------------------------
13813
13814 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13815
13816 when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
13817 Discard : Boolean;
13818 Stmt : Node_Id;
13819 Typ : Entity_Id;
13820
13821 begin
13822 GNAT_Pragma;
13823 Check_No_Identifiers;
13824 Check_At_Most_N_Arguments (1);
13825
13826 Stmt := Prev (N);
13827 while Present (Stmt) loop
13828
13829 -- Skip prior pragmas, but check for duplicates
13830
13831 if Nkind (Stmt) = N_Pragma then
13832 if Pragma_Name (Stmt) = Pname then
13833 Error_Msg_Name_1 := Pname;
13834 Error_Msg_Sloc := Sloc (Stmt);
13835 Error_Msg_N ("pragma % duplicates pragma declared#", N);
13836 end if;
13837
13838 -- Skip internally generated code
13839
13840 elsif not Comes_From_Source (Stmt) then
13841 null;
13842
13843 -- The associated private type [extension] has been found, stop
13844 -- the search.
13845
13846 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
13847 N_Private_Type_Declaration)
13848 then
13849 Typ := Defining_Entity (Stmt);
13850 exit;
13851
13852 -- The pragma does not apply to a legal construct, issue an
13853 -- error and stop the analysis.
13854
13855 else
13856 Pragma_Misplaced;
13857 return;
13858 end if;
13859
13860 Stmt := Prev (Stmt);
13861 end loop;
13862
13863 -- A pragma that applies to a Ghost entity becomes Ghost for the
13864 -- purposes of legality checks and removal of ignored Ghost code.
13865
13866 Mark_Pragma_As_Ghost (N, Typ);
13867 Set_Has_Default_Init_Cond (Typ);
13868 Set_Has_Inherited_Default_Init_Cond (Typ, False);
13869
13870 -- Chain the pragma on the rep item chain for further processing
13871
13872 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13873 end Default_Init_Cond;
13874
13875 ----------------------------------
13876 -- Default_Scalar_Storage_Order --
13877 ----------------------------------
13878
13879 -- pragma Default_Scalar_Storage_Order
13880 -- (High_Order_First | Low_Order_First);
13881
13882 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
13883 Default : Character;
13884
13885 begin
13886 GNAT_Pragma;
13887 Check_Arg_Count (1);
13888
13889 -- Default_Scalar_Storage_Order can appear as a configuration
13890 -- pragma, or in a declarative part of a package spec.
13891
13892 if not Is_Configuration_Pragma then
13893 Check_Is_In_Decl_Part_Or_Package_Spec;
13894 end if;
13895
13896 Check_No_Identifiers;
13897 Check_Arg_Is_One_Of
13898 (Arg1, Name_High_Order_First, Name_Low_Order_First);
13899 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13900 Default := Fold_Upper (Name_Buffer (1));
13901
13902 if not Support_Nondefault_SSO_On_Target
13903 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
13904 then
13905 if Warn_On_Unrecognized_Pragma then
13906 Error_Msg_N
13907 ("non-default Scalar_Storage_Order not supported "
13908 & "on target?g?", N);
13909 Error_Msg_N
13910 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
13911 end if;
13912
13913 -- Here set the specified default
13914
13915 else
13916 Opt.Default_SSO := Default;
13917 end if;
13918 end DSSO;
13919
13920 --------------------------
13921 -- Default_Storage_Pool --
13922 --------------------------
13923
13924 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13925
13926 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
13927 Pool : Node_Id;
13928
13929 begin
13930 Ada_2012_Pragma;
13931 Check_Arg_Count (1);
13932
13933 -- Default_Storage_Pool can appear as a configuration pragma, or
13934 -- in a declarative part of a package spec.
13935
13936 if not Is_Configuration_Pragma then
13937 Check_Is_In_Decl_Part_Or_Package_Spec;
13938 end if;
13939
13940 if From_Aspect_Specification (N) then
13941 declare
13942 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
13943 begin
13944 if not In_Open_Scopes (E) then
13945 Error_Msg_N
13946 ("aspect must apply to package or subprogram", N);
13947 end if;
13948 end;
13949 end if;
13950
13951 if Present (Arg1) then
13952 Pool := Get_Pragma_Arg (Arg1);
13953
13954 -- Case of Default_Storage_Pool (null);
13955
13956 if Nkind (Pool) = N_Null then
13957 Analyze (Pool);
13958
13959 -- This is an odd case, this is not really an expression,
13960 -- so we don't have a type for it. So just set the type to
13961 -- Empty.
13962
13963 Set_Etype (Pool, Empty);
13964
13965 -- Case of Default_Storage_Pool (storage_pool_NAME);
13966
13967 else
13968 -- If it's a configuration pragma, then the only allowed
13969 -- argument is "null".
13970
13971 if Is_Configuration_Pragma then
13972 Error_Pragma_Arg ("NULL expected", Arg1);
13973 end if;
13974
13975 -- The expected type for a non-"null" argument is
13976 -- Root_Storage_Pool'Class, and the pool must be a variable.
13977
13978 Analyze_And_Resolve
13979 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13980
13981 if Is_Variable (Pool) then
13982
13983 -- A pragma that applies to a Ghost entity becomes Ghost
13984 -- for the purposes of legality checks and removal of
13985 -- ignored Ghost code.
13986
13987 Mark_Pragma_As_Ghost (N, Entity (Pool));
13988
13989 else
13990 Error_Pragma_Arg
13991 ("default storage pool must be a variable", Arg1);
13992 end if;
13993 end if;
13994
13995 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13996 -- access type will use this information to set the appropriate
13997 -- attributes of the access type.
13998
13999 Default_Pool := Pool;
14000 end if;
14001 end Default_Storage_Pool;
14002
14003 -------------
14004 -- Depends --
14005 -------------
14006
14007 -- pragma Depends (DEPENDENCY_RELATION);
14008
14009 -- DEPENDENCY_RELATION ::=
14010 -- null
14011 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14012
14013 -- DEPENDENCY_CLAUSE ::=
14014 -- OUTPUT_LIST =>[+] INPUT_LIST
14015 -- | NULL_DEPENDENCY_CLAUSE
14016
14017 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14018
14019 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14020
14021 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14022
14023 -- OUTPUT ::= NAME | FUNCTION_RESULT
14024 -- INPUT ::= NAME
14025
14026 -- where FUNCTION_RESULT is a function Result attribute_reference
14027
14028 -- Characteristics:
14029
14030 -- * Analysis - The annotation undergoes initial checks to verify
14031 -- the legal placement and context. Secondary checks fully analyze
14032 -- the dependency clauses in:
14033
14034 -- Analyze_Depends_In_Decl_Part
14035
14036 -- * Expansion - None.
14037
14038 -- * Template - The annotation utilizes the generic template of the
14039 -- related subprogram [body] when it is:
14040
14041 -- aspect on subprogram declaration
14042 -- aspect on stand alone subprogram body
14043 -- pragma on stand alone subprogram body
14044
14045 -- The annotation must prepare its own template when it is:
14046
14047 -- pragma on subprogram declaration
14048
14049 -- * Globals - Capture of global references must occur after full
14050 -- analysis.
14051
14052 -- * Instance - The annotation is instantiated automatically when
14053 -- the related generic subprogram [body] is instantiated except for
14054 -- the "pragma on subprogram declaration" case. In that scenario
14055 -- the annotation must instantiate itself.
14056
14057 when Pragma_Depends => Depends : declare
14058 Legal : Boolean;
14059 Spec_Id : Entity_Id;
14060 Subp_Decl : Node_Id;
14061
14062 begin
14063 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
14064
14065 if Legal then
14066
14067 -- Chain the pragma on the contract for further processing by
14068 -- Analyze_Depends_In_Decl_Part.
14069
14070 Add_Contract_Item (N, Spec_Id);
14071
14072 -- Fully analyze the pragma when it appears inside an entry
14073 -- or subprogram body because it cannot benefit from forward
14074 -- references.
14075
14076 if Nkind_In (Subp_Decl, N_Entry_Body,
14077 N_Subprogram_Body,
14078 N_Subprogram_Body_Stub)
14079 then
14080 -- The legality checks of pragmas Depends and Global are
14081 -- affected by the SPARK mode in effect and the volatility
14082 -- of the context. In addition these two pragmas are subject
14083 -- to an inherent order:
14084
14085 -- 1) Global
14086 -- 2) Depends
14087
14088 -- Analyze all these pragmas in the order outlined above
14089
14090 Analyze_If_Present (Pragma_SPARK_Mode);
14091 Analyze_If_Present (Pragma_Volatile_Function);
14092 Analyze_If_Present (Pragma_Global);
14093 Analyze_Depends_In_Decl_Part (N);
14094 end if;
14095 end if;
14096 end Depends;
14097
14098 ---------------------
14099 -- Detect_Blocking --
14100 ---------------------
14101
14102 -- pragma Detect_Blocking;
14103
14104 when Pragma_Detect_Blocking =>
14105 Ada_2005_Pragma;
14106 Check_Arg_Count (0);
14107 Check_Valid_Configuration_Pragma;
14108 Detect_Blocking := True;
14109
14110 ------------------------------------
14111 -- Disable_Atomic_Synchronization --
14112 ------------------------------------
14113
14114 -- pragma Disable_Atomic_Synchronization [(Entity)];
14115
14116 when Pragma_Disable_Atomic_Synchronization =>
14117 GNAT_Pragma;
14118 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
14119
14120 -------------------
14121 -- Discard_Names --
14122 -------------------
14123
14124 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14125
14126 when Pragma_Discard_Names => Discard_Names : declare
14127 E : Entity_Id;
14128 E_Id : Node_Id;
14129
14130 begin
14131 Check_Ada_83_Warning;
14132
14133 -- Deal with configuration pragma case
14134
14135 if Arg_Count = 0 and then Is_Configuration_Pragma then
14136 Global_Discard_Names := True;
14137 return;
14138
14139 -- Otherwise, check correct appropriate context
14140
14141 else
14142 Check_Is_In_Decl_Part_Or_Package_Spec;
14143
14144 if Arg_Count = 0 then
14145
14146 -- If there is no parameter, then from now on this pragma
14147 -- applies to any enumeration, exception or tagged type
14148 -- defined in the current declarative part, and recursively
14149 -- to any nested scope.
14150
14151 Set_Discard_Names (Current_Scope);
14152 return;
14153
14154 else
14155 Check_Arg_Count (1);
14156 Check_Optional_Identifier (Arg1, Name_On);
14157 Check_Arg_Is_Local_Name (Arg1);
14158
14159 E_Id := Get_Pragma_Arg (Arg1);
14160
14161 if Etype (E_Id) = Any_Type then
14162 return;
14163 else
14164 E := Entity (E_Id);
14165 end if;
14166
14167 -- A pragma that applies to a Ghost entity becomes Ghost for
14168 -- the purposes of legality checks and removal of ignored
14169 -- Ghost code.
14170
14171 Mark_Pragma_As_Ghost (N, E);
14172
14173 if (Is_First_Subtype (E)
14174 and then
14175 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
14176 or else Ekind (E) = E_Exception
14177 then
14178 Set_Discard_Names (E);
14179 Record_Rep_Item (E, N);
14180
14181 else
14182 Error_Pragma_Arg
14183 ("inappropriate entity for pragma%", Arg1);
14184 end if;
14185 end if;
14186 end if;
14187 end Discard_Names;
14188
14189 ------------------------
14190 -- Dispatching_Domain --
14191 ------------------------
14192
14193 -- pragma Dispatching_Domain (EXPRESSION);
14194
14195 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
14196 P : constant Node_Id := Parent (N);
14197 Arg : Node_Id;
14198 Ent : Entity_Id;
14199
14200 begin
14201 Ada_2012_Pragma;
14202 Check_No_Identifiers;
14203 Check_Arg_Count (1);
14204
14205 -- This pragma is born obsolete, but not the aspect
14206
14207 if not From_Aspect_Specification (N) then
14208 Check_Restriction
14209 (No_Obsolescent_Features, Pragma_Identifier (N));
14210 end if;
14211
14212 if Nkind (P) = N_Task_Definition then
14213 Arg := Get_Pragma_Arg (Arg1);
14214 Ent := Defining_Identifier (Parent (P));
14215
14216 -- A pragma that applies to a Ghost entity becomes Ghost for
14217 -- the purposes of legality checks and removal of ignored Ghost
14218 -- code.
14219
14220 Mark_Pragma_As_Ghost (N, Ent);
14221
14222 -- The expression must be analyzed in the special manner
14223 -- described in "Handling of Default and Per-Object
14224 -- Expressions" in sem.ads.
14225
14226 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
14227
14228 -- Check duplicate pragma before we chain the pragma in the Rep
14229 -- Item chain of Ent.
14230
14231 Check_Duplicate_Pragma (Ent);
14232 Record_Rep_Item (Ent, N);
14233
14234 -- Anything else is incorrect
14235
14236 else
14237 Pragma_Misplaced;
14238 end if;
14239 end Dispatching_Domain;
14240
14241 ---------------
14242 -- Elaborate --
14243 ---------------
14244
14245 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14246
14247 when Pragma_Elaborate => Elaborate : declare
14248 Arg : Node_Id;
14249 Citem : Node_Id;
14250
14251 begin
14252 -- Pragma must be in context items list of a compilation unit
14253
14254 if not Is_In_Context_Clause then
14255 Pragma_Misplaced;
14256 end if;
14257
14258 -- Must be at least one argument
14259
14260 if Arg_Count = 0 then
14261 Error_Pragma ("pragma% requires at least one argument");
14262 end if;
14263
14264 -- In Ada 83 mode, there can be no items following it in the
14265 -- context list except other pragmas and implicit with clauses
14266 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14267 -- placement rule does not apply.
14268
14269 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
14270 Citem := Next (N);
14271 while Present (Citem) loop
14272 if Nkind (Citem) = N_Pragma
14273 or else (Nkind (Citem) = N_With_Clause
14274 and then Implicit_With (Citem))
14275 then
14276 null;
14277 else
14278 Error_Pragma
14279 ("(Ada 83) pragma% must be at end of context clause");
14280 end if;
14281
14282 Next (Citem);
14283 end loop;
14284 end if;
14285
14286 -- Finally, the arguments must all be units mentioned in a with
14287 -- clause in the same context clause. Note we already checked (in
14288 -- Par.Prag) that the arguments are all identifiers or selected
14289 -- components.
14290
14291 Arg := Arg1;
14292 Outer : while Present (Arg) loop
14293 Citem := First (List_Containing (N));
14294 Inner : while Citem /= N loop
14295 if Nkind (Citem) = N_With_Clause
14296 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14297 then
14298 Set_Elaborate_Present (Citem, True);
14299 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14300
14301 -- With the pragma present, elaboration calls on
14302 -- subprograms from the named unit need no further
14303 -- checks, as long as the pragma appears in the current
14304 -- compilation unit. If the pragma appears in some unit
14305 -- in the context, there might still be a need for an
14306 -- Elaborate_All_Desirable from the current compilation
14307 -- to the named unit, so we keep the check enabled.
14308
14309 if In_Extended_Main_Source_Unit (N) then
14310
14311 -- This does not apply in SPARK mode, where we allow
14312 -- pragma Elaborate, but we don't trust it to be right
14313 -- so we will still insist on the Elaborate_All.
14314
14315 if SPARK_Mode /= On then
14316 Set_Suppress_Elaboration_Warnings
14317 (Entity (Name (Citem)));
14318 end if;
14319 end if;
14320
14321 exit Inner;
14322 end if;
14323
14324 Next (Citem);
14325 end loop Inner;
14326
14327 if Citem = N then
14328 Error_Pragma_Arg
14329 ("argument of pragma% is not withed unit", Arg);
14330 end if;
14331
14332 Next (Arg);
14333 end loop Outer;
14334
14335 -- Give a warning if operating in static mode with one of the
14336 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14337
14338 if Elab_Warnings
14339 and not Dynamic_Elaboration_Checks
14340
14341 -- pragma Elaborate not allowed in SPARK mode anyway. We
14342 -- already complained about it, no point in generating any
14343 -- further complaint.
14344
14345 and SPARK_Mode /= On
14346 then
14347 Error_Msg_N
14348 ("?l?use of pragma Elaborate may not be safe", N);
14349 Error_Msg_N
14350 ("?l?use pragma Elaborate_All instead if possible", N);
14351 end if;
14352 end Elaborate;
14353
14354 -------------------
14355 -- Elaborate_All --
14356 -------------------
14357
14358 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14359
14360 when Pragma_Elaborate_All => Elaborate_All : declare
14361 Arg : Node_Id;
14362 Citem : Node_Id;
14363
14364 begin
14365 Check_Ada_83_Warning;
14366
14367 -- Pragma must be in context items list of a compilation unit
14368
14369 if not Is_In_Context_Clause then
14370 Pragma_Misplaced;
14371 end if;
14372
14373 -- Must be at least one argument
14374
14375 if Arg_Count = 0 then
14376 Error_Pragma ("pragma% requires at least one argument");
14377 end if;
14378
14379 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14380 -- have to appear at the end of the context clause, but may
14381 -- appear mixed in with other items, even in Ada 83 mode.
14382
14383 -- Final check: the arguments must all be units mentioned in
14384 -- a with clause in the same context clause. Note that we
14385 -- already checked (in Par.Prag) that all the arguments are
14386 -- either identifiers or selected components.
14387
14388 Arg := Arg1;
14389 Outr : while Present (Arg) loop
14390 Citem := First (List_Containing (N));
14391 Innr : while Citem /= N loop
14392 if Nkind (Citem) = N_With_Clause
14393 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14394 then
14395 Set_Elaborate_All_Present (Citem, True);
14396 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14397
14398 -- Suppress warnings and elaboration checks on the named
14399 -- unit if the pragma is in the current compilation, as
14400 -- for pragma Elaborate.
14401
14402 if In_Extended_Main_Source_Unit (N) then
14403 Set_Suppress_Elaboration_Warnings
14404 (Entity (Name (Citem)));
14405 end if;
14406 exit Innr;
14407 end if;
14408
14409 Next (Citem);
14410 end loop Innr;
14411
14412 if Citem = N then
14413 Set_Error_Posted (N);
14414 Error_Pragma_Arg
14415 ("argument of pragma% is not withed unit", Arg);
14416 end if;
14417
14418 Next (Arg);
14419 end loop Outr;
14420 end Elaborate_All;
14421
14422 --------------------
14423 -- Elaborate_Body --
14424 --------------------
14425
14426 -- pragma Elaborate_Body [( library_unit_NAME )];
14427
14428 when Pragma_Elaborate_Body => Elaborate_Body : declare
14429 Cunit_Node : Node_Id;
14430 Cunit_Ent : Entity_Id;
14431
14432 begin
14433 Check_Ada_83_Warning;
14434 Check_Valid_Library_Unit_Pragma;
14435
14436 if Nkind (N) = N_Null_Statement then
14437 return;
14438 end if;
14439
14440 Cunit_Node := Cunit (Current_Sem_Unit);
14441 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
14442
14443 -- A pragma that applies to a Ghost entity becomes Ghost for the
14444 -- purposes of legality checks and removal of ignored Ghost code.
14445
14446 Mark_Pragma_As_Ghost (N, Cunit_Ent);
14447
14448 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14449 N_Subprogram_Body)
14450 then
14451 Error_Pragma ("pragma% must refer to a spec, not a body");
14452 else
14453 Set_Body_Required (Cunit_Node, True);
14454 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14455
14456 -- If we are in dynamic elaboration mode, then we suppress
14457 -- elaboration warnings for the unit, since it is definitely
14458 -- fine NOT to do dynamic checks at the first level (and such
14459 -- checks will be suppressed because no elaboration boolean
14460 -- is created for Elaborate_Body packages).
14461
14462 -- But in the static model of elaboration, Elaborate_Body is
14463 -- definitely NOT good enough to ensure elaboration safety on
14464 -- its own, since the body may WITH other units that are not
14465 -- safe from an elaboration point of view, so a client must
14466 -- still do an Elaborate_All on such units.
14467
14468 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14469 -- Elaborate_Body always suppressed elab warnings.
14470
14471 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14472 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14473 end if;
14474 end if;
14475 end Elaborate_Body;
14476
14477 ------------------------
14478 -- Elaboration_Checks --
14479 ------------------------
14480
14481 -- pragma Elaboration_Checks (Static | Dynamic);
14482
14483 when Pragma_Elaboration_Checks =>
14484 GNAT_Pragma;
14485 Check_Arg_Count (1);
14486 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14487
14488 -- Set flag accordingly (ignore attempt at dynamic elaboration
14489 -- checks in SPARK mode).
14490
14491 Dynamic_Elaboration_Checks :=
14492 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
14493
14494 ---------------
14495 -- Eliminate --
14496 ---------------
14497
14498 -- pragma Eliminate (
14499 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14500 -- [,[Entity =>] IDENTIFIER |
14501 -- SELECTED_COMPONENT |
14502 -- STRING_LITERAL]
14503 -- [, OVERLOADING_RESOLUTION]);
14504
14505 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14506 -- SOURCE_LOCATION
14507
14508 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14509 -- FUNCTION_PROFILE
14510
14511 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14512
14513 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14514 -- Result_Type => result_SUBTYPE_NAME]
14515
14516 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14517 -- SUBTYPE_NAME ::= STRING_LITERAL
14518
14519 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14520 -- SOURCE_TRACE ::= STRING_LITERAL
14521
14522 when Pragma_Eliminate => Eliminate : declare
14523 Args : Args_List (1 .. 5);
14524 Names : constant Name_List (1 .. 5) := (
14525 Name_Unit_Name,
14526 Name_Entity,
14527 Name_Parameter_Types,
14528 Name_Result_Type,
14529 Name_Source_Location);
14530
14531 Unit_Name : Node_Id renames Args (1);
14532 Entity : Node_Id renames Args (2);
14533 Parameter_Types : Node_Id renames Args (3);
14534 Result_Type : Node_Id renames Args (4);
14535 Source_Location : Node_Id renames Args (5);
14536
14537 begin
14538 GNAT_Pragma;
14539 Check_Valid_Configuration_Pragma;
14540 Gather_Associations (Names, Args);
14541
14542 if No (Unit_Name) then
14543 Error_Pragma ("missing Unit_Name argument for pragma%");
14544 end if;
14545
14546 if No (Entity)
14547 and then (Present (Parameter_Types)
14548 or else
14549 Present (Result_Type)
14550 or else
14551 Present (Source_Location))
14552 then
14553 Error_Pragma ("missing Entity argument for pragma%");
14554 end if;
14555
14556 if (Present (Parameter_Types)
14557 or else
14558 Present (Result_Type))
14559 and then
14560 Present (Source_Location)
14561 then
14562 Error_Pragma
14563 ("parameter profile and source location cannot be used "
14564 & "together in pragma%");
14565 end if;
14566
14567 Process_Eliminate_Pragma
14568 (N,
14569 Unit_Name,
14570 Entity,
14571 Parameter_Types,
14572 Result_Type,
14573 Source_Location);
14574 end Eliminate;
14575
14576 -----------------------------------
14577 -- Enable_Atomic_Synchronization --
14578 -----------------------------------
14579
14580 -- pragma Enable_Atomic_Synchronization [(Entity)];
14581
14582 when Pragma_Enable_Atomic_Synchronization =>
14583 GNAT_Pragma;
14584 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14585
14586 ------------
14587 -- Export --
14588 ------------
14589
14590 -- pragma Export (
14591 -- [ Convention =>] convention_IDENTIFIER,
14592 -- [ Entity =>] LOCAL_NAME
14593 -- [, [External_Name =>] static_string_EXPRESSION ]
14594 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14595
14596 when Pragma_Export => Export : declare
14597 C : Convention_Id;
14598 Def_Id : Entity_Id;
14599
14600 pragma Warnings (Off, C);
14601
14602 begin
14603 Check_Ada_83_Warning;
14604 Check_Arg_Order
14605 ((Name_Convention,
14606 Name_Entity,
14607 Name_External_Name,
14608 Name_Link_Name));
14609
14610 Check_At_Least_N_Arguments (2);
14611 Check_At_Most_N_Arguments (4);
14612
14613 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14614 -- pragma Export (Entity, "external name");
14615
14616 if Relaxed_RM_Semantics
14617 and then Arg_Count = 2
14618 and then Nkind (Expression (Arg2)) = N_String_Literal
14619 then
14620 C := Convention_C;
14621 Def_Id := Get_Pragma_Arg (Arg1);
14622 Analyze (Def_Id);
14623
14624 if not Is_Entity_Name (Def_Id) then
14625 Error_Pragma_Arg ("entity name required", Arg1);
14626 end if;
14627
14628 Def_Id := Entity (Def_Id);
14629 Set_Exported (Def_Id, Arg1);
14630
14631 else
14632 Process_Convention (C, Def_Id);
14633
14634 -- A pragma that applies to a Ghost entity becomes Ghost for
14635 -- the purposes of legality checks and removal of ignored Ghost
14636 -- code.
14637
14638 Mark_Pragma_As_Ghost (N, Def_Id);
14639
14640 if Ekind (Def_Id) /= E_Constant then
14641 Note_Possible_Modification
14642 (Get_Pragma_Arg (Arg2), Sure => False);
14643 end if;
14644
14645 Process_Interface_Name (Def_Id, Arg3, Arg4);
14646 Set_Exported (Def_Id, Arg2);
14647 end if;
14648
14649 -- If the entity is a deferred constant, propagate the information
14650 -- to the full view, because gigi elaborates the full view only.
14651
14652 if Ekind (Def_Id) = E_Constant
14653 and then Present (Full_View (Def_Id))
14654 then
14655 declare
14656 Id2 : constant Entity_Id := Full_View (Def_Id);
14657 begin
14658 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14659 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14660 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14661 end;
14662 end if;
14663 end Export;
14664
14665 ---------------------
14666 -- Export_Function --
14667 ---------------------
14668
14669 -- pragma Export_Function (
14670 -- [Internal =>] LOCAL_NAME
14671 -- [, [External =>] EXTERNAL_SYMBOL]
14672 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14673 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14674 -- [, [Mechanism =>] MECHANISM]
14675 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14676
14677 -- EXTERNAL_SYMBOL ::=
14678 -- IDENTIFIER
14679 -- | static_string_EXPRESSION
14680
14681 -- PARAMETER_TYPES ::=
14682 -- null
14683 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14684
14685 -- TYPE_DESIGNATOR ::=
14686 -- subtype_NAME
14687 -- | subtype_Name ' Access
14688
14689 -- MECHANISM ::=
14690 -- MECHANISM_NAME
14691 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14692
14693 -- MECHANISM_ASSOCIATION ::=
14694 -- [formal_parameter_NAME =>] MECHANISM_NAME
14695
14696 -- MECHANISM_NAME ::=
14697 -- Value
14698 -- | Reference
14699
14700 when Pragma_Export_Function => Export_Function : declare
14701 Args : Args_List (1 .. 6);
14702 Names : constant Name_List (1 .. 6) := (
14703 Name_Internal,
14704 Name_External,
14705 Name_Parameter_Types,
14706 Name_Result_Type,
14707 Name_Mechanism,
14708 Name_Result_Mechanism);
14709
14710 Internal : Node_Id renames Args (1);
14711 External : Node_Id renames Args (2);
14712 Parameter_Types : Node_Id renames Args (3);
14713 Result_Type : Node_Id renames Args (4);
14714 Mechanism : Node_Id renames Args (5);
14715 Result_Mechanism : Node_Id renames Args (6);
14716
14717 begin
14718 GNAT_Pragma;
14719 Gather_Associations (Names, Args);
14720 Process_Extended_Import_Export_Subprogram_Pragma (
14721 Arg_Internal => Internal,
14722 Arg_External => External,
14723 Arg_Parameter_Types => Parameter_Types,
14724 Arg_Result_Type => Result_Type,
14725 Arg_Mechanism => Mechanism,
14726 Arg_Result_Mechanism => Result_Mechanism);
14727 end Export_Function;
14728
14729 -------------------
14730 -- Export_Object --
14731 -------------------
14732
14733 -- pragma Export_Object (
14734 -- [Internal =>] LOCAL_NAME
14735 -- [, [External =>] EXTERNAL_SYMBOL]
14736 -- [, [Size =>] EXTERNAL_SYMBOL]);
14737
14738 -- EXTERNAL_SYMBOL ::=
14739 -- IDENTIFIER
14740 -- | static_string_EXPRESSION
14741
14742 -- PARAMETER_TYPES ::=
14743 -- null
14744 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14745
14746 -- TYPE_DESIGNATOR ::=
14747 -- subtype_NAME
14748 -- | subtype_Name ' Access
14749
14750 -- MECHANISM ::=
14751 -- MECHANISM_NAME
14752 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14753
14754 -- MECHANISM_ASSOCIATION ::=
14755 -- [formal_parameter_NAME =>] MECHANISM_NAME
14756
14757 -- MECHANISM_NAME ::=
14758 -- Value
14759 -- | Reference
14760
14761 when Pragma_Export_Object => Export_Object : declare
14762 Args : Args_List (1 .. 3);
14763 Names : constant Name_List (1 .. 3) := (
14764 Name_Internal,
14765 Name_External,
14766 Name_Size);
14767
14768 Internal : Node_Id renames Args (1);
14769 External : Node_Id renames Args (2);
14770 Size : Node_Id renames Args (3);
14771
14772 begin
14773 GNAT_Pragma;
14774 Gather_Associations (Names, Args);
14775 Process_Extended_Import_Export_Object_Pragma (
14776 Arg_Internal => Internal,
14777 Arg_External => External,
14778 Arg_Size => Size);
14779 end Export_Object;
14780
14781 ----------------------
14782 -- Export_Procedure --
14783 ----------------------
14784
14785 -- pragma Export_Procedure (
14786 -- [Internal =>] LOCAL_NAME
14787 -- [, [External =>] EXTERNAL_SYMBOL]
14788 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14789 -- [, [Mechanism =>] MECHANISM]);
14790
14791 -- EXTERNAL_SYMBOL ::=
14792 -- IDENTIFIER
14793 -- | static_string_EXPRESSION
14794
14795 -- PARAMETER_TYPES ::=
14796 -- null
14797 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14798
14799 -- TYPE_DESIGNATOR ::=
14800 -- subtype_NAME
14801 -- | subtype_Name ' Access
14802
14803 -- MECHANISM ::=
14804 -- MECHANISM_NAME
14805 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14806
14807 -- MECHANISM_ASSOCIATION ::=
14808 -- [formal_parameter_NAME =>] MECHANISM_NAME
14809
14810 -- MECHANISM_NAME ::=
14811 -- Value
14812 -- | Reference
14813
14814 when Pragma_Export_Procedure => Export_Procedure : declare
14815 Args : Args_List (1 .. 4);
14816 Names : constant Name_List (1 .. 4) := (
14817 Name_Internal,
14818 Name_External,
14819 Name_Parameter_Types,
14820 Name_Mechanism);
14821
14822 Internal : Node_Id renames Args (1);
14823 External : Node_Id renames Args (2);
14824 Parameter_Types : Node_Id renames Args (3);
14825 Mechanism : Node_Id renames Args (4);
14826
14827 begin
14828 GNAT_Pragma;
14829 Gather_Associations (Names, Args);
14830 Process_Extended_Import_Export_Subprogram_Pragma (
14831 Arg_Internal => Internal,
14832 Arg_External => External,
14833 Arg_Parameter_Types => Parameter_Types,
14834 Arg_Mechanism => Mechanism);
14835 end Export_Procedure;
14836
14837 ------------------
14838 -- Export_Value --
14839 ------------------
14840
14841 -- pragma Export_Value (
14842 -- [Value =>] static_integer_EXPRESSION,
14843 -- [Link_Name =>] static_string_EXPRESSION);
14844
14845 when Pragma_Export_Value =>
14846 GNAT_Pragma;
14847 Check_Arg_Order ((Name_Value, Name_Link_Name));
14848 Check_Arg_Count (2);
14849
14850 Check_Optional_Identifier (Arg1, Name_Value);
14851 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
14852
14853 Check_Optional_Identifier (Arg2, Name_Link_Name);
14854 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
14855
14856 -----------------------------
14857 -- Export_Valued_Procedure --
14858 -----------------------------
14859
14860 -- pragma Export_Valued_Procedure (
14861 -- [Internal =>] LOCAL_NAME
14862 -- [, [External =>] EXTERNAL_SYMBOL,]
14863 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14864 -- [, [Mechanism =>] MECHANISM]);
14865
14866 -- EXTERNAL_SYMBOL ::=
14867 -- IDENTIFIER
14868 -- | static_string_EXPRESSION
14869
14870 -- PARAMETER_TYPES ::=
14871 -- null
14872 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14873
14874 -- TYPE_DESIGNATOR ::=
14875 -- subtype_NAME
14876 -- | subtype_Name ' Access
14877
14878 -- MECHANISM ::=
14879 -- MECHANISM_NAME
14880 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14881
14882 -- MECHANISM_ASSOCIATION ::=
14883 -- [formal_parameter_NAME =>] MECHANISM_NAME
14884
14885 -- MECHANISM_NAME ::=
14886 -- Value
14887 -- | Reference
14888
14889 when Pragma_Export_Valued_Procedure =>
14890 Export_Valued_Procedure : declare
14891 Args : Args_List (1 .. 4);
14892 Names : constant Name_List (1 .. 4) := (
14893 Name_Internal,
14894 Name_External,
14895 Name_Parameter_Types,
14896 Name_Mechanism);
14897
14898 Internal : Node_Id renames Args (1);
14899 External : Node_Id renames Args (2);
14900 Parameter_Types : Node_Id renames Args (3);
14901 Mechanism : Node_Id renames Args (4);
14902
14903 begin
14904 GNAT_Pragma;
14905 Gather_Associations (Names, Args);
14906 Process_Extended_Import_Export_Subprogram_Pragma (
14907 Arg_Internal => Internal,
14908 Arg_External => External,
14909 Arg_Parameter_Types => Parameter_Types,
14910 Arg_Mechanism => Mechanism);
14911 end Export_Valued_Procedure;
14912
14913 -------------------
14914 -- Extend_System --
14915 -------------------
14916
14917 -- pragma Extend_System ([Name =>] Identifier);
14918
14919 when Pragma_Extend_System => Extend_System : declare
14920 begin
14921 GNAT_Pragma;
14922 Check_Valid_Configuration_Pragma;
14923 Check_Arg_Count (1);
14924 Check_Optional_Identifier (Arg1, Name_Name);
14925 Check_Arg_Is_Identifier (Arg1);
14926
14927 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14928
14929 if Name_Len > 4
14930 and then Name_Buffer (1 .. 4) = "aux_"
14931 then
14932 if Present (System_Extend_Pragma_Arg) then
14933 if Chars (Get_Pragma_Arg (Arg1)) =
14934 Chars (Expression (System_Extend_Pragma_Arg))
14935 then
14936 null;
14937 else
14938 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
14939 Error_Pragma ("pragma% conflicts with that #");
14940 end if;
14941
14942 else
14943 System_Extend_Pragma_Arg := Arg1;
14944
14945 if not GNAT_Mode then
14946 System_Extend_Unit := Arg1;
14947 end if;
14948 end if;
14949 else
14950 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14951 end if;
14952 end Extend_System;
14953
14954 ------------------------
14955 -- Extensions_Allowed --
14956 ------------------------
14957
14958 -- pragma Extensions_Allowed (ON | OFF);
14959
14960 when Pragma_Extensions_Allowed =>
14961 GNAT_Pragma;
14962 Check_Arg_Count (1);
14963 Check_No_Identifiers;
14964 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14965
14966 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14967 Extensions_Allowed := True;
14968 Ada_Version := Ada_Version_Type'Last;
14969
14970 else
14971 Extensions_Allowed := False;
14972 Ada_Version := Ada_Version_Explicit;
14973 Ada_Version_Pragma := Empty;
14974 end if;
14975
14976 ------------------------
14977 -- Extensions_Visible --
14978 ------------------------
14979
14980 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14981
14982 -- Characteristics:
14983
14984 -- * Analysis - The annotation is fully analyzed immediately upon
14985 -- elaboration as its expression must be static.
14986
14987 -- * Expansion - None.
14988
14989 -- * Template - The annotation utilizes the generic template of the
14990 -- related subprogram [body] when it is:
14991
14992 -- aspect on subprogram declaration
14993 -- aspect on stand alone subprogram body
14994 -- pragma on stand alone subprogram body
14995
14996 -- The annotation must prepare its own template when it is:
14997
14998 -- pragma on subprogram declaration
14999
15000 -- * Globals - Capture of global references must occur after full
15001 -- analysis.
15002
15003 -- * Instance - The annotation is instantiated automatically when
15004 -- the related generic subprogram [body] is instantiated except for
15005 -- the "pragma on subprogram declaration" case. In that scenario
15006 -- the annotation must instantiate itself.
15007
15008 when Pragma_Extensions_Visible => Extensions_Visible : declare
15009 Formal : Entity_Id;
15010 Has_OK_Formal : Boolean := False;
15011 Spec_Id : Entity_Id;
15012 Subp_Decl : Node_Id;
15013
15014 begin
15015 GNAT_Pragma;
15016 Check_No_Identifiers;
15017 Check_At_Most_N_Arguments (1);
15018
15019 Subp_Decl :=
15020 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
15021
15022 -- Abstract subprogram declaration
15023
15024 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
15025 null;
15026
15027 -- Generic subprogram declaration
15028
15029 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
15030 null;
15031
15032 -- Body acts as spec
15033
15034 elsif Nkind (Subp_Decl) = N_Subprogram_Body
15035 and then No (Corresponding_Spec (Subp_Decl))
15036 then
15037 null;
15038
15039 -- Body stub acts as spec
15040
15041 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
15042 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
15043 then
15044 null;
15045
15046 -- Subprogram declaration
15047
15048 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
15049 null;
15050
15051 -- Otherwise the pragma is associated with an illegal construct
15052
15053 else
15054 Error_Pragma ("pragma % must apply to a subprogram");
15055 return;
15056 end if;
15057
15058 -- Chain the pragma on the contract for completeness
15059
15060 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
15061
15062 -- The legality checks of pragma Extension_Visible are affected
15063 -- by the SPARK mode in effect. Analyze all pragmas in specific
15064 -- order.
15065
15066 Analyze_If_Present (Pragma_SPARK_Mode);
15067
15068 -- Mark the pragma as Ghost if the related subprogram is also
15069 -- Ghost. This also ensures that any expansion performed further
15070 -- below will produce Ghost nodes.
15071
15072 Spec_Id := Unique_Defining_Entity (Subp_Decl);
15073 Mark_Pragma_As_Ghost (N, Spec_Id);
15074
15075 -- Examine the formals of the related subprogram
15076
15077 Formal := First_Formal (Spec_Id);
15078 while Present (Formal) loop
15079
15080 -- At least one of the formals is of a specific tagged type,
15081 -- the pragma is legal.
15082
15083 if Is_Specific_Tagged_Type (Etype (Formal)) then
15084 Has_OK_Formal := True;
15085 exit;
15086
15087 -- A generic subprogram with at least one formal of a private
15088 -- type ensures the legality of the pragma because the actual
15089 -- may be specifically tagged. Note that this is verified by
15090 -- the check above at instantiation time.
15091
15092 elsif Is_Private_Type (Etype (Formal))
15093 and then Is_Generic_Type (Etype (Formal))
15094 then
15095 Has_OK_Formal := True;
15096 exit;
15097 end if;
15098
15099 Next_Formal (Formal);
15100 end loop;
15101
15102 if not Has_OK_Formal then
15103 Error_Msg_Name_1 := Pname;
15104 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
15105 Error_Msg_NE
15106 ("\subprogram & lacks parameter of specific tagged or "
15107 & "generic private type", N, Spec_Id);
15108
15109 return;
15110 end if;
15111
15112 -- Analyze the Boolean expression (if any)
15113
15114 if Present (Arg1) then
15115 Check_Static_Boolean_Expression
15116 (Expression (Get_Argument (N, Spec_Id)));
15117 end if;
15118 end Extensions_Visible;
15119
15120 --------------
15121 -- External --
15122 --------------
15123
15124 -- pragma External (
15125 -- [ Convention =>] convention_IDENTIFIER,
15126 -- [ Entity =>] LOCAL_NAME
15127 -- [, [External_Name =>] static_string_EXPRESSION ]
15128 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15129
15130 when Pragma_External => External : declare
15131 C : Convention_Id;
15132 E : Entity_Id;
15133 pragma Warnings (Off, C);
15134
15135 begin
15136 GNAT_Pragma;
15137 Check_Arg_Order
15138 ((Name_Convention,
15139 Name_Entity,
15140 Name_External_Name,
15141 Name_Link_Name));
15142 Check_At_Least_N_Arguments (2);
15143 Check_At_Most_N_Arguments (4);
15144 Process_Convention (C, E);
15145
15146 -- A pragma that applies to a Ghost entity becomes Ghost for the
15147 -- purposes of legality checks and removal of ignored Ghost code.
15148
15149 Mark_Pragma_As_Ghost (N, E);
15150
15151 Note_Possible_Modification
15152 (Get_Pragma_Arg (Arg2), Sure => False);
15153 Process_Interface_Name (E, Arg3, Arg4);
15154 Set_Exported (E, Arg2);
15155 end External;
15156
15157 --------------------------
15158 -- External_Name_Casing --
15159 --------------------------
15160
15161 -- pragma External_Name_Casing (
15162 -- UPPERCASE | LOWERCASE
15163 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15164
15165 when Pragma_External_Name_Casing => External_Name_Casing : declare
15166 begin
15167 GNAT_Pragma;
15168 Check_No_Identifiers;
15169
15170 if Arg_Count = 2 then
15171 Check_Arg_Is_One_Of
15172 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
15173
15174 case Chars (Get_Pragma_Arg (Arg2)) is
15175 when Name_As_Is =>
15176 Opt.External_Name_Exp_Casing := As_Is;
15177
15178 when Name_Uppercase =>
15179 Opt.External_Name_Exp_Casing := Uppercase;
15180
15181 when Name_Lowercase =>
15182 Opt.External_Name_Exp_Casing := Lowercase;
15183
15184 when others =>
15185 null;
15186 end case;
15187
15188 else
15189 Check_Arg_Count (1);
15190 end if;
15191
15192 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
15193
15194 case Chars (Get_Pragma_Arg (Arg1)) is
15195 when Name_Uppercase =>
15196 Opt.External_Name_Imp_Casing := Uppercase;
15197
15198 when Name_Lowercase =>
15199 Opt.External_Name_Imp_Casing := Lowercase;
15200
15201 when others =>
15202 null;
15203 end case;
15204 end External_Name_Casing;
15205
15206 ---------------
15207 -- Fast_Math --
15208 ---------------
15209
15210 -- pragma Fast_Math;
15211
15212 when Pragma_Fast_Math =>
15213 GNAT_Pragma;
15214 Check_No_Identifiers;
15215 Check_Valid_Configuration_Pragma;
15216 Fast_Math := True;
15217
15218 --------------------------
15219 -- Favor_Top_Level --
15220 --------------------------
15221
15222 -- pragma Favor_Top_Level (type_NAME);
15223
15224 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
15225 Typ : Entity_Id;
15226
15227 begin
15228 GNAT_Pragma;
15229 Check_No_Identifiers;
15230 Check_Arg_Count (1);
15231 Check_Arg_Is_Local_Name (Arg1);
15232 Typ := Entity (Get_Pragma_Arg (Arg1));
15233
15234 -- A pragma that applies to a Ghost entity becomes Ghost for the
15235 -- purposes of legality checks and removal of ignored Ghost code.
15236
15237 Mark_Pragma_As_Ghost (N, Typ);
15238
15239 -- If it's an access-to-subprogram type (in particular, not a
15240 -- subtype), set the flag on that type.
15241
15242 if Is_Access_Subprogram_Type (Typ) then
15243 Set_Can_Use_Internal_Rep (Typ, False);
15244
15245 -- Otherwise it's an error (name denotes the wrong sort of entity)
15246
15247 else
15248 Error_Pragma_Arg
15249 ("access-to-subprogram type expected",
15250 Get_Pragma_Arg (Arg1));
15251 end if;
15252 end Favor_Top_Level;
15253
15254 ---------------------------
15255 -- Finalize_Storage_Only --
15256 ---------------------------
15257
15258 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15259
15260 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
15261 Assoc : constant Node_Id := Arg1;
15262 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
15263 Typ : Entity_Id;
15264
15265 begin
15266 GNAT_Pragma;
15267 Check_No_Identifiers;
15268 Check_Arg_Count (1);
15269 Check_Arg_Is_Local_Name (Arg1);
15270
15271 Find_Type (Type_Id);
15272 Typ := Entity (Type_Id);
15273
15274 if Typ = Any_Type
15275 or else Rep_Item_Too_Early (Typ, N)
15276 then
15277 return;
15278 else
15279 Typ := Underlying_Type (Typ);
15280 end if;
15281
15282 if not Is_Controlled (Typ) then
15283 Error_Pragma ("pragma% must specify controlled type");
15284 end if;
15285
15286 Check_First_Subtype (Arg1);
15287
15288 if Finalize_Storage_Only (Typ) then
15289 Error_Pragma ("duplicate pragma%, only one allowed");
15290
15291 elsif not Rep_Item_Too_Late (Typ, N) then
15292 Set_Finalize_Storage_Only (Base_Type (Typ), True);
15293 end if;
15294 end Finalize_Storage;
15295
15296 -----------
15297 -- Ghost --
15298 -----------
15299
15300 -- pragma Ghost [ (boolean_EXPRESSION) ];
15301
15302 when Pragma_Ghost => Ghost : declare
15303 Context : Node_Id;
15304 Expr : Node_Id;
15305 Id : Entity_Id;
15306 Orig_Stmt : Node_Id;
15307 Prev_Id : Entity_Id;
15308 Stmt : Node_Id;
15309
15310 begin
15311 GNAT_Pragma;
15312 Check_No_Identifiers;
15313 Check_At_Most_N_Arguments (1);
15314
15315 Id := Empty;
15316 Stmt := Prev (N);
15317 while Present (Stmt) loop
15318
15319 -- Skip prior pragmas, but check for duplicates
15320
15321 if Nkind (Stmt) = N_Pragma then
15322 if Pragma_Name (Stmt) = Pname then
15323 Error_Msg_Name_1 := Pname;
15324 Error_Msg_Sloc := Sloc (Stmt);
15325 Error_Msg_N ("pragma % duplicates pragma declared#", N);
15326 end if;
15327
15328 -- Task unit declared without a definition cannot be subject to
15329 -- pragma Ghost (SPARK RM 6.9(19)).
15330
15331 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15332 N_Task_Type_Declaration)
15333 then
15334 Error_Pragma ("pragma % cannot apply to a task type");
15335 return;
15336
15337 -- Skip internally generated code
15338
15339 elsif not Comes_From_Source (Stmt) then
15340 Orig_Stmt := Original_Node (Stmt);
15341
15342 -- When pragma Ghost applies to an untagged derivation, the
15343 -- derivation is transformed into a [sub]type declaration.
15344
15345 if Nkind_In (Stmt, N_Full_Type_Declaration,
15346 N_Subtype_Declaration)
15347 and then Comes_From_Source (Orig_Stmt)
15348 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15349 and then Nkind (Type_Definition (Orig_Stmt)) =
15350 N_Derived_Type_Definition
15351 then
15352 Id := Defining_Entity (Stmt);
15353 exit;
15354
15355 -- When pragma Ghost applies to an object declaration which
15356 -- is initialized by means of a function call that returns
15357 -- on the secondary stack, the object declaration becomes a
15358 -- renaming.
15359
15360 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15361 and then Comes_From_Source (Orig_Stmt)
15362 and then Nkind (Orig_Stmt) = N_Object_Declaration
15363 then
15364 Id := Defining_Entity (Stmt);
15365 exit;
15366
15367 -- When pragma Ghost applies to an expression function, the
15368 -- expression function is transformed into a subprogram.
15369
15370 elsif Nkind (Stmt) = N_Subprogram_Declaration
15371 and then Comes_From_Source (Orig_Stmt)
15372 and then Nkind (Orig_Stmt) = N_Expression_Function
15373 then
15374 Id := Defining_Entity (Stmt);
15375 exit;
15376 end if;
15377
15378 -- The pragma applies to a legal construct, stop the traversal
15379
15380 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15381 N_Full_Type_Declaration,
15382 N_Generic_Subprogram_Declaration,
15383 N_Object_Declaration,
15384 N_Private_Extension_Declaration,
15385 N_Private_Type_Declaration,
15386 N_Subprogram_Declaration,
15387 N_Subtype_Declaration)
15388 then
15389 Id := Defining_Entity (Stmt);
15390 exit;
15391
15392 -- The pragma does not apply to a legal construct, issue an
15393 -- error and stop the analysis.
15394
15395 else
15396 Error_Pragma
15397 ("pragma % must apply to an object, package, subprogram "
15398 & "or type");
15399 return;
15400 end if;
15401
15402 Stmt := Prev (Stmt);
15403 end loop;
15404
15405 Context := Parent (N);
15406
15407 -- Handle compilation units
15408
15409 if Nkind (Context) = N_Compilation_Unit_Aux then
15410 Context := Unit (Parent (Context));
15411 end if;
15412
15413 -- Protected and task types cannot be subject to pragma Ghost
15414 -- (SPARK RM 6.9(19)).
15415
15416 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15417 then
15418 Error_Pragma ("pragma % cannot apply to a protected type");
15419 return;
15420
15421 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15422 Error_Pragma ("pragma % cannot apply to a task type");
15423 return;
15424 end if;
15425
15426 if No (Id) then
15427
15428 -- When pragma Ghost is associated with a [generic] package, it
15429 -- appears in the visible declarations.
15430
15431 if Nkind (Context) = N_Package_Specification
15432 and then Present (Visible_Declarations (Context))
15433 and then List_Containing (N) = Visible_Declarations (Context)
15434 then
15435 Id := Defining_Entity (Context);
15436
15437 -- Pragma Ghost applies to a stand alone subprogram body
15438
15439 elsif Nkind (Context) = N_Subprogram_Body
15440 and then No (Corresponding_Spec (Context))
15441 then
15442 Id := Defining_Entity (Context);
15443
15444 -- Pragma Ghost applies to a subprogram declaration that acts
15445 -- as a compilation unit.
15446
15447 elsif Nkind (Context) = N_Subprogram_Declaration then
15448 Id := Defining_Entity (Context);
15449 end if;
15450 end if;
15451
15452 if No (Id) then
15453 Error_Pragma
15454 ("pragma % must apply to an object, package, subprogram or "
15455 & "type");
15456 return;
15457 end if;
15458
15459 -- Handle completions of types and constants that are subject to
15460 -- pragma Ghost.
15461
15462 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15463 Prev_Id := Incomplete_Or_Partial_View (Id);
15464
15465 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15466 Error_Msg_Name_1 := Pname;
15467
15468 -- The full declaration of a deferred constant cannot be
15469 -- subject to pragma Ghost unless the deferred declaration
15470 -- is also Ghost (SPARK RM 6.9(9)).
15471
15472 if Ekind (Prev_Id) = E_Constant then
15473 Error_Msg_Name_1 := Pname;
15474 Error_Msg_NE (Fix_Error
15475 ("pragma % must apply to declaration of deferred "
15476 & "constant &"), N, Id);
15477 return;
15478
15479 -- Pragma Ghost may appear on the full view of an incomplete
15480 -- type because the incomplete declaration lacks aspects and
15481 -- cannot be subject to pragma Ghost.
15482
15483 elsif Ekind (Prev_Id) = E_Incomplete_Type then
15484 null;
15485
15486 -- The full declaration of a type cannot be subject to
15487 -- pragma Ghost unless the partial view is also Ghost
15488 -- (SPARK RM 6.9(9)).
15489
15490 else
15491 Error_Msg_NE (Fix_Error
15492 ("pragma % must apply to partial view of type &"),
15493 N, Id);
15494 return;
15495 end if;
15496 end if;
15497
15498 -- A synchronized object cannot be subject to pragma Ghost
15499 -- (SPARK RM 6.9(19)).
15500
15501 elsif Ekind (Id) = E_Variable then
15502 if Is_Protected_Type (Etype (Id)) then
15503 Error_Pragma ("pragma % cannot apply to a protected object");
15504 return;
15505
15506 elsif Is_Task_Type (Etype (Id)) then
15507 Error_Pragma ("pragma % cannot apply to a task object");
15508 return;
15509 end if;
15510 end if;
15511
15512 -- Analyze the Boolean expression (if any)
15513
15514 if Present (Arg1) then
15515 Expr := Get_Pragma_Arg (Arg1);
15516
15517 Analyze_And_Resolve (Expr, Standard_Boolean);
15518
15519 if Is_OK_Static_Expression (Expr) then
15520
15521 -- "Ghostness" cannot be turned off once enabled within a
15522 -- region (SPARK RM 6.9(6)).
15523
15524 if Is_False (Expr_Value (Expr))
15525 and then Ghost_Mode > None
15526 then
15527 Error_Pragma
15528 ("pragma % with value False cannot appear in enabled "
15529 & "ghost region");
15530 return;
15531 end if;
15532
15533 -- Otherwie the expression is not static
15534
15535 else
15536 Error_Pragma_Arg
15537 ("expression of pragma % must be static", Expr);
15538 return;
15539 end if;
15540 end if;
15541
15542 Set_Is_Ghost_Entity (Id);
15543 end Ghost;
15544
15545 ------------
15546 -- Global --
15547 ------------
15548
15549 -- pragma Global (GLOBAL_SPECIFICATION);
15550
15551 -- GLOBAL_SPECIFICATION ::=
15552 -- null
15553 -- | (GLOBAL_LIST)
15554 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15555
15556 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15557
15558 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15559 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15560 -- GLOBAL_ITEM ::= NAME
15561
15562 -- Characteristics:
15563
15564 -- * Analysis - The annotation undergoes initial checks to verify
15565 -- the legal placement and context. Secondary checks fully analyze
15566 -- the dependency clauses in:
15567
15568 -- Analyze_Global_In_Decl_Part
15569
15570 -- * Expansion - None.
15571
15572 -- * Template - The annotation utilizes the generic template of the
15573 -- related subprogram [body] when it is:
15574
15575 -- aspect on subprogram declaration
15576 -- aspect on stand alone subprogram body
15577 -- pragma on stand alone subprogram body
15578
15579 -- The annotation must prepare its own template when it is:
15580
15581 -- pragma on subprogram declaration
15582
15583 -- * Globals - Capture of global references must occur after full
15584 -- analysis.
15585
15586 -- * Instance - The annotation is instantiated automatically when
15587 -- the related generic subprogram [body] is instantiated except for
15588 -- the "pragma on subprogram declaration" case. In that scenario
15589 -- the annotation must instantiate itself.
15590
15591 when Pragma_Global => Global : declare
15592 Legal : Boolean;
15593 Spec_Id : Entity_Id;
15594 Subp_Decl : Node_Id;
15595
15596 begin
15597 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15598
15599 if Legal then
15600
15601 -- Chain the pragma on the contract for further processing by
15602 -- Analyze_Global_In_Decl_Part.
15603
15604 Add_Contract_Item (N, Spec_Id);
15605
15606 -- Fully analyze the pragma when it appears inside an entry
15607 -- or subprogram body because it cannot benefit from forward
15608 -- references.
15609
15610 if Nkind_In (Subp_Decl, N_Entry_Body,
15611 N_Subprogram_Body,
15612 N_Subprogram_Body_Stub)
15613 then
15614 -- The legality checks of pragmas Depends and Global are
15615 -- affected by the SPARK mode in effect and the volatility
15616 -- of the context. In addition these two pragmas are subject
15617 -- to an inherent order:
15618
15619 -- 1) Global
15620 -- 2) Depends
15621
15622 -- Analyze all these pragmas in the order outlined above
15623
15624 Analyze_If_Present (Pragma_SPARK_Mode);
15625 Analyze_If_Present (Pragma_Volatile_Function);
15626 Analyze_Global_In_Decl_Part (N);
15627 Analyze_If_Present (Pragma_Depends);
15628 end if;
15629 end if;
15630 end Global;
15631
15632 -----------
15633 -- Ident --
15634 -----------
15635
15636 -- pragma Ident (static_string_EXPRESSION)
15637
15638 -- Note: pragma Comment shares this processing. Pragma Ident is
15639 -- identical in effect to pragma Commment.
15640
15641 when Pragma_Ident | Pragma_Comment => Ident : declare
15642 Str : Node_Id;
15643
15644 begin
15645 GNAT_Pragma;
15646 Check_Arg_Count (1);
15647 Check_No_Identifiers;
15648 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15649 Store_Note (N);
15650
15651 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15652
15653 declare
15654 CS : Node_Id;
15655 GP : Node_Id;
15656
15657 begin
15658 GP := Parent (Parent (N));
15659
15660 if Nkind_In (GP, N_Package_Declaration,
15661 N_Generic_Package_Declaration)
15662 then
15663 GP := Parent (GP);
15664 end if;
15665
15666 -- If we have a compilation unit, then record the ident value,
15667 -- checking for improper duplication.
15668
15669 if Nkind (GP) = N_Compilation_Unit then
15670 CS := Ident_String (Current_Sem_Unit);
15671
15672 if Present (CS) then
15673
15674 -- If we have multiple instances, concatenate them, but
15675 -- not in ASIS, where we want the original tree.
15676
15677 if not ASIS_Mode then
15678 Start_String (Strval (CS));
15679 Store_String_Char (' ');
15680 Store_String_Chars (Strval (Str));
15681 Set_Strval (CS, End_String);
15682 end if;
15683
15684 else
15685 Set_Ident_String (Current_Sem_Unit, Str);
15686 end if;
15687
15688 -- For subunits, we just ignore the Ident, since in GNAT these
15689 -- are not separate object files, and hence not separate units
15690 -- in the unit table.
15691
15692 elsif Nkind (GP) = N_Subunit then
15693 null;
15694 end if;
15695 end;
15696 end Ident;
15697
15698 -------------------
15699 -- Ignore_Pragma --
15700 -------------------
15701
15702 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15703
15704 -- Entirely handled in the parser, nothing to do here
15705
15706 when Pragma_Ignore_Pragma =>
15707 null;
15708
15709 ----------------------------
15710 -- Implementation_Defined --
15711 ----------------------------
15712
15713 -- pragma Implementation_Defined (LOCAL_NAME);
15714
15715 -- Marks previously declared entity as implementation defined. For
15716 -- an overloaded entity, applies to the most recent homonym.
15717
15718 -- pragma Implementation_Defined;
15719
15720 -- The form with no arguments appears anywhere within a scope, most
15721 -- typically a package spec, and indicates that all entities that are
15722 -- defined within the package spec are Implementation_Defined.
15723
15724 when Pragma_Implementation_Defined => Implementation_Defined : declare
15725 Ent : Entity_Id;
15726
15727 begin
15728 GNAT_Pragma;
15729 Check_No_Identifiers;
15730
15731 -- Form with no arguments
15732
15733 if Arg_Count = 0 then
15734 Set_Is_Implementation_Defined (Current_Scope);
15735
15736 -- Form with one argument
15737
15738 else
15739 Check_Arg_Count (1);
15740 Check_Arg_Is_Local_Name (Arg1);
15741 Ent := Entity (Get_Pragma_Arg (Arg1));
15742 Set_Is_Implementation_Defined (Ent);
15743 end if;
15744 end Implementation_Defined;
15745
15746 -----------------
15747 -- Implemented --
15748 -----------------
15749
15750 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15751
15752 -- IMPLEMENTATION_KIND ::=
15753 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15754
15755 -- "By_Any" and "Optional" are treated as synonyms in order to
15756 -- support Ada 2012 aspect Synchronization.
15757
15758 when Pragma_Implemented => Implemented : declare
15759 Proc_Id : Entity_Id;
15760 Typ : Entity_Id;
15761
15762 begin
15763 Ada_2012_Pragma;
15764 Check_Arg_Count (2);
15765 Check_No_Identifiers;
15766 Check_Arg_Is_Identifier (Arg1);
15767 Check_Arg_Is_Local_Name (Arg1);
15768 Check_Arg_Is_One_Of (Arg2,
15769 Name_By_Any,
15770 Name_By_Entry,
15771 Name_By_Protected_Procedure,
15772 Name_Optional);
15773
15774 -- Extract the name of the local procedure
15775
15776 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
15777
15778 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15779 -- primitive procedure of a synchronized tagged type.
15780
15781 if Ekind (Proc_Id) = E_Procedure
15782 and then Is_Primitive (Proc_Id)
15783 and then Present (First_Formal (Proc_Id))
15784 then
15785 Typ := Etype (First_Formal (Proc_Id));
15786
15787 if Is_Tagged_Type (Typ)
15788 and then
15789
15790 -- Check for a protected, a synchronized or a task interface
15791
15792 ((Is_Interface (Typ)
15793 and then Is_Synchronized_Interface (Typ))
15794
15795 -- Check for a protected type or a task type that implements
15796 -- an interface.
15797
15798 or else
15799 (Is_Concurrent_Record_Type (Typ)
15800 and then Present (Interfaces (Typ)))
15801
15802 -- In analysis-only mode, examine original protected type
15803
15804 or else
15805 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
15806 and then Present (Interface_List (Parent (Typ))))
15807
15808 -- Check for a private record extension with keyword
15809 -- "synchronized".
15810
15811 or else
15812 (Ekind_In (Typ, E_Record_Type_With_Private,
15813 E_Record_Subtype_With_Private)
15814 and then Synchronized_Present (Parent (Typ))))
15815 then
15816 null;
15817 else
15818 Error_Pragma_Arg
15819 ("controlling formal must be of synchronized tagged type",
15820 Arg1);
15821 return;
15822 end if;
15823
15824 -- Procedures declared inside a protected type must be accepted
15825
15826 elsif Ekind (Proc_Id) = E_Procedure
15827 and then Is_Protected_Type (Scope (Proc_Id))
15828 then
15829 null;
15830
15831 -- The first argument is not a primitive procedure
15832
15833 else
15834 Error_Pragma_Arg
15835 ("pragma % must be applied to a primitive procedure", Arg1);
15836 return;
15837 end if;
15838
15839 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15840 -- By_Protected_Procedure to the primitive procedure of a task
15841 -- interface.
15842
15843 if Chars (Arg2) = Name_By_Protected_Procedure
15844 and then Is_Interface (Typ)
15845 and then Is_Task_Interface (Typ)
15846 then
15847 Error_Pragma_Arg
15848 ("implementation kind By_Protected_Procedure cannot be "
15849 & "applied to a task interface primitive", Arg2);
15850 return;
15851 end if;
15852
15853 Record_Rep_Item (Proc_Id, N);
15854 end Implemented;
15855
15856 ----------------------
15857 -- Implicit_Packing --
15858 ----------------------
15859
15860 -- pragma Implicit_Packing;
15861
15862 when Pragma_Implicit_Packing =>
15863 GNAT_Pragma;
15864 Check_Arg_Count (0);
15865 Implicit_Packing := True;
15866
15867 ------------
15868 -- Import --
15869 ------------
15870
15871 -- pragma Import (
15872 -- [Convention =>] convention_IDENTIFIER,
15873 -- [Entity =>] LOCAL_NAME
15874 -- [, [External_Name =>] static_string_EXPRESSION ]
15875 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15876
15877 when Pragma_Import =>
15878 Check_Ada_83_Warning;
15879 Check_Arg_Order
15880 ((Name_Convention,
15881 Name_Entity,
15882 Name_External_Name,
15883 Name_Link_Name));
15884
15885 Check_At_Least_N_Arguments (2);
15886 Check_At_Most_N_Arguments (4);
15887 Process_Import_Or_Interface;
15888
15889 ---------------------
15890 -- Import_Function --
15891 ---------------------
15892
15893 -- pragma Import_Function (
15894 -- [Internal =>] LOCAL_NAME,
15895 -- [, [External =>] EXTERNAL_SYMBOL]
15896 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15897 -- [, [Result_Type =>] SUBTYPE_MARK]
15898 -- [, [Mechanism =>] MECHANISM]
15899 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15900
15901 -- EXTERNAL_SYMBOL ::=
15902 -- IDENTIFIER
15903 -- | static_string_EXPRESSION
15904
15905 -- PARAMETER_TYPES ::=
15906 -- null
15907 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15908
15909 -- TYPE_DESIGNATOR ::=
15910 -- subtype_NAME
15911 -- | subtype_Name ' Access
15912
15913 -- MECHANISM ::=
15914 -- MECHANISM_NAME
15915 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15916
15917 -- MECHANISM_ASSOCIATION ::=
15918 -- [formal_parameter_NAME =>] MECHANISM_NAME
15919
15920 -- MECHANISM_NAME ::=
15921 -- Value
15922 -- | Reference
15923
15924 when Pragma_Import_Function => Import_Function : declare
15925 Args : Args_List (1 .. 6);
15926 Names : constant Name_List (1 .. 6) := (
15927 Name_Internal,
15928 Name_External,
15929 Name_Parameter_Types,
15930 Name_Result_Type,
15931 Name_Mechanism,
15932 Name_Result_Mechanism);
15933
15934 Internal : Node_Id renames Args (1);
15935 External : Node_Id renames Args (2);
15936 Parameter_Types : Node_Id renames Args (3);
15937 Result_Type : Node_Id renames Args (4);
15938 Mechanism : Node_Id renames Args (5);
15939 Result_Mechanism : Node_Id renames Args (6);
15940
15941 begin
15942 GNAT_Pragma;
15943 Gather_Associations (Names, Args);
15944 Process_Extended_Import_Export_Subprogram_Pragma (
15945 Arg_Internal => Internal,
15946 Arg_External => External,
15947 Arg_Parameter_Types => Parameter_Types,
15948 Arg_Result_Type => Result_Type,
15949 Arg_Mechanism => Mechanism,
15950 Arg_Result_Mechanism => Result_Mechanism);
15951 end Import_Function;
15952
15953 -------------------
15954 -- Import_Object --
15955 -------------------
15956
15957 -- pragma Import_Object (
15958 -- [Internal =>] LOCAL_NAME
15959 -- [, [External =>] EXTERNAL_SYMBOL]
15960 -- [, [Size =>] EXTERNAL_SYMBOL]);
15961
15962 -- EXTERNAL_SYMBOL ::=
15963 -- IDENTIFIER
15964 -- | static_string_EXPRESSION
15965
15966 when Pragma_Import_Object => Import_Object : declare
15967 Args : Args_List (1 .. 3);
15968 Names : constant Name_List (1 .. 3) := (
15969 Name_Internal,
15970 Name_External,
15971 Name_Size);
15972
15973 Internal : Node_Id renames Args (1);
15974 External : Node_Id renames Args (2);
15975 Size : Node_Id renames Args (3);
15976
15977 begin
15978 GNAT_Pragma;
15979 Gather_Associations (Names, Args);
15980 Process_Extended_Import_Export_Object_Pragma (
15981 Arg_Internal => Internal,
15982 Arg_External => External,
15983 Arg_Size => Size);
15984 end Import_Object;
15985
15986 ----------------------
15987 -- Import_Procedure --
15988 ----------------------
15989
15990 -- pragma Import_Procedure (
15991 -- [Internal =>] LOCAL_NAME
15992 -- [, [External =>] EXTERNAL_SYMBOL]
15993 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15994 -- [, [Mechanism =>] MECHANISM]);
15995
15996 -- EXTERNAL_SYMBOL ::=
15997 -- IDENTIFIER
15998 -- | static_string_EXPRESSION
15999
16000 -- PARAMETER_TYPES ::=
16001 -- null
16002 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16003
16004 -- TYPE_DESIGNATOR ::=
16005 -- subtype_NAME
16006 -- | subtype_Name ' Access
16007
16008 -- MECHANISM ::=
16009 -- MECHANISM_NAME
16010 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16011
16012 -- MECHANISM_ASSOCIATION ::=
16013 -- [formal_parameter_NAME =>] MECHANISM_NAME
16014
16015 -- MECHANISM_NAME ::=
16016 -- Value
16017 -- | Reference
16018
16019 when Pragma_Import_Procedure => Import_Procedure : declare
16020 Args : Args_List (1 .. 4);
16021 Names : constant Name_List (1 .. 4) := (
16022 Name_Internal,
16023 Name_External,
16024 Name_Parameter_Types,
16025 Name_Mechanism);
16026
16027 Internal : Node_Id renames Args (1);
16028 External : Node_Id renames Args (2);
16029 Parameter_Types : Node_Id renames Args (3);
16030 Mechanism : Node_Id renames Args (4);
16031
16032 begin
16033 GNAT_Pragma;
16034 Gather_Associations (Names, Args);
16035 Process_Extended_Import_Export_Subprogram_Pragma (
16036 Arg_Internal => Internal,
16037 Arg_External => External,
16038 Arg_Parameter_Types => Parameter_Types,
16039 Arg_Mechanism => Mechanism);
16040 end Import_Procedure;
16041
16042 -----------------------------
16043 -- Import_Valued_Procedure --
16044 -----------------------------
16045
16046 -- pragma Import_Valued_Procedure (
16047 -- [Internal =>] LOCAL_NAME
16048 -- [, [External =>] EXTERNAL_SYMBOL]
16049 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16050 -- [, [Mechanism =>] MECHANISM]);
16051
16052 -- EXTERNAL_SYMBOL ::=
16053 -- IDENTIFIER
16054 -- | static_string_EXPRESSION
16055
16056 -- PARAMETER_TYPES ::=
16057 -- null
16058 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16059
16060 -- TYPE_DESIGNATOR ::=
16061 -- subtype_NAME
16062 -- | subtype_Name ' Access
16063
16064 -- MECHANISM ::=
16065 -- MECHANISM_NAME
16066 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16067
16068 -- MECHANISM_ASSOCIATION ::=
16069 -- [formal_parameter_NAME =>] MECHANISM_NAME
16070
16071 -- MECHANISM_NAME ::=
16072 -- Value
16073 -- | Reference
16074
16075 when Pragma_Import_Valued_Procedure =>
16076 Import_Valued_Procedure : declare
16077 Args : Args_List (1 .. 4);
16078 Names : constant Name_List (1 .. 4) := (
16079 Name_Internal,
16080 Name_External,
16081 Name_Parameter_Types,
16082 Name_Mechanism);
16083
16084 Internal : Node_Id renames Args (1);
16085 External : Node_Id renames Args (2);
16086 Parameter_Types : Node_Id renames Args (3);
16087 Mechanism : Node_Id renames Args (4);
16088
16089 begin
16090 GNAT_Pragma;
16091 Gather_Associations (Names, Args);
16092 Process_Extended_Import_Export_Subprogram_Pragma (
16093 Arg_Internal => Internal,
16094 Arg_External => External,
16095 Arg_Parameter_Types => Parameter_Types,
16096 Arg_Mechanism => Mechanism);
16097 end Import_Valued_Procedure;
16098
16099 -----------------
16100 -- Independent --
16101 -----------------
16102
16103 -- pragma Independent (LOCAL_NAME);
16104
16105 when Pragma_Independent =>
16106 Process_Atomic_Independent_Shared_Volatile;
16107
16108 ----------------------------
16109 -- Independent_Components --
16110 ----------------------------
16111
16112 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16113
16114 when Pragma_Independent_Components => Independent_Components : declare
16115 C : Node_Id;
16116 D : Node_Id;
16117 E_Id : Node_Id;
16118 E : Entity_Id;
16119 K : Node_Kind;
16120
16121 begin
16122 Check_Ada_83_Warning;
16123 Ada_2012_Pragma;
16124 Check_No_Identifiers;
16125 Check_Arg_Count (1);
16126 Check_Arg_Is_Local_Name (Arg1);
16127 E_Id := Get_Pragma_Arg (Arg1);
16128
16129 if Etype (E_Id) = Any_Type then
16130 return;
16131 end if;
16132
16133 E := Entity (E_Id);
16134
16135 -- A pragma that applies to a Ghost entity becomes Ghost for the
16136 -- purposes of legality checks and removal of ignored Ghost code.
16137
16138 Mark_Pragma_As_Ghost (N, E);
16139
16140 -- Check duplicate before we chain ourselves
16141
16142 Check_Duplicate_Pragma (E);
16143
16144 -- Check appropriate entity
16145
16146 if Rep_Item_Too_Early (E, N)
16147 or else
16148 Rep_Item_Too_Late (E, N)
16149 then
16150 return;
16151 end if;
16152
16153 D := Declaration_Node (E);
16154 K := Nkind (D);
16155
16156 -- The flag is set on the base type, or on the object
16157
16158 if K = N_Full_Type_Declaration
16159 and then (Is_Array_Type (E) or else Is_Record_Type (E))
16160 then
16161 Set_Has_Independent_Components (Base_Type (E));
16162 Record_Independence_Check (N, Base_Type (E));
16163
16164 -- For record type, set all components independent
16165
16166 if Is_Record_Type (E) then
16167 C := First_Component (E);
16168 while Present (C) loop
16169 Set_Is_Independent (C);
16170 Next_Component (C);
16171 end loop;
16172 end if;
16173
16174 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
16175 and then Nkind (D) = N_Object_Declaration
16176 and then Nkind (Object_Definition (D)) =
16177 N_Constrained_Array_Definition
16178 then
16179 Set_Has_Independent_Components (E);
16180 Record_Independence_Check (N, E);
16181
16182 else
16183 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
16184 end if;
16185 end Independent_Components;
16186
16187 -----------------------
16188 -- Initial_Condition --
16189 -----------------------
16190
16191 -- pragma Initial_Condition (boolean_EXPRESSION);
16192
16193 -- Characteristics:
16194
16195 -- * Analysis - The annotation undergoes initial checks to verify
16196 -- the legal placement and context. Secondary checks preanalyze the
16197 -- expression in:
16198
16199 -- Analyze_Initial_Condition_In_Decl_Part
16200
16201 -- * Expansion - The annotation is expanded during the expansion of
16202 -- the package body whose declaration is subject to the annotation
16203 -- as done in:
16204
16205 -- Expand_Pragma_Initial_Condition
16206
16207 -- * Template - The annotation utilizes the generic template of the
16208 -- related package declaration.
16209
16210 -- * Globals - Capture of global references must occur after full
16211 -- analysis.
16212
16213 -- * Instance - The annotation is instantiated automatically when
16214 -- the related generic package is instantiated.
16215
16216 when Pragma_Initial_Condition => Initial_Condition : declare
16217 Pack_Decl : Node_Id;
16218 Pack_Id : Entity_Id;
16219
16220 begin
16221 GNAT_Pragma;
16222 Check_No_Identifiers;
16223 Check_Arg_Count (1);
16224
16225 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16226
16227 -- Ensure the proper placement of the pragma. Initial_Condition
16228 -- must be associated with a package declaration.
16229
16230 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16231 N_Package_Declaration)
16232 then
16233 null;
16234
16235 -- Otherwise the pragma is associated with an illegal context
16236
16237 else
16238 Pragma_Misplaced;
16239 return;
16240 end if;
16241
16242 Pack_Id := Defining_Entity (Pack_Decl);
16243
16244 -- Chain the pragma on the contract for further processing by
16245 -- Analyze_Initial_Condition_In_Decl_Part.
16246
16247 Add_Contract_Item (N, Pack_Id);
16248
16249 -- The legality checks of pragmas Abstract_State, Initializes, and
16250 -- Initial_Condition are affected by the SPARK mode in effect. In
16251 -- addition, these three pragmas are subject to an inherent order:
16252
16253 -- 1) Abstract_State
16254 -- 2) Initializes
16255 -- 3) Initial_Condition
16256
16257 -- Analyze all these pragmas in the order outlined above
16258
16259 Analyze_If_Present (Pragma_SPARK_Mode);
16260 Analyze_If_Present (Pragma_Abstract_State);
16261 Analyze_If_Present (Pragma_Initializes);
16262
16263 -- A pragma that applies to a Ghost entity becomes Ghost for the
16264 -- purposes of legality checks and removal of ignored Ghost code.
16265
16266 Mark_Pragma_As_Ghost (N, Pack_Id);
16267 end Initial_Condition;
16268
16269 ------------------------
16270 -- Initialize_Scalars --
16271 ------------------------
16272
16273 -- pragma Initialize_Scalars;
16274
16275 when Pragma_Initialize_Scalars =>
16276 GNAT_Pragma;
16277 Check_Arg_Count (0);
16278 Check_Valid_Configuration_Pragma;
16279 Check_Restriction (No_Initialize_Scalars, N);
16280
16281 -- Initialize_Scalars creates false positives in CodePeer, and
16282 -- incorrect negative results in GNATprove mode, so ignore this
16283 -- pragma in these modes.
16284
16285 if not Restriction_Active (No_Initialize_Scalars)
16286 and then not (CodePeer_Mode or GNATprove_Mode)
16287 then
16288 Init_Or_Norm_Scalars := True;
16289 Initialize_Scalars := True;
16290 end if;
16291
16292 -----------------
16293 -- Initializes --
16294 -----------------
16295
16296 -- pragma Initializes (INITIALIZATION_LIST);
16297
16298 -- INITIALIZATION_LIST ::=
16299 -- null
16300 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16301
16302 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16303
16304 -- INPUT_LIST ::=
16305 -- null
16306 -- | INPUT
16307 -- | (INPUT {, INPUT})
16308
16309 -- INPUT ::= name
16310
16311 -- Characteristics:
16312
16313 -- * Analysis - The annotation undergoes initial checks to verify
16314 -- the legal placement and context. Secondary checks preanalyze the
16315 -- expression in:
16316
16317 -- Analyze_Initializes_In_Decl_Part
16318
16319 -- * Expansion - None.
16320
16321 -- * Template - The annotation utilizes the generic template of the
16322 -- related package declaration.
16323
16324 -- * Globals - Capture of global references must occur after full
16325 -- analysis.
16326
16327 -- * Instance - The annotation is instantiated automatically when
16328 -- the related generic package is instantiated.
16329
16330 when Pragma_Initializes => Initializes : declare
16331 Pack_Decl : Node_Id;
16332 Pack_Id : Entity_Id;
16333
16334 begin
16335 GNAT_Pragma;
16336 Check_No_Identifiers;
16337 Check_Arg_Count (1);
16338
16339 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16340
16341 -- Ensure the proper placement of the pragma. Initializes must be
16342 -- associated with a package declaration.
16343
16344 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16345 N_Package_Declaration)
16346 then
16347 null;
16348
16349 -- Otherwise the pragma is associated with an illegal construc
16350
16351 else
16352 Pragma_Misplaced;
16353 return;
16354 end if;
16355
16356 Pack_Id := Defining_Entity (Pack_Decl);
16357
16358 -- Chain the pragma on the contract for further processing by
16359 -- Analyze_Initializes_In_Decl_Part.
16360
16361 Add_Contract_Item (N, Pack_Id);
16362
16363 -- The legality checks of pragmas Abstract_State, Initializes, and
16364 -- Initial_Condition are affected by the SPARK mode in effect. In
16365 -- addition, these three pragmas are subject to an inherent order:
16366
16367 -- 1) Abstract_State
16368 -- 2) Initializes
16369 -- 3) Initial_Condition
16370
16371 -- Analyze all these pragmas in the order outlined above
16372
16373 Analyze_If_Present (Pragma_SPARK_Mode);
16374 Analyze_If_Present (Pragma_Abstract_State);
16375
16376 -- A pragma that applies to a Ghost entity becomes Ghost for the
16377 -- purposes of legality checks and removal of ignored Ghost code.
16378
16379 Mark_Pragma_As_Ghost (N, Pack_Id);
16380 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16381
16382 Analyze_If_Present (Pragma_Initial_Condition);
16383 end Initializes;
16384
16385 ------------
16386 -- Inline --
16387 ------------
16388
16389 -- pragma Inline ( NAME {, NAME} );
16390
16391 when Pragma_Inline =>
16392
16393 -- Pragma always active unless in GNATprove mode. It is disabled
16394 -- in GNATprove mode because frontend inlining is applied
16395 -- independently of pragmas Inline and Inline_Always for
16396 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16397 -- in inline.ads.
16398
16399 if not GNATprove_Mode then
16400
16401 -- Inline status is Enabled if inlining option is active
16402
16403 if Inline_Active then
16404 Process_Inline (Enabled);
16405 else
16406 Process_Inline (Disabled);
16407 end if;
16408 end if;
16409
16410 -------------------
16411 -- Inline_Always --
16412 -------------------
16413
16414 -- pragma Inline_Always ( NAME {, NAME} );
16415
16416 when Pragma_Inline_Always =>
16417 GNAT_Pragma;
16418
16419 -- Pragma always active unless in CodePeer mode or GNATprove
16420 -- mode. It is disabled in CodePeer mode because inlining is
16421 -- not helpful, and enabling it caused walk order issues. It
16422 -- is disabled in GNATprove mode because frontend inlining is
16423 -- applied independently of pragmas Inline and Inline_Always for
16424 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16425 -- inline.ads.
16426
16427 if not CodePeer_Mode and not GNATprove_Mode then
16428 Process_Inline (Enabled);
16429 end if;
16430
16431 --------------------
16432 -- Inline_Generic --
16433 --------------------
16434
16435 -- pragma Inline_Generic (NAME {, NAME});
16436
16437 when Pragma_Inline_Generic =>
16438 GNAT_Pragma;
16439 Process_Generic_List;
16440
16441 ----------------------
16442 -- Inspection_Point --
16443 ----------------------
16444
16445 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16446
16447 when Pragma_Inspection_Point => Inspection_Point : declare
16448 Arg : Node_Id;
16449 Exp : Node_Id;
16450
16451 begin
16452 ip;
16453
16454 if Arg_Count > 0 then
16455 Arg := Arg1;
16456 loop
16457 Exp := Get_Pragma_Arg (Arg);
16458 Analyze (Exp);
16459
16460 if not Is_Entity_Name (Exp)
16461 or else not Is_Object (Entity (Exp))
16462 then
16463 Error_Pragma_Arg ("object name required", Arg);
16464 end if;
16465
16466 Next (Arg);
16467 exit when No (Arg);
16468 end loop;
16469 end if;
16470 end Inspection_Point;
16471
16472 ---------------
16473 -- Interface --
16474 ---------------
16475
16476 -- pragma Interface (
16477 -- [ Convention =>] convention_IDENTIFIER,
16478 -- [ Entity =>] LOCAL_NAME
16479 -- [, [External_Name =>] static_string_EXPRESSION ]
16480 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16481
16482 when Pragma_Interface =>
16483 GNAT_Pragma;
16484 Check_Arg_Order
16485 ((Name_Convention,
16486 Name_Entity,
16487 Name_External_Name,
16488 Name_Link_Name));
16489 Check_At_Least_N_Arguments (2);
16490 Check_At_Most_N_Arguments (4);
16491 Process_Import_Or_Interface;
16492
16493 -- In Ada 2005, the permission to use Interface (a reserved word)
16494 -- as a pragma name is considered an obsolescent feature, and this
16495 -- pragma was already obsolescent in Ada 95.
16496
16497 if Ada_Version >= Ada_95 then
16498 Check_Restriction
16499 (No_Obsolescent_Features, Pragma_Identifier (N));
16500
16501 if Warn_On_Obsolescent_Feature then
16502 Error_Msg_N
16503 ("pragma Interface is an obsolescent feature?j?", N);
16504 Error_Msg_N
16505 ("|use pragma Import instead?j?", N);
16506 end if;
16507 end if;
16508
16509 --------------------
16510 -- Interface_Name --
16511 --------------------
16512
16513 -- pragma Interface_Name (
16514 -- [ Entity =>] LOCAL_NAME
16515 -- [,[External_Name =>] static_string_EXPRESSION ]
16516 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16517
16518 when Pragma_Interface_Name => Interface_Name : declare
16519 Id : Node_Id;
16520 Def_Id : Entity_Id;
16521 Hom_Id : Entity_Id;
16522 Found : Boolean;
16523
16524 begin
16525 GNAT_Pragma;
16526 Check_Arg_Order
16527 ((Name_Entity, Name_External_Name, Name_Link_Name));
16528 Check_At_Least_N_Arguments (2);
16529 Check_At_Most_N_Arguments (3);
16530 Id := Get_Pragma_Arg (Arg1);
16531 Analyze (Id);
16532
16533 -- This is obsolete from Ada 95 on, but it is an implementation
16534 -- defined pragma, so we do not consider that it violates the
16535 -- restriction (No_Obsolescent_Features).
16536
16537 if Ada_Version >= Ada_95 then
16538 if Warn_On_Obsolescent_Feature then
16539 Error_Msg_N
16540 ("pragma Interface_Name is an obsolescent feature?j?", N);
16541 Error_Msg_N
16542 ("|use pragma Import instead?j?", N);
16543 end if;
16544 end if;
16545
16546 if not Is_Entity_Name (Id) then
16547 Error_Pragma_Arg
16548 ("first argument for pragma% must be entity name", Arg1);
16549 elsif Etype (Id) = Any_Type then
16550 return;
16551 else
16552 Def_Id := Entity (Id);
16553 end if;
16554
16555 -- Special DEC-compatible processing for the object case, forces
16556 -- object to be imported.
16557
16558 if Ekind (Def_Id) = E_Variable then
16559 Kill_Size_Check_Code (Def_Id);
16560 Note_Possible_Modification (Id, Sure => False);
16561
16562 -- Initialization is not allowed for imported variable
16563
16564 if Present (Expression (Parent (Def_Id)))
16565 and then Comes_From_Source (Expression (Parent (Def_Id)))
16566 then
16567 Error_Msg_Sloc := Sloc (Def_Id);
16568 Error_Pragma_Arg
16569 ("no initialization allowed for declaration of& #",
16570 Arg2);
16571
16572 else
16573 -- For compatibility, support VADS usage of providing both
16574 -- pragmas Interface and Interface_Name to obtain the effect
16575 -- of a single Import pragma.
16576
16577 if Is_Imported (Def_Id)
16578 and then Present (First_Rep_Item (Def_Id))
16579 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16580 and then
16581 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
16582 then
16583 null;
16584 else
16585 Set_Imported (Def_Id);
16586 end if;
16587
16588 Set_Is_Public (Def_Id);
16589 Process_Interface_Name (Def_Id, Arg2, Arg3);
16590 end if;
16591
16592 -- Otherwise must be subprogram
16593
16594 elsif not Is_Subprogram (Def_Id) then
16595 Error_Pragma_Arg
16596 ("argument of pragma% is not subprogram", Arg1);
16597
16598 else
16599 Check_At_Most_N_Arguments (3);
16600 Hom_Id := Def_Id;
16601 Found := False;
16602
16603 -- Loop through homonyms
16604
16605 loop
16606 Def_Id := Get_Base_Subprogram (Hom_Id);
16607
16608 if Is_Imported (Def_Id) then
16609 Process_Interface_Name (Def_Id, Arg2, Arg3);
16610 Found := True;
16611 end if;
16612
16613 exit when From_Aspect_Specification (N);
16614 Hom_Id := Homonym (Hom_Id);
16615
16616 exit when No (Hom_Id)
16617 or else Scope (Hom_Id) /= Current_Scope;
16618 end loop;
16619
16620 if not Found then
16621 Error_Pragma_Arg
16622 ("argument of pragma% is not imported subprogram",
16623 Arg1);
16624 end if;
16625 end if;
16626 end Interface_Name;
16627
16628 -----------------------
16629 -- Interrupt_Handler --
16630 -----------------------
16631
16632 -- pragma Interrupt_Handler (handler_NAME);
16633
16634 when Pragma_Interrupt_Handler =>
16635 Check_Ada_83_Warning;
16636 Check_Arg_Count (1);
16637 Check_No_Identifiers;
16638
16639 if No_Run_Time_Mode then
16640 Error_Msg_CRT ("Interrupt_Handler pragma", N);
16641 else
16642 Check_Interrupt_Or_Attach_Handler;
16643 Process_Interrupt_Or_Attach_Handler;
16644 end if;
16645
16646 ------------------------
16647 -- Interrupt_Priority --
16648 ------------------------
16649
16650 -- pragma Interrupt_Priority [(EXPRESSION)];
16651
16652 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16653 P : constant Node_Id := Parent (N);
16654 Arg : Node_Id;
16655 Ent : Entity_Id;
16656
16657 begin
16658 Check_Ada_83_Warning;
16659
16660 if Arg_Count /= 0 then
16661 Arg := Get_Pragma_Arg (Arg1);
16662 Check_Arg_Count (1);
16663 Check_No_Identifiers;
16664
16665 -- The expression must be analyzed in the special manner
16666 -- described in "Handling of Default and Per-Object
16667 -- Expressions" in sem.ads.
16668
16669 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16670 end if;
16671
16672 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16673 Pragma_Misplaced;
16674 return;
16675
16676 else
16677 Ent := Defining_Identifier (Parent (P));
16678
16679 -- Check duplicate pragma before we chain the pragma in the Rep
16680 -- Item chain of Ent.
16681
16682 Check_Duplicate_Pragma (Ent);
16683 Record_Rep_Item (Ent, N);
16684
16685 -- Check the No_Task_At_Interrupt_Priority restriction
16686
16687 if Nkind (P) = N_Task_Definition then
16688 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16689 end if;
16690 end if;
16691 end Interrupt_Priority;
16692
16693 ---------------------
16694 -- Interrupt_State --
16695 ---------------------
16696
16697 -- pragma Interrupt_State (
16698 -- [Name =>] INTERRUPT_ID,
16699 -- [State =>] INTERRUPT_STATE);
16700
16701 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16702 -- INTERRUPT_STATE => System | Runtime | User
16703
16704 -- Note: if the interrupt id is given as an identifier, then it must
16705 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16706 -- given as a static integer expression which must be in the range of
16707 -- Ada.Interrupts.Interrupt_ID.
16708
16709 when Pragma_Interrupt_State => Interrupt_State : declare
16710 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16711 -- This is the entity Ada.Interrupts.Interrupt_ID;
16712
16713 State_Type : Character;
16714 -- Set to 's'/'r'/'u' for System/Runtime/User
16715
16716 IST_Num : Pos;
16717 -- Index to entry in Interrupt_States table
16718
16719 Int_Val : Uint;
16720 -- Value of interrupt
16721
16722 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16723 -- The first argument to the pragma
16724
16725 Int_Ent : Entity_Id;
16726 -- Interrupt entity in Ada.Interrupts.Names
16727
16728 begin
16729 GNAT_Pragma;
16730 Check_Arg_Order ((Name_Name, Name_State));
16731 Check_Arg_Count (2);
16732
16733 Check_Optional_Identifier (Arg1, Name_Name);
16734 Check_Optional_Identifier (Arg2, Name_State);
16735 Check_Arg_Is_Identifier (Arg2);
16736
16737 -- First argument is identifier
16738
16739 if Nkind (Arg1X) = N_Identifier then
16740
16741 -- Search list of names in Ada.Interrupts.Names
16742
16743 Int_Ent := First_Entity (RTE (RE_Names));
16744 loop
16745 if No (Int_Ent) then
16746 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16747
16748 elsif Chars (Int_Ent) = Chars (Arg1X) then
16749 Int_Val := Expr_Value (Constant_Value (Int_Ent));
16750 exit;
16751 end if;
16752
16753 Next_Entity (Int_Ent);
16754 end loop;
16755
16756 -- First argument is not an identifier, so it must be a static
16757 -- expression of type Ada.Interrupts.Interrupt_ID.
16758
16759 else
16760 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16761 Int_Val := Expr_Value (Arg1X);
16762
16763 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
16764 or else
16765 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
16766 then
16767 Error_Pragma_Arg
16768 ("value not in range of type "
16769 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
16770 end if;
16771 end if;
16772
16773 -- Check OK state
16774
16775 case Chars (Get_Pragma_Arg (Arg2)) is
16776 when Name_Runtime => State_Type := 'r';
16777 when Name_System => State_Type := 's';
16778 when Name_User => State_Type := 'u';
16779
16780 when others =>
16781 Error_Pragma_Arg ("invalid interrupt state", Arg2);
16782 end case;
16783
16784 -- Check if entry is already stored
16785
16786 IST_Num := Interrupt_States.First;
16787 loop
16788 -- If entry not found, add it
16789
16790 if IST_Num > Interrupt_States.Last then
16791 Interrupt_States.Append
16792 ((Interrupt_Number => UI_To_Int (Int_Val),
16793 Interrupt_State => State_Type,
16794 Pragma_Loc => Loc));
16795 exit;
16796
16797 -- Case of entry for the same entry
16798
16799 elsif Int_Val = Interrupt_States.Table (IST_Num).
16800 Interrupt_Number
16801 then
16802 -- If state matches, done, no need to make redundant entry
16803
16804 exit when
16805 State_Type = Interrupt_States.Table (IST_Num).
16806 Interrupt_State;
16807
16808 -- Otherwise if state does not match, error
16809
16810 Error_Msg_Sloc :=
16811 Interrupt_States.Table (IST_Num).Pragma_Loc;
16812 Error_Pragma_Arg
16813 ("state conflicts with that given #", Arg2);
16814 exit;
16815 end if;
16816
16817 IST_Num := IST_Num + 1;
16818 end loop;
16819 end Interrupt_State;
16820
16821 ---------------
16822 -- Invariant --
16823 ---------------
16824
16825 -- pragma Invariant
16826 -- ([Entity =>] type_LOCAL_NAME,
16827 -- [Check =>] EXPRESSION
16828 -- [,[Message =>] String_Expression]);
16829
16830 when Pragma_Invariant => Invariant : declare
16831 Discard : Boolean;
16832 Typ : Entity_Id;
16833 Typ_Arg : Node_Id;
16834
16835 CRec_Typ : Entity_Id;
16836 -- The corresponding record type of Full_Typ
16837
16838 Full_Base : Entity_Id;
16839 -- The base type of Full_Typ
16840
16841 Full_Typ : Entity_Id;
16842 -- The full view of Typ
16843
16844 Priv_Typ : Entity_Id;
16845 -- The partial view of Typ
16846
16847 begin
16848 GNAT_Pragma;
16849 Check_At_Least_N_Arguments (2);
16850 Check_At_Most_N_Arguments (3);
16851 Check_Optional_Identifier (Arg1, Name_Entity);
16852 Check_Optional_Identifier (Arg2, Name_Check);
16853
16854 if Arg_Count = 3 then
16855 Check_Optional_Identifier (Arg3, Name_Message);
16856 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
16857 end if;
16858
16859 Check_Arg_Is_Local_Name (Arg1);
16860
16861 Typ_Arg := Get_Pragma_Arg (Arg1);
16862 Find_Type (Typ_Arg);
16863 Typ := Entity (Typ_Arg);
16864
16865 -- Nothing to do of the related type is erroneous in some way
16866
16867 if Typ = Any_Type then
16868 return;
16869
16870 -- AI12-0041: Invariants are allowed in interface types
16871
16872 elsif Is_Interface (Typ) then
16873 null;
16874
16875 -- An invariant must apply to a private type, or appear in the
16876 -- private part of a package spec and apply to a completion.
16877 -- a class-wide invariant can only appear on a private declaration
16878 -- or private extension, not a completion.
16879
16880 -- A [class-wide] invariant may be associated a [limited] private
16881 -- type or a private extension.
16882
16883 elsif Ekind_In (Typ, E_Limited_Private_Type,
16884 E_Private_Type,
16885 E_Record_Type_With_Private)
16886 then
16887 null;
16888
16889 -- A non-class-wide invariant may be associated with the full view
16890 -- of a [limited] private type or a private extension.
16891
16892 elsif Has_Private_Declaration (Typ)
16893 and then not Class_Present (N)
16894 then
16895 null;
16896
16897 -- A class-wide invariant may appear on the partial view only
16898
16899 elsif Class_Present (N) then
16900 Error_Pragma_Arg
16901 ("pragma % only allowed for private type", Arg1);
16902 return;
16903
16904 -- A regular invariant may appear on both views
16905
16906 else
16907 Error_Pragma_Arg
16908 ("pragma % only allowed for private type or corresponding "
16909 & "full view", Arg1);
16910 return;
16911 end if;
16912
16913 -- An invariant associated with an abstract type (this includes
16914 -- interfaces) must be class-wide.
16915
16916 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
16917 Error_Pragma_Arg
16918 ("pragma % not allowed for abstract type", Arg1);
16919 return;
16920 end if;
16921
16922 -- A pragma that applies to a Ghost entity becomes Ghost for the
16923 -- purposes of legality checks and removal of ignored Ghost code.
16924
16925 Mark_Pragma_As_Ghost (N, Typ);
16926
16927 -- The pragma defines a type-specific invariant, the type is said
16928 -- to have invariants of its "own".
16929
16930 Set_Has_Own_Invariants (Typ);
16931
16932 -- If the invariant is class-wide, then it can be inherited by
16933 -- derived or interface implementing types. The type is said to
16934 -- have "inheritable" invariants.
16935
16936 if Class_Present (N) then
16937 Set_Has_Inheritable_Invariants (Typ);
16938 end if;
16939
16940 Get_Views (Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
16941
16942 -- Propagate invariant-related attributes to all views of the type
16943 -- and any additional types that may have been created.
16944
16945 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Typ);
16946 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Typ);
16947 Propagate_Invariant_Attributes (Full_Base, From_Typ => Typ);
16948 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Typ);
16949
16950 -- Chain the pragma on to the rep item chain, for processing when
16951 -- the type is frozen.
16952
16953 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16954
16955 -- Create the declaration of the invariant procedure which will
16956 -- verify the invariant at run-time. Note that interfaces do not
16957 -- carry such a declaration.
16958
16959 Build_Invariant_Procedure_Declaration (Typ);
16960 end Invariant;
16961
16962 ----------------
16963 -- Keep_Names --
16964 ----------------
16965
16966 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16967
16968 when Pragma_Keep_Names => Keep_Names : declare
16969 Arg : Node_Id;
16970
16971 begin
16972 GNAT_Pragma;
16973 Check_Arg_Count (1);
16974 Check_Optional_Identifier (Arg1, Name_On);
16975 Check_Arg_Is_Local_Name (Arg1);
16976
16977 Arg := Get_Pragma_Arg (Arg1);
16978 Analyze (Arg);
16979
16980 if Etype (Arg) = Any_Type then
16981 return;
16982 end if;
16983
16984 if not Is_Entity_Name (Arg)
16985 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16986 then
16987 Error_Pragma_Arg
16988 ("pragma% requires a local enumeration type", Arg1);
16989 end if;
16990
16991 Set_Discard_Names (Entity (Arg), False);
16992 end Keep_Names;
16993
16994 -------------
16995 -- License --
16996 -------------
16997
16998 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16999
17000 when Pragma_License =>
17001 GNAT_Pragma;
17002
17003 -- Do not analyze pragma any further in CodePeer mode, to avoid
17004 -- extraneous errors in this implementation-dependent pragma,
17005 -- which has a different profile on other compilers.
17006
17007 if CodePeer_Mode then
17008 return;
17009 end if;
17010
17011 Check_Arg_Count (1);
17012 Check_No_Identifiers;
17013 Check_Valid_Configuration_Pragma;
17014 Check_Arg_Is_Identifier (Arg1);
17015
17016 declare
17017 Sind : constant Source_File_Index :=
17018 Source_Index (Current_Sem_Unit);
17019
17020 begin
17021 case Chars (Get_Pragma_Arg (Arg1)) is
17022 when Name_GPL =>
17023 Set_License (Sind, GPL);
17024
17025 when Name_Modified_GPL =>
17026 Set_License (Sind, Modified_GPL);
17027
17028 when Name_Restricted =>
17029 Set_License (Sind, Restricted);
17030
17031 when Name_Unrestricted =>
17032 Set_License (Sind, Unrestricted);
17033
17034 when others =>
17035 Error_Pragma_Arg ("invalid license name", Arg1);
17036 end case;
17037 end;
17038
17039 ---------------
17040 -- Link_With --
17041 ---------------
17042
17043 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17044
17045 when Pragma_Link_With => Link_With : declare
17046 Arg : Node_Id;
17047
17048 begin
17049 GNAT_Pragma;
17050
17051 if Operating_Mode = Generate_Code
17052 and then In_Extended_Main_Source_Unit (N)
17053 then
17054 Check_At_Least_N_Arguments (1);
17055 Check_No_Identifiers;
17056 Check_Is_In_Decl_Part_Or_Package_Spec;
17057 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17058 Start_String;
17059
17060 Arg := Arg1;
17061 while Present (Arg) loop
17062 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17063
17064 -- Store argument, converting sequences of spaces to a
17065 -- single null character (this is one of the differences
17066 -- in processing between Link_With and Linker_Options).
17067
17068 Arg_Store : declare
17069 C : constant Char_Code := Get_Char_Code (' ');
17070 S : constant String_Id :=
17071 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
17072 L : constant Nat := String_Length (S);
17073 F : Nat := 1;
17074
17075 procedure Skip_Spaces;
17076 -- Advance F past any spaces
17077
17078 -----------------
17079 -- Skip_Spaces --
17080 -----------------
17081
17082 procedure Skip_Spaces is
17083 begin
17084 while F <= L and then Get_String_Char (S, F) = C loop
17085 F := F + 1;
17086 end loop;
17087 end Skip_Spaces;
17088
17089 -- Start of processing for Arg_Store
17090
17091 begin
17092 Skip_Spaces; -- skip leading spaces
17093
17094 -- Loop through characters, changing any embedded
17095 -- sequence of spaces to a single null character (this
17096 -- is how Link_With/Linker_Options differ)
17097
17098 while F <= L loop
17099 if Get_String_Char (S, F) = C then
17100 Skip_Spaces;
17101 exit when F > L;
17102 Store_String_Char (ASCII.NUL);
17103
17104 else
17105 Store_String_Char (Get_String_Char (S, F));
17106 F := F + 1;
17107 end if;
17108 end loop;
17109 end Arg_Store;
17110
17111 Arg := Next (Arg);
17112
17113 if Present (Arg) then
17114 Store_String_Char (ASCII.NUL);
17115 end if;
17116 end loop;
17117
17118 Store_Linker_Option_String (End_String);
17119 end if;
17120 end Link_With;
17121
17122 ------------------
17123 -- Linker_Alias --
17124 ------------------
17125
17126 -- pragma Linker_Alias (
17127 -- [Entity =>] LOCAL_NAME
17128 -- [Target =>] static_string_EXPRESSION);
17129
17130 when Pragma_Linker_Alias =>
17131 GNAT_Pragma;
17132 Check_Arg_Order ((Name_Entity, Name_Target));
17133 Check_Arg_Count (2);
17134 Check_Optional_Identifier (Arg1, Name_Entity);
17135 Check_Optional_Identifier (Arg2, Name_Target);
17136 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17137 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17138
17139 -- The only processing required is to link this item on to the
17140 -- list of rep items for the given entity. This is accomplished
17141 -- by the call to Rep_Item_Too_Late (when no error is detected
17142 -- and False is returned).
17143
17144 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
17145 return;
17146 else
17147 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17148 end if;
17149
17150 ------------------------
17151 -- Linker_Constructor --
17152 ------------------------
17153
17154 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17155
17156 -- Code is shared with Linker_Destructor
17157
17158 -----------------------
17159 -- Linker_Destructor --
17160 -----------------------
17161
17162 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17163
17164 when Pragma_Linker_Constructor |
17165 Pragma_Linker_Destructor =>
17166 Linker_Constructor : declare
17167 Arg1_X : Node_Id;
17168 Proc : Entity_Id;
17169
17170 begin
17171 GNAT_Pragma;
17172 Check_Arg_Count (1);
17173 Check_No_Identifiers;
17174 Check_Arg_Is_Local_Name (Arg1);
17175 Arg1_X := Get_Pragma_Arg (Arg1);
17176 Analyze (Arg1_X);
17177 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
17178
17179 if not Is_Library_Level_Entity (Proc) then
17180 Error_Pragma_Arg
17181 ("argument for pragma% must be library level entity", Arg1);
17182 end if;
17183
17184 -- The only processing required is to link this item on to the
17185 -- list of rep items for the given entity. This is accomplished
17186 -- by the call to Rep_Item_Too_Late (when no error is detected
17187 -- and False is returned).
17188
17189 if Rep_Item_Too_Late (Proc, N) then
17190 return;
17191 else
17192 Set_Has_Gigi_Rep_Item (Proc);
17193 end if;
17194 end Linker_Constructor;
17195
17196 --------------------
17197 -- Linker_Options --
17198 --------------------
17199
17200 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17201
17202 when Pragma_Linker_Options => Linker_Options : declare
17203 Arg : Node_Id;
17204
17205 begin
17206 Check_Ada_83_Warning;
17207 Check_No_Identifiers;
17208 Check_Arg_Count (1);
17209 Check_Is_In_Decl_Part_Or_Package_Spec;
17210 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17211 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
17212
17213 Arg := Arg2;
17214 while Present (Arg) loop
17215 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17216 Store_String_Char (ASCII.NUL);
17217 Store_String_Chars
17218 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
17219 Arg := Next (Arg);
17220 end loop;
17221
17222 if Operating_Mode = Generate_Code
17223 and then In_Extended_Main_Source_Unit (N)
17224 then
17225 Store_Linker_Option_String (End_String);
17226 end if;
17227 end Linker_Options;
17228
17229 --------------------
17230 -- Linker_Section --
17231 --------------------
17232
17233 -- pragma Linker_Section (
17234 -- [Entity =>] LOCAL_NAME
17235 -- [Section =>] static_string_EXPRESSION);
17236
17237 when Pragma_Linker_Section => Linker_Section : declare
17238 Arg : Node_Id;
17239 Ent : Entity_Id;
17240 LPE : Node_Id;
17241
17242 Ghost_Error_Posted : Boolean := False;
17243 -- Flag set when an error concerning the illegal mix of Ghost and
17244 -- non-Ghost subprograms is emitted.
17245
17246 Ghost_Id : Entity_Id := Empty;
17247 -- The entity of the first Ghost subprogram encountered while
17248 -- processing the arguments of the pragma.
17249
17250 begin
17251 GNAT_Pragma;
17252 Check_Arg_Order ((Name_Entity, Name_Section));
17253 Check_Arg_Count (2);
17254 Check_Optional_Identifier (Arg1, Name_Entity);
17255 Check_Optional_Identifier (Arg2, Name_Section);
17256 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17257 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17258
17259 -- Check kind of entity
17260
17261 Arg := Get_Pragma_Arg (Arg1);
17262 Ent := Entity (Arg);
17263
17264 case Ekind (Ent) is
17265
17266 -- Objects (constants and variables) and types. For these cases
17267 -- all we need to do is to set the Linker_Section_pragma field,
17268 -- checking that we do not have a duplicate.
17269
17270 when E_Constant | E_Variable | Type_Kind =>
17271 LPE := Linker_Section_Pragma (Ent);
17272
17273 if Present (LPE) then
17274 Error_Msg_Sloc := Sloc (LPE);
17275 Error_Msg_NE
17276 ("Linker_Section already specified for &#", Arg1, Ent);
17277 end if;
17278
17279 Set_Linker_Section_Pragma (Ent, N);
17280
17281 -- A pragma that applies to a Ghost entity becomes Ghost for
17282 -- the purposes of legality checks and removal of ignored
17283 -- Ghost code.
17284
17285 Mark_Pragma_As_Ghost (N, Ent);
17286
17287 -- Subprograms
17288
17289 when Subprogram_Kind =>
17290
17291 -- Aspect case, entity already set
17292
17293 if From_Aspect_Specification (N) then
17294 Set_Linker_Section_Pragma
17295 (Entity (Corresponding_Aspect (N)), N);
17296
17297 -- Pragma case, we must climb the homonym chain, but skip
17298 -- any for which the linker section is already set.
17299
17300 else
17301 loop
17302 if No (Linker_Section_Pragma (Ent)) then
17303 Set_Linker_Section_Pragma (Ent, N);
17304
17305 -- A pragma that applies to a Ghost entity becomes
17306 -- Ghost for the purposes of legality checks and
17307 -- removal of ignored Ghost code.
17308
17309 Mark_Pragma_As_Ghost (N, Ent);
17310
17311 -- Capture the entity of the first Ghost subprogram
17312 -- being processed for error detection purposes.
17313
17314 if Is_Ghost_Entity (Ent) then
17315 if No (Ghost_Id) then
17316 Ghost_Id := Ent;
17317 end if;
17318
17319 -- Otherwise the subprogram is non-Ghost. It is
17320 -- illegal to mix references to Ghost and non-Ghost
17321 -- entities (SPARK RM 6.9).
17322
17323 elsif Present (Ghost_Id)
17324 and then not Ghost_Error_Posted
17325 then
17326 Ghost_Error_Posted := True;
17327
17328 Error_Msg_Name_1 := Pname;
17329 Error_Msg_N
17330 ("pragma % cannot mention ghost and "
17331 & "non-ghost subprograms", N);
17332
17333 Error_Msg_Sloc := Sloc (Ghost_Id);
17334 Error_Msg_NE
17335 ("\& # declared as ghost", N, Ghost_Id);
17336
17337 Error_Msg_Sloc := Sloc (Ent);
17338 Error_Msg_NE
17339 ("\& # declared as non-ghost", N, Ent);
17340 end if;
17341 end if;
17342
17343 Ent := Homonym (Ent);
17344 exit when No (Ent)
17345 or else Scope (Ent) /= Current_Scope;
17346 end loop;
17347 end if;
17348
17349 -- All other cases are illegal
17350
17351 when others =>
17352 Error_Pragma_Arg
17353 ("pragma% applies only to objects, subprograms, and types",
17354 Arg1);
17355 end case;
17356 end Linker_Section;
17357
17358 ----------
17359 -- List --
17360 ----------
17361
17362 -- pragma List (On | Off)
17363
17364 -- There is nothing to do here, since we did all the processing for
17365 -- this pragma in Par.Prag (so that it works properly even in syntax
17366 -- only mode).
17367
17368 when Pragma_List =>
17369 null;
17370
17371 ---------------
17372 -- Lock_Free --
17373 ---------------
17374
17375 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17376
17377 when Pragma_Lock_Free => Lock_Free : declare
17378 P : constant Node_Id := Parent (N);
17379 Arg : Node_Id;
17380 Ent : Entity_Id;
17381 Val : Boolean;
17382
17383 begin
17384 Check_No_Identifiers;
17385 Check_At_Most_N_Arguments (1);
17386
17387 -- Protected definition case
17388
17389 if Nkind (P) = N_Protected_Definition then
17390 Ent := Defining_Identifier (Parent (P));
17391
17392 -- One argument
17393
17394 if Arg_Count = 1 then
17395 Arg := Get_Pragma_Arg (Arg1);
17396 Val := Is_True (Static_Boolean (Arg));
17397
17398 -- No arguments (expression is considered to be True)
17399
17400 else
17401 Val := True;
17402 end if;
17403
17404 -- Check duplicate pragma before we chain the pragma in the Rep
17405 -- Item chain of Ent.
17406
17407 Check_Duplicate_Pragma (Ent);
17408 Record_Rep_Item (Ent, N);
17409 Set_Uses_Lock_Free (Ent, Val);
17410
17411 -- Anything else is incorrect placement
17412
17413 else
17414 Pragma_Misplaced;
17415 end if;
17416 end Lock_Free;
17417
17418 --------------------
17419 -- Locking_Policy --
17420 --------------------
17421
17422 -- pragma Locking_Policy (policy_IDENTIFIER);
17423
17424 when Pragma_Locking_Policy => declare
17425 subtype LP_Range is Name_Id
17426 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17427 LP_Val : LP_Range;
17428 LP : Character;
17429
17430 begin
17431 Check_Ada_83_Warning;
17432 Check_Arg_Count (1);
17433 Check_No_Identifiers;
17434 Check_Arg_Is_Locking_Policy (Arg1);
17435 Check_Valid_Configuration_Pragma;
17436 LP_Val := Chars (Get_Pragma_Arg (Arg1));
17437
17438 case LP_Val is
17439 when Name_Ceiling_Locking =>
17440 LP := 'C';
17441 when Name_Inheritance_Locking =>
17442 LP := 'I';
17443 when Name_Concurrent_Readers_Locking =>
17444 LP := 'R';
17445 end case;
17446
17447 if Locking_Policy /= ' '
17448 and then Locking_Policy /= LP
17449 then
17450 Error_Msg_Sloc := Locking_Policy_Sloc;
17451 Error_Pragma ("locking policy incompatible with policy#");
17452
17453 -- Set new policy, but always preserve System_Location since we
17454 -- like the error message with the run time name.
17455
17456 else
17457 Locking_Policy := LP;
17458
17459 if Locking_Policy_Sloc /= System_Location then
17460 Locking_Policy_Sloc := Loc;
17461 end if;
17462 end if;
17463 end;
17464
17465 -------------------
17466 -- Loop_Optimize --
17467 -------------------
17468
17469 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17470
17471 -- OPTIMIZATION_HINT ::=
17472 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17473
17474 when Pragma_Loop_Optimize => Loop_Optimize : declare
17475 Hint : Node_Id;
17476
17477 begin
17478 GNAT_Pragma;
17479 Check_At_Least_N_Arguments (1);
17480 Check_No_Identifiers;
17481
17482 Hint := First (Pragma_Argument_Associations (N));
17483 while Present (Hint) loop
17484 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17485 Name_No_Unroll,
17486 Name_Unroll,
17487 Name_No_Vector,
17488 Name_Vector);
17489 Next (Hint);
17490 end loop;
17491
17492 Check_Loop_Pragma_Placement;
17493 end Loop_Optimize;
17494
17495 ------------------
17496 -- Loop_Variant --
17497 ------------------
17498
17499 -- pragma Loop_Variant
17500 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17501
17502 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17503
17504 -- CHANGE_DIRECTION ::= Increases | Decreases
17505
17506 when Pragma_Loop_Variant => Loop_Variant : declare
17507 Variant : Node_Id;
17508
17509 begin
17510 GNAT_Pragma;
17511 Check_At_Least_N_Arguments (1);
17512 Check_Loop_Pragma_Placement;
17513
17514 -- Process all increasing / decreasing expressions
17515
17516 Variant := First (Pragma_Argument_Associations (N));
17517 while Present (Variant) loop
17518 if not Nam_In (Chars (Variant), Name_Decreases,
17519 Name_Increases)
17520 then
17521 Error_Pragma_Arg ("wrong change modifier", Variant);
17522 end if;
17523
17524 Preanalyze_Assert_Expression
17525 (Expression (Variant), Any_Discrete);
17526
17527 Next (Variant);
17528 end loop;
17529 end Loop_Variant;
17530
17531 -----------------------
17532 -- Machine_Attribute --
17533 -----------------------
17534
17535 -- pragma Machine_Attribute (
17536 -- [Entity =>] LOCAL_NAME,
17537 -- [Attribute_Name =>] static_string_EXPRESSION
17538 -- [, [Info =>] static_EXPRESSION] );
17539
17540 when Pragma_Machine_Attribute => Machine_Attribute : declare
17541 Def_Id : Entity_Id;
17542
17543 begin
17544 GNAT_Pragma;
17545 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17546
17547 if Arg_Count = 3 then
17548 Check_Optional_Identifier (Arg3, Name_Info);
17549 Check_Arg_Is_OK_Static_Expression (Arg3);
17550 else
17551 Check_Arg_Count (2);
17552 end if;
17553
17554 Check_Optional_Identifier (Arg1, Name_Entity);
17555 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17556 Check_Arg_Is_Local_Name (Arg1);
17557 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17558 Def_Id := Entity (Get_Pragma_Arg (Arg1));
17559
17560 if Is_Access_Type (Def_Id) then
17561 Def_Id := Designated_Type (Def_Id);
17562 end if;
17563
17564 if Rep_Item_Too_Early (Def_Id, N) then
17565 return;
17566 end if;
17567
17568 Def_Id := Underlying_Type (Def_Id);
17569
17570 -- The only processing required is to link this item on to the
17571 -- list of rep items for the given entity. This is accomplished
17572 -- by the call to Rep_Item_Too_Late (when no error is detected
17573 -- and False is returned).
17574
17575 if Rep_Item_Too_Late (Def_Id, N) then
17576 return;
17577 else
17578 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17579 end if;
17580 end Machine_Attribute;
17581
17582 ----------
17583 -- Main --
17584 ----------
17585
17586 -- pragma Main
17587 -- (MAIN_OPTION [, MAIN_OPTION]);
17588
17589 -- MAIN_OPTION ::=
17590 -- [STACK_SIZE =>] static_integer_EXPRESSION
17591 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17592 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17593
17594 when Pragma_Main => Main : declare
17595 Args : Args_List (1 .. 3);
17596 Names : constant Name_List (1 .. 3) := (
17597 Name_Stack_Size,
17598 Name_Task_Stack_Size_Default,
17599 Name_Time_Slicing_Enabled);
17600
17601 Nod : Node_Id;
17602
17603 begin
17604 GNAT_Pragma;
17605 Gather_Associations (Names, Args);
17606
17607 for J in 1 .. 2 loop
17608 if Present (Args (J)) then
17609 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17610 end if;
17611 end loop;
17612
17613 if Present (Args (3)) then
17614 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17615 end if;
17616
17617 Nod := Next (N);
17618 while Present (Nod) loop
17619 if Nkind (Nod) = N_Pragma
17620 and then Pragma_Name (Nod) = Name_Main
17621 then
17622 Error_Msg_Name_1 := Pname;
17623 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17624 end if;
17625
17626 Next (Nod);
17627 end loop;
17628 end Main;
17629
17630 ------------------
17631 -- Main_Storage --
17632 ------------------
17633
17634 -- pragma Main_Storage
17635 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17636
17637 -- MAIN_STORAGE_OPTION ::=
17638 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17639 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17640
17641 when Pragma_Main_Storage => Main_Storage : declare
17642 Args : Args_List (1 .. 2);
17643 Names : constant Name_List (1 .. 2) := (
17644 Name_Working_Storage,
17645 Name_Top_Guard);
17646
17647 Nod : Node_Id;
17648
17649 begin
17650 GNAT_Pragma;
17651 Gather_Associations (Names, Args);
17652
17653 for J in 1 .. 2 loop
17654 if Present (Args (J)) then
17655 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17656 end if;
17657 end loop;
17658
17659 Check_In_Main_Program;
17660
17661 Nod := Next (N);
17662 while Present (Nod) loop
17663 if Nkind (Nod) = N_Pragma
17664 and then Pragma_Name (Nod) = Name_Main_Storage
17665 then
17666 Error_Msg_Name_1 := Pname;
17667 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17668 end if;
17669
17670 Next (Nod);
17671 end loop;
17672 end Main_Storage;
17673
17674 -----------------
17675 -- Memory_Size --
17676 -----------------
17677
17678 -- pragma Memory_Size (NUMERIC_LITERAL)
17679
17680 when Pragma_Memory_Size =>
17681 GNAT_Pragma;
17682
17683 -- Memory size is simply ignored
17684
17685 Check_No_Identifiers;
17686 Check_Arg_Count (1);
17687 Check_Arg_Is_Integer_Literal (Arg1);
17688
17689 -------------
17690 -- No_Body --
17691 -------------
17692
17693 -- pragma No_Body;
17694
17695 -- The only correct use of this pragma is on its own in a file, in
17696 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17697 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17698 -- check for a file containing nothing but a No_Body pragma). If we
17699 -- attempt to process it during normal semantics processing, it means
17700 -- it was misplaced.
17701
17702 when Pragma_No_Body =>
17703 GNAT_Pragma;
17704 Pragma_Misplaced;
17705
17706 -----------------------------
17707 -- No_Elaboration_Code_All --
17708 -----------------------------
17709
17710 -- pragma No_Elaboration_Code_All;
17711
17712 when Pragma_No_Elaboration_Code_All =>
17713 GNAT_Pragma;
17714 Check_Valid_Library_Unit_Pragma;
17715
17716 if Nkind (N) = N_Null_Statement then
17717 return;
17718 end if;
17719
17720 -- Must appear for a spec or generic spec
17721
17722 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
17723 N_Generic_Package_Declaration,
17724 N_Generic_Subprogram_Declaration,
17725 N_Package_Declaration,
17726 N_Subprogram_Declaration)
17727 then
17728 Error_Pragma
17729 (Fix_Error
17730 ("pragma% can only occur for package "
17731 & "or subprogram spec"));
17732 end if;
17733
17734 -- Set flag in unit table
17735
17736 Set_No_Elab_Code_All (Current_Sem_Unit);
17737
17738 -- Set restriction No_Elaboration_Code if this is the main unit
17739
17740 if Current_Sem_Unit = Main_Unit then
17741 Set_Restriction (No_Elaboration_Code, N);
17742 end if;
17743
17744 -- If we are in the main unit or in an extended main source unit,
17745 -- then we also add it to the configuration restrictions so that
17746 -- it will apply to all units in the extended main source.
17747
17748 if Current_Sem_Unit = Main_Unit
17749 or else In_Extended_Main_Source_Unit (N)
17750 then
17751 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
17752 end if;
17753
17754 -- If in main extended unit, activate transitive with test
17755
17756 if In_Extended_Main_Source_Unit (N) then
17757 Opt.No_Elab_Code_All_Pragma := N;
17758 end if;
17759
17760 ---------------
17761 -- No_Inline --
17762 ---------------
17763
17764 -- pragma No_Inline ( NAME {, NAME} );
17765
17766 when Pragma_No_Inline =>
17767 GNAT_Pragma;
17768 Process_Inline (Suppressed);
17769
17770 ---------------
17771 -- No_Return --
17772 ---------------
17773
17774 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17775
17776 when Pragma_No_Return => No_Return : declare
17777 Arg : Node_Id;
17778 E : Entity_Id;
17779 Found : Boolean;
17780 Id : Node_Id;
17781
17782 Ghost_Error_Posted : Boolean := False;
17783 -- Flag set when an error concerning the illegal mix of Ghost and
17784 -- non-Ghost subprograms is emitted.
17785
17786 Ghost_Id : Entity_Id := Empty;
17787 -- The entity of the first Ghost procedure encountered while
17788 -- processing the arguments of the pragma.
17789
17790 begin
17791 Ada_2005_Pragma;
17792 Check_At_Least_N_Arguments (1);
17793
17794 -- Loop through arguments of pragma
17795
17796 Arg := Arg1;
17797 while Present (Arg) loop
17798 Check_Arg_Is_Local_Name (Arg);
17799 Id := Get_Pragma_Arg (Arg);
17800 Analyze (Id);
17801
17802 if not Is_Entity_Name (Id) then
17803 Error_Pragma_Arg ("entity name required", Arg);
17804 end if;
17805
17806 if Etype (Id) = Any_Type then
17807 raise Pragma_Exit;
17808 end if;
17809
17810 -- Loop to find matching procedures
17811
17812 E := Entity (Id);
17813
17814 Found := False;
17815 while Present (E)
17816 and then Scope (E) = Current_Scope
17817 loop
17818 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
17819 Set_No_Return (E);
17820
17821 -- A pragma that applies to a Ghost entity becomes Ghost
17822 -- for the purposes of legality checks and removal of
17823 -- ignored Ghost code.
17824
17825 Mark_Pragma_As_Ghost (N, E);
17826
17827 -- Capture the entity of the first Ghost procedure being
17828 -- processed for error detection purposes.
17829
17830 if Is_Ghost_Entity (E) then
17831 if No (Ghost_Id) then
17832 Ghost_Id := E;
17833 end if;
17834
17835 -- Otherwise the subprogram is non-Ghost. It is illegal
17836 -- to mix references to Ghost and non-Ghost entities
17837 -- (SPARK RM 6.9).
17838
17839 elsif Present (Ghost_Id)
17840 and then not Ghost_Error_Posted
17841 then
17842 Ghost_Error_Posted := True;
17843
17844 Error_Msg_Name_1 := Pname;
17845 Error_Msg_N
17846 ("pragma % cannot mention ghost and non-ghost "
17847 & "procedures", N);
17848
17849 Error_Msg_Sloc := Sloc (Ghost_Id);
17850 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
17851
17852 Error_Msg_Sloc := Sloc (E);
17853 Error_Msg_NE ("\& # declared as non-ghost", N, E);
17854 end if;
17855
17856 -- Set flag on any alias as well
17857
17858 if Is_Overloadable (E) and then Present (Alias (E)) then
17859 Set_No_Return (Alias (E));
17860 end if;
17861
17862 Found := True;
17863 end if;
17864
17865 exit when From_Aspect_Specification (N);
17866 E := Homonym (E);
17867 end loop;
17868
17869 -- If entity in not in current scope it may be the enclosing
17870 -- suprogram body to which the aspect applies.
17871
17872 if not Found then
17873 if Entity (Id) = Current_Scope
17874 and then From_Aspect_Specification (N)
17875 then
17876 Set_No_Return (Entity (Id));
17877 else
17878 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17879 end if;
17880 end if;
17881
17882 Next (Arg);
17883 end loop;
17884 end No_Return;
17885
17886 -----------------
17887 -- No_Run_Time --
17888 -----------------
17889
17890 -- pragma No_Run_Time;
17891
17892 -- Note: this pragma is retained for backwards compatibility. See
17893 -- body of Rtsfind for full details on its handling.
17894
17895 when Pragma_No_Run_Time =>
17896 GNAT_Pragma;
17897 Check_Valid_Configuration_Pragma;
17898 Check_Arg_Count (0);
17899
17900 -- Remove backward compatibility if Build_Type is FSF or GPL and
17901 -- generate a warning.
17902
17903 declare
17904 Ignore : constant Boolean := Build_Type in FSF .. GPL;
17905 begin
17906 if Ignore then
17907 Error_Pragma ("pragma% is ignored, has no effect??");
17908 else
17909 No_Run_Time_Mode := True;
17910 Configurable_Run_Time_Mode := True;
17911
17912 -- Set Duration to 32 bits if word size is 32
17913
17914 if Ttypes.System_Word_Size = 32 then
17915 Duration_32_Bits_On_Target := True;
17916 end if;
17917
17918 -- Set appropriate restrictions
17919
17920 Set_Restriction (No_Finalization, N);
17921 Set_Restriction (No_Exception_Handlers, N);
17922 Set_Restriction (Max_Tasks, N, 0);
17923 Set_Restriction (No_Tasking, N);
17924 end if;
17925 end;
17926
17927 -----------------------
17928 -- No_Tagged_Streams --
17929 -----------------------
17930
17931 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
17932
17933 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
17934 E : Entity_Id;
17935 E_Id : Node_Id;
17936
17937 begin
17938 GNAT_Pragma;
17939 Check_At_Most_N_Arguments (1);
17940
17941 -- One argument case
17942
17943 if Arg_Count = 1 then
17944 Check_Optional_Identifier (Arg1, Name_Entity);
17945 Check_Arg_Is_Local_Name (Arg1);
17946 E_Id := Get_Pragma_Arg (Arg1);
17947
17948 if Etype (E_Id) = Any_Type then
17949 return;
17950 end if;
17951
17952 E := Entity (E_Id);
17953
17954 Check_Duplicate_Pragma (E);
17955
17956 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
17957 Error_Pragma_Arg
17958 ("argument for pragma% must be root tagged type", Arg1);
17959 end if;
17960
17961 if Rep_Item_Too_Early (E, N)
17962 or else
17963 Rep_Item_Too_Late (E, N)
17964 then
17965 return;
17966 else
17967 Set_No_Tagged_Streams_Pragma (E, N);
17968 end if;
17969
17970 -- Zero argument case
17971
17972 else
17973 Check_Is_In_Decl_Part_Or_Package_Spec;
17974 No_Tagged_Streams := N;
17975 end if;
17976 end No_Tagged_Strms;
17977
17978 ------------------------
17979 -- No_Strict_Aliasing --
17980 ------------------------
17981
17982 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17983
17984 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
17985 E_Id : Entity_Id;
17986
17987 begin
17988 GNAT_Pragma;
17989 Check_At_Most_N_Arguments (1);
17990
17991 if Arg_Count = 0 then
17992 Check_Valid_Configuration_Pragma;
17993 Opt.No_Strict_Aliasing := True;
17994
17995 else
17996 Check_Optional_Identifier (Arg2, Name_Entity);
17997 Check_Arg_Is_Local_Name (Arg1);
17998 E_Id := Entity (Get_Pragma_Arg (Arg1));
17999
18000 if E_Id = Any_Type then
18001 return;
18002 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
18003 Error_Pragma_Arg ("pragma% requires access type", Arg1);
18004 end if;
18005
18006 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
18007 end if;
18008 end No_Strict_Aliasing;
18009
18010 -----------------------
18011 -- Normalize_Scalars --
18012 -----------------------
18013
18014 -- pragma Normalize_Scalars;
18015
18016 when Pragma_Normalize_Scalars =>
18017 Check_Ada_83_Warning;
18018 Check_Arg_Count (0);
18019 Check_Valid_Configuration_Pragma;
18020
18021 -- Normalize_Scalars creates false positives in CodePeer, and
18022 -- incorrect negative results in GNATprove mode, so ignore this
18023 -- pragma in these modes.
18024
18025 if not (CodePeer_Mode or GNATprove_Mode) then
18026 Normalize_Scalars := True;
18027 Init_Or_Norm_Scalars := True;
18028 end if;
18029
18030 -----------------
18031 -- Obsolescent --
18032 -----------------
18033
18034 -- pragma Obsolescent;
18035
18036 -- pragma Obsolescent (
18037 -- [Message =>] static_string_EXPRESSION
18038 -- [,[Version =>] Ada_05]]);
18039
18040 -- pragma Obsolescent (
18041 -- [Entity =>] NAME
18042 -- [,[Message =>] static_string_EXPRESSION
18043 -- [,[Version =>] Ada_05]] );
18044
18045 when Pragma_Obsolescent => Obsolescent : declare
18046 Decl : Node_Id;
18047 Ename : Node_Id;
18048
18049 procedure Set_Obsolescent (E : Entity_Id);
18050 -- Given an entity Ent, mark it as obsolescent if appropriate
18051
18052 ---------------------
18053 -- Set_Obsolescent --
18054 ---------------------
18055
18056 procedure Set_Obsolescent (E : Entity_Id) is
18057 Active : Boolean;
18058 Ent : Entity_Id;
18059 S : String_Id;
18060
18061 begin
18062 Active := True;
18063 Ent := E;
18064
18065 -- A pragma that applies to a Ghost entity becomes Ghost for
18066 -- the purposes of legality checks and removal of ignored Ghost
18067 -- code.
18068
18069 Mark_Pragma_As_Ghost (N, E);
18070
18071 -- Entity name was given
18072
18073 if Present (Ename) then
18074
18075 -- If entity name matches, we are fine. Save entity in
18076 -- pragma argument, for ASIS use.
18077
18078 if Chars (Ename) = Chars (Ent) then
18079 Set_Entity (Ename, Ent);
18080 Generate_Reference (Ent, Ename);
18081
18082 -- If entity name does not match, only possibility is an
18083 -- enumeration literal from an enumeration type declaration.
18084
18085 elsif Ekind (Ent) /= E_Enumeration_Type then
18086 Error_Pragma
18087 ("pragma % entity name does not match declaration");
18088
18089 else
18090 Ent := First_Literal (E);
18091 loop
18092 if No (Ent) then
18093 Error_Pragma
18094 ("pragma % entity name does not match any "
18095 & "enumeration literal");
18096
18097 elsif Chars (Ent) = Chars (Ename) then
18098 Set_Entity (Ename, Ent);
18099 Generate_Reference (Ent, Ename);
18100 exit;
18101
18102 else
18103 Ent := Next_Literal (Ent);
18104 end if;
18105 end loop;
18106 end if;
18107 end if;
18108
18109 -- Ent points to entity to be marked
18110
18111 if Arg_Count >= 1 then
18112
18113 -- Deal with static string argument
18114
18115 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18116 S := Strval (Get_Pragma_Arg (Arg1));
18117
18118 for J in 1 .. String_Length (S) loop
18119 if not In_Character_Range (Get_String_Char (S, J)) then
18120 Error_Pragma_Arg
18121 ("pragma% argument does not allow wide characters",
18122 Arg1);
18123 end if;
18124 end loop;
18125
18126 Obsolescent_Warnings.Append
18127 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
18128
18129 -- Check for Ada_05 parameter
18130
18131 if Arg_Count /= 1 then
18132 Check_Arg_Count (2);
18133
18134 declare
18135 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
18136
18137 begin
18138 Check_Arg_Is_Identifier (Argx);
18139
18140 if Chars (Argx) /= Name_Ada_05 then
18141 Error_Msg_Name_2 := Name_Ada_05;
18142 Error_Pragma_Arg
18143 ("only allowed argument for pragma% is %", Argx);
18144 end if;
18145
18146 if Ada_Version_Explicit < Ada_2005
18147 or else not Warn_On_Ada_2005_Compatibility
18148 then
18149 Active := False;
18150 end if;
18151 end;
18152 end if;
18153 end if;
18154
18155 -- Set flag if pragma active
18156
18157 if Active then
18158 Set_Is_Obsolescent (Ent);
18159 end if;
18160
18161 return;
18162 end Set_Obsolescent;
18163
18164 -- Start of processing for pragma Obsolescent
18165
18166 begin
18167 GNAT_Pragma;
18168
18169 Check_At_Most_N_Arguments (3);
18170
18171 -- See if first argument specifies an entity name
18172
18173 if Arg_Count >= 1
18174 and then
18175 (Chars (Arg1) = Name_Entity
18176 or else
18177 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
18178 N_Identifier,
18179 N_Operator_Symbol))
18180 then
18181 Ename := Get_Pragma_Arg (Arg1);
18182
18183 -- Eliminate first argument, so we can share processing
18184
18185 Arg1 := Arg2;
18186 Arg2 := Arg3;
18187 Arg_Count := Arg_Count - 1;
18188
18189 -- No Entity name argument given
18190
18191 else
18192 Ename := Empty;
18193 end if;
18194
18195 if Arg_Count >= 1 then
18196 Check_Optional_Identifier (Arg1, Name_Message);
18197
18198 if Arg_Count = 2 then
18199 Check_Optional_Identifier (Arg2, Name_Version);
18200 end if;
18201 end if;
18202
18203 -- Get immediately preceding declaration
18204
18205 Decl := Prev (N);
18206 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
18207 Prev (Decl);
18208 end loop;
18209
18210 -- Cases where we do not follow anything other than another pragma
18211
18212 if No (Decl) then
18213
18214 -- First case: library level compilation unit declaration with
18215 -- the pragma immediately following the declaration.
18216
18217 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
18218 Set_Obsolescent
18219 (Defining_Entity (Unit (Parent (Parent (N)))));
18220 return;
18221
18222 -- Case 2: library unit placement for package
18223
18224 else
18225 declare
18226 Ent : constant Entity_Id := Find_Lib_Unit_Name;
18227 begin
18228 if Is_Package_Or_Generic_Package (Ent) then
18229 Set_Obsolescent (Ent);
18230 return;
18231 end if;
18232 end;
18233 end if;
18234
18235 -- Cases where we must follow a declaration, including an
18236 -- abstract subprogram declaration, which is not in the
18237 -- other node subtypes.
18238
18239 else
18240 if Nkind (Decl) not in N_Declaration
18241 and then Nkind (Decl) not in N_Later_Decl_Item
18242 and then Nkind (Decl) not in N_Generic_Declaration
18243 and then Nkind (Decl) not in N_Renaming_Declaration
18244 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
18245 then
18246 Error_Pragma
18247 ("pragma% misplaced, "
18248 & "must immediately follow a declaration");
18249
18250 else
18251 Set_Obsolescent (Defining_Entity (Decl));
18252 return;
18253 end if;
18254 end if;
18255 end Obsolescent;
18256
18257 --------------
18258 -- Optimize --
18259 --------------
18260
18261 -- pragma Optimize (Time | Space | Off);
18262
18263 -- The actual check for optimize is done in Gigi. Note that this
18264 -- pragma does not actually change the optimization setting, it
18265 -- simply checks that it is consistent with the pragma.
18266
18267 when Pragma_Optimize =>
18268 Check_No_Identifiers;
18269 Check_Arg_Count (1);
18270 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
18271
18272 ------------------------
18273 -- Optimize_Alignment --
18274 ------------------------
18275
18276 -- pragma Optimize_Alignment (Time | Space | Off);
18277
18278 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
18279 GNAT_Pragma;
18280 Check_No_Identifiers;
18281 Check_Arg_Count (1);
18282 Check_Valid_Configuration_Pragma;
18283
18284 declare
18285 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
18286 begin
18287 case Nam is
18288 when Name_Time =>
18289 Opt.Optimize_Alignment := 'T';
18290 when Name_Space =>
18291 Opt.Optimize_Alignment := 'S';
18292 when Name_Off =>
18293 Opt.Optimize_Alignment := 'O';
18294 when others =>
18295 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
18296 end case;
18297 end;
18298
18299 -- Set indication that mode is set locally. If we are in fact in a
18300 -- configuration pragma file, this setting is harmless since the
18301 -- switch will get reset anyway at the start of each unit.
18302
18303 Optimize_Alignment_Local := True;
18304 end Optimize_Alignment;
18305
18306 -------------
18307 -- Ordered --
18308 -------------
18309
18310 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18311
18312 when Pragma_Ordered => Ordered : declare
18313 Assoc : constant Node_Id := Arg1;
18314 Type_Id : Node_Id;
18315 Typ : Entity_Id;
18316
18317 begin
18318 GNAT_Pragma;
18319 Check_No_Identifiers;
18320 Check_Arg_Count (1);
18321 Check_Arg_Is_Local_Name (Arg1);
18322
18323 Type_Id := Get_Pragma_Arg (Assoc);
18324 Find_Type (Type_Id);
18325 Typ := Entity (Type_Id);
18326
18327 if Typ = Any_Type then
18328 return;
18329 else
18330 Typ := Underlying_Type (Typ);
18331 end if;
18332
18333 if not Is_Enumeration_Type (Typ) then
18334 Error_Pragma ("pragma% must specify enumeration type");
18335 end if;
18336
18337 Check_First_Subtype (Arg1);
18338 Set_Has_Pragma_Ordered (Base_Type (Typ));
18339 end Ordered;
18340
18341 -------------------
18342 -- Overflow_Mode --
18343 -------------------
18344
18345 -- pragma Overflow_Mode
18346 -- ([General => ] MODE [, [Assertions => ] MODE]);
18347
18348 -- MODE := STRICT | MINIMIZED | ELIMINATED
18349
18350 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18351 -- since System.Bignums makes this assumption. This is true of nearly
18352 -- all (all?) targets.
18353
18354 when Pragma_Overflow_Mode => Overflow_Mode : declare
18355 function Get_Overflow_Mode
18356 (Name : Name_Id;
18357 Arg : Node_Id) return Overflow_Mode_Type;
18358 -- Function to process one pragma argument, Arg. If an identifier
18359 -- is present, it must be Name. Mode type is returned if a valid
18360 -- argument exists, otherwise an error is signalled.
18361
18362 -----------------------
18363 -- Get_Overflow_Mode --
18364 -----------------------
18365
18366 function Get_Overflow_Mode
18367 (Name : Name_Id;
18368 Arg : Node_Id) return Overflow_Mode_Type
18369 is
18370 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
18371
18372 begin
18373 Check_Optional_Identifier (Arg, Name);
18374 Check_Arg_Is_Identifier (Argx);
18375
18376 if Chars (Argx) = Name_Strict then
18377 return Strict;
18378
18379 elsif Chars (Argx) = Name_Minimized then
18380 return Minimized;
18381
18382 elsif Chars (Argx) = Name_Eliminated then
18383 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18384 Error_Pragma_Arg
18385 ("Eliminated not implemented on this target", Argx);
18386 else
18387 return Eliminated;
18388 end if;
18389
18390 else
18391 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18392 end if;
18393 end Get_Overflow_Mode;
18394
18395 -- Start of processing for Overflow_Mode
18396
18397 begin
18398 GNAT_Pragma;
18399 Check_At_Least_N_Arguments (1);
18400 Check_At_Most_N_Arguments (2);
18401
18402 -- Process first argument
18403
18404 Scope_Suppress.Overflow_Mode_General :=
18405 Get_Overflow_Mode (Name_General, Arg1);
18406
18407 -- Case of only one argument
18408
18409 if Arg_Count = 1 then
18410 Scope_Suppress.Overflow_Mode_Assertions :=
18411 Scope_Suppress.Overflow_Mode_General;
18412
18413 -- Case of two arguments present
18414
18415 else
18416 Scope_Suppress.Overflow_Mode_Assertions :=
18417 Get_Overflow_Mode (Name_Assertions, Arg2);
18418 end if;
18419 end Overflow_Mode;
18420
18421 --------------------------
18422 -- Overriding Renamings --
18423 --------------------------
18424
18425 -- pragma Overriding_Renamings;
18426
18427 when Pragma_Overriding_Renamings =>
18428 GNAT_Pragma;
18429 Check_Arg_Count (0);
18430 Check_Valid_Configuration_Pragma;
18431 Overriding_Renamings := True;
18432
18433 ----------
18434 -- Pack --
18435 ----------
18436
18437 -- pragma Pack (first_subtype_LOCAL_NAME);
18438
18439 when Pragma_Pack => Pack : declare
18440 Assoc : constant Node_Id := Arg1;
18441 Ctyp : Entity_Id;
18442 Ignore : Boolean := False;
18443 Typ : Entity_Id;
18444 Type_Id : Node_Id;
18445
18446 begin
18447 Check_No_Identifiers;
18448 Check_Arg_Count (1);
18449 Check_Arg_Is_Local_Name (Arg1);
18450 Type_Id := Get_Pragma_Arg (Assoc);
18451
18452 if not Is_Entity_Name (Type_Id)
18453 or else not Is_Type (Entity (Type_Id))
18454 then
18455 Error_Pragma_Arg
18456 ("argument for pragma% must be type or subtype", Arg1);
18457 end if;
18458
18459 Find_Type (Type_Id);
18460 Typ := Entity (Type_Id);
18461
18462 if Typ = Any_Type
18463 or else Rep_Item_Too_Early (Typ, N)
18464 then
18465 return;
18466 else
18467 Typ := Underlying_Type (Typ);
18468 end if;
18469
18470 -- A pragma that applies to a Ghost entity becomes Ghost for the
18471 -- purposes of legality checks and removal of ignored Ghost code.
18472
18473 Mark_Pragma_As_Ghost (N, Typ);
18474
18475 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18476 Error_Pragma ("pragma% must specify array or record type");
18477 end if;
18478
18479 Check_First_Subtype (Arg1);
18480 Check_Duplicate_Pragma (Typ);
18481
18482 -- Array type
18483
18484 if Is_Array_Type (Typ) then
18485 Ctyp := Component_Type (Typ);
18486
18487 -- Ignore pack that does nothing
18488
18489 if Known_Static_Esize (Ctyp)
18490 and then Known_Static_RM_Size (Ctyp)
18491 and then Esize (Ctyp) = RM_Size (Ctyp)
18492 and then Addressable (Esize (Ctyp))
18493 then
18494 Ignore := True;
18495 end if;
18496
18497 -- Process OK pragma Pack. Note that if there is a separate
18498 -- component clause present, the Pack will be cancelled. This
18499 -- processing is in Freeze.
18500
18501 if not Rep_Item_Too_Late (Typ, N) then
18502
18503 -- In CodePeer mode, we do not need complex front-end
18504 -- expansions related to pragma Pack, so disable handling
18505 -- of pragma Pack.
18506
18507 if CodePeer_Mode then
18508 null;
18509
18510 -- Normal case where we do the pack action
18511
18512 else
18513 if not Ignore then
18514 Set_Is_Packed (Base_Type (Typ));
18515 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18516 end if;
18517
18518 Set_Has_Pragma_Pack (Base_Type (Typ));
18519 end if;
18520 end if;
18521
18522 -- For record types, the pack is always effective
18523
18524 else pragma Assert (Is_Record_Type (Typ));
18525 if not Rep_Item_Too_Late (Typ, N) then
18526 Set_Is_Packed (Base_Type (Typ));
18527 Set_Has_Pragma_Pack (Base_Type (Typ));
18528 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18529 end if;
18530 end if;
18531 end Pack;
18532
18533 ----------
18534 -- Page --
18535 ----------
18536
18537 -- pragma Page;
18538
18539 -- There is nothing to do here, since we did all the processing for
18540 -- this pragma in Par.Prag (so that it works properly even in syntax
18541 -- only mode).
18542
18543 when Pragma_Page =>
18544 null;
18545
18546 -------------
18547 -- Part_Of --
18548 -------------
18549
18550 -- pragma Part_Of (ABSTRACT_STATE);
18551
18552 -- ABSTRACT_STATE ::= NAME
18553
18554 when Pragma_Part_Of => Part_Of : declare
18555 procedure Propagate_Part_Of
18556 (Pack_Id : Entity_Id;
18557 State_Id : Entity_Id;
18558 Instance : Node_Id);
18559 -- Propagate the Part_Of indicator to all abstract states and
18560 -- objects declared in the visible state space of a package
18561 -- denoted by Pack_Id. State_Id is the encapsulating state.
18562 -- Instance is the package instantiation node.
18563
18564 -----------------------
18565 -- Propagate_Part_Of --
18566 -----------------------
18567
18568 procedure Propagate_Part_Of
18569 (Pack_Id : Entity_Id;
18570 State_Id : Entity_Id;
18571 Instance : Node_Id)
18572 is
18573 Has_Item : Boolean := False;
18574 -- Flag set when the visible state space contains at least one
18575 -- abstract state or variable.
18576
18577 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
18578 -- Propagate the Part_Of indicator to all abstract states and
18579 -- objects declared in the visible state space of a package
18580 -- denoted by Pack_Id.
18581
18582 -----------------------
18583 -- Propagate_Part_Of --
18584 -----------------------
18585
18586 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
18587 Constits : Elist_Id;
18588 Item_Id : Entity_Id;
18589
18590 begin
18591 -- Traverse the entity chain of the package and set relevant
18592 -- attributes of abstract states and objects declared in the
18593 -- visible state space of the package.
18594
18595 Item_Id := First_Entity (Pack_Id);
18596 while Present (Item_Id)
18597 and then not In_Private_Part (Item_Id)
18598 loop
18599 -- Do not consider internally generated items
18600
18601 if not Comes_From_Source (Item_Id) then
18602 null;
18603
18604 -- The Part_Of indicator turns an abstract state or an
18605 -- object into a constituent of the encapsulating state.
18606
18607 elsif Ekind_In (Item_Id, E_Abstract_State,
18608 E_Constant,
18609 E_Variable)
18610 then
18611 Has_Item := True;
18612 Constits := Part_Of_Constituents (State_Id);
18613
18614 if No (Constits) then
18615 Constits := New_Elmt_List;
18616 Set_Part_Of_Constituents (State_Id, Constits);
18617 end if;
18618
18619 Append_Elmt (Item_Id, Constits);
18620 Set_Encapsulating_State (Item_Id, State_Id);
18621
18622 -- Recursively handle nested packages and instantiations
18623
18624 elsif Ekind (Item_Id) = E_Package then
18625 Propagate_Part_Of (Item_Id);
18626 end if;
18627
18628 Next_Entity (Item_Id);
18629 end loop;
18630 end Propagate_Part_Of;
18631
18632 -- Start of processing for Propagate_Part_Of
18633
18634 begin
18635 Propagate_Part_Of (Pack_Id);
18636
18637 -- Detect a package instantiation that is subject to a Part_Of
18638 -- indicator, but has no visible state.
18639
18640 if not Has_Item then
18641 SPARK_Msg_NE
18642 ("package instantiation & has Part_Of indicator but "
18643 & "lacks visible state", Instance, Pack_Id);
18644 end if;
18645 end Propagate_Part_Of;
18646
18647 -- Local variables
18648
18649 Constits : Elist_Id;
18650 Encap : Node_Id;
18651 Encap_Id : Entity_Id;
18652 Item_Id : Entity_Id;
18653 Legal : Boolean;
18654 Stmt : Node_Id;
18655
18656 -- Start of processing for Part_Of
18657
18658 begin
18659 GNAT_Pragma;
18660 Check_No_Identifiers;
18661 Check_Arg_Count (1);
18662
18663 Stmt := Find_Related_Context (N, Do_Checks => True);
18664
18665 -- Object declaration
18666
18667 if Nkind (Stmt) = N_Object_Declaration then
18668 null;
18669
18670 -- Package instantiation
18671
18672 elsif Nkind (Stmt) = N_Package_Instantiation then
18673 null;
18674
18675 -- Single concurrent type declaration
18676
18677 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
18678 null;
18679
18680 -- Otherwise the pragma is associated with an illegal construct
18681
18682 else
18683 Pragma_Misplaced;
18684 return;
18685 end if;
18686
18687 -- Extract the entity of the related object declaration or package
18688 -- instantiation. In the case of the instantiation, use the entity
18689 -- of the instance spec.
18690
18691 if Nkind (Stmt) = N_Package_Instantiation then
18692 Stmt := Instance_Spec (Stmt);
18693 end if;
18694
18695 Item_Id := Defining_Entity (Stmt);
18696 Encap := Get_Pragma_Arg (Arg1);
18697
18698 -- A pragma that applies to a Ghost entity becomes Ghost for the
18699 -- purposes of legality checks and removal of ignored Ghost code.
18700
18701 Mark_Pragma_As_Ghost (N, Item_Id);
18702
18703 -- Chain the pragma on the contract for further processing by
18704 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18705
18706 Add_Contract_Item (N, Item_Id);
18707
18708 -- A variable may act as consituent of a single concurrent type
18709 -- which in turn could be declared after the variable. Due to this
18710 -- discrepancy, the full analysis of indicator Part_Of is delayed
18711 -- until the end of the enclosing declarative region (see routine
18712 -- Analyze_Part_Of_In_Decl_Part).
18713
18714 if Ekind (Item_Id) = E_Variable then
18715 null;
18716
18717 -- Otherwise indicator Part_Of applies to a constant or a package
18718 -- instantiation.
18719
18720 else
18721 -- Detect any discrepancies between the placement of the
18722 -- constant or package instantiation with respect to state
18723 -- space and the encapsulating state.
18724
18725 Analyze_Part_Of
18726 (Indic => N,
18727 Item_Id => Item_Id,
18728 Encap => Encap,
18729 Encap_Id => Encap_Id,
18730 Legal => Legal);
18731
18732 if Legal then
18733 pragma Assert (Present (Encap_Id));
18734
18735 if Ekind (Item_Id) = E_Constant then
18736 Constits := Part_Of_Constituents (Encap_Id);
18737
18738 if No (Constits) then
18739 Constits := New_Elmt_List;
18740 Set_Part_Of_Constituents (Encap_Id, Constits);
18741 end if;
18742
18743 Append_Elmt (Item_Id, Constits);
18744 Set_Encapsulating_State (Item_Id, Encap_Id);
18745
18746 -- Propagate the Part_Of indicator to the visible state
18747 -- space of the package instantiation.
18748
18749 else
18750 Propagate_Part_Of
18751 (Pack_Id => Item_Id,
18752 State_Id => Encap_Id,
18753 Instance => Stmt);
18754 end if;
18755 end if;
18756 end if;
18757 end Part_Of;
18758
18759 ----------------------------------
18760 -- Partition_Elaboration_Policy --
18761 ----------------------------------
18762
18763 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18764
18765 when Pragma_Partition_Elaboration_Policy => declare
18766 subtype PEP_Range is Name_Id
18767 range First_Partition_Elaboration_Policy_Name
18768 .. Last_Partition_Elaboration_Policy_Name;
18769 PEP_Val : PEP_Range;
18770 PEP : Character;
18771
18772 begin
18773 Ada_2005_Pragma;
18774 Check_Arg_Count (1);
18775 Check_No_Identifiers;
18776 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
18777 Check_Valid_Configuration_Pragma;
18778 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
18779
18780 case PEP_Val is
18781 when Name_Concurrent =>
18782 PEP := 'C';
18783 when Name_Sequential =>
18784 PEP := 'S';
18785 end case;
18786
18787 if Partition_Elaboration_Policy /= ' '
18788 and then Partition_Elaboration_Policy /= PEP
18789 then
18790 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
18791 Error_Pragma
18792 ("partition elaboration policy incompatible with policy#");
18793
18794 -- Set new policy, but always preserve System_Location since we
18795 -- like the error message with the run time name.
18796
18797 else
18798 Partition_Elaboration_Policy := PEP;
18799
18800 if Partition_Elaboration_Policy_Sloc /= System_Location then
18801 Partition_Elaboration_Policy_Sloc := Loc;
18802 end if;
18803 end if;
18804 end;
18805
18806 -------------
18807 -- Passive --
18808 -------------
18809
18810 -- pragma Passive [(PASSIVE_FORM)];
18811
18812 -- PASSIVE_FORM ::= Semaphore | No
18813
18814 when Pragma_Passive =>
18815 GNAT_Pragma;
18816
18817 if Nkind (Parent (N)) /= N_Task_Definition then
18818 Error_Pragma ("pragma% must be within task definition");
18819 end if;
18820
18821 if Arg_Count /= 0 then
18822 Check_Arg_Count (1);
18823 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
18824 end if;
18825
18826 ----------------------------------
18827 -- Preelaborable_Initialization --
18828 ----------------------------------
18829
18830 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18831
18832 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
18833 Ent : Entity_Id;
18834
18835 begin
18836 Ada_2005_Pragma;
18837 Check_Arg_Count (1);
18838 Check_No_Identifiers;
18839 Check_Arg_Is_Identifier (Arg1);
18840 Check_Arg_Is_Local_Name (Arg1);
18841 Check_First_Subtype (Arg1);
18842 Ent := Entity (Get_Pragma_Arg (Arg1));
18843
18844 -- A pragma that applies to a Ghost entity becomes Ghost for the
18845 -- purposes of legality checks and removal of ignored Ghost code.
18846
18847 Mark_Pragma_As_Ghost (N, Ent);
18848
18849 -- The pragma may come from an aspect on a private declaration,
18850 -- even if the freeze point at which this is analyzed in the
18851 -- private part after the full view.
18852
18853 if Has_Private_Declaration (Ent)
18854 and then From_Aspect_Specification (N)
18855 then
18856 null;
18857
18858 -- Check appropriate type argument
18859
18860 elsif Is_Private_Type (Ent)
18861 or else Is_Protected_Type (Ent)
18862 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
18863
18864 -- AI05-0028: The pragma applies to all composite types. Note
18865 -- that we apply this binding interpretation to earlier versions
18866 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18867 -- choice since there are other compilers that do the same.
18868
18869 or else Is_Composite_Type (Ent)
18870 then
18871 null;
18872
18873 else
18874 Error_Pragma_Arg
18875 ("pragma % can only be applied to private, formal derived, "
18876 & "protected, or composite type", Arg1);
18877 end if;
18878
18879 -- Give an error if the pragma is applied to a protected type that
18880 -- does not qualify (due to having entries, or due to components
18881 -- that do not qualify).
18882
18883 if Is_Protected_Type (Ent)
18884 and then not Has_Preelaborable_Initialization (Ent)
18885 then
18886 Error_Msg_N
18887 ("protected type & does not have preelaborable "
18888 & "initialization", Ent);
18889
18890 -- Otherwise mark the type as definitely having preelaborable
18891 -- initialization.
18892
18893 else
18894 Set_Known_To_Have_Preelab_Init (Ent);
18895 end if;
18896
18897 if Has_Pragma_Preelab_Init (Ent)
18898 and then Warn_On_Redundant_Constructs
18899 then
18900 Error_Pragma ("?r?duplicate pragma%!");
18901 else
18902 Set_Has_Pragma_Preelab_Init (Ent);
18903 end if;
18904 end Preelab_Init;
18905
18906 --------------------
18907 -- Persistent_BSS --
18908 --------------------
18909
18910 -- pragma Persistent_BSS [(object_NAME)];
18911
18912 when Pragma_Persistent_BSS => Persistent_BSS : declare
18913 Decl : Node_Id;
18914 Ent : Entity_Id;
18915 Prag : Node_Id;
18916
18917 begin
18918 GNAT_Pragma;
18919 Check_At_Most_N_Arguments (1);
18920
18921 -- Case of application to specific object (one argument)
18922
18923 if Arg_Count = 1 then
18924 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18925
18926 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18927 or else not
18928 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18929 E_Constant)
18930 then
18931 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18932 end if;
18933
18934 Ent := Entity (Get_Pragma_Arg (Arg1));
18935 Decl := Parent (Ent);
18936
18937 -- A pragma that applies to a Ghost entity becomes Ghost for
18938 -- the purposes of legality checks and removal of ignored Ghost
18939 -- code.
18940
18941 Mark_Pragma_As_Ghost (N, Ent);
18942
18943 -- Check for duplication before inserting in list of
18944 -- representation items.
18945
18946 Check_Duplicate_Pragma (Ent);
18947
18948 if Rep_Item_Too_Late (Ent, N) then
18949 return;
18950 end if;
18951
18952 if Present (Expression (Decl)) then
18953 Error_Pragma_Arg
18954 ("object for pragma% cannot have initialization", Arg1);
18955 end if;
18956
18957 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18958 Error_Pragma_Arg
18959 ("object type for pragma% is not potentially persistent",
18960 Arg1);
18961 end if;
18962
18963 Prag :=
18964 Make_Linker_Section_Pragma
18965 (Ent, Sloc (N), ".persistent.bss");
18966 Insert_After (N, Prag);
18967 Analyze (Prag);
18968
18969 -- Case of use as configuration pragma with no arguments
18970
18971 else
18972 Check_Valid_Configuration_Pragma;
18973 Persistent_BSS_Mode := True;
18974 end if;
18975 end Persistent_BSS;
18976
18977 -------------
18978 -- Polling --
18979 -------------
18980
18981 -- pragma Polling (ON | OFF);
18982
18983 when Pragma_Polling =>
18984 GNAT_Pragma;
18985 Check_Arg_Count (1);
18986 Check_No_Identifiers;
18987 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18988 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
18989
18990 -----------------------------------
18991 -- Post/Post_Class/Postcondition --
18992 -----------------------------------
18993
18994 -- pragma Post (Boolean_EXPRESSION);
18995 -- pragma Post_Class (Boolean_EXPRESSION);
18996 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18997 -- [,[Message =>] String_EXPRESSION]);
18998
18999 -- Characteristics:
19000
19001 -- * Analysis - The annotation undergoes initial checks to verify
19002 -- the legal placement and context. Secondary checks preanalyze the
19003 -- expression in:
19004
19005 -- Analyze_Pre_Post_Condition_In_Decl_Part
19006
19007 -- * Expansion - The annotation is expanded during the expansion of
19008 -- the related subprogram [body] contract as performed in:
19009
19010 -- Expand_Subprogram_Contract
19011
19012 -- * Template - The annotation utilizes the generic template of the
19013 -- related subprogram [body] when it is:
19014
19015 -- aspect on subprogram declaration
19016 -- aspect on stand alone subprogram body
19017 -- pragma on stand alone subprogram body
19018
19019 -- The annotation must prepare its own template when it is:
19020
19021 -- pragma on subprogram declaration
19022
19023 -- * Globals - Capture of global references must occur after full
19024 -- analysis.
19025
19026 -- * Instance - The annotation is instantiated automatically when
19027 -- the related generic subprogram [body] is instantiated except for
19028 -- the "pragma on subprogram declaration" case. In that scenario
19029 -- the annotation must instantiate itself.
19030
19031 when Pragma_Post |
19032 Pragma_Post_Class |
19033 Pragma_Postcondition =>
19034 Analyze_Pre_Post_Condition;
19035
19036 --------------------------------
19037 -- Pre/Pre_Class/Precondition --
19038 --------------------------------
19039
19040 -- pragma Pre (Boolean_EXPRESSION);
19041 -- pragma Pre_Class (Boolean_EXPRESSION);
19042 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19043 -- [,[Message =>] String_EXPRESSION]);
19044
19045 -- Characteristics:
19046
19047 -- * Analysis - The annotation undergoes initial checks to verify
19048 -- the legal placement and context. Secondary checks preanalyze the
19049 -- expression in:
19050
19051 -- Analyze_Pre_Post_Condition_In_Decl_Part
19052
19053 -- * Expansion - The annotation is expanded during the expansion of
19054 -- the related subprogram [body] contract as performed in:
19055
19056 -- Expand_Subprogram_Contract
19057
19058 -- * Template - The annotation utilizes the generic template of the
19059 -- related subprogram [body] when it is:
19060
19061 -- aspect on subprogram declaration
19062 -- aspect on stand alone subprogram body
19063 -- pragma on stand alone subprogram body
19064
19065 -- The annotation must prepare its own template when it is:
19066
19067 -- pragma on subprogram declaration
19068
19069 -- * Globals - Capture of global references must occur after full
19070 -- analysis.
19071
19072 -- * Instance - The annotation is instantiated automatically when
19073 -- the related generic subprogram [body] is instantiated except for
19074 -- the "pragma on subprogram declaration" case. In that scenario
19075 -- the annotation must instantiate itself.
19076
19077 when Pragma_Pre |
19078 Pragma_Pre_Class |
19079 Pragma_Precondition =>
19080 Analyze_Pre_Post_Condition;
19081
19082 ---------------
19083 -- Predicate --
19084 ---------------
19085
19086 -- pragma Predicate
19087 -- ([Entity =>] type_LOCAL_NAME,
19088 -- [Check =>] boolean_EXPRESSION);
19089
19090 when Pragma_Predicate => Predicate : declare
19091 Discard : Boolean;
19092 Typ : Entity_Id;
19093 Type_Id : Node_Id;
19094
19095 begin
19096 GNAT_Pragma;
19097 Check_Arg_Count (2);
19098 Check_Optional_Identifier (Arg1, Name_Entity);
19099 Check_Optional_Identifier (Arg2, Name_Check);
19100
19101 Check_Arg_Is_Local_Name (Arg1);
19102
19103 Type_Id := Get_Pragma_Arg (Arg1);
19104 Find_Type (Type_Id);
19105 Typ := Entity (Type_Id);
19106
19107 if Typ = Any_Type then
19108 return;
19109 end if;
19110
19111 -- A pragma that applies to a Ghost entity becomes Ghost for the
19112 -- purposes of legality checks and removal of ignored Ghost code.
19113
19114 Mark_Pragma_As_Ghost (N, Typ);
19115
19116 -- The remaining processing is simply to link the pragma on to
19117 -- the rep item chain, for processing when the type is frozen.
19118 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19119 -- mark the type as having predicates.
19120 -- If the current policy is Ignore mark the subtype accordingly.
19121 -- In the case of predicates we consider them enabled unless an
19122 -- Ignore is specified, to preserve existing warnings.
19123
19124 Set_Has_Predicates (Typ);
19125 Set_Predicates_Ignored (Typ,
19126 Present (Check_Policy_List)
19127 and then
19128 Policy_In_Effect (Name_Assertion_Policy) = Name_Ignore);
19129 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19130 end Predicate;
19131
19132 -----------------------
19133 -- Predicate_Failure --
19134 -----------------------
19135
19136 -- pragma Predicate_Failure
19137 -- ([Entity =>] type_LOCAL_NAME,
19138 -- [Message =>] string_EXPRESSION);
19139
19140 when Pragma_Predicate_Failure => Predicate_Failure : declare
19141 Discard : Boolean;
19142 Typ : Entity_Id;
19143 Type_Id : Node_Id;
19144
19145 begin
19146 GNAT_Pragma;
19147 Check_Arg_Count (2);
19148 Check_Optional_Identifier (Arg1, Name_Entity);
19149 Check_Optional_Identifier (Arg2, Name_Message);
19150
19151 Check_Arg_Is_Local_Name (Arg1);
19152
19153 Type_Id := Get_Pragma_Arg (Arg1);
19154 Find_Type (Type_Id);
19155 Typ := Entity (Type_Id);
19156
19157 if Typ = Any_Type then
19158 return;
19159 end if;
19160
19161 -- A pragma that applies to a Ghost entity becomes Ghost for the
19162 -- purposes of legality checks and removal of ignored Ghost code.
19163
19164 Mark_Pragma_As_Ghost (N, Typ);
19165
19166 -- The remaining processing is simply to link the pragma on to
19167 -- the rep item chain, for processing when the type is frozen.
19168 -- This is accomplished by a call to Rep_Item_Too_Late.
19169
19170 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19171 end Predicate_Failure;
19172
19173 ------------------
19174 -- Preelaborate --
19175 ------------------
19176
19177 -- pragma Preelaborate [(library_unit_NAME)];
19178
19179 -- Set the flag Is_Preelaborated of program unit name entity
19180
19181 when Pragma_Preelaborate => Preelaborate : declare
19182 Pa : constant Node_Id := Parent (N);
19183 Pk : constant Node_Kind := Nkind (Pa);
19184 Ent : Entity_Id;
19185
19186 begin
19187 Check_Ada_83_Warning;
19188 Check_Valid_Library_Unit_Pragma;
19189
19190 if Nkind (N) = N_Null_Statement then
19191 return;
19192 end if;
19193
19194 Ent := Find_Lib_Unit_Name;
19195
19196 -- A pragma that applies to a Ghost entity becomes Ghost for the
19197 -- purposes of legality checks and removal of ignored Ghost code.
19198
19199 Mark_Pragma_As_Ghost (N, Ent);
19200 Check_Duplicate_Pragma (Ent);
19201
19202 -- This filters out pragmas inside generic parents that show up
19203 -- inside instantiations. Pragmas that come from aspects in the
19204 -- unit are not ignored.
19205
19206 if Present (Ent) then
19207 if Pk = N_Package_Specification
19208 and then Present (Generic_Parent (Pa))
19209 and then not From_Aspect_Specification (N)
19210 then
19211 null;
19212
19213 else
19214 if not Debug_Flag_U then
19215 Set_Is_Preelaborated (Ent);
19216 Set_Suppress_Elaboration_Warnings (Ent);
19217 end if;
19218 end if;
19219 end if;
19220 end Preelaborate;
19221
19222 -------------------------------
19223 -- Prefix_Exception_Messages --
19224 -------------------------------
19225
19226 -- pragma Prefix_Exception_Messages;
19227
19228 when Pragma_Prefix_Exception_Messages =>
19229 GNAT_Pragma;
19230 Check_Valid_Configuration_Pragma;
19231 Check_Arg_Count (0);
19232 Prefix_Exception_Messages := True;
19233
19234 --------------
19235 -- Priority --
19236 --------------
19237
19238 -- pragma Priority (EXPRESSION);
19239
19240 when Pragma_Priority => Priority : declare
19241 P : constant Node_Id := Parent (N);
19242 Arg : Node_Id;
19243 Ent : Entity_Id;
19244
19245 begin
19246 Check_No_Identifiers;
19247 Check_Arg_Count (1);
19248
19249 -- Subprogram case
19250
19251 if Nkind (P) = N_Subprogram_Body then
19252 Check_In_Main_Program;
19253
19254 Ent := Defining_Unit_Name (Specification (P));
19255
19256 if Nkind (Ent) = N_Defining_Program_Unit_Name then
19257 Ent := Defining_Identifier (Ent);
19258 end if;
19259
19260 Arg := Get_Pragma_Arg (Arg1);
19261 Analyze_And_Resolve (Arg, Standard_Integer);
19262
19263 -- Must be static
19264
19265 if not Is_OK_Static_Expression (Arg) then
19266 Flag_Non_Static_Expr
19267 ("main subprogram priority is not static!", Arg);
19268 raise Pragma_Exit;
19269
19270 -- If constraint error, then we already signalled an error
19271
19272 elsif Raises_Constraint_Error (Arg) then
19273 null;
19274
19275 -- Otherwise check in range except if Relaxed_RM_Semantics
19276 -- where we ignore the value if out of range.
19277
19278 else
19279 if not Relaxed_RM_Semantics
19280 and then not Is_In_Range (Arg, RTE (RE_Priority))
19281 then
19282 Error_Pragma_Arg
19283 ("main subprogram priority is out of range", Arg1);
19284 else
19285 Set_Main_Priority
19286 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
19287 end if;
19288 end if;
19289
19290 -- Load an arbitrary entity from System.Tasking.Stages or
19291 -- System.Tasking.Restricted.Stages (depending on the
19292 -- supported profile) to make sure that one of these packages
19293 -- is implicitly with'ed, since we need to have the tasking
19294 -- run time active for the pragma Priority to have any effect.
19295 -- Previously we with'ed the package System.Tasking, but this
19296 -- package does not trigger the required initialization of the
19297 -- run-time library.
19298
19299 declare
19300 Discard : Entity_Id;
19301 pragma Warnings (Off, Discard);
19302 begin
19303 if Restricted_Profile then
19304 Discard := RTE (RE_Activate_Restricted_Tasks);
19305 else
19306 Discard := RTE (RE_Activate_Tasks);
19307 end if;
19308 end;
19309
19310 -- Task or Protected, must be of type Integer
19311
19312 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
19313 Arg := Get_Pragma_Arg (Arg1);
19314 Ent := Defining_Identifier (Parent (P));
19315
19316 -- The expression must be analyzed in the special manner
19317 -- described in "Handling of Default and Per-Object
19318 -- Expressions" in sem.ads.
19319
19320 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
19321
19322 if not Is_OK_Static_Expression (Arg) then
19323 Check_Restriction (Static_Priorities, Arg);
19324 end if;
19325
19326 -- Anything else is incorrect
19327
19328 else
19329 Pragma_Misplaced;
19330 end if;
19331
19332 -- Check duplicate pragma before we chain the pragma in the Rep
19333 -- Item chain of Ent.
19334
19335 Check_Duplicate_Pragma (Ent);
19336 Record_Rep_Item (Ent, N);
19337 end Priority;
19338
19339 -----------------------------------
19340 -- Priority_Specific_Dispatching --
19341 -----------------------------------
19342
19343 -- pragma Priority_Specific_Dispatching (
19344 -- policy_IDENTIFIER,
19345 -- first_priority_EXPRESSION,
19346 -- last_priority_EXPRESSION);
19347
19348 when Pragma_Priority_Specific_Dispatching =>
19349 Priority_Specific_Dispatching : declare
19350 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
19351 -- This is the entity System.Any_Priority;
19352
19353 DP : Character;
19354 Lower_Bound : Node_Id;
19355 Upper_Bound : Node_Id;
19356 Lower_Val : Uint;
19357 Upper_Val : Uint;
19358
19359 begin
19360 Ada_2005_Pragma;
19361 Check_Arg_Count (3);
19362 Check_No_Identifiers;
19363 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
19364 Check_Valid_Configuration_Pragma;
19365 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19366 DP := Fold_Upper (Name_Buffer (1));
19367
19368 Lower_Bound := Get_Pragma_Arg (Arg2);
19369 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
19370 Lower_Val := Expr_Value (Lower_Bound);
19371
19372 Upper_Bound := Get_Pragma_Arg (Arg3);
19373 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19374 Upper_Val := Expr_Value (Upper_Bound);
19375
19376 -- It is not allowed to use Task_Dispatching_Policy and
19377 -- Priority_Specific_Dispatching in the same partition.
19378
19379 if Task_Dispatching_Policy /= ' ' then
19380 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19381 Error_Pragma
19382 ("pragma% incompatible with Task_Dispatching_Policy#");
19383
19384 -- Check lower bound in range
19385
19386 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19387 or else
19388 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19389 then
19390 Error_Pragma_Arg
19391 ("first_priority is out of range", Arg2);
19392
19393 -- Check upper bound in range
19394
19395 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19396 or else
19397 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19398 then
19399 Error_Pragma_Arg
19400 ("last_priority is out of range", Arg3);
19401
19402 -- Check that the priority range is valid
19403
19404 elsif Lower_Val > Upper_Val then
19405 Error_Pragma
19406 ("last_priority_expression must be greater than or equal to "
19407 & "first_priority_expression");
19408
19409 -- Store the new policy, but always preserve System_Location since
19410 -- we like the error message with the run-time name.
19411
19412 else
19413 -- Check overlapping in the priority ranges specified in other
19414 -- Priority_Specific_Dispatching pragmas within the same
19415 -- partition. We can only check those we know about.
19416
19417 for J in
19418 Specific_Dispatching.First .. Specific_Dispatching.Last
19419 loop
19420 if Specific_Dispatching.Table (J).First_Priority in
19421 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19422 or else Specific_Dispatching.Table (J).Last_Priority in
19423 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19424 then
19425 Error_Msg_Sloc :=
19426 Specific_Dispatching.Table (J).Pragma_Loc;
19427 Error_Pragma
19428 ("priority range overlaps with "
19429 & "Priority_Specific_Dispatching#");
19430 end if;
19431 end loop;
19432
19433 -- The use of Priority_Specific_Dispatching is incompatible
19434 -- with Task_Dispatching_Policy.
19435
19436 if Task_Dispatching_Policy /= ' ' then
19437 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19438 Error_Pragma
19439 ("Priority_Specific_Dispatching incompatible "
19440 & "with Task_Dispatching_Policy#");
19441 end if;
19442
19443 -- The use of Priority_Specific_Dispatching forces ceiling
19444 -- locking policy.
19445
19446 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19447 Error_Msg_Sloc := Locking_Policy_Sloc;
19448 Error_Pragma
19449 ("Priority_Specific_Dispatching incompatible "
19450 & "with Locking_Policy#");
19451
19452 -- Set the Ceiling_Locking policy, but preserve System_Location
19453 -- since we like the error message with the run time name.
19454
19455 else
19456 Locking_Policy := 'C';
19457
19458 if Locking_Policy_Sloc /= System_Location then
19459 Locking_Policy_Sloc := Loc;
19460 end if;
19461 end if;
19462
19463 -- Add entry in the table
19464
19465 Specific_Dispatching.Append
19466 ((Dispatching_Policy => DP,
19467 First_Priority => UI_To_Int (Lower_Val),
19468 Last_Priority => UI_To_Int (Upper_Val),
19469 Pragma_Loc => Loc));
19470 end if;
19471 end Priority_Specific_Dispatching;
19472
19473 -------------
19474 -- Profile --
19475 -------------
19476
19477 -- pragma Profile (profile_IDENTIFIER);
19478
19479 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19480
19481 when Pragma_Profile =>
19482 Ada_2005_Pragma;
19483 Check_Arg_Count (1);
19484 Check_Valid_Configuration_Pragma;
19485 Check_No_Identifiers;
19486
19487 declare
19488 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19489
19490 begin
19491 if Chars (Argx) = Name_Ravenscar then
19492 Set_Ravenscar_Profile (Ravenscar, N);
19493
19494 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
19495 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
19496
19497 elsif Chars (Argx) = Name_Restricted then
19498 Set_Profile_Restrictions
19499 (Restricted,
19500 N, Warn => Treat_Restrictions_As_Warnings);
19501
19502 elsif Chars (Argx) = Name_Rational then
19503 Set_Rational_Profile;
19504
19505 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19506 Set_Profile_Restrictions
19507 (No_Implementation_Extensions,
19508 N, Warn => Treat_Restrictions_As_Warnings);
19509
19510 else
19511 Error_Pragma_Arg ("& is not a valid profile", Argx);
19512 end if;
19513 end;
19514
19515 ----------------------
19516 -- Profile_Warnings --
19517 ----------------------
19518
19519 -- pragma Profile_Warnings (profile_IDENTIFIER);
19520
19521 -- profile_IDENTIFIER => Restricted | Ravenscar
19522
19523 when Pragma_Profile_Warnings =>
19524 GNAT_Pragma;
19525 Check_Arg_Count (1);
19526 Check_Valid_Configuration_Pragma;
19527 Check_No_Identifiers;
19528
19529 declare
19530 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19531
19532 begin
19533 if Chars (Argx) = Name_Ravenscar then
19534 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
19535
19536 elsif Chars (Argx) = Name_Restricted then
19537 Set_Profile_Restrictions (Restricted, N, Warn => True);
19538
19539 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19540 Set_Profile_Restrictions
19541 (No_Implementation_Extensions, N, Warn => True);
19542
19543 else
19544 Error_Pragma_Arg ("& is not a valid profile", Argx);
19545 end if;
19546 end;
19547
19548 --------------------------
19549 -- Propagate_Exceptions --
19550 --------------------------
19551
19552 -- pragma Propagate_Exceptions;
19553
19554 -- Note: this pragma is obsolete and has no effect
19555
19556 when Pragma_Propagate_Exceptions =>
19557 GNAT_Pragma;
19558 Check_Arg_Count (0);
19559
19560 if Warn_On_Obsolescent_Feature then
19561 Error_Msg_N
19562 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19563 "and has no effect?j?", N);
19564 end if;
19565
19566 -----------------------------
19567 -- Provide_Shift_Operators --
19568 -----------------------------
19569
19570 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19571
19572 when Pragma_Provide_Shift_Operators =>
19573 Provide_Shift_Operators : declare
19574 Ent : Entity_Id;
19575
19576 procedure Declare_Shift_Operator (Nam : Name_Id);
19577 -- Insert declaration and pragma Instrinsic for named shift op
19578
19579 ----------------------------
19580 -- Declare_Shift_Operator --
19581 ----------------------------
19582
19583 procedure Declare_Shift_Operator (Nam : Name_Id) is
19584 Func : Node_Id;
19585 Import : Node_Id;
19586
19587 begin
19588 Func :=
19589 Make_Subprogram_Declaration (Loc,
19590 Make_Function_Specification (Loc,
19591 Defining_Unit_Name =>
19592 Make_Defining_Identifier (Loc, Chars => Nam),
19593
19594 Result_Definition =>
19595 Make_Identifier (Loc, Chars => Chars (Ent)),
19596
19597 Parameter_Specifications => New_List (
19598 Make_Parameter_Specification (Loc,
19599 Defining_Identifier =>
19600 Make_Defining_Identifier (Loc, Name_Value),
19601 Parameter_Type =>
19602 Make_Identifier (Loc, Chars => Chars (Ent))),
19603
19604 Make_Parameter_Specification (Loc,
19605 Defining_Identifier =>
19606 Make_Defining_Identifier (Loc, Name_Amount),
19607 Parameter_Type =>
19608 New_Occurrence_Of (Standard_Natural, Loc)))));
19609
19610 Import :=
19611 Make_Pragma (Loc,
19612 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
19613 Pragma_Argument_Associations => New_List (
19614 Make_Pragma_Argument_Association (Loc,
19615 Expression => Make_Identifier (Loc, Name_Intrinsic)),
19616 Make_Pragma_Argument_Association (Loc,
19617 Expression => Make_Identifier (Loc, Nam))));
19618
19619 Insert_After (N, Import);
19620 Insert_After (N, Func);
19621 end Declare_Shift_Operator;
19622
19623 -- Start of processing for Provide_Shift_Operators
19624
19625 begin
19626 GNAT_Pragma;
19627 Check_Arg_Count (1);
19628 Check_Arg_Is_Local_Name (Arg1);
19629
19630 Arg1 := Get_Pragma_Arg (Arg1);
19631
19632 -- We must have an entity name
19633
19634 if not Is_Entity_Name (Arg1) then
19635 Error_Pragma_Arg
19636 ("pragma % must apply to integer first subtype", Arg1);
19637 end if;
19638
19639 -- If no Entity, means there was a prior error so ignore
19640
19641 if Present (Entity (Arg1)) then
19642 Ent := Entity (Arg1);
19643
19644 -- Apply error checks
19645
19646 if not Is_First_Subtype (Ent) then
19647 Error_Pragma_Arg
19648 ("cannot apply pragma %",
19649 "\& is not a first subtype",
19650 Arg1);
19651
19652 elsif not Is_Integer_Type (Ent) then
19653 Error_Pragma_Arg
19654 ("cannot apply pragma %",
19655 "\& is not an integer type",
19656 Arg1);
19657
19658 elsif Has_Shift_Operator (Ent) then
19659 Error_Pragma_Arg
19660 ("cannot apply pragma %",
19661 "\& already has declared shift operators",
19662 Arg1);
19663
19664 elsif Is_Frozen (Ent) then
19665 Error_Pragma_Arg
19666 ("pragma % appears too late",
19667 "\& is already frozen",
19668 Arg1);
19669 end if;
19670
19671 -- Now declare the operators. We do this during analysis rather
19672 -- than expansion, since we want the operators available if we
19673 -- are operating in -gnatc or ASIS mode.
19674
19675 Declare_Shift_Operator (Name_Rotate_Left);
19676 Declare_Shift_Operator (Name_Rotate_Right);
19677 Declare_Shift_Operator (Name_Shift_Left);
19678 Declare_Shift_Operator (Name_Shift_Right);
19679 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
19680 end if;
19681 end Provide_Shift_Operators;
19682
19683 ------------------
19684 -- Psect_Object --
19685 ------------------
19686
19687 -- pragma Psect_Object (
19688 -- [Internal =>] LOCAL_NAME,
19689 -- [, [External =>] EXTERNAL_SYMBOL]
19690 -- [, [Size =>] EXTERNAL_SYMBOL]);
19691
19692 when Pragma_Psect_Object | Pragma_Common_Object =>
19693 Psect_Object : declare
19694 Args : Args_List (1 .. 3);
19695 Names : constant Name_List (1 .. 3) := (
19696 Name_Internal,
19697 Name_External,
19698 Name_Size);
19699
19700 Internal : Node_Id renames Args (1);
19701 External : Node_Id renames Args (2);
19702 Size : Node_Id renames Args (3);
19703
19704 Def_Id : Entity_Id;
19705
19706 procedure Check_Arg (Arg : Node_Id);
19707 -- Checks that argument is either a string literal or an
19708 -- identifier, and posts error message if not.
19709
19710 ---------------
19711 -- Check_Arg --
19712 ---------------
19713
19714 procedure Check_Arg (Arg : Node_Id) is
19715 begin
19716 if not Nkind_In (Original_Node (Arg),
19717 N_String_Literal,
19718 N_Identifier)
19719 then
19720 Error_Pragma_Arg
19721 ("inappropriate argument for pragma %", Arg);
19722 end if;
19723 end Check_Arg;
19724
19725 -- Start of processing for Common_Object/Psect_Object
19726
19727 begin
19728 GNAT_Pragma;
19729 Gather_Associations (Names, Args);
19730 Process_Extended_Import_Export_Internal_Arg (Internal);
19731
19732 Def_Id := Entity (Internal);
19733
19734 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
19735 Error_Pragma_Arg
19736 ("pragma% must designate an object", Internal);
19737 end if;
19738
19739 Check_Arg (Internal);
19740
19741 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
19742 Error_Pragma_Arg
19743 ("cannot use pragma% for imported/exported object",
19744 Internal);
19745 end if;
19746
19747 if Is_Concurrent_Type (Etype (Internal)) then
19748 Error_Pragma_Arg
19749 ("cannot specify pragma % for task/protected object",
19750 Internal);
19751 end if;
19752
19753 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
19754 or else
19755 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
19756 then
19757 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
19758 end if;
19759
19760 if Ekind (Def_Id) = E_Constant then
19761 Error_Pragma_Arg
19762 ("cannot specify pragma % for a constant", Internal);
19763 end if;
19764
19765 if Is_Record_Type (Etype (Internal)) then
19766 declare
19767 Ent : Entity_Id;
19768 Decl : Entity_Id;
19769
19770 begin
19771 Ent := First_Entity (Etype (Internal));
19772 while Present (Ent) loop
19773 Decl := Declaration_Node (Ent);
19774
19775 if Ekind (Ent) = E_Component
19776 and then Nkind (Decl) = N_Component_Declaration
19777 and then Present (Expression (Decl))
19778 and then Warn_On_Export_Import
19779 then
19780 Error_Msg_N
19781 ("?x?object for pragma % has defaults", Internal);
19782 exit;
19783
19784 else
19785 Next_Entity (Ent);
19786 end if;
19787 end loop;
19788 end;
19789 end if;
19790
19791 if Present (Size) then
19792 Check_Arg (Size);
19793 end if;
19794
19795 if Present (External) then
19796 Check_Arg_Is_External_Name (External);
19797 end if;
19798
19799 -- If all error tests pass, link pragma on to the rep item chain
19800
19801 Record_Rep_Item (Def_Id, N);
19802 end Psect_Object;
19803
19804 ----------
19805 -- Pure --
19806 ----------
19807
19808 -- pragma Pure [(library_unit_NAME)];
19809
19810 when Pragma_Pure => Pure : declare
19811 Ent : Entity_Id;
19812
19813 begin
19814 Check_Ada_83_Warning;
19815
19816 -- If the pragma comes from a subprogram instantiation, nothing to
19817 -- check, this can happen at any level of nesting.
19818
19819 if Is_Wrapper_Package (Current_Scope) then
19820 return;
19821 else
19822 Check_Valid_Library_Unit_Pragma;
19823 end if;
19824
19825 if Nkind (N) = N_Null_Statement then
19826 return;
19827 end if;
19828
19829 Ent := Find_Lib_Unit_Name;
19830
19831 -- A pragma that applies to a Ghost entity becomes Ghost for the
19832 -- purposes of legality checks and removal of ignored Ghost code.
19833
19834 Mark_Pragma_As_Ghost (N, Ent);
19835
19836 if not Debug_Flag_U then
19837 Set_Is_Pure (Ent);
19838 Set_Has_Pragma_Pure (Ent);
19839 Set_Suppress_Elaboration_Warnings (Ent);
19840 end if;
19841 end Pure;
19842
19843 -------------------
19844 -- Pure_Function --
19845 -------------------
19846
19847 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19848
19849 when Pragma_Pure_Function => Pure_Function : declare
19850 Def_Id : Entity_Id;
19851 E : Entity_Id;
19852 E_Id : Node_Id;
19853 Effective : Boolean := False;
19854
19855 begin
19856 GNAT_Pragma;
19857 Check_Arg_Count (1);
19858 Check_Optional_Identifier (Arg1, Name_Entity);
19859 Check_Arg_Is_Local_Name (Arg1);
19860 E_Id := Get_Pragma_Arg (Arg1);
19861
19862 if Error_Posted (E_Id) then
19863 return;
19864 end if;
19865
19866 -- Loop through homonyms (overloadings) of referenced entity
19867
19868 E := Entity (E_Id);
19869
19870 -- A pragma that applies to a Ghost entity becomes Ghost for the
19871 -- purposes of legality checks and removal of ignored Ghost code.
19872
19873 Mark_Pragma_As_Ghost (N, E);
19874
19875 if Present (E) then
19876 loop
19877 Def_Id := Get_Base_Subprogram (E);
19878
19879 if not Ekind_In (Def_Id, E_Function,
19880 E_Generic_Function,
19881 E_Operator)
19882 then
19883 Error_Pragma_Arg
19884 ("pragma% requires a function name", Arg1);
19885 end if;
19886
19887 Set_Is_Pure (Def_Id);
19888
19889 if not Has_Pragma_Pure_Function (Def_Id) then
19890 Set_Has_Pragma_Pure_Function (Def_Id);
19891 Effective := True;
19892 end if;
19893
19894 exit when From_Aspect_Specification (N);
19895 E := Homonym (E);
19896 exit when No (E) or else Scope (E) /= Current_Scope;
19897 end loop;
19898
19899 if not Effective
19900 and then Warn_On_Redundant_Constructs
19901 then
19902 Error_Msg_NE
19903 ("pragma Pure_Function on& is redundant?r?",
19904 N, Entity (E_Id));
19905 end if;
19906 end if;
19907 end Pure_Function;
19908
19909 --------------------
19910 -- Queuing_Policy --
19911 --------------------
19912
19913 -- pragma Queuing_Policy (policy_IDENTIFIER);
19914
19915 when Pragma_Queuing_Policy => declare
19916 QP : Character;
19917
19918 begin
19919 Check_Ada_83_Warning;
19920 Check_Arg_Count (1);
19921 Check_No_Identifiers;
19922 Check_Arg_Is_Queuing_Policy (Arg1);
19923 Check_Valid_Configuration_Pragma;
19924 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19925 QP := Fold_Upper (Name_Buffer (1));
19926
19927 if Queuing_Policy /= ' '
19928 and then Queuing_Policy /= QP
19929 then
19930 Error_Msg_Sloc := Queuing_Policy_Sloc;
19931 Error_Pragma ("queuing policy incompatible with policy#");
19932
19933 -- Set new policy, but always preserve System_Location since we
19934 -- like the error message with the run time name.
19935
19936 else
19937 Queuing_Policy := QP;
19938
19939 if Queuing_Policy_Sloc /= System_Location then
19940 Queuing_Policy_Sloc := Loc;
19941 end if;
19942 end if;
19943 end;
19944
19945 --------------
19946 -- Rational --
19947 --------------
19948
19949 -- pragma Rational, for compatibility with foreign compiler
19950
19951 when Pragma_Rational =>
19952 Set_Rational_Profile;
19953
19954 ---------------------
19955 -- Refined_Depends --
19956 ---------------------
19957
19958 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19959
19960 -- DEPENDENCY_RELATION ::=
19961 -- null
19962 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19963
19964 -- DEPENDENCY_CLAUSE ::=
19965 -- OUTPUT_LIST =>[+] INPUT_LIST
19966 -- | NULL_DEPENDENCY_CLAUSE
19967
19968 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19969
19970 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19971
19972 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19973
19974 -- OUTPUT ::= NAME | FUNCTION_RESULT
19975 -- INPUT ::= NAME
19976
19977 -- where FUNCTION_RESULT is a function Result attribute_reference
19978
19979 -- Characteristics:
19980
19981 -- * Analysis - The annotation undergoes initial checks to verify
19982 -- the legal placement and context. Secondary checks fully analyze
19983 -- the dependency clauses/global list in:
19984
19985 -- Analyze_Refined_Depends_In_Decl_Part
19986
19987 -- * Expansion - None.
19988
19989 -- * Template - The annotation utilizes the generic template of the
19990 -- related subprogram body.
19991
19992 -- * Globals - Capture of global references must occur after full
19993 -- analysis.
19994
19995 -- * Instance - The annotation is instantiated automatically when
19996 -- the related generic subprogram body is instantiated.
19997
19998 when Pragma_Refined_Depends => Refined_Depends : declare
19999 Body_Id : Entity_Id;
20000 Legal : Boolean;
20001 Spec_Id : Entity_Id;
20002
20003 begin
20004 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20005
20006 if Legal then
20007
20008 -- Chain the pragma on the contract for further processing by
20009 -- Analyze_Refined_Depends_In_Decl_Part.
20010
20011 Add_Contract_Item (N, Body_Id);
20012
20013 -- The legality checks of pragmas Refined_Depends and
20014 -- Refined_Global are affected by the SPARK mode in effect and
20015 -- the volatility of the context. In addition these two pragmas
20016 -- are subject to an inherent order:
20017
20018 -- 1) Refined_Global
20019 -- 2) Refined_Depends
20020
20021 -- Analyze all these pragmas in the order outlined above
20022
20023 Analyze_If_Present (Pragma_SPARK_Mode);
20024 Analyze_If_Present (Pragma_Volatile_Function);
20025 Analyze_If_Present (Pragma_Refined_Global);
20026 Analyze_Refined_Depends_In_Decl_Part (N);
20027 end if;
20028 end Refined_Depends;
20029
20030 --------------------
20031 -- Refined_Global --
20032 --------------------
20033
20034 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20035
20036 -- GLOBAL_SPECIFICATION ::=
20037 -- null
20038 -- | (GLOBAL_LIST)
20039 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20040
20041 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20042
20043 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20044 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20045 -- GLOBAL_ITEM ::= NAME
20046
20047 -- Characteristics:
20048
20049 -- * Analysis - The annotation undergoes initial checks to verify
20050 -- the legal placement and context. Secondary checks fully analyze
20051 -- the dependency clauses/global list in:
20052
20053 -- Analyze_Refined_Global_In_Decl_Part
20054
20055 -- * Expansion - None.
20056
20057 -- * Template - The annotation utilizes the generic template of the
20058 -- related subprogram body.
20059
20060 -- * Globals - Capture of global references must occur after full
20061 -- analysis.
20062
20063 -- * Instance - The annotation is instantiated automatically when
20064 -- the related generic subprogram body is instantiated.
20065
20066 when Pragma_Refined_Global => Refined_Global : declare
20067 Body_Id : Entity_Id;
20068 Legal : Boolean;
20069 Spec_Id : Entity_Id;
20070
20071 begin
20072 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20073
20074 if Legal then
20075
20076 -- Chain the pragma on the contract for further processing by
20077 -- Analyze_Refined_Global_In_Decl_Part.
20078
20079 Add_Contract_Item (N, Body_Id);
20080
20081 -- The legality checks of pragmas Refined_Depends and
20082 -- Refined_Global are affected by the SPARK mode in effect and
20083 -- the volatility of the context. In addition these two pragmas
20084 -- are subject to an inherent order:
20085
20086 -- 1) Refined_Global
20087 -- 2) Refined_Depends
20088
20089 -- Analyze all these pragmas in the order outlined above
20090
20091 Analyze_If_Present (Pragma_SPARK_Mode);
20092 Analyze_If_Present (Pragma_Volatile_Function);
20093 Analyze_Refined_Global_In_Decl_Part (N);
20094 Analyze_If_Present (Pragma_Refined_Depends);
20095 end if;
20096 end Refined_Global;
20097
20098 ------------------
20099 -- Refined_Post --
20100 ------------------
20101
20102 -- pragma Refined_Post (boolean_EXPRESSION);
20103
20104 -- Characteristics:
20105
20106 -- * Analysis - The annotation is fully analyzed immediately upon
20107 -- elaboration as it cannot forward reference entities.
20108
20109 -- * Expansion - The annotation is expanded during the expansion of
20110 -- the related subprogram body contract as performed in:
20111
20112 -- Expand_Subprogram_Contract
20113
20114 -- * Template - The annotation utilizes the generic template of the
20115 -- related subprogram body.
20116
20117 -- * Globals - Capture of global references must occur after full
20118 -- analysis.
20119
20120 -- * Instance - The annotation is instantiated automatically when
20121 -- the related generic subprogram body is instantiated.
20122
20123 when Pragma_Refined_Post => Refined_Post : declare
20124 Body_Id : Entity_Id;
20125 Legal : Boolean;
20126 Spec_Id : Entity_Id;
20127
20128 begin
20129 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20130
20131 -- Fully analyze the pragma when it appears inside a subprogram
20132 -- body because it cannot benefit from forward references.
20133
20134 if Legal then
20135
20136 -- Chain the pragma on the contract for completeness
20137
20138 Add_Contract_Item (N, Body_Id);
20139
20140 -- The legality checks of pragma Refined_Post are affected by
20141 -- the SPARK mode in effect and the volatility of the context.
20142 -- Analyze all pragmas in a specific order.
20143
20144 Analyze_If_Present (Pragma_SPARK_Mode);
20145 Analyze_If_Present (Pragma_Volatile_Function);
20146 Analyze_Pre_Post_Condition_In_Decl_Part (N);
20147
20148 -- Currently it is not possible to inline pre/postconditions on
20149 -- a subprogram subject to pragma Inline_Always.
20150
20151 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
20152 end if;
20153 end Refined_Post;
20154
20155 -------------------
20156 -- Refined_State --
20157 -------------------
20158
20159 -- pragma Refined_State (REFINEMENT_LIST);
20160
20161 -- REFINEMENT_LIST ::=
20162 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20163
20164 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20165
20166 -- CONSTITUENT_LIST ::=
20167 -- null
20168 -- | CONSTITUENT
20169 -- | (CONSTITUENT {, CONSTITUENT})
20170
20171 -- CONSTITUENT ::= object_NAME | state_NAME
20172
20173 -- Characteristics:
20174
20175 -- * Analysis - The annotation undergoes initial checks to verify
20176 -- the legal placement and context. Secondary checks preanalyze the
20177 -- refinement clauses in:
20178
20179 -- Analyze_Refined_State_In_Decl_Part
20180
20181 -- * Expansion - None.
20182
20183 -- * Template - The annotation utilizes the template of the related
20184 -- package body.
20185
20186 -- * Globals - Capture of global references must occur after full
20187 -- analysis.
20188
20189 -- * Instance - The annotation is instantiated automatically when
20190 -- the related generic package body is instantiated.
20191
20192 when Pragma_Refined_State => Refined_State : declare
20193 Pack_Decl : Node_Id;
20194 Spec_Id : Entity_Id;
20195
20196 begin
20197 GNAT_Pragma;
20198 Check_No_Identifiers;
20199 Check_Arg_Count (1);
20200
20201 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
20202
20203 -- Ensure the proper placement of the pragma. Refined states must
20204 -- be associated with a package body.
20205
20206 if Nkind (Pack_Decl) = N_Package_Body then
20207 null;
20208
20209 -- Otherwise the pragma is associated with an illegal construct
20210
20211 else
20212 Pragma_Misplaced;
20213 return;
20214 end if;
20215
20216 Spec_Id := Corresponding_Spec (Pack_Decl);
20217
20218 -- Chain the pragma on the contract for further processing by
20219 -- Analyze_Refined_State_In_Decl_Part.
20220
20221 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
20222
20223 -- The legality checks of pragma Refined_State are affected by the
20224 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20225
20226 Analyze_If_Present (Pragma_SPARK_Mode);
20227
20228 -- A pragma that applies to a Ghost entity becomes Ghost for the
20229 -- purposes of legality checks and removal of ignored Ghost code.
20230
20231 Mark_Pragma_As_Ghost (N, Spec_Id);
20232
20233 -- State refinement is allowed only when the corresponding package
20234 -- declaration has non-null pragma Abstract_State. Refinement not
20235 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20236
20237 if SPARK_Mode /= Off
20238 and then
20239 (No (Abstract_States (Spec_Id))
20240 or else Has_Null_Abstract_State (Spec_Id))
20241 then
20242 Error_Msg_NE
20243 ("useless refinement, package & does not define abstract "
20244 & "states", N, Spec_Id);
20245 return;
20246 end if;
20247 end Refined_State;
20248
20249 -----------------------
20250 -- Relative_Deadline --
20251 -----------------------
20252
20253 -- pragma Relative_Deadline (time_span_EXPRESSION);
20254
20255 when Pragma_Relative_Deadline => Relative_Deadline : declare
20256 P : constant Node_Id := Parent (N);
20257 Arg : Node_Id;
20258
20259 begin
20260 Ada_2005_Pragma;
20261 Check_No_Identifiers;
20262 Check_Arg_Count (1);
20263
20264 Arg := Get_Pragma_Arg (Arg1);
20265
20266 -- The expression must be analyzed in the special manner described
20267 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20268
20269 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
20270
20271 -- Subprogram case
20272
20273 if Nkind (P) = N_Subprogram_Body then
20274 Check_In_Main_Program;
20275
20276 -- Only Task and subprogram cases allowed
20277
20278 elsif Nkind (P) /= N_Task_Definition then
20279 Pragma_Misplaced;
20280 end if;
20281
20282 -- Check duplicate pragma before we set the corresponding flag
20283
20284 if Has_Relative_Deadline_Pragma (P) then
20285 Error_Pragma ("duplicate pragma% not allowed");
20286 end if;
20287
20288 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20289 -- Relative_Deadline pragma node cannot be inserted in the Rep
20290 -- Item chain of Ent since it is rewritten by the expander as a
20291 -- procedure call statement that will break the chain.
20292
20293 Set_Has_Relative_Deadline_Pragma (P);
20294 end Relative_Deadline;
20295
20296 ------------------------
20297 -- Remote_Access_Type --
20298 ------------------------
20299
20300 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20301
20302 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
20303 E : Entity_Id;
20304
20305 begin
20306 GNAT_Pragma;
20307 Check_Arg_Count (1);
20308 Check_Optional_Identifier (Arg1, Name_Entity);
20309 Check_Arg_Is_Local_Name (Arg1);
20310
20311 E := Entity (Get_Pragma_Arg (Arg1));
20312
20313 -- A pragma that applies to a Ghost entity becomes Ghost for the
20314 -- purposes of legality checks and removal of ignored Ghost code.
20315
20316 Mark_Pragma_As_Ghost (N, E);
20317
20318 if Nkind (Parent (E)) = N_Formal_Type_Declaration
20319 and then Ekind (E) = E_General_Access_Type
20320 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
20321 and then Scope (Root_Type (Directly_Designated_Type (E)))
20322 = Scope (E)
20323 and then Is_Valid_Remote_Object_Type
20324 (Root_Type (Directly_Designated_Type (E)))
20325 then
20326 Set_Is_Remote_Types (E);
20327
20328 else
20329 Error_Pragma_Arg
20330 ("pragma% applies only to formal access to classwide types",
20331 Arg1);
20332 end if;
20333 end Remote_Access_Type;
20334
20335 ---------------------------
20336 -- Remote_Call_Interface --
20337 ---------------------------
20338
20339 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20340
20341 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
20342 Cunit_Node : Node_Id;
20343 Cunit_Ent : Entity_Id;
20344 K : Node_Kind;
20345
20346 begin
20347 Check_Ada_83_Warning;
20348 Check_Valid_Library_Unit_Pragma;
20349
20350 if Nkind (N) = N_Null_Statement then
20351 return;
20352 end if;
20353
20354 Cunit_Node := Cunit (Current_Sem_Unit);
20355 K := Nkind (Unit (Cunit_Node));
20356 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20357
20358 -- A pragma that applies to a Ghost entity becomes Ghost for the
20359 -- purposes of legality checks and removal of ignored Ghost code.
20360
20361 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20362
20363 if K = N_Package_Declaration
20364 or else K = N_Generic_Package_Declaration
20365 or else K = N_Subprogram_Declaration
20366 or else K = N_Generic_Subprogram_Declaration
20367 or else (K = N_Subprogram_Body
20368 and then Acts_As_Spec (Unit (Cunit_Node)))
20369 then
20370 null;
20371 else
20372 Error_Pragma (
20373 "pragma% must apply to package or subprogram declaration");
20374 end if;
20375
20376 Set_Is_Remote_Call_Interface (Cunit_Ent);
20377 end Remote_Call_Interface;
20378
20379 ------------------
20380 -- Remote_Types --
20381 ------------------
20382
20383 -- pragma Remote_Types [(library_unit_NAME)];
20384
20385 when Pragma_Remote_Types => Remote_Types : declare
20386 Cunit_Node : Node_Id;
20387 Cunit_Ent : Entity_Id;
20388
20389 begin
20390 Check_Ada_83_Warning;
20391 Check_Valid_Library_Unit_Pragma;
20392
20393 if Nkind (N) = N_Null_Statement then
20394 return;
20395 end if;
20396
20397 Cunit_Node := Cunit (Current_Sem_Unit);
20398 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20399
20400 -- A pragma that applies to a Ghost entity becomes Ghost for the
20401 -- purposes of legality checks and removal of ignored Ghost code.
20402
20403 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20404
20405 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20406 N_Generic_Package_Declaration)
20407 then
20408 Error_Pragma
20409 ("pragma% can only apply to a package declaration");
20410 end if;
20411
20412 Set_Is_Remote_Types (Cunit_Ent);
20413 end Remote_Types;
20414
20415 ---------------
20416 -- Ravenscar --
20417 ---------------
20418
20419 -- pragma Ravenscar;
20420
20421 when Pragma_Ravenscar =>
20422 GNAT_Pragma;
20423 Check_Arg_Count (0);
20424 Check_Valid_Configuration_Pragma;
20425 Set_Ravenscar_Profile (Ravenscar, N);
20426
20427 if Warn_On_Obsolescent_Feature then
20428 Error_Msg_N
20429 ("pragma Ravenscar is an obsolescent feature?j?", N);
20430 Error_Msg_N
20431 ("|use pragma Profile (Ravenscar) instead?j?", N);
20432 end if;
20433
20434 -------------------------
20435 -- Restricted_Run_Time --
20436 -------------------------
20437
20438 -- pragma Restricted_Run_Time;
20439
20440 when Pragma_Restricted_Run_Time =>
20441 GNAT_Pragma;
20442 Check_Arg_Count (0);
20443 Check_Valid_Configuration_Pragma;
20444 Set_Profile_Restrictions
20445 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20446
20447 if Warn_On_Obsolescent_Feature then
20448 Error_Msg_N
20449 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20450 N);
20451 Error_Msg_N
20452 ("|use pragma Profile (Restricted) instead?j?", N);
20453 end if;
20454
20455 ------------------
20456 -- Restrictions --
20457 ------------------
20458
20459 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20460
20461 -- RESTRICTION ::=
20462 -- restriction_IDENTIFIER
20463 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20464
20465 when Pragma_Restrictions =>
20466 Process_Restrictions_Or_Restriction_Warnings
20467 (Warn => Treat_Restrictions_As_Warnings);
20468
20469 --------------------------
20470 -- Restriction_Warnings --
20471 --------------------------
20472
20473 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20474
20475 -- RESTRICTION ::=
20476 -- restriction_IDENTIFIER
20477 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20478
20479 when Pragma_Restriction_Warnings =>
20480 GNAT_Pragma;
20481 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
20482
20483 ----------------
20484 -- Reviewable --
20485 ----------------
20486
20487 -- pragma Reviewable;
20488
20489 when Pragma_Reviewable =>
20490 Check_Ada_83_Warning;
20491 Check_Arg_Count (0);
20492
20493 -- Call dummy debugging function rv. This is done to assist front
20494 -- end debugging. By placing a Reviewable pragma in the source
20495 -- program, a breakpoint on rv catches this place in the source,
20496 -- allowing convenient stepping to the point of interest.
20497
20498 rv;
20499
20500 --------------------------
20501 -- Short_Circuit_And_Or --
20502 --------------------------
20503
20504 -- pragma Short_Circuit_And_Or;
20505
20506 when Pragma_Short_Circuit_And_Or =>
20507 GNAT_Pragma;
20508 Check_Arg_Count (0);
20509 Check_Valid_Configuration_Pragma;
20510 Short_Circuit_And_Or := True;
20511
20512 -------------------
20513 -- Share_Generic --
20514 -------------------
20515
20516 -- pragma Share_Generic (GNAME {, GNAME});
20517
20518 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20519
20520 when Pragma_Share_Generic =>
20521 GNAT_Pragma;
20522 Process_Generic_List;
20523
20524 ------------
20525 -- Shared --
20526 ------------
20527
20528 -- pragma Shared (LOCAL_NAME);
20529
20530 when Pragma_Shared =>
20531 GNAT_Pragma;
20532 Process_Atomic_Independent_Shared_Volatile;
20533
20534 --------------------
20535 -- Shared_Passive --
20536 --------------------
20537
20538 -- pragma Shared_Passive [(library_unit_NAME)];
20539
20540 -- Set the flag Is_Shared_Passive of program unit name entity
20541
20542 when Pragma_Shared_Passive => Shared_Passive : declare
20543 Cunit_Node : Node_Id;
20544 Cunit_Ent : Entity_Id;
20545
20546 begin
20547 Check_Ada_83_Warning;
20548 Check_Valid_Library_Unit_Pragma;
20549
20550 if Nkind (N) = N_Null_Statement then
20551 return;
20552 end if;
20553
20554 Cunit_Node := Cunit (Current_Sem_Unit);
20555 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20556
20557 -- A pragma that applies to a Ghost entity becomes Ghost for the
20558 -- purposes of legality checks and removal of ignored Ghost code.
20559
20560 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20561
20562 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20563 N_Generic_Package_Declaration)
20564 then
20565 Error_Pragma
20566 ("pragma% can only apply to a package declaration");
20567 end if;
20568
20569 Set_Is_Shared_Passive (Cunit_Ent);
20570 end Shared_Passive;
20571
20572 -----------------------
20573 -- Short_Descriptors --
20574 -----------------------
20575
20576 -- pragma Short_Descriptors;
20577
20578 -- Recognize and validate, but otherwise ignore
20579
20580 when Pragma_Short_Descriptors =>
20581 GNAT_Pragma;
20582 Check_Arg_Count (0);
20583 Check_Valid_Configuration_Pragma;
20584
20585 ------------------------------
20586 -- Simple_Storage_Pool_Type --
20587 ------------------------------
20588
20589 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20590
20591 when Pragma_Simple_Storage_Pool_Type =>
20592 Simple_Storage_Pool_Type : declare
20593 Typ : Entity_Id;
20594 Type_Id : Node_Id;
20595
20596 begin
20597 GNAT_Pragma;
20598 Check_Arg_Count (1);
20599 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20600
20601 Type_Id := Get_Pragma_Arg (Arg1);
20602 Find_Type (Type_Id);
20603 Typ := Entity (Type_Id);
20604
20605 if Typ = Any_Type then
20606 return;
20607 end if;
20608
20609 -- A pragma that applies to a Ghost entity becomes Ghost for the
20610 -- purposes of legality checks and removal of ignored Ghost code.
20611
20612 Mark_Pragma_As_Ghost (N, Typ);
20613
20614 -- We require the pragma to apply to a type declared in a package
20615 -- declaration, but not (immediately) within a package body.
20616
20617 if Ekind (Current_Scope) /= E_Package
20618 or else In_Package_Body (Current_Scope)
20619 then
20620 Error_Pragma
20621 ("pragma% can only apply to type declared immediately "
20622 & "within a package declaration");
20623 end if;
20624
20625 -- A simple storage pool type must be an immutably limited record
20626 -- or private type. If the pragma is given for a private type,
20627 -- the full type is similarly restricted (which is checked later
20628 -- in Freeze_Entity).
20629
20630 if Is_Record_Type (Typ)
20631 and then not Is_Limited_View (Typ)
20632 then
20633 Error_Pragma
20634 ("pragma% can only apply to explicitly limited record type");
20635
20636 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
20637 Error_Pragma
20638 ("pragma% can only apply to a private type that is limited");
20639
20640 elsif not Is_Record_Type (Typ)
20641 and then not Is_Private_Type (Typ)
20642 then
20643 Error_Pragma
20644 ("pragma% can only apply to limited record or private type");
20645 end if;
20646
20647 Record_Rep_Item (Typ, N);
20648 end Simple_Storage_Pool_Type;
20649
20650 ----------------------
20651 -- Source_File_Name --
20652 ----------------------
20653
20654 -- There are five forms for this pragma:
20655
20656 -- pragma Source_File_Name (
20657 -- [UNIT_NAME =>] unit_NAME,
20658 -- BODY_FILE_NAME => STRING_LITERAL
20659 -- [, [INDEX =>] INTEGER_LITERAL]);
20660
20661 -- pragma Source_File_Name (
20662 -- [UNIT_NAME =>] unit_NAME,
20663 -- SPEC_FILE_NAME => STRING_LITERAL
20664 -- [, [INDEX =>] INTEGER_LITERAL]);
20665
20666 -- pragma Source_File_Name (
20667 -- BODY_FILE_NAME => STRING_LITERAL
20668 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20669 -- [, CASING => CASING_SPEC]);
20670
20671 -- pragma Source_File_Name (
20672 -- SPEC_FILE_NAME => STRING_LITERAL
20673 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20674 -- [, CASING => CASING_SPEC]);
20675
20676 -- pragma Source_File_Name (
20677 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20678 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20679 -- [, CASING => CASING_SPEC]);
20680
20681 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20682
20683 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20684 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20685 -- only be used when no project file is used, while SFNP can only be
20686 -- used when a project file is used.
20687
20688 -- No processing here. Processing was completed during parsing, since
20689 -- we need to have file names set as early as possible. Units are
20690 -- loaded well before semantic processing starts.
20691
20692 -- The only processing we defer to this point is the check for
20693 -- correct placement.
20694
20695 when Pragma_Source_File_Name =>
20696 GNAT_Pragma;
20697 Check_Valid_Configuration_Pragma;
20698
20699 ------------------------------
20700 -- Source_File_Name_Project --
20701 ------------------------------
20702
20703 -- See Source_File_Name for syntax
20704
20705 -- No processing here. Processing was completed during parsing, since
20706 -- we need to have file names set as early as possible. Units are
20707 -- loaded well before semantic processing starts.
20708
20709 -- The only processing we defer to this point is the check for
20710 -- correct placement.
20711
20712 when Pragma_Source_File_Name_Project =>
20713 GNAT_Pragma;
20714 Check_Valid_Configuration_Pragma;
20715
20716 -- Check that a pragma Source_File_Name_Project is used only in a
20717 -- configuration pragmas file.
20718
20719 -- Pragmas Source_File_Name_Project should only be generated by
20720 -- the Project Manager in configuration pragmas files.
20721
20722 -- This is really an ugly test. It seems to depend on some
20723 -- accidental and undocumented property. At the very least it
20724 -- needs to be documented, but it would be better to have a
20725 -- clean way of testing if we are in a configuration file???
20726
20727 if Present (Parent (N)) then
20728 Error_Pragma
20729 ("pragma% can only appear in a configuration pragmas file");
20730 end if;
20731
20732 ----------------------
20733 -- Source_Reference --
20734 ----------------------
20735
20736 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20737
20738 -- Nothing to do, all processing completed in Par.Prag, since we need
20739 -- the information for possible parser messages that are output.
20740
20741 when Pragma_Source_Reference =>
20742 GNAT_Pragma;
20743
20744 ----------------
20745 -- SPARK_Mode --
20746 ----------------
20747
20748 -- pragma SPARK_Mode [(On | Off)];
20749
20750 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
20751 Mode_Id : SPARK_Mode_Type;
20752
20753 procedure Check_Pragma_Conformance
20754 (Context_Pragma : Node_Id;
20755 Entity : Entity_Id;
20756 Entity_Pragma : Node_Id);
20757 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20758 -- conformance of pragma N depending the following scenarios:
20759 --
20760 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20761 -- compatible with the pragma Context_Pragma that was inherited
20762 -- from the context:
20763 -- * If the mode of Context_Pragma is ON, then the new mode can
20764 -- be anything.
20765 -- * If the mode of Context_Pragma is OFF, then the only allowed
20766 -- new mode is also OFF. Emit error if this is not the case.
20767 --
20768 -- If Entity is not Empty, verify that pragma N is compatible with
20769 -- pragma Entity_Pragma that belongs to Entity.
20770 -- * If Entity_Pragma is Empty, always issue an error as this
20771 -- corresponds to the case where a previous section of Entity
20772 -- has no SPARK_Mode set.
20773 -- * If the mode of Entity_Pragma is ON, then the new mode can
20774 -- be anything.
20775 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20776 -- new mode is also OFF. Emit error if this is not the case.
20777
20778 procedure Check_Library_Level_Entity (E : Entity_Id);
20779 -- Subsidiary to routines Process_xxx. Verify that the related
20780 -- entity E subject to pragma SPARK_Mode is library-level.
20781
20782 procedure Process_Body (Decl : Node_Id);
20783 -- Verify the legality of pragma SPARK_Mode when it appears as the
20784 -- top of the body declarations of entry, package, protected unit,
20785 -- subprogram or task unit body denoted by Decl.
20786
20787 procedure Process_Overloadable (Decl : Node_Id);
20788 -- Verify the legality of pragma SPARK_Mode when it applies to an
20789 -- entry or [generic] subprogram declaration denoted by Decl.
20790
20791 procedure Process_Private_Part (Decl : Node_Id);
20792 -- Verify the legality of pragma SPARK_Mode when it appears at the
20793 -- top of the private declarations of a package spec, protected or
20794 -- task unit declaration denoted by Decl.
20795
20796 procedure Process_Statement_Part (Decl : Node_Id);
20797 -- Verify the legality of pragma SPARK_Mode when it appears at the
20798 -- top of the statement sequence of a package body denoted by node
20799 -- Decl.
20800
20801 procedure Process_Visible_Part (Decl : Node_Id);
20802 -- Verify the legality of pragma SPARK_Mode when it appears at the
20803 -- top of the visible declarations of a package spec, protected or
20804 -- task unit declaration denoted by Decl. The routine is also used
20805 -- on protected or task units declared without a definition.
20806
20807 procedure Set_SPARK_Context;
20808 -- Subsidiary to routines Process_xxx. Set the global variables
20809 -- which represent the mode of the context from pragma N. Ensure
20810 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20811
20812 ------------------------------
20813 -- Check_Pragma_Conformance --
20814 ------------------------------
20815
20816 procedure Check_Pragma_Conformance
20817 (Context_Pragma : Node_Id;
20818 Entity : Entity_Id;
20819 Entity_Pragma : Node_Id)
20820 is
20821 Err_Id : Entity_Id;
20822 Err_N : Node_Id;
20823
20824 begin
20825 -- The current pragma may appear without an argument. If this
20826 -- is the case, associate all error messages with the pragma
20827 -- itself.
20828
20829 if Present (Arg1) then
20830 Err_N := Arg1;
20831 else
20832 Err_N := N;
20833 end if;
20834
20835 -- The mode of the current pragma is compared against that of
20836 -- an enclosing context.
20837
20838 if Present (Context_Pragma) then
20839 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
20840
20841 -- Issue an error if the new mode is less restrictive than
20842 -- that of the context.
20843
20844 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
20845 and then Get_SPARK_Mode_From_Annotation (N) = On
20846 then
20847 Error_Msg_N
20848 ("cannot change SPARK_Mode from Off to On", Err_N);
20849 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20850 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
20851 raise Pragma_Exit;
20852 end if;
20853 end if;
20854
20855 -- The mode of the current pragma is compared against that of
20856 -- an initial package, protected type, subprogram or task type
20857 -- declaration.
20858
20859 if Present (Entity) then
20860
20861 -- A simple protected or task type is transformed into an
20862 -- anonymous type whose name cannot be used to issue error
20863 -- messages. Recover the original entity of the type.
20864
20865 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
20866 Err_Id :=
20867 Defining_Entity
20868 (Original_Node (Unit_Declaration_Node (Entity)));
20869 else
20870 Err_Id := Entity;
20871 end if;
20872
20873 -- Both the initial declaration and the completion carry
20874 -- SPARK_Mode pragmas.
20875
20876 if Present (Entity_Pragma) then
20877 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
20878
20879 -- Issue an error if the new mode is less restrictive
20880 -- than that of the initial declaration.
20881
20882 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
20883 and then Get_SPARK_Mode_From_Annotation (N) = On
20884 then
20885 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20886 Error_Msg_Sloc := Sloc (Entity_Pragma);
20887 Error_Msg_NE
20888 ("\value Off was set for SPARK_Mode on&#",
20889 Err_N, Err_Id);
20890 raise Pragma_Exit;
20891 end if;
20892
20893 -- Otherwise the initial declaration lacks a SPARK_Mode
20894 -- pragma in which case the current pragma is illegal as
20895 -- it cannot "complete".
20896
20897 else
20898 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20899 Error_Msg_Sloc := Sloc (Err_Id);
20900 Error_Msg_NE
20901 ("\no value was set for SPARK_Mode on&#",
20902 Err_N, Err_Id);
20903 raise Pragma_Exit;
20904 end if;
20905 end if;
20906 end Check_Pragma_Conformance;
20907
20908 --------------------------------
20909 -- Check_Library_Level_Entity --
20910 --------------------------------
20911
20912 procedure Check_Library_Level_Entity (E : Entity_Id) is
20913 procedure Add_Entity_To_Name_Buffer;
20914 -- Add the E_Kind of entity E to the name buffer
20915
20916 -------------------------------
20917 -- Add_Entity_To_Name_Buffer --
20918 -------------------------------
20919
20920 procedure Add_Entity_To_Name_Buffer is
20921 begin
20922 if Ekind_In (E, E_Entry, E_Entry_Family) then
20923 Add_Str_To_Name_Buffer ("entry");
20924
20925 elsif Ekind_In (E, E_Generic_Package,
20926 E_Package,
20927 E_Package_Body)
20928 then
20929 Add_Str_To_Name_Buffer ("package");
20930
20931 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
20932 Add_Str_To_Name_Buffer ("protected type");
20933
20934 elsif Ekind_In (E, E_Function,
20935 E_Generic_Function,
20936 E_Generic_Procedure,
20937 E_Procedure,
20938 E_Subprogram_Body)
20939 then
20940 Add_Str_To_Name_Buffer ("subprogram");
20941
20942 else
20943 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
20944 Add_Str_To_Name_Buffer ("task type");
20945 end if;
20946 end Add_Entity_To_Name_Buffer;
20947
20948 -- Local variables
20949
20950 Msg_1 : constant String := "incorrect placement of pragma%";
20951 Msg_2 : Name_Id;
20952
20953 -- Start of processing for Check_Library_Level_Entity
20954
20955 begin
20956 if not Is_Library_Level_Entity (E) then
20957 Error_Msg_Name_1 := Pname;
20958 Error_Msg_N (Fix_Error (Msg_1), N);
20959
20960 Name_Len := 0;
20961 Add_Str_To_Name_Buffer ("\& is not a library-level ");
20962 Add_Entity_To_Name_Buffer;
20963
20964 Msg_2 := Name_Find;
20965 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
20966
20967 raise Pragma_Exit;
20968 end if;
20969 end Check_Library_Level_Entity;
20970
20971 ------------------
20972 -- Process_Body --
20973 ------------------
20974
20975 procedure Process_Body (Decl : Node_Id) is
20976 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20977 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
20978
20979 begin
20980 -- Ignore pragma when applied to the special body created for
20981 -- inlining, recognized by its internal name _Parent.
20982
20983 if Chars (Body_Id) = Name_uParent then
20984 return;
20985 end if;
20986
20987 Check_Library_Level_Entity (Body_Id);
20988
20989 -- For entry bodies, verify the legality against:
20990 -- * The mode of the context
20991 -- * The mode of the spec (if any)
20992
20993 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
20994
20995 -- A stand alone subprogram body
20996
20997 if Body_Id = Spec_Id then
20998 Check_Pragma_Conformance
20999 (Context_Pragma => SPARK_Pragma (Body_Id),
21000 Entity => Empty,
21001 Entity_Pragma => Empty);
21002
21003 -- An entry or subprogram body that completes a previous
21004 -- declaration.
21005
21006 else
21007 Check_Pragma_Conformance
21008 (Context_Pragma => SPARK_Pragma (Body_Id),
21009 Entity => Spec_Id,
21010 Entity_Pragma => SPARK_Pragma (Spec_Id));
21011 end if;
21012
21013 Set_SPARK_Context;
21014 Set_SPARK_Pragma (Body_Id, N);
21015 Set_SPARK_Pragma_Inherited (Body_Id, False);
21016
21017 -- For package bodies, verify the legality against:
21018 -- * The mode of the context
21019 -- * The mode of the private part
21020
21021 -- This case is separated from protected and task bodies
21022 -- because the statement part of the package body inherits
21023 -- the mode of the body declarations.
21024
21025 elsif Nkind (Decl) = N_Package_Body then
21026 Check_Pragma_Conformance
21027 (Context_Pragma => SPARK_Pragma (Body_Id),
21028 Entity => Spec_Id,
21029 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21030
21031 Set_SPARK_Context;
21032 Set_SPARK_Pragma (Body_Id, N);
21033 Set_SPARK_Pragma_Inherited (Body_Id, False);
21034 Set_SPARK_Aux_Pragma (Body_Id, N);
21035 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
21036
21037 -- For protected and task bodies, verify the legality against:
21038 -- * The mode of the context
21039 -- * The mode of the private part
21040
21041 else
21042 pragma Assert
21043 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
21044
21045 Check_Pragma_Conformance
21046 (Context_Pragma => SPARK_Pragma (Body_Id),
21047 Entity => Spec_Id,
21048 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21049
21050 Set_SPARK_Context;
21051 Set_SPARK_Pragma (Body_Id, N);
21052 Set_SPARK_Pragma_Inherited (Body_Id, False);
21053 end if;
21054 end Process_Body;
21055
21056 --------------------------
21057 -- Process_Overloadable --
21058 --------------------------
21059
21060 procedure Process_Overloadable (Decl : Node_Id) is
21061 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21062 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
21063
21064 begin
21065 Check_Library_Level_Entity (Spec_Id);
21066
21067 -- Verify the legality against:
21068 -- * The mode of the context
21069
21070 Check_Pragma_Conformance
21071 (Context_Pragma => SPARK_Pragma (Spec_Id),
21072 Entity => Empty,
21073 Entity_Pragma => Empty);
21074
21075 Set_SPARK_Pragma (Spec_Id, N);
21076 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21077
21078 -- When the pragma applies to the anonymous object created for
21079 -- a single task type, decorate the type as well. This scenario
21080 -- arises when the single task type lacks a task definition,
21081 -- therefore there is no issue with respect to a potential
21082 -- pragma SPARK_Mode in the private part.
21083
21084 -- task type Anon_Task_Typ;
21085 -- Obj : Anon_Task_Typ;
21086 -- pragma SPARK_Mode ...;
21087
21088 if Is_Single_Task_Object (Spec_Id) then
21089 Set_SPARK_Pragma (Spec_Typ, N);
21090 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
21091 Set_SPARK_Aux_Pragma (Spec_Typ, N);
21092 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
21093 end if;
21094 end Process_Overloadable;
21095
21096 --------------------------
21097 -- Process_Private_Part --
21098 --------------------------
21099
21100 procedure Process_Private_Part (Decl : Node_Id) is
21101 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21102
21103 begin
21104 Check_Library_Level_Entity (Spec_Id);
21105
21106 -- Verify the legality against:
21107 -- * The mode of the visible declarations
21108
21109 Check_Pragma_Conformance
21110 (Context_Pragma => Empty,
21111 Entity => Spec_Id,
21112 Entity_Pragma => SPARK_Pragma (Spec_Id));
21113
21114 Set_SPARK_Context;
21115 Set_SPARK_Aux_Pragma (Spec_Id, N);
21116 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
21117 end Process_Private_Part;
21118
21119 ----------------------------
21120 -- Process_Statement_Part --
21121 ----------------------------
21122
21123 procedure Process_Statement_Part (Decl : Node_Id) is
21124 Body_Id : constant Entity_Id := Defining_Entity (Decl);
21125
21126 begin
21127 Check_Library_Level_Entity (Body_Id);
21128
21129 -- Verify the legality against:
21130 -- * The mode of the body declarations
21131
21132 Check_Pragma_Conformance
21133 (Context_Pragma => Empty,
21134 Entity => Body_Id,
21135 Entity_Pragma => SPARK_Pragma (Body_Id));
21136
21137 Set_SPARK_Context;
21138 Set_SPARK_Aux_Pragma (Body_Id, N);
21139 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
21140 end Process_Statement_Part;
21141
21142 --------------------------
21143 -- Process_Visible_Part --
21144 --------------------------
21145
21146 procedure Process_Visible_Part (Decl : Node_Id) is
21147 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21148 Obj_Id : Entity_Id;
21149
21150 begin
21151 Check_Library_Level_Entity (Spec_Id);
21152
21153 -- Verify the legality against:
21154 -- * The mode of the context
21155
21156 Check_Pragma_Conformance
21157 (Context_Pragma => SPARK_Pragma (Spec_Id),
21158 Entity => Empty,
21159 Entity_Pragma => Empty);
21160
21161 -- A task unit declared without a definition does not set the
21162 -- SPARK_Mode of the context because the task does not have any
21163 -- entries that could inherit the mode.
21164
21165 if not Nkind_In (Decl, N_Single_Task_Declaration,
21166 N_Task_Type_Declaration)
21167 then
21168 Set_SPARK_Context;
21169 end if;
21170
21171 Set_SPARK_Pragma (Spec_Id, N);
21172 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21173 Set_SPARK_Aux_Pragma (Spec_Id, N);
21174 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
21175
21176 -- When the pragma applies to a single protected or task type,
21177 -- decorate the corresponding anonymous object as well.
21178
21179 -- protected Anon_Prot_Typ is
21180 -- pragma SPARK_Mode ...;
21181 -- ...
21182 -- end Anon_Prot_Typ;
21183
21184 -- Obj : Anon_Prot_Typ;
21185
21186 if Is_Single_Concurrent_Type (Spec_Id) then
21187 Obj_Id := Anonymous_Object (Spec_Id);
21188
21189 Set_SPARK_Pragma (Obj_Id, N);
21190 Set_SPARK_Pragma_Inherited (Obj_Id, False);
21191 end if;
21192 end Process_Visible_Part;
21193
21194 -----------------------
21195 -- Set_SPARK_Context --
21196 -----------------------
21197
21198 procedure Set_SPARK_Context is
21199 begin
21200 SPARK_Mode := Mode_Id;
21201 SPARK_Mode_Pragma := N;
21202 end Set_SPARK_Context;
21203
21204 -- Local variables
21205
21206 Context : Node_Id;
21207 Mode : Name_Id;
21208 Stmt : Node_Id;
21209
21210 -- Start of processing for Do_SPARK_Mode
21211
21212 begin
21213 -- When a SPARK_Mode pragma appears inside an instantiation whose
21214 -- enclosing context has SPARK_Mode set to "off", the pragma has
21215 -- no semantic effect.
21216
21217 if Ignore_Pragma_SPARK_Mode then
21218 Rewrite (N, Make_Null_Statement (Loc));
21219 Analyze (N);
21220 return;
21221 end if;
21222
21223 GNAT_Pragma;
21224 Check_No_Identifiers;
21225 Check_At_Most_N_Arguments (1);
21226
21227 -- Check the legality of the mode (no argument = ON)
21228
21229 if Arg_Count = 1 then
21230 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21231 Mode := Chars (Get_Pragma_Arg (Arg1));
21232 else
21233 Mode := Name_On;
21234 end if;
21235
21236 Mode_Id := Get_SPARK_Mode_Type (Mode);
21237 Context := Parent (N);
21238
21239 -- The pragma appears in a configuration file
21240
21241 if No (Context) then
21242 Check_Valid_Configuration_Pragma;
21243
21244 if Present (SPARK_Mode_Pragma) then
21245 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
21246 Error_Msg_N ("pragma% duplicates pragma declared#", N);
21247 raise Pragma_Exit;
21248 end if;
21249
21250 Set_SPARK_Context;
21251
21252 -- The pragma acts as a configuration pragma in a compilation unit
21253
21254 -- pragma SPARK_Mode ...;
21255 -- package Pack is ...;
21256
21257 elsif Nkind (Context) = N_Compilation_Unit
21258 and then List_Containing (N) = Context_Items (Context)
21259 then
21260 Check_Valid_Configuration_Pragma;
21261 Set_SPARK_Context;
21262
21263 -- Otherwise the placement of the pragma within the tree dictates
21264 -- its associated construct. Inspect the declarative list where
21265 -- the pragma resides to find a potential construct.
21266
21267 else
21268 Stmt := Prev (N);
21269 while Present (Stmt) loop
21270
21271 -- Skip prior pragmas, but check for duplicates. Note that
21272 -- this also takes care of pragmas generated for aspects.
21273
21274 if Nkind (Stmt) = N_Pragma then
21275 if Pragma_Name (Stmt) = Pname then
21276 Error_Msg_Name_1 := Pname;
21277 Error_Msg_Sloc := Sloc (Stmt);
21278 Error_Msg_N ("pragma% duplicates pragma declared#", N);
21279 raise Pragma_Exit;
21280 end if;
21281
21282 -- The pragma applies to an expression function that has
21283 -- already been rewritten into a subprogram declaration.
21284
21285 -- function Expr_Func return ... is (...);
21286 -- pragma SPARK_Mode ...;
21287
21288 elsif Nkind (Stmt) = N_Subprogram_Declaration
21289 and then Nkind (Original_Node (Stmt)) =
21290 N_Expression_Function
21291 then
21292 Process_Overloadable (Stmt);
21293 return;
21294
21295 -- The pragma applies to the anonymous object created for a
21296 -- single concurrent type.
21297
21298 -- protected type Anon_Prot_Typ ...;
21299 -- Obj : Anon_Prot_Typ;
21300 -- pragma SPARK_Mode ...;
21301
21302 elsif Nkind (Stmt) = N_Object_Declaration
21303 and then Is_Single_Concurrent_Object
21304 (Defining_Entity (Stmt))
21305 then
21306 Process_Overloadable (Stmt);
21307 return;
21308
21309 -- Skip internally generated code
21310
21311 elsif not Comes_From_Source (Stmt) then
21312 null;
21313
21314 -- The pragma applies to an entry or [generic] subprogram
21315 -- declaration.
21316
21317 -- entry Ent ...;
21318 -- pragma SPARK_Mode ...;
21319
21320 -- [generic]
21321 -- procedure Proc ...;
21322 -- pragma SPARK_Mode ...;
21323
21324 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
21325 N_Subprogram_Declaration)
21326 or else (Nkind (Stmt) = N_Entry_Declaration
21327 and then Is_Protected_Type
21328 (Scope (Defining_Entity (Stmt))))
21329 then
21330 Process_Overloadable (Stmt);
21331 return;
21332
21333 -- Otherwise the pragma does not apply to a legal construct
21334 -- or it does not appear at the top of a declarative or a
21335 -- statement list. Issue an error and stop the analysis.
21336
21337 else
21338 Pragma_Misplaced;
21339 exit;
21340 end if;
21341
21342 Prev (Stmt);
21343 end loop;
21344
21345 -- The pragma applies to a package or a subprogram that acts as
21346 -- a compilation unit.
21347
21348 -- procedure Proc ...;
21349 -- pragma SPARK_Mode ...;
21350
21351 if Nkind (Context) = N_Compilation_Unit_Aux then
21352 Context := Unit (Parent (Context));
21353 end if;
21354
21355 -- The pragma appears at the top of entry, package, protected
21356 -- unit, subprogram or task unit body declarations.
21357
21358 -- entry Ent when ... is
21359 -- pragma SPARK_Mode ...;
21360
21361 -- package body Pack is
21362 -- pragma SPARK_Mode ...;
21363
21364 -- procedure Proc ... is
21365 -- pragma SPARK_Mode;
21366
21367 -- protected body Prot is
21368 -- pragma SPARK_Mode ...;
21369
21370 if Nkind_In (Context, N_Entry_Body,
21371 N_Package_Body,
21372 N_Protected_Body,
21373 N_Subprogram_Body,
21374 N_Task_Body)
21375 then
21376 Process_Body (Context);
21377
21378 -- The pragma appears at the top of the visible or private
21379 -- declaration of a package spec, protected or task unit.
21380
21381 -- package Pack is
21382 -- pragma SPARK_Mode ...;
21383 -- private
21384 -- pragma SPARK_Mode ...;
21385
21386 -- protected [type] Prot is
21387 -- pragma SPARK_Mode ...;
21388 -- private
21389 -- pragma SPARK_Mode ...;
21390
21391 elsif Nkind_In (Context, N_Package_Specification,
21392 N_Protected_Definition,
21393 N_Task_Definition)
21394 then
21395 if List_Containing (N) = Visible_Declarations (Context) then
21396 Process_Visible_Part (Parent (Context));
21397 else
21398 Process_Private_Part (Parent (Context));
21399 end if;
21400
21401 -- The pragma appears at the top of package body statements
21402
21403 -- package body Pack is
21404 -- begin
21405 -- pragma SPARK_Mode;
21406
21407 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
21408 and then Nkind (Parent (Context)) = N_Package_Body
21409 then
21410 Process_Statement_Part (Parent (Context));
21411
21412 -- The pragma appeared as an aspect of a [generic] subprogram
21413 -- declaration that acts as a compilation unit.
21414
21415 -- [generic]
21416 -- procedure Proc ...;
21417 -- pragma SPARK_Mode ...;
21418
21419 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
21420 N_Subprogram_Declaration)
21421 then
21422 Process_Overloadable (Context);
21423
21424 -- The pragma does not apply to a legal construct, issue error
21425
21426 else
21427 Pragma_Misplaced;
21428 end if;
21429 end if;
21430 end Do_SPARK_Mode;
21431
21432 --------------------------------
21433 -- Static_Elaboration_Desired --
21434 --------------------------------
21435
21436 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21437
21438 when Pragma_Static_Elaboration_Desired =>
21439 GNAT_Pragma;
21440 Check_At_Most_N_Arguments (1);
21441
21442 if Is_Compilation_Unit (Current_Scope)
21443 and then Ekind (Current_Scope) = E_Package
21444 then
21445 Set_Static_Elaboration_Desired (Current_Scope, True);
21446 else
21447 Error_Pragma ("pragma% must apply to a library-level package");
21448 end if;
21449
21450 ------------------
21451 -- Storage_Size --
21452 ------------------
21453
21454 -- pragma Storage_Size (EXPRESSION);
21455
21456 when Pragma_Storage_Size => Storage_Size : declare
21457 P : constant Node_Id := Parent (N);
21458 Arg : Node_Id;
21459
21460 begin
21461 Check_No_Identifiers;
21462 Check_Arg_Count (1);
21463
21464 -- The expression must be analyzed in the special manner described
21465 -- in "Handling of Default Expressions" in sem.ads.
21466
21467 Arg := Get_Pragma_Arg (Arg1);
21468 Preanalyze_Spec_Expression (Arg, Any_Integer);
21469
21470 if not Is_OK_Static_Expression (Arg) then
21471 Check_Restriction (Static_Storage_Size, Arg);
21472 end if;
21473
21474 if Nkind (P) /= N_Task_Definition then
21475 Pragma_Misplaced;
21476 return;
21477
21478 else
21479 if Has_Storage_Size_Pragma (P) then
21480 Error_Pragma ("duplicate pragma% not allowed");
21481 else
21482 Set_Has_Storage_Size_Pragma (P, True);
21483 end if;
21484
21485 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
21486 end if;
21487 end Storage_Size;
21488
21489 ------------------
21490 -- Storage_Unit --
21491 ------------------
21492
21493 -- pragma Storage_Unit (NUMERIC_LITERAL);
21494
21495 -- Only permitted argument is System'Storage_Unit value
21496
21497 when Pragma_Storage_Unit =>
21498 Check_No_Identifiers;
21499 Check_Arg_Count (1);
21500 Check_Arg_Is_Integer_Literal (Arg1);
21501
21502 if Intval (Get_Pragma_Arg (Arg1)) /=
21503 UI_From_Int (Ttypes.System_Storage_Unit)
21504 then
21505 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
21506 Error_Pragma_Arg
21507 ("the only allowed argument for pragma% is ^", Arg1);
21508 end if;
21509
21510 --------------------
21511 -- Stream_Convert --
21512 --------------------
21513
21514 -- pragma Stream_Convert (
21515 -- [Entity =>] type_LOCAL_NAME,
21516 -- [Read =>] function_NAME,
21517 -- [Write =>] function NAME);
21518
21519 when Pragma_Stream_Convert => Stream_Convert : declare
21520
21521 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
21522 -- Check that the given argument is the name of a local function
21523 -- of one argument that is not overloaded earlier in the current
21524 -- local scope. A check is also made that the argument is a
21525 -- function with one parameter.
21526
21527 --------------------------------------
21528 -- Check_OK_Stream_Convert_Function --
21529 --------------------------------------
21530
21531 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
21532 Ent : Entity_Id;
21533
21534 begin
21535 Check_Arg_Is_Local_Name (Arg);
21536 Ent := Entity (Get_Pragma_Arg (Arg));
21537
21538 if Has_Homonym (Ent) then
21539 Error_Pragma_Arg
21540 ("argument for pragma% may not be overloaded", Arg);
21541 end if;
21542
21543 if Ekind (Ent) /= E_Function
21544 or else No (First_Formal (Ent))
21545 or else Present (Next_Formal (First_Formal (Ent)))
21546 then
21547 Error_Pragma_Arg
21548 ("argument for pragma% must be function of one argument",
21549 Arg);
21550 end if;
21551 end Check_OK_Stream_Convert_Function;
21552
21553 -- Start of processing for Stream_Convert
21554
21555 begin
21556 GNAT_Pragma;
21557 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
21558 Check_Arg_Count (3);
21559 Check_Optional_Identifier (Arg1, Name_Entity);
21560 Check_Optional_Identifier (Arg2, Name_Read);
21561 Check_Optional_Identifier (Arg3, Name_Write);
21562 Check_Arg_Is_Local_Name (Arg1);
21563 Check_OK_Stream_Convert_Function (Arg2);
21564 Check_OK_Stream_Convert_Function (Arg3);
21565
21566 declare
21567 Typ : constant Entity_Id :=
21568 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
21569 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
21570 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
21571
21572 begin
21573 Check_First_Subtype (Arg1);
21574
21575 -- Check for too early or too late. Note that we don't enforce
21576 -- the rule about primitive operations in this case, since, as
21577 -- is the case for explicit stream attributes themselves, these
21578 -- restrictions are not appropriate. Note that the chaining of
21579 -- the pragma by Rep_Item_Too_Late is actually the critical
21580 -- processing done for this pragma.
21581
21582 if Rep_Item_Too_Early (Typ, N)
21583 or else
21584 Rep_Item_Too_Late (Typ, N, FOnly => True)
21585 then
21586 return;
21587 end if;
21588
21589 -- Return if previous error
21590
21591 if Etype (Typ) = Any_Type
21592 or else
21593 Etype (Read) = Any_Type
21594 or else
21595 Etype (Write) = Any_Type
21596 then
21597 return;
21598 end if;
21599
21600 -- Error checks
21601
21602 if Underlying_Type (Etype (Read)) /= Typ then
21603 Error_Pragma_Arg
21604 ("incorrect return type for function&", Arg2);
21605 end if;
21606
21607 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
21608 Error_Pragma_Arg
21609 ("incorrect parameter type for function&", Arg3);
21610 end if;
21611
21612 if Underlying_Type (Etype (First_Formal (Read))) /=
21613 Underlying_Type (Etype (Write))
21614 then
21615 Error_Pragma_Arg
21616 ("result type of & does not match Read parameter type",
21617 Arg3);
21618 end if;
21619 end;
21620 end Stream_Convert;
21621
21622 ------------------
21623 -- Style_Checks --
21624 ------------------
21625
21626 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21627
21628 -- This is processed by the parser since some of the style checks
21629 -- take place during source scanning and parsing. This means that
21630 -- we don't need to issue error messages here.
21631
21632 when Pragma_Style_Checks => Style_Checks : declare
21633 A : constant Node_Id := Get_Pragma_Arg (Arg1);
21634 S : String_Id;
21635 C : Char_Code;
21636
21637 begin
21638 GNAT_Pragma;
21639 Check_No_Identifiers;
21640
21641 -- Two argument form
21642
21643 if Arg_Count = 2 then
21644 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21645
21646 declare
21647 E_Id : Node_Id;
21648 E : Entity_Id;
21649
21650 begin
21651 E_Id := Get_Pragma_Arg (Arg2);
21652 Analyze (E_Id);
21653
21654 if not Is_Entity_Name (E_Id) then
21655 Error_Pragma_Arg
21656 ("second argument of pragma% must be entity name",
21657 Arg2);
21658 end if;
21659
21660 E := Entity (E_Id);
21661
21662 if not Ignore_Style_Checks_Pragmas then
21663 if E = Any_Id then
21664 return;
21665 else
21666 loop
21667 Set_Suppress_Style_Checks
21668 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
21669 exit when No (Homonym (E));
21670 E := Homonym (E);
21671 end loop;
21672 end if;
21673 end if;
21674 end;
21675
21676 -- One argument form
21677
21678 else
21679 Check_Arg_Count (1);
21680
21681 if Nkind (A) = N_String_Literal then
21682 S := Strval (A);
21683
21684 declare
21685 Slen : constant Natural := Natural (String_Length (S));
21686 Options : String (1 .. Slen);
21687 J : Positive;
21688
21689 begin
21690 J := 1;
21691 loop
21692 C := Get_String_Char (S, Pos (J));
21693 exit when not In_Character_Range (C);
21694 Options (J) := Get_Character (C);
21695
21696 -- If at end of string, set options. As per discussion
21697 -- above, no need to check for errors, since we issued
21698 -- them in the parser.
21699
21700 if J = Slen then
21701 if not Ignore_Style_Checks_Pragmas then
21702 Set_Style_Check_Options (Options);
21703 end if;
21704
21705 exit;
21706 end if;
21707
21708 J := J + 1;
21709 end loop;
21710 end;
21711
21712 elsif Nkind (A) = N_Identifier then
21713 if Chars (A) = Name_All_Checks then
21714 if not Ignore_Style_Checks_Pragmas then
21715 if GNAT_Mode then
21716 Set_GNAT_Style_Check_Options;
21717 else
21718 Set_Default_Style_Check_Options;
21719 end if;
21720 end if;
21721
21722 elsif Chars (A) = Name_On then
21723 if not Ignore_Style_Checks_Pragmas then
21724 Style_Check := True;
21725 end if;
21726
21727 elsif Chars (A) = Name_Off then
21728 if not Ignore_Style_Checks_Pragmas then
21729 Style_Check := False;
21730 end if;
21731 end if;
21732 end if;
21733 end if;
21734 end Style_Checks;
21735
21736 --------------
21737 -- Subtitle --
21738 --------------
21739
21740 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21741
21742 when Pragma_Subtitle =>
21743 GNAT_Pragma;
21744 Check_Arg_Count (1);
21745 Check_Optional_Identifier (Arg1, Name_Subtitle);
21746 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21747 Store_Note (N);
21748
21749 --------------
21750 -- Suppress --
21751 --------------
21752
21753 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21754
21755 when Pragma_Suppress =>
21756 Process_Suppress_Unsuppress (Suppress_Case => True);
21757
21758 ------------------
21759 -- Suppress_All --
21760 ------------------
21761
21762 -- pragma Suppress_All;
21763
21764 -- The only check made here is that the pragma has no arguments.
21765 -- There are no placement rules, and the processing required (setting
21766 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21767 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21768 -- then creates and inserts a pragma Suppress (All_Checks).
21769
21770 when Pragma_Suppress_All =>
21771 GNAT_Pragma;
21772 Check_Arg_Count (0);
21773
21774 -------------------------
21775 -- Suppress_Debug_Info --
21776 -------------------------
21777
21778 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21779
21780 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
21781 Nam_Id : Entity_Id;
21782
21783 begin
21784 GNAT_Pragma;
21785 Check_Arg_Count (1);
21786 Check_Optional_Identifier (Arg1, Name_Entity);
21787 Check_Arg_Is_Local_Name (Arg1);
21788
21789 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
21790
21791 -- A pragma that applies to a Ghost entity becomes Ghost for the
21792 -- purposes of legality checks and removal of ignored Ghost code.
21793
21794 Mark_Pragma_As_Ghost (N, Nam_Id);
21795 Set_Debug_Info_Off (Nam_Id);
21796 end Suppress_Debug_Info;
21797
21798 ----------------------------------
21799 -- Suppress_Exception_Locations --
21800 ----------------------------------
21801
21802 -- pragma Suppress_Exception_Locations;
21803
21804 when Pragma_Suppress_Exception_Locations =>
21805 GNAT_Pragma;
21806 Check_Arg_Count (0);
21807 Check_Valid_Configuration_Pragma;
21808 Exception_Locations_Suppressed := True;
21809
21810 -----------------------------
21811 -- Suppress_Initialization --
21812 -----------------------------
21813
21814 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21815
21816 when Pragma_Suppress_Initialization => Suppress_Init : declare
21817 E : Entity_Id;
21818 E_Id : Node_Id;
21819
21820 begin
21821 GNAT_Pragma;
21822 Check_Arg_Count (1);
21823 Check_Optional_Identifier (Arg1, Name_Entity);
21824 Check_Arg_Is_Local_Name (Arg1);
21825
21826 E_Id := Get_Pragma_Arg (Arg1);
21827
21828 if Etype (E_Id) = Any_Type then
21829 return;
21830 end if;
21831
21832 E := Entity (E_Id);
21833
21834 -- A pragma that applies to a Ghost entity becomes Ghost for the
21835 -- purposes of legality checks and removal of ignored Ghost code.
21836
21837 Mark_Pragma_As_Ghost (N, E);
21838
21839 if not Is_Type (E) and then Ekind (E) /= E_Variable then
21840 Error_Pragma_Arg
21841 ("pragma% requires variable, type or subtype", Arg1);
21842 end if;
21843
21844 if Rep_Item_Too_Early (E, N)
21845 or else
21846 Rep_Item_Too_Late (E, N, FOnly => True)
21847 then
21848 return;
21849 end if;
21850
21851 -- For incomplete/private type, set flag on full view
21852
21853 if Is_Incomplete_Or_Private_Type (E) then
21854 if No (Full_View (Base_Type (E))) then
21855 Error_Pragma_Arg
21856 ("argument of pragma% cannot be an incomplete type", Arg1);
21857 else
21858 Set_Suppress_Initialization (Full_View (Base_Type (E)));
21859 end if;
21860
21861 -- For first subtype, set flag on base type
21862
21863 elsif Is_First_Subtype (E) then
21864 Set_Suppress_Initialization (Base_Type (E));
21865
21866 -- For other than first subtype, set flag on subtype or variable
21867
21868 else
21869 Set_Suppress_Initialization (E);
21870 end if;
21871 end Suppress_Init;
21872
21873 -----------------
21874 -- System_Name --
21875 -----------------
21876
21877 -- pragma System_Name (DIRECT_NAME);
21878
21879 -- Syntax check: one argument, which must be the identifier GNAT or
21880 -- the identifier GCC, no other identifiers are acceptable.
21881
21882 when Pragma_System_Name =>
21883 GNAT_Pragma;
21884 Check_No_Identifiers;
21885 Check_Arg_Count (1);
21886 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
21887
21888 -----------------------------
21889 -- Task_Dispatching_Policy --
21890 -----------------------------
21891
21892 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21893
21894 when Pragma_Task_Dispatching_Policy => declare
21895 DP : Character;
21896
21897 begin
21898 Check_Ada_83_Warning;
21899 Check_Arg_Count (1);
21900 Check_No_Identifiers;
21901 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21902 Check_Valid_Configuration_Pragma;
21903 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21904 DP := Fold_Upper (Name_Buffer (1));
21905
21906 if Task_Dispatching_Policy /= ' '
21907 and then Task_Dispatching_Policy /= DP
21908 then
21909 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21910 Error_Pragma
21911 ("task dispatching policy incompatible with policy#");
21912
21913 -- Set new policy, but always preserve System_Location since we
21914 -- like the error message with the run time name.
21915
21916 else
21917 Task_Dispatching_Policy := DP;
21918
21919 if Task_Dispatching_Policy_Sloc /= System_Location then
21920 Task_Dispatching_Policy_Sloc := Loc;
21921 end if;
21922 end if;
21923 end;
21924
21925 ---------------
21926 -- Task_Info --
21927 ---------------
21928
21929 -- pragma Task_Info (EXPRESSION);
21930
21931 when Pragma_Task_Info => Task_Info : declare
21932 P : constant Node_Id := Parent (N);
21933 Ent : Entity_Id;
21934
21935 begin
21936 GNAT_Pragma;
21937
21938 if Warn_On_Obsolescent_Feature then
21939 Error_Msg_N
21940 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21941 & "instead?j?", N);
21942 end if;
21943
21944 if Nkind (P) /= N_Task_Definition then
21945 Error_Pragma ("pragma% must appear in task definition");
21946 end if;
21947
21948 Check_No_Identifiers;
21949 Check_Arg_Count (1);
21950
21951 Analyze_And_Resolve
21952 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
21953
21954 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
21955 return;
21956 end if;
21957
21958 Ent := Defining_Identifier (Parent (P));
21959
21960 -- Check duplicate pragma before we chain the pragma in the Rep
21961 -- Item chain of Ent.
21962
21963 if Has_Rep_Pragma
21964 (Ent, Name_Task_Info, Check_Parents => False)
21965 then
21966 Error_Pragma ("duplicate pragma% not allowed");
21967 end if;
21968
21969 Record_Rep_Item (Ent, N);
21970 end Task_Info;
21971
21972 ---------------
21973 -- Task_Name --
21974 ---------------
21975
21976 -- pragma Task_Name (string_EXPRESSION);
21977
21978 when Pragma_Task_Name => Task_Name : declare
21979 P : constant Node_Id := Parent (N);
21980 Arg : Node_Id;
21981 Ent : Entity_Id;
21982
21983 begin
21984 Check_No_Identifiers;
21985 Check_Arg_Count (1);
21986
21987 Arg := Get_Pragma_Arg (Arg1);
21988
21989 -- The expression is used in the call to Create_Task, and must be
21990 -- expanded there, not in the context of the current spec. It must
21991 -- however be analyzed to capture global references, in case it
21992 -- appears in a generic context.
21993
21994 Preanalyze_And_Resolve (Arg, Standard_String);
21995
21996 if Nkind (P) /= N_Task_Definition then
21997 Pragma_Misplaced;
21998 end if;
21999
22000 Ent := Defining_Identifier (Parent (P));
22001
22002 -- Check duplicate pragma before we chain the pragma in the Rep
22003 -- Item chain of Ent.
22004
22005 if Has_Rep_Pragma
22006 (Ent, Name_Task_Name, Check_Parents => False)
22007 then
22008 Error_Pragma ("duplicate pragma% not allowed");
22009 end if;
22010
22011 Record_Rep_Item (Ent, N);
22012 end Task_Name;
22013
22014 ------------------
22015 -- Task_Storage --
22016 ------------------
22017
22018 -- pragma Task_Storage (
22019 -- [Task_Type =>] LOCAL_NAME,
22020 -- [Top_Guard =>] static_integer_EXPRESSION);
22021
22022 when Pragma_Task_Storage => Task_Storage : declare
22023 Args : Args_List (1 .. 2);
22024 Names : constant Name_List (1 .. 2) := (
22025 Name_Task_Type,
22026 Name_Top_Guard);
22027
22028 Task_Type : Node_Id renames Args (1);
22029 Top_Guard : Node_Id renames Args (2);
22030
22031 Ent : Entity_Id;
22032
22033 begin
22034 GNAT_Pragma;
22035 Gather_Associations (Names, Args);
22036
22037 if No (Task_Type) then
22038 Error_Pragma
22039 ("missing task_type argument for pragma%");
22040 end if;
22041
22042 Check_Arg_Is_Local_Name (Task_Type);
22043
22044 Ent := Entity (Task_Type);
22045
22046 if not Is_Task_Type (Ent) then
22047 Error_Pragma_Arg
22048 ("argument for pragma% must be task type", Task_Type);
22049 end if;
22050
22051 if No (Top_Guard) then
22052 Error_Pragma_Arg
22053 ("pragma% takes two arguments", Task_Type);
22054 else
22055 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
22056 end if;
22057
22058 Check_First_Subtype (Task_Type);
22059
22060 if Rep_Item_Too_Late (Ent, N) then
22061 raise Pragma_Exit;
22062 end if;
22063 end Task_Storage;
22064
22065 ---------------
22066 -- Test_Case --
22067 ---------------
22068
22069 -- pragma Test_Case
22070 -- ([Name =>] Static_String_EXPRESSION
22071 -- ,[Mode =>] MODE_TYPE
22072 -- [, Requires => Boolean_EXPRESSION]
22073 -- [, Ensures => Boolean_EXPRESSION]);
22074
22075 -- MODE_TYPE ::= Nominal | Robustness
22076
22077 -- Characteristics:
22078
22079 -- * Analysis - The annotation undergoes initial checks to verify
22080 -- the legal placement and context. Secondary checks preanalyze the
22081 -- expressions in:
22082
22083 -- Analyze_Test_Case_In_Decl_Part
22084
22085 -- * Expansion - None.
22086
22087 -- * Template - The annotation utilizes the generic template of the
22088 -- related subprogram when it is:
22089
22090 -- aspect on subprogram declaration
22091
22092 -- The annotation must prepare its own template when it is:
22093
22094 -- pragma on subprogram declaration
22095
22096 -- * Globals - Capture of global references must occur after full
22097 -- analysis.
22098
22099 -- * Instance - The annotation is instantiated automatically when
22100 -- the related generic subprogram is instantiated except for the
22101 -- "pragma on subprogram declaration" case. In that scenario the
22102 -- annotation must instantiate itself.
22103
22104 when Pragma_Test_Case => Test_Case : declare
22105 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
22106 -- Ensure that the contract of subprogram Subp_Id does not contain
22107 -- another Test_Case pragma with the same Name as the current one.
22108
22109 -------------------------
22110 -- Check_Distinct_Name --
22111 -------------------------
22112
22113 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
22114 Items : constant Node_Id := Contract (Subp_Id);
22115 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
22116 Prag : Node_Id;
22117
22118 begin
22119 -- Inspect all Test_Case pragma of the related subprogram
22120 -- looking for one with a duplicate "Name" argument.
22121
22122 if Present (Items) then
22123 Prag := Contract_Test_Cases (Items);
22124 while Present (Prag) loop
22125 if Pragma_Name (Prag) = Name_Test_Case
22126 and then Prag /= N
22127 and then String_Equal
22128 (Name, Get_Name_From_CTC_Pragma (Prag))
22129 then
22130 Error_Msg_Sloc := Sloc (Prag);
22131 Error_Pragma ("name for pragma % is already used #");
22132 end if;
22133
22134 Prag := Next_Pragma (Prag);
22135 end loop;
22136 end if;
22137 end Check_Distinct_Name;
22138
22139 -- Local variables
22140
22141 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
22142 Asp_Arg : Node_Id;
22143 Context : Node_Id;
22144 Subp_Decl : Node_Id;
22145 Subp_Id : Entity_Id;
22146
22147 -- Start of processing for Test_Case
22148
22149 begin
22150 GNAT_Pragma;
22151 Check_At_Least_N_Arguments (2);
22152 Check_At_Most_N_Arguments (4);
22153 Check_Arg_Order
22154 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
22155
22156 -- Argument "Name"
22157
22158 Check_Optional_Identifier (Arg1, Name_Name);
22159 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22160
22161 -- Argument "Mode"
22162
22163 Check_Optional_Identifier (Arg2, Name_Mode);
22164 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
22165
22166 -- Arguments "Requires" and "Ensures"
22167
22168 if Present (Arg3) then
22169 if Present (Arg4) then
22170 Check_Identifier (Arg3, Name_Requires);
22171 Check_Identifier (Arg4, Name_Ensures);
22172 else
22173 Check_Identifier_Is_One_Of
22174 (Arg3, Name_Requires, Name_Ensures);
22175 end if;
22176 end if;
22177
22178 -- Pragma Test_Case must be associated with a subprogram declared
22179 -- in a library-level package. First determine whether the current
22180 -- compilation unit is a legal context.
22181
22182 if Nkind_In (Pack_Decl, N_Package_Declaration,
22183 N_Generic_Package_Declaration)
22184 then
22185 null;
22186
22187 -- Otherwise the placement is illegal
22188
22189 else
22190 Error_Pragma
22191 ("pragma % must be specified within a package declaration");
22192 return;
22193 end if;
22194
22195 Subp_Decl := Find_Related_Declaration_Or_Body (N);
22196
22197 -- Find the enclosing context
22198
22199 Context := Parent (Subp_Decl);
22200
22201 if Present (Context) then
22202 Context := Parent (Context);
22203 end if;
22204
22205 -- Verify the placement of the pragma
22206
22207 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
22208 Error_Pragma
22209 ("pragma % cannot be applied to abstract subprogram");
22210 return;
22211
22212 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
22213 Error_Pragma ("pragma % cannot be applied to entry");
22214 return;
22215
22216 -- The context is a [generic] subprogram declared at the top level
22217 -- of the [generic] package unit.
22218
22219 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
22220 N_Subprogram_Declaration)
22221 and then Present (Context)
22222 and then Nkind_In (Context, N_Generic_Package_Declaration,
22223 N_Package_Declaration)
22224 then
22225 null;
22226
22227 -- Otherwise the placement is illegal
22228
22229 else
22230 Error_Pragma
22231 ("pragma % must be applied to a library-level subprogram "
22232 & "declaration");
22233 return;
22234 end if;
22235
22236 Subp_Id := Defining_Entity (Subp_Decl);
22237
22238 -- Chain the pragma on the contract for further processing by
22239 -- Analyze_Test_Case_In_Decl_Part.
22240
22241 Add_Contract_Item (N, Subp_Id);
22242
22243 -- A pragma that applies to a Ghost entity becomes Ghost for the
22244 -- purposes of legality checks and removal of ignored Ghost code.
22245
22246 Mark_Pragma_As_Ghost (N, Subp_Id);
22247
22248 -- Preanalyze the original aspect argument "Name" for ASIS or for
22249 -- a generic subprogram to properly capture global references.
22250
22251 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
22252 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
22253
22254 if Present (Asp_Arg) then
22255
22256 -- The argument appears with an identifier in association
22257 -- form.
22258
22259 if Nkind (Asp_Arg) = N_Component_Association then
22260 Asp_Arg := Expression (Asp_Arg);
22261 end if;
22262
22263 Check_Expr_Is_OK_Static_Expression
22264 (Asp_Arg, Standard_String);
22265 end if;
22266 end if;
22267
22268 -- Ensure that the all Test_Case pragmas of the related subprogram
22269 -- have distinct names.
22270
22271 Check_Distinct_Name (Subp_Id);
22272
22273 -- Fully analyze the pragma when it appears inside an entry
22274 -- or subprogram body because it cannot benefit from forward
22275 -- references.
22276
22277 if Nkind_In (Subp_Decl, N_Entry_Body,
22278 N_Subprogram_Body,
22279 N_Subprogram_Body_Stub)
22280 then
22281 -- The legality checks of pragma Test_Case are affected by the
22282 -- SPARK mode in effect and the volatility of the context.
22283 -- Analyze all pragmas in a specific order.
22284
22285 Analyze_If_Present (Pragma_SPARK_Mode);
22286 Analyze_If_Present (Pragma_Volatile_Function);
22287 Analyze_Test_Case_In_Decl_Part (N);
22288 end if;
22289 end Test_Case;
22290
22291 --------------------------
22292 -- Thread_Local_Storage --
22293 --------------------------
22294
22295 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22296
22297 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
22298 E : Entity_Id;
22299 Id : Node_Id;
22300
22301 begin
22302 GNAT_Pragma;
22303 Check_Arg_Count (1);
22304 Check_Optional_Identifier (Arg1, Name_Entity);
22305 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22306
22307 Id := Get_Pragma_Arg (Arg1);
22308 Analyze (Id);
22309
22310 if not Is_Entity_Name (Id)
22311 or else Ekind (Entity (Id)) /= E_Variable
22312 then
22313 Error_Pragma_Arg ("local variable name required", Arg1);
22314 end if;
22315
22316 E := Entity (Id);
22317
22318 -- A pragma that applies to a Ghost entity becomes Ghost for the
22319 -- purposes of legality checks and removal of ignored Ghost code.
22320
22321 Mark_Pragma_As_Ghost (N, E);
22322
22323 if Rep_Item_Too_Early (E, N)
22324 or else
22325 Rep_Item_Too_Late (E, N)
22326 then
22327 raise Pragma_Exit;
22328 end if;
22329
22330 Set_Has_Pragma_Thread_Local_Storage (E);
22331 Set_Has_Gigi_Rep_Item (E);
22332 end Thread_Local_Storage;
22333
22334 ----------------
22335 -- Time_Slice --
22336 ----------------
22337
22338 -- pragma Time_Slice (static_duration_EXPRESSION);
22339
22340 when Pragma_Time_Slice => Time_Slice : declare
22341 Val : Ureal;
22342 Nod : Node_Id;
22343
22344 begin
22345 GNAT_Pragma;
22346 Check_Arg_Count (1);
22347 Check_No_Identifiers;
22348 Check_In_Main_Program;
22349 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
22350
22351 if not Error_Posted (Arg1) then
22352 Nod := Next (N);
22353 while Present (Nod) loop
22354 if Nkind (Nod) = N_Pragma
22355 and then Pragma_Name (Nod) = Name_Time_Slice
22356 then
22357 Error_Msg_Name_1 := Pname;
22358 Error_Msg_N ("duplicate pragma% not permitted", Nod);
22359 end if;
22360
22361 Next (Nod);
22362 end loop;
22363 end if;
22364
22365 -- Process only if in main unit
22366
22367 if Get_Source_Unit (Loc) = Main_Unit then
22368 Opt.Time_Slice_Set := True;
22369 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22370
22371 if Val <= Ureal_0 then
22372 Opt.Time_Slice_Value := 0;
22373
22374 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22375 Opt.Time_Slice_Value := 1_000_000_000;
22376
22377 else
22378 Opt.Time_Slice_Value :=
22379 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22380 end if;
22381 end if;
22382 end Time_Slice;
22383
22384 -----------
22385 -- Title --
22386 -----------
22387
22388 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22389
22390 -- TITLING_OPTION ::=
22391 -- [Title =>] STRING_LITERAL
22392 -- | [Subtitle =>] STRING_LITERAL
22393
22394 when Pragma_Title => Title : declare
22395 Args : Args_List (1 .. 2);
22396 Names : constant Name_List (1 .. 2) := (
22397 Name_Title,
22398 Name_Subtitle);
22399
22400 begin
22401 GNAT_Pragma;
22402 Gather_Associations (Names, Args);
22403 Store_Note (N);
22404
22405 for J in 1 .. 2 loop
22406 if Present (Args (J)) then
22407 Check_Arg_Is_OK_Static_Expression
22408 (Args (J), Standard_String);
22409 end if;
22410 end loop;
22411 end Title;
22412
22413 ----------------------------
22414 -- Type_Invariant[_Class] --
22415 ----------------------------
22416
22417 -- pragma Type_Invariant[_Class]
22418 -- ([Entity =>] type_LOCAL_NAME,
22419 -- [Check =>] EXPRESSION);
22420
22421 when Pragma_Type_Invariant |
22422 Pragma_Type_Invariant_Class =>
22423 Type_Invariant : declare
22424 I_Pragma : Node_Id;
22425
22426 begin
22427 Check_Arg_Count (2);
22428
22429 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22430 -- setting Class_Present for the Type_Invariant_Class case.
22431
22432 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
22433 I_Pragma := New_Copy (N);
22434 Set_Pragma_Identifier
22435 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
22436 Rewrite (N, I_Pragma);
22437 Set_Analyzed (N, False);
22438 Analyze (N);
22439 end Type_Invariant;
22440
22441 ---------------------
22442 -- Unchecked_Union --
22443 ---------------------
22444
22445 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22446
22447 when Pragma_Unchecked_Union => Unchecked_Union : declare
22448 Assoc : constant Node_Id := Arg1;
22449 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
22450 Clist : Node_Id;
22451 Comp : Node_Id;
22452 Tdef : Node_Id;
22453 Typ : Entity_Id;
22454 Variant : Node_Id;
22455 Vpart : Node_Id;
22456
22457 begin
22458 Ada_2005_Pragma;
22459 Check_No_Identifiers;
22460 Check_Arg_Count (1);
22461 Check_Arg_Is_Local_Name (Arg1);
22462
22463 Find_Type (Type_Id);
22464
22465 Typ := Entity (Type_Id);
22466
22467 -- A pragma that applies to a Ghost entity becomes Ghost for the
22468 -- purposes of legality checks and removal of ignored Ghost code.
22469
22470 Mark_Pragma_As_Ghost (N, Typ);
22471
22472 if Typ = Any_Type
22473 or else Rep_Item_Too_Early (Typ, N)
22474 then
22475 return;
22476 else
22477 Typ := Underlying_Type (Typ);
22478 end if;
22479
22480 if Rep_Item_Too_Late (Typ, N) then
22481 return;
22482 end if;
22483
22484 Check_First_Subtype (Arg1);
22485
22486 -- Note remaining cases are references to a type in the current
22487 -- declarative part. If we find an error, we post the error on
22488 -- the relevant type declaration at an appropriate point.
22489
22490 if not Is_Record_Type (Typ) then
22491 Error_Msg_N ("unchecked union must be record type", Typ);
22492 return;
22493
22494 elsif Is_Tagged_Type (Typ) then
22495 Error_Msg_N ("unchecked union must not be tagged", Typ);
22496 return;
22497
22498 elsif not Has_Discriminants (Typ) then
22499 Error_Msg_N
22500 ("unchecked union must have one discriminant", Typ);
22501 return;
22502
22503 -- Note: in previous versions of GNAT we used to check for limited
22504 -- types and give an error, but in fact the standard does allow
22505 -- Unchecked_Union on limited types, so this check was removed.
22506
22507 -- Similarly, GNAT used to require that all discriminants have
22508 -- default values, but this is not mandated by the RM.
22509
22510 -- Proceed with basic error checks completed
22511
22512 else
22513 Tdef := Type_Definition (Declaration_Node (Typ));
22514 Clist := Component_List (Tdef);
22515
22516 -- Check presence of component list and variant part
22517
22518 if No (Clist) or else No (Variant_Part (Clist)) then
22519 Error_Msg_N
22520 ("unchecked union must have variant part", Tdef);
22521 return;
22522 end if;
22523
22524 -- Check components
22525
22526 Comp := First (Component_Items (Clist));
22527 while Present (Comp) loop
22528 Check_Component (Comp, Typ);
22529 Next (Comp);
22530 end loop;
22531
22532 -- Check variant part
22533
22534 Vpart := Variant_Part (Clist);
22535
22536 Variant := First (Variants (Vpart));
22537 while Present (Variant) loop
22538 Check_Variant (Variant, Typ);
22539 Next (Variant);
22540 end loop;
22541 end if;
22542
22543 Set_Is_Unchecked_Union (Typ);
22544 Set_Convention (Typ, Convention_C);
22545 Set_Has_Unchecked_Union (Base_Type (Typ));
22546 Set_Is_Unchecked_Union (Base_Type (Typ));
22547 end Unchecked_Union;
22548
22549 ----------------------------
22550 -- Unevaluated_Use_Of_Old --
22551 ----------------------------
22552
22553 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22554
22555 when Pragma_Unevaluated_Use_Of_Old =>
22556 GNAT_Pragma;
22557 Check_Arg_Count (1);
22558 Check_No_Identifiers;
22559 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
22560
22561 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22562 -- a declarative part or a package spec.
22563
22564 if not Is_Configuration_Pragma then
22565 Check_Is_In_Decl_Part_Or_Package_Spec;
22566 end if;
22567
22568 -- Store proper setting of Uneval_Old
22569
22570 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22571 Uneval_Old := Fold_Upper (Name_Buffer (1));
22572
22573 ------------------------
22574 -- Unimplemented_Unit --
22575 ------------------------
22576
22577 -- pragma Unimplemented_Unit;
22578
22579 -- Note: this only gives an error if we are generating code, or if
22580 -- we are in a generic library unit (where the pragma appears in the
22581 -- body, not in the spec).
22582
22583 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
22584 Cunitent : constant Entity_Id :=
22585 Cunit_Entity (Get_Source_Unit (Loc));
22586 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
22587
22588 begin
22589 GNAT_Pragma;
22590 Check_Arg_Count (0);
22591
22592 if Operating_Mode = Generate_Code
22593 or else Ent_Kind = E_Generic_Function
22594 or else Ent_Kind = E_Generic_Procedure
22595 or else Ent_Kind = E_Generic_Package
22596 then
22597 Get_Name_String (Chars (Cunitent));
22598 Set_Casing (Mixed_Case);
22599 Write_Str (Name_Buffer (1 .. Name_Len));
22600 Write_Str (" is not supported in this configuration");
22601 Write_Eol;
22602 raise Unrecoverable_Error;
22603 end if;
22604 end Unimplemented_Unit;
22605
22606 ------------------------
22607 -- Universal_Aliasing --
22608 ------------------------
22609
22610 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22611
22612 when Pragma_Universal_Aliasing => Universal_Alias : declare
22613 E_Id : Entity_Id;
22614
22615 begin
22616 GNAT_Pragma;
22617 Check_Arg_Count (1);
22618 Check_Optional_Identifier (Arg2, Name_Entity);
22619 Check_Arg_Is_Local_Name (Arg1);
22620 E_Id := Entity (Get_Pragma_Arg (Arg1));
22621
22622 if E_Id = Any_Type then
22623 return;
22624 elsif No (E_Id) or else not Is_Type (E_Id) then
22625 Error_Pragma_Arg ("pragma% requires type", Arg1);
22626 end if;
22627
22628 -- A pragma that applies to a Ghost entity becomes Ghost for the
22629 -- purposes of legality checks and removal of ignored Ghost code.
22630
22631 Mark_Pragma_As_Ghost (N, E_Id);
22632 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
22633 Record_Rep_Item (E_Id, N);
22634 end Universal_Alias;
22635
22636 --------------------
22637 -- Universal_Data --
22638 --------------------
22639
22640 -- pragma Universal_Data [(library_unit_NAME)];
22641
22642 when Pragma_Universal_Data =>
22643 GNAT_Pragma;
22644 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
22645
22646 ----------------
22647 -- Unmodified --
22648 ----------------
22649
22650 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22651
22652 when Pragma_Unmodified =>
22653 Analyze_Unmodified_Or_Unused;
22654
22655 ------------------
22656 -- Unreferenced --
22657 ------------------
22658
22659 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22660
22661 -- or when used in a context clause:
22662
22663 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22664
22665 when Pragma_Unreferenced =>
22666 Analyze_Unreferenced_Or_Unused;
22667
22668 --------------------------
22669 -- Unreferenced_Objects --
22670 --------------------------
22671
22672 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22673
22674 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
22675 Arg : Node_Id;
22676 Arg_Expr : Node_Id;
22677 Arg_Id : Entity_Id;
22678
22679 Ghost_Error_Posted : Boolean := False;
22680 -- Flag set when an error concerning the illegal mix of Ghost and
22681 -- non-Ghost types is emitted.
22682
22683 Ghost_Id : Entity_Id := Empty;
22684 -- The entity of the first Ghost type encountered while processing
22685 -- the arguments of the pragma.
22686
22687 begin
22688 GNAT_Pragma;
22689 Check_At_Least_N_Arguments (1);
22690
22691 Arg := Arg1;
22692 while Present (Arg) loop
22693 Check_No_Identifier (Arg);
22694 Check_Arg_Is_Local_Name (Arg);
22695 Arg_Expr := Get_Pragma_Arg (Arg);
22696
22697 if Is_Entity_Name (Arg_Expr) then
22698 Arg_Id := Entity (Arg_Expr);
22699
22700 if Is_Type (Arg_Id) then
22701 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
22702
22703 -- A pragma that applies to a Ghost entity becomes Ghost
22704 -- for the purposes of legality checks and removal of
22705 -- ignored Ghost code.
22706
22707 Mark_Pragma_As_Ghost (N, Arg_Id);
22708
22709 -- Capture the entity of the first Ghost type being
22710 -- processed for error detection purposes.
22711
22712 if Is_Ghost_Entity (Arg_Id) then
22713 if No (Ghost_Id) then
22714 Ghost_Id := Arg_Id;
22715 end if;
22716
22717 -- Otherwise the type is non-Ghost. It is illegal to mix
22718 -- references to Ghost and non-Ghost entities
22719 -- (SPARK RM 6.9).
22720
22721 elsif Present (Ghost_Id)
22722 and then not Ghost_Error_Posted
22723 then
22724 Ghost_Error_Posted := True;
22725
22726 Error_Msg_Name_1 := Pname;
22727 Error_Msg_N
22728 ("pragma % cannot mention ghost and non-ghost types",
22729 N);
22730
22731 Error_Msg_Sloc := Sloc (Ghost_Id);
22732 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22733
22734 Error_Msg_Sloc := Sloc (Arg_Id);
22735 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22736 end if;
22737 else
22738 Error_Pragma_Arg
22739 ("argument for pragma% must be type or subtype", Arg);
22740 end if;
22741 else
22742 Error_Pragma_Arg
22743 ("argument for pragma% must be type or subtype", Arg);
22744 end if;
22745
22746 Next (Arg);
22747 end loop;
22748 end Unreferenced_Objects;
22749
22750 ------------------------------
22751 -- Unreserve_All_Interrupts --
22752 ------------------------------
22753
22754 -- pragma Unreserve_All_Interrupts;
22755
22756 when Pragma_Unreserve_All_Interrupts =>
22757 GNAT_Pragma;
22758 Check_Arg_Count (0);
22759
22760 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
22761 Unreserve_All_Interrupts := True;
22762 end if;
22763
22764 ----------------
22765 -- Unsuppress --
22766 ----------------
22767
22768 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22769
22770 when Pragma_Unsuppress =>
22771 Ada_2005_Pragma;
22772 Process_Suppress_Unsuppress (Suppress_Case => False);
22773
22774 ------------
22775 -- Unused --
22776 ------------
22777
22778 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
22779
22780 when Pragma_Unused =>
22781 Analyze_Unmodified_Or_Unused (Is_Unused => True);
22782 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
22783
22784 -------------------
22785 -- Use_VADS_Size --
22786 -------------------
22787
22788 -- pragma Use_VADS_Size;
22789
22790 when Pragma_Use_VADS_Size =>
22791 GNAT_Pragma;
22792 Check_Arg_Count (0);
22793 Check_Valid_Configuration_Pragma;
22794 Use_VADS_Size := True;
22795
22796 ---------------------
22797 -- Validity_Checks --
22798 ---------------------
22799
22800 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22801
22802 when Pragma_Validity_Checks => Validity_Checks : declare
22803 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22804 S : String_Id;
22805 C : Char_Code;
22806
22807 begin
22808 GNAT_Pragma;
22809 Check_Arg_Count (1);
22810 Check_No_Identifiers;
22811
22812 -- Pragma always active unless in CodePeer or GNATprove modes,
22813 -- which use a fixed configuration of validity checks.
22814
22815 if not (CodePeer_Mode or GNATprove_Mode) then
22816 if Nkind (A) = N_String_Literal then
22817 S := Strval (A);
22818
22819 declare
22820 Slen : constant Natural := Natural (String_Length (S));
22821 Options : String (1 .. Slen);
22822 J : Positive;
22823
22824 begin
22825 -- Couldn't we use a for loop here over Options'Range???
22826
22827 J := 1;
22828 loop
22829 C := Get_String_Char (S, Pos (J));
22830
22831 -- This is a weird test, it skips setting validity
22832 -- checks entirely if any element of S is out of
22833 -- range of Character, what is that about ???
22834
22835 exit when not In_Character_Range (C);
22836 Options (J) := Get_Character (C);
22837
22838 if J = Slen then
22839 Set_Validity_Check_Options (Options);
22840 exit;
22841 else
22842 J := J + 1;
22843 end if;
22844 end loop;
22845 end;
22846
22847 elsif Nkind (A) = N_Identifier then
22848 if Chars (A) = Name_All_Checks then
22849 Set_Validity_Check_Options ("a");
22850 elsif Chars (A) = Name_On then
22851 Validity_Checks_On := True;
22852 elsif Chars (A) = Name_Off then
22853 Validity_Checks_On := False;
22854 end if;
22855 end if;
22856 end if;
22857 end Validity_Checks;
22858
22859 --------------
22860 -- Volatile --
22861 --------------
22862
22863 -- pragma Volatile (LOCAL_NAME);
22864
22865 when Pragma_Volatile =>
22866 Process_Atomic_Independent_Shared_Volatile;
22867
22868 -------------------------
22869 -- Volatile_Components --
22870 -------------------------
22871
22872 -- pragma Volatile_Components (array_LOCAL_NAME);
22873
22874 -- Volatile is handled by the same circuit as Atomic_Components
22875
22876 --------------------------
22877 -- Volatile_Full_Access --
22878 --------------------------
22879
22880 -- pragma Volatile_Full_Access (LOCAL_NAME);
22881
22882 when Pragma_Volatile_Full_Access =>
22883 GNAT_Pragma;
22884 Process_Atomic_Independent_Shared_Volatile;
22885
22886 -----------------------
22887 -- Volatile_Function --
22888 -----------------------
22889
22890 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22891
22892 when Pragma_Volatile_Function => Volatile_Function : declare
22893 Over_Id : Entity_Id;
22894 Spec_Id : Entity_Id;
22895 Subp_Decl : Node_Id;
22896
22897 begin
22898 GNAT_Pragma;
22899 Check_No_Identifiers;
22900 Check_At_Most_N_Arguments (1);
22901
22902 Subp_Decl :=
22903 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
22904
22905 -- Generic subprogram
22906
22907 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
22908 null;
22909
22910 -- Body acts as spec
22911
22912 elsif Nkind (Subp_Decl) = N_Subprogram_Body
22913 and then No (Corresponding_Spec (Subp_Decl))
22914 then
22915 null;
22916
22917 -- Body stub acts as spec
22918
22919 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
22920 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
22921 then
22922 null;
22923
22924 -- Subprogram
22925
22926 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
22927 null;
22928
22929 else
22930 Pragma_Misplaced;
22931 return;
22932 end if;
22933
22934 Spec_Id := Unique_Defining_Entity (Subp_Decl);
22935
22936 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
22937 Pragma_Misplaced;
22938 return;
22939 end if;
22940
22941 -- Chain the pragma on the contract for completeness
22942
22943 Add_Contract_Item (N, Spec_Id);
22944
22945 -- The legality checks of pragma Volatile_Function are affected by
22946 -- the SPARK mode in effect. Analyze all pragmas in a specific
22947 -- order.
22948
22949 Analyze_If_Present (Pragma_SPARK_Mode);
22950
22951 -- A pragma that applies to a Ghost entity becomes Ghost for the
22952 -- purposes of legality checks and removal of ignored Ghost code.
22953
22954 Mark_Pragma_As_Ghost (N, Spec_Id);
22955
22956 -- A volatile function cannot override a non-volatile function
22957 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22958 -- in New_Overloaded_Entity, however at that point the pragma has
22959 -- not been processed yet.
22960
22961 Over_Id := Overridden_Operation (Spec_Id);
22962
22963 if Present (Over_Id)
22964 and then not Is_Volatile_Function (Over_Id)
22965 then
22966 Error_Msg_N
22967 ("incompatible volatile function values in effect", Spec_Id);
22968
22969 Error_Msg_Sloc := Sloc (Over_Id);
22970 Error_Msg_N
22971 ("\& declared # with Volatile_Function value False",
22972 Spec_Id);
22973
22974 Error_Msg_Sloc := Sloc (Spec_Id);
22975 Error_Msg_N
22976 ("\overridden # with Volatile_Function value True",
22977 Spec_Id);
22978 end if;
22979
22980 -- Analyze the Boolean expression (if any)
22981
22982 if Present (Arg1) then
22983 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
22984 end if;
22985 end Volatile_Function;
22986
22987 ----------------------
22988 -- Warning_As_Error --
22989 ----------------------
22990
22991 -- pragma Warning_As_Error (static_string_EXPRESSION);
22992
22993 when Pragma_Warning_As_Error =>
22994 GNAT_Pragma;
22995 Check_Arg_Count (1);
22996 Check_No_Identifiers;
22997 Check_Valid_Configuration_Pragma;
22998
22999 if not Is_Static_String_Expression (Arg1) then
23000 Error_Pragma_Arg
23001 ("argument of pragma% must be static string expression",
23002 Arg1);
23003
23004 -- OK static string expression
23005
23006 else
23007 Acquire_Warning_Match_String (Arg1);
23008 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
23009 Warnings_As_Errors (Warnings_As_Errors_Count) :=
23010 new String'(Name_Buffer (1 .. Name_Len));
23011 end if;
23012
23013 --------------
23014 -- Warnings --
23015 --------------
23016
23017 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23018
23019 -- DETAILS ::= On | Off
23020 -- DETAILS ::= On | Off, local_NAME
23021 -- DETAILS ::= static_string_EXPRESSION
23022 -- DETAILS ::= On | Off, static_string_EXPRESSION
23023
23024 -- TOOL_NAME ::= GNAT | GNATProve
23025
23026 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23027
23028 -- Note: If the first argument matches an allowed tool name, it is
23029 -- always considered to be a tool name, even if there is a string
23030 -- variable of that name.
23031
23032 -- Note if the second argument of DETAILS is a local_NAME then the
23033 -- second form is always understood. If the intention is to use
23034 -- the fourth form, then you can write NAME & "" to force the
23035 -- intepretation as a static_string_EXPRESSION.
23036
23037 when Pragma_Warnings => Warnings : declare
23038 Reason : String_Id;
23039
23040 begin
23041 GNAT_Pragma;
23042 Check_At_Least_N_Arguments (1);
23043
23044 -- See if last argument is labeled Reason. If so, make sure we
23045 -- have a string literal or a concatenation of string literals,
23046 -- and acquire the REASON string. Then remove the REASON argument
23047 -- by decreasing Num_Args by one; Remaining processing looks only
23048 -- at first Num_Args arguments).
23049
23050 declare
23051 Last_Arg : constant Node_Id :=
23052 Last (Pragma_Argument_Associations (N));
23053
23054 begin
23055 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23056 and then Chars (Last_Arg) = Name_Reason
23057 then
23058 Start_String;
23059 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23060 Reason := End_String;
23061 Arg_Count := Arg_Count - 1;
23062
23063 -- Not allowed in compiler units (bootstrap issues)
23064
23065 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23066
23067 -- No REASON string, set null string as reason
23068
23069 else
23070 Reason := Null_String_Id;
23071 end if;
23072 end;
23073
23074 -- Now proceed with REASON taken care of and eliminated
23075
23076 Check_No_Identifiers;
23077
23078 -- If debug flag -gnatd.i is set, pragma is ignored
23079
23080 if Debug_Flag_Dot_I then
23081 return;
23082 end if;
23083
23084 -- Process various forms of the pragma
23085
23086 declare
23087 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23088 Shifted_Args : List_Id;
23089
23090 begin
23091 -- See if first argument is a tool name, currently either
23092 -- GNAT or GNATprove. If so, either ignore the pragma if the
23093 -- tool used does not match, or continue as if no tool name
23094 -- was given otherwise, by shifting the arguments.
23095
23096 if Nkind (Argx) = N_Identifier
23097 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23098 then
23099 if Chars (Argx) = Name_Gnat then
23100 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23101 Rewrite (N, Make_Null_Statement (Loc));
23102 Analyze (N);
23103 raise Pragma_Exit;
23104 end if;
23105
23106 elsif Chars (Argx) = Name_Gnatprove then
23107 if not GNATprove_Mode then
23108 Rewrite (N, Make_Null_Statement (Loc));
23109 Analyze (N);
23110 raise Pragma_Exit;
23111 end if;
23112
23113 else
23114 raise Program_Error;
23115 end if;
23116
23117 -- At this point, the pragma Warnings applies to the tool,
23118 -- so continue with shifted arguments.
23119
23120 Arg_Count := Arg_Count - 1;
23121
23122 if Arg_Count = 1 then
23123 Shifted_Args := New_List (New_Copy (Arg2));
23124 elsif Arg_Count = 2 then
23125 Shifted_Args := New_List (New_Copy (Arg2),
23126 New_Copy (Arg3));
23127 elsif Arg_Count = 3 then
23128 Shifted_Args := New_List (New_Copy (Arg2),
23129 New_Copy (Arg3),
23130 New_Copy (Arg4));
23131 else
23132 raise Program_Error;
23133 end if;
23134
23135 Rewrite (N,
23136 Make_Pragma (Loc,
23137 Chars => Name_Warnings,
23138 Pragma_Argument_Associations => Shifted_Args));
23139 Analyze (N);
23140 raise Pragma_Exit;
23141 end if;
23142
23143 -- One argument case
23144
23145 if Arg_Count = 1 then
23146
23147 -- On/Off one argument case was processed by parser
23148
23149 if Nkind (Argx) = N_Identifier
23150 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23151 then
23152 null;
23153
23154 -- One argument case must be ON/OFF or static string expr
23155
23156 elsif not Is_Static_String_Expression (Arg1) then
23157 Error_Pragma_Arg
23158 ("argument of pragma% must be On/Off or static string "
23159 & "expression", Arg1);
23160
23161 -- One argument string expression case
23162
23163 else
23164 declare
23165 Lit : constant Node_Id := Expr_Value_S (Argx);
23166 Str : constant String_Id := Strval (Lit);
23167 Len : constant Nat := String_Length (Str);
23168 C : Char_Code;
23169 J : Nat;
23170 OK : Boolean;
23171 Chr : Character;
23172
23173 begin
23174 J := 1;
23175 while J <= Len loop
23176 C := Get_String_Char (Str, J);
23177 OK := In_Character_Range (C);
23178
23179 if OK then
23180 Chr := Get_Character (C);
23181
23182 -- Dash case: only -Wxxx is accepted
23183
23184 if J = 1
23185 and then J < Len
23186 and then Chr = '-'
23187 then
23188 J := J + 1;
23189 C := Get_String_Char (Str, J);
23190 Chr := Get_Character (C);
23191 exit when Chr = 'W';
23192 OK := False;
23193
23194 -- Dot case
23195
23196 elsif J < Len and then Chr = '.' then
23197 J := J + 1;
23198 C := Get_String_Char (Str, J);
23199 Chr := Get_Character (C);
23200
23201 if not Set_Dot_Warning_Switch (Chr) then
23202 Error_Pragma_Arg
23203 ("invalid warning switch character "
23204 & '.' & Chr, Arg1);
23205 end if;
23206
23207 -- Non-Dot case
23208
23209 else
23210 OK := Set_Warning_Switch (Chr);
23211 end if;
23212 end if;
23213
23214 if not OK then
23215 Error_Pragma_Arg
23216 ("invalid warning switch character " & Chr,
23217 Arg1);
23218 end if;
23219
23220 J := J + 1;
23221 end loop;
23222 end;
23223 end if;
23224
23225 -- Two or more arguments (must be two)
23226
23227 else
23228 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23229 Check_Arg_Count (2);
23230
23231 declare
23232 E_Id : Node_Id;
23233 E : Entity_Id;
23234 Err : Boolean;
23235
23236 begin
23237 E_Id := Get_Pragma_Arg (Arg2);
23238 Analyze (E_Id);
23239
23240 -- In the expansion of an inlined body, a reference to
23241 -- the formal may be wrapped in a conversion if the
23242 -- actual is a conversion. Retrieve the real entity name.
23243
23244 if (In_Instance_Body or In_Inlined_Body)
23245 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23246 then
23247 E_Id := Expression (E_Id);
23248 end if;
23249
23250 -- Entity name case
23251
23252 if Is_Entity_Name (E_Id) then
23253 E := Entity (E_Id);
23254
23255 if E = Any_Id then
23256 return;
23257 else
23258 loop
23259 Set_Warnings_Off
23260 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23261 Name_Off));
23262
23263 -- For OFF case, make entry in warnings off
23264 -- pragma table for later processing. But we do
23265 -- not do that within an instance, since these
23266 -- warnings are about what is needed in the
23267 -- template, not an instance of it.
23268
23269 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23270 and then Warn_On_Warnings_Off
23271 and then not In_Instance
23272 then
23273 Warnings_Off_Pragmas.Append ((N, E, Reason));
23274 end if;
23275
23276 if Is_Enumeration_Type (E) then
23277 declare
23278 Lit : Entity_Id;
23279 begin
23280 Lit := First_Literal (E);
23281 while Present (Lit) loop
23282 Set_Warnings_Off (Lit);
23283 Next_Literal (Lit);
23284 end loop;
23285 end;
23286 end if;
23287
23288 exit when No (Homonym (E));
23289 E := Homonym (E);
23290 end loop;
23291 end if;
23292
23293 -- Error if not entity or static string expression case
23294
23295 elsif not Is_Static_String_Expression (Arg2) then
23296 Error_Pragma_Arg
23297 ("second argument of pragma% must be entity name "
23298 & "or static string expression", Arg2);
23299
23300 -- Static string expression case
23301
23302 else
23303 Acquire_Warning_Match_String (Arg2);
23304
23305 -- Note on configuration pragma case: If this is a
23306 -- configuration pragma, then for an OFF pragma, we
23307 -- just set Config True in the call, which is all
23308 -- that needs to be done. For the case of ON, this
23309 -- is normally an error, unless it is canceling the
23310 -- effect of a previous OFF pragma in the same file.
23311 -- In any other case, an error will be signalled (ON
23312 -- with no matching OFF).
23313
23314 -- Note: We set Used if we are inside a generic to
23315 -- disable the test that the non-config case actually
23316 -- cancels a warning. That's because we can't be sure
23317 -- there isn't an instantiation in some other unit
23318 -- where a warning is suppressed.
23319
23320 -- We could do a little better here by checking if the
23321 -- generic unit we are inside is public, but for now
23322 -- we don't bother with that refinement.
23323
23324 if Chars (Argx) = Name_Off then
23325 Set_Specific_Warning_Off
23326 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23327 Config => Is_Configuration_Pragma,
23328 Used => Inside_A_Generic or else In_Instance);
23329
23330 elsif Chars (Argx) = Name_On then
23331 Set_Specific_Warning_On
23332 (Loc, Name_Buffer (1 .. Name_Len), Err);
23333
23334 if Err then
23335 Error_Msg
23336 ("??pragma Warnings On with no matching "
23337 & "Warnings Off", Loc);
23338 end if;
23339 end if;
23340 end if;
23341 end;
23342 end if;
23343 end;
23344 end Warnings;
23345
23346 -------------------
23347 -- Weak_External --
23348 -------------------
23349
23350 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23351
23352 when Pragma_Weak_External => Weak_External : declare
23353 Ent : Entity_Id;
23354
23355 begin
23356 GNAT_Pragma;
23357 Check_Arg_Count (1);
23358 Check_Optional_Identifier (Arg1, Name_Entity);
23359 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23360 Ent := Entity (Get_Pragma_Arg (Arg1));
23361
23362 if Rep_Item_Too_Early (Ent, N) then
23363 return;
23364 else
23365 Ent := Underlying_Type (Ent);
23366 end if;
23367
23368 -- The only processing required is to link this item on to the
23369 -- list of rep items for the given entity. This is accomplished
23370 -- by the call to Rep_Item_Too_Late (when no error is detected
23371 -- and False is returned).
23372
23373 if Rep_Item_Too_Late (Ent, N) then
23374 return;
23375 else
23376 Set_Has_Gigi_Rep_Item (Ent);
23377 end if;
23378 end Weak_External;
23379
23380 -----------------------------
23381 -- Wide_Character_Encoding --
23382 -----------------------------
23383
23384 -- pragma Wide_Character_Encoding (IDENTIFIER);
23385
23386 when Pragma_Wide_Character_Encoding =>
23387 GNAT_Pragma;
23388
23389 -- Nothing to do, handled in parser. Note that we do not enforce
23390 -- configuration pragma placement, this pragma can appear at any
23391 -- place in the source, allowing mixed encodings within a single
23392 -- source program.
23393
23394 null;
23395
23396 --------------------
23397 -- Unknown_Pragma --
23398 --------------------
23399
23400 -- Should be impossible, since the case of an unknown pragma is
23401 -- separately processed before the case statement is entered.
23402
23403 when Unknown_Pragma =>
23404 raise Program_Error;
23405 end case;
23406
23407 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23408 -- until AI is formally approved.
23409
23410 -- Check_Order_Dependence;
23411
23412 exception
23413 when Pragma_Exit => null;
23414 end Analyze_Pragma;
23415
23416 ---------------------------------------------
23417 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23418 ---------------------------------------------
23419
23420 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23421 (N : Node_Id;
23422 Freeze_Id : Entity_Id := Empty)
23423 is
23424 Disp_Typ : Entity_Id;
23425 -- The dispatching type of the subprogram subject to the pre- or
23426 -- postcondition.
23427
23428 function Check_References (Nod : Node_Id) return Traverse_Result;
23429 -- Check that expression Nod does not mention non-primitives of the
23430 -- type, global objects of the type, or other illegalities described
23431 -- and implied by AI12-0113.
23432
23433 ----------------------
23434 -- Check_References --
23435 ----------------------
23436
23437 function Check_References (Nod : Node_Id) return Traverse_Result is
23438 begin
23439 if Nkind (Nod) = N_Function_Call
23440 and then Is_Entity_Name (Name (Nod))
23441 then
23442 declare
23443 Func : constant Entity_Id := Entity (Name (Nod));
23444 Form : Entity_Id;
23445
23446 begin
23447 -- An operation of the type must be a primitive
23448
23449 if No (Find_Dispatching_Type (Func)) then
23450 Form := First_Formal (Func);
23451 while Present (Form) loop
23452 if Etype (Form) = Disp_Typ then
23453 Error_Msg_NE
23454 ("operation in class-wide condition must be "
23455 & "primitive of &", Nod, Disp_Typ);
23456 end if;
23457
23458 Next_Formal (Form);
23459 end loop;
23460
23461 -- A return object of the type is illegal as well
23462
23463 if Etype (Func) = Disp_Typ
23464 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23465 then
23466 Error_Msg_NE
23467 ("operation in class-wide condition must be primitive "
23468 & "of &", Nod, Disp_Typ);
23469 end if;
23470 end if;
23471 end;
23472
23473 elsif Is_Entity_Name (Nod)
23474 and then
23475 (Etype (Nod) = Disp_Typ
23476 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23477 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
23478 then
23479 Error_Msg_NE
23480 ("object in class-wide condition must be formal of type &",
23481 Nod, Disp_Typ);
23482
23483 elsif Nkind (Nod) = N_Explicit_Dereference
23484 and then (Etype (Nod) = Disp_Typ
23485 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23486 and then (not Is_Entity_Name (Prefix (Nod))
23487 or else not Is_Formal (Entity (Prefix (Nod))))
23488 then
23489 Error_Msg_NE
23490 ("operation in class-wide condition must be primitive of &",
23491 Nod, Disp_Typ);
23492 end if;
23493
23494 return OK;
23495 end Check_References;
23496
23497 procedure Check_Class_Wide_Condition is
23498 new Traverse_Proc (Check_References);
23499
23500 -- Local variables
23501
23502 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23503 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23504 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23505
23506 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23507
23508 Errors : Nat;
23509 Restore_Scope : Boolean := False;
23510
23511 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23512
23513 begin
23514 -- Do not analyze the pragma multiple times
23515
23516 if Is_Analyzed_Pragma (N) then
23517 return;
23518 end if;
23519
23520 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23521 -- analysis of the pragma, the Ghost mode at point of declaration and
23522 -- point of analysis may not necessarily be the same. Use the mode in
23523 -- effect at the point of declaration.
23524
23525 Set_Ghost_Mode (N);
23526
23527 -- Ensure that the subprogram and its formals are visible when analyzing
23528 -- the expression of the pragma.
23529
23530 if not In_Open_Scopes (Spec_Id) then
23531 Restore_Scope := True;
23532 Push_Scope (Spec_Id);
23533
23534 if Is_Generic_Subprogram (Spec_Id) then
23535 Install_Generic_Formals (Spec_Id);
23536 else
23537 Install_Formals (Spec_Id);
23538 end if;
23539 end if;
23540
23541 Errors := Serious_Errors_Detected;
23542 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23543
23544 -- Emit a clarification message when the expression contains at least
23545 -- one undefined reference, possibly due to contract "freezing".
23546
23547 if Errors /= Serious_Errors_Detected
23548 and then Present (Freeze_Id)
23549 and then Has_Undefined_Reference (Expr)
23550 then
23551 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23552 end if;
23553
23554 if Class_Present (N) then
23555
23556 -- Verify that a class-wide condition is legal, i.e. the operation is
23557 -- a primitive of a tagged type. Note that a generic subprogram is
23558 -- not a primitive operation.
23559
23560 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23561
23562 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23563 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23564
23565 if From_Aspect_Specification (N) then
23566 Error_Msg_N
23567 ("aspect % can only be specified for a primitive operation "
23568 & "of a tagged type", Corresponding_Aspect (N));
23569
23570 -- The pragma is a source construct
23571
23572 else
23573 Error_Msg_N
23574 ("pragma % can only be specified for a primitive operation "
23575 & "of a tagged type", N);
23576 end if;
23577
23578 -- Remaining semantic checks require a full tree traversal
23579
23580 else
23581 Check_Class_Wide_Condition (Expr);
23582 end if;
23583
23584 end if;
23585
23586 if Restore_Scope then
23587 End_Scope;
23588 end if;
23589
23590 -- Currently it is not possible to inline pre/postconditions on a
23591 -- subprogram subject to pragma Inline_Always.
23592
23593 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23594 Ghost_Mode := Save_Ghost_Mode;
23595
23596 Set_Is_Analyzed_Pragma (N);
23597 end Analyze_Pre_Post_Condition_In_Decl_Part;
23598
23599 ------------------------------------------
23600 -- Analyze_Refined_Depends_In_Decl_Part --
23601 ------------------------------------------
23602
23603 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23604 Body_Inputs : Elist_Id := No_Elist;
23605 Body_Outputs : Elist_Id := No_Elist;
23606 -- The inputs and outputs of the subprogram body synthesized from pragma
23607 -- Refined_Depends.
23608
23609 Dependencies : List_Id := No_List;
23610 Depends : Node_Id;
23611 -- The corresponding Depends pragma along with its clauses
23612
23613 Matched_Items : Elist_Id := No_Elist;
23614 -- A list containing the entities of all successfully matched items
23615 -- found in pragma Depends.
23616
23617 Refinements : List_Id := No_List;
23618 -- The clauses of pragma Refined_Depends
23619
23620 Spec_Id : Entity_Id;
23621 -- The entity of the subprogram subject to pragma Refined_Depends
23622
23623 Spec_Inputs : Elist_Id := No_Elist;
23624 Spec_Outputs : Elist_Id := No_Elist;
23625 -- The inputs and outputs of the subprogram spec synthesized from pragma
23626 -- Depends.
23627
23628 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23629 -- Try to match a single dependency clause Dep_Clause against one or
23630 -- more refinement clauses found in list Refinements. Each successful
23631 -- match eliminates at least one refinement clause from Refinements.
23632
23633 procedure Check_Output_States;
23634 -- Determine whether pragma Depends contains an output state with a
23635 -- visible refinement and if so, ensure that pragma Refined_Depends
23636 -- mentions all its constituents as outputs.
23637
23638 procedure Normalize_Clauses (Clauses : List_Id);
23639 -- Given a list of dependence or refinement clauses Clauses, normalize
23640 -- each clause by creating multiple dependencies with exactly one input
23641 -- and one output.
23642
23643 procedure Report_Extra_Clauses;
23644 -- Emit an error for each extra clause found in list Refinements
23645
23646 -----------------------------
23647 -- Check_Dependency_Clause --
23648 -----------------------------
23649
23650 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23651 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23652 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23653
23654 function Is_In_Out_State_Clause return Boolean;
23655 -- Determine whether dependence clause Dep_Clause denotes an abstract
23656 -- state that depends on itself (State => State).
23657
23658 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23659 -- Determine whether item Item denotes an abstract state with visible
23660 -- null refinement.
23661
23662 procedure Match_Items
23663 (Dep_Item : Node_Id;
23664 Ref_Item : Node_Id;
23665 Matched : out Boolean);
23666 -- Try to match dependence item Dep_Item against refinement item
23667 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23668 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23669 -- the following conformance scenarios is in effect:
23670 -- 1) Both items denote null
23671 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23672 -- 3) Both items denote attribute 'Result
23673 -- 4) Both items denote the same object
23674 -- 5) Both items denote the same formal parameter
23675 -- 6) Both items denote the same current instance of a type
23676 -- 7) Both items denote the same discriminant
23677 -- 8) Dep_Item is an abstract state with visible null refinement
23678 -- and Ref_Item denotes null.
23679 -- 9) Dep_Item is an abstract state with visible null refinement
23680 -- and Ref_Item is Empty (special case).
23681 -- 10) Dep_Item is an abstract state with visible non-null
23682 -- refinement and Ref_Item denotes one of its constituents.
23683 -- 11) Dep_Item is an abstract state without a visible refinement
23684 -- and Ref_Item denotes the same state.
23685 -- When scenario 10 is in effect, the entity of the abstract state
23686 -- denoted by Dep_Item is added to list Refined_States.
23687
23688 procedure Record_Item (Item_Id : Entity_Id);
23689 -- Store the entity of an item denoted by Item_Id in Matched_Items
23690
23691 ----------------------------
23692 -- Is_In_Out_State_Clause --
23693 ----------------------------
23694
23695 function Is_In_Out_State_Clause return Boolean is
23696 Dep_Input_Id : Entity_Id;
23697 Dep_Output_Id : Entity_Id;
23698
23699 begin
23700 -- Detect the following clause:
23701 -- State => State
23702
23703 if Is_Entity_Name (Dep_Input)
23704 and then Is_Entity_Name (Dep_Output)
23705 then
23706 -- Handle abstract views generated for limited with clauses
23707
23708 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
23709 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
23710
23711 return
23712 Ekind (Dep_Input_Id) = E_Abstract_State
23713 and then Dep_Input_Id = Dep_Output_Id;
23714 else
23715 return False;
23716 end if;
23717 end Is_In_Out_State_Clause;
23718
23719 ---------------------------
23720 -- Is_Null_Refined_State --
23721 ---------------------------
23722
23723 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
23724 Item_Id : Entity_Id;
23725
23726 begin
23727 if Is_Entity_Name (Item) then
23728
23729 -- Handle abstract views generated for limited with clauses
23730
23731 Item_Id := Available_View (Entity_Of (Item));
23732
23733 return
23734 Ekind (Item_Id) = E_Abstract_State
23735 and then Has_Null_Visible_Refinement (Item_Id);
23736 else
23737 return False;
23738 end if;
23739 end Is_Null_Refined_State;
23740
23741 -----------------
23742 -- Match_Items --
23743 -----------------
23744
23745 procedure Match_Items
23746 (Dep_Item : Node_Id;
23747 Ref_Item : Node_Id;
23748 Matched : out Boolean)
23749 is
23750 Dep_Item_Id : Entity_Id;
23751 Ref_Item_Id : Entity_Id;
23752
23753 begin
23754 -- Assume that the two items do not match
23755
23756 Matched := False;
23757
23758 -- A null matches null or Empty (special case)
23759
23760 if Nkind (Dep_Item) = N_Null
23761 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23762 then
23763 Matched := True;
23764
23765 -- Attribute 'Result matches attribute 'Result
23766
23767 elsif Is_Attribute_Result (Dep_Item)
23768 and then Is_Attribute_Result (Dep_Item)
23769 then
23770 Matched := True;
23771
23772 -- Abstract states, current instances of concurrent types,
23773 -- discriminants, formal parameters and objects.
23774
23775 elsif Is_Entity_Name (Dep_Item) then
23776
23777 -- Handle abstract views generated for limited with clauses
23778
23779 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
23780
23781 if Ekind (Dep_Item_Id) = E_Abstract_State then
23782
23783 -- An abstract state with visible null refinement matches
23784 -- null or Empty (special case).
23785
23786 if Has_Null_Visible_Refinement (Dep_Item_Id)
23787 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23788 then
23789 Record_Item (Dep_Item_Id);
23790 Matched := True;
23791
23792 -- An abstract state with visible non-null refinement
23793 -- matches one of its constituents.
23794
23795 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
23796 if Is_Entity_Name (Ref_Item) then
23797 Ref_Item_Id := Entity_Of (Ref_Item);
23798
23799 if Ekind_In (Ref_Item_Id, E_Abstract_State,
23800 E_Constant,
23801 E_Variable)
23802 and then Present (Encapsulating_State (Ref_Item_Id))
23803 and then Encapsulating_State (Ref_Item_Id) =
23804 Dep_Item_Id
23805 then
23806 Record_Item (Dep_Item_Id);
23807 Matched := True;
23808 end if;
23809 end if;
23810
23811 -- An abstract state without a visible refinement matches
23812 -- itself.
23813
23814 elsif Is_Entity_Name (Ref_Item)
23815 and then Entity_Of (Ref_Item) = Dep_Item_Id
23816 then
23817 Record_Item (Dep_Item_Id);
23818 Matched := True;
23819 end if;
23820
23821 -- A current instance of a concurrent type, discriminant,
23822 -- formal parameter or an object matches itself.
23823
23824 elsif Is_Entity_Name (Ref_Item)
23825 and then Entity_Of (Ref_Item) = Dep_Item_Id
23826 then
23827 Record_Item (Dep_Item_Id);
23828 Matched := True;
23829 end if;
23830 end if;
23831 end Match_Items;
23832
23833 -----------------
23834 -- Record_Item --
23835 -----------------
23836
23837 procedure Record_Item (Item_Id : Entity_Id) is
23838 begin
23839 if not Contains (Matched_Items, Item_Id) then
23840 Append_New_Elmt (Item_Id, Matched_Items);
23841 end if;
23842 end Record_Item;
23843
23844 -- Local variables
23845
23846 Clause_Matched : Boolean := False;
23847 Dummy : Boolean := False;
23848 Inputs_Match : Boolean;
23849 Next_Ref_Clause : Node_Id;
23850 Outputs_Match : Boolean;
23851 Ref_Clause : Node_Id;
23852 Ref_Input : Node_Id;
23853 Ref_Output : Node_Id;
23854
23855 -- Start of processing for Check_Dependency_Clause
23856
23857 begin
23858 -- Do not perform this check in an instance because it was already
23859 -- performed successfully in the generic template.
23860
23861 if Is_Generic_Instance (Spec_Id) then
23862 return;
23863 end if;
23864
23865 -- Examine all refinement clauses and compare them against the
23866 -- dependence clause.
23867
23868 Ref_Clause := First (Refinements);
23869 while Present (Ref_Clause) loop
23870 Next_Ref_Clause := Next (Ref_Clause);
23871
23872 -- Obtain the attributes of the current refinement clause
23873
23874 Ref_Input := Expression (Ref_Clause);
23875 Ref_Output := First (Choices (Ref_Clause));
23876
23877 -- The current refinement clause matches the dependence clause
23878 -- when both outputs match and both inputs match. See routine
23879 -- Match_Items for all possible conformance scenarios.
23880
23881 -- Depends Dep_Output => Dep_Input
23882 -- ^ ^
23883 -- match ? match ?
23884 -- v v
23885 -- Refined_Depends Ref_Output => Ref_Input
23886
23887 Match_Items
23888 (Dep_Item => Dep_Input,
23889 Ref_Item => Ref_Input,
23890 Matched => Inputs_Match);
23891
23892 Match_Items
23893 (Dep_Item => Dep_Output,
23894 Ref_Item => Ref_Output,
23895 Matched => Outputs_Match);
23896
23897 -- An In_Out state clause may be matched against a refinement with
23898 -- a null input or null output as long as the non-null side of the
23899 -- relation contains a valid constituent of the In_Out_State.
23900
23901 if Is_In_Out_State_Clause then
23902
23903 -- Depends => (State => State)
23904 -- Refined_Depends => (null => Constit) -- OK
23905
23906 if Inputs_Match
23907 and then not Outputs_Match
23908 and then Nkind (Ref_Output) = N_Null
23909 then
23910 Outputs_Match := True;
23911 end if;
23912
23913 -- Depends => (State => State)
23914 -- Refined_Depends => (Constit => null) -- OK
23915
23916 if not Inputs_Match
23917 and then Outputs_Match
23918 and then Nkind (Ref_Input) = N_Null
23919 then
23920 Inputs_Match := True;
23921 end if;
23922 end if;
23923
23924 -- The current refinement clause is legally constructed following
23925 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23926 -- the pool of candidates. The seach continues because a single
23927 -- dependence clause may have multiple matching refinements.
23928
23929 if Inputs_Match and Outputs_Match then
23930 Clause_Matched := True;
23931 Remove (Ref_Clause);
23932 end if;
23933
23934 Ref_Clause := Next_Ref_Clause;
23935 end loop;
23936
23937 -- Depending on the order or composition of refinement clauses, an
23938 -- In_Out state clause may not be directly refinable.
23939
23940 -- Depends => ((Output, State) => (Input, State))
23941 -- Refined_State => (State => (Constit_1, Constit_2))
23942 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23943
23944 -- Matching normalized clause (State => State) fails because there is
23945 -- no direct refinement capable of satisfying this relation. Another
23946 -- similar case arises when clauses (Constit_1 => Input) and (Output
23947 -- => Constit_2) are matched first, leaving no candidates for clause
23948 -- (State => State). Both scenarios are legal as long as one of the
23949 -- previous clauses mentioned a valid constituent of State.
23950
23951 if not Clause_Matched
23952 and then Is_In_Out_State_Clause
23953 and then
23954 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23955 then
23956 Clause_Matched := True;
23957 end if;
23958
23959 -- A clause where the input is an abstract state with visible null
23960 -- refinement is implicitly matched when the output has already been
23961 -- matched in a previous clause.
23962
23963 -- Depends => (Output => State) -- implicitly OK
23964 -- Refined_State => (State => null)
23965 -- Refined_Depends => (Output => ...)
23966
23967 if not Clause_Matched
23968 and then Is_Null_Refined_State (Dep_Input)
23969 and then Is_Entity_Name (Dep_Output)
23970 and then
23971 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
23972 then
23973 Clause_Matched := True;
23974 end if;
23975
23976 -- A clause where the output is an abstract state with visible null
23977 -- refinement is implicitly matched when the input has already been
23978 -- matched in a previous clause.
23979
23980 -- Depends => (State => Input) -- implicitly OK
23981 -- Refined_State => (State => null)
23982 -- Refined_Depends => (... => Input)
23983
23984 if not Clause_Matched
23985 and then Is_Null_Refined_State (Dep_Output)
23986 and then Is_Entity_Name (Dep_Input)
23987 and then
23988 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23989 then
23990 Clause_Matched := True;
23991 end if;
23992
23993 -- At this point either all refinement clauses have been examined or
23994 -- pragma Refined_Depends contains a solitary null. Only an abstract
23995 -- state with null refinement can possibly match these cases.
23996
23997 -- Depends => (State => null)
23998 -- Refined_State => (State => null)
23999 -- Refined_Depends => null -- OK
24000
24001 if not Clause_Matched then
24002 Match_Items
24003 (Dep_Item => Dep_Input,
24004 Ref_Item => Empty,
24005 Matched => Inputs_Match);
24006
24007 Match_Items
24008 (Dep_Item => Dep_Output,
24009 Ref_Item => Empty,
24010 Matched => Outputs_Match);
24011
24012 Clause_Matched := Inputs_Match and Outputs_Match;
24013 end if;
24014
24015 -- If the contents of Refined_Depends are legal, then the current
24016 -- dependence clause should be satisfied either by an explicit match
24017 -- or by one of the special cases.
24018
24019 if not Clause_Matched then
24020 SPARK_Msg_NE
24021 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
24022 & "matching refinement in body"), Dep_Clause, Spec_Id);
24023 end if;
24024 end Check_Dependency_Clause;
24025
24026 -------------------------
24027 -- Check_Output_States --
24028 -------------------------
24029
24030 procedure Check_Output_States is
24031 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24032 -- Determine whether all constituents of state State_Id with visible
24033 -- refinement are used as outputs in pragma Refined_Depends. Emit an
24034 -- error if this is not the case.
24035
24036 -----------------------------
24037 -- Check_Constituent_Usage --
24038 -----------------------------
24039
24040 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24041 Constits : constant Elist_Id :=
24042 Refinement_Constituents (State_Id);
24043 Constit_Elmt : Elmt_Id;
24044 Constit_Id : Entity_Id;
24045 Posted : Boolean := False;
24046
24047 begin
24048 if Present (Constits) then
24049 Constit_Elmt := First_Elmt (Constits);
24050 while Present (Constit_Elmt) loop
24051 Constit_Id := Node (Constit_Elmt);
24052
24053 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24054
24055 if Present (Body_Inputs)
24056 and then Appears_In (Body_Inputs, Constit_Id)
24057 then
24058 Error_Msg_Name_1 := Chars (State_Id);
24059 SPARK_Msg_NE
24060 ("constituent & of state % must act as output in "
24061 & "dependence refinement", N, Constit_Id);
24062
24063 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24064
24065 elsif No (Body_Outputs)
24066 or else not Appears_In (Body_Outputs, Constit_Id)
24067 then
24068 if not Posted then
24069 Posted := True;
24070 SPARK_Msg_NE
24071 ("output state & must be replaced by all its "
24072 & "constituents in dependence refinement",
24073 N, State_Id);
24074 end if;
24075
24076 SPARK_Msg_NE
24077 ("\constituent & is missing in output list",
24078 N, Constit_Id);
24079 end if;
24080
24081 Next_Elmt (Constit_Elmt);
24082 end loop;
24083 end if;
24084 end Check_Constituent_Usage;
24085
24086 -- Local variables
24087
24088 Item : Node_Id;
24089 Item_Elmt : Elmt_Id;
24090 Item_Id : Entity_Id;
24091
24092 -- Start of processing for Check_Output_States
24093
24094 begin
24095 -- Do not perform this check in an instance because it was already
24096 -- performed successfully in the generic template.
24097
24098 if Is_Generic_Instance (Spec_Id) then
24099 null;
24100
24101 -- Inspect the outputs of pragma Depends looking for a state with a
24102 -- visible refinement.
24103
24104 elsif Present (Spec_Outputs) then
24105 Item_Elmt := First_Elmt (Spec_Outputs);
24106 while Present (Item_Elmt) loop
24107 Item := Node (Item_Elmt);
24108
24109 -- Deal with the mixed nature of the input and output lists
24110
24111 if Nkind (Item) = N_Defining_Identifier then
24112 Item_Id := Item;
24113 else
24114 Item_Id := Available_View (Entity_Of (Item));
24115 end if;
24116
24117 if Ekind (Item_Id) = E_Abstract_State then
24118
24119 -- The state acts as an input-output, skip it
24120
24121 if Present (Spec_Inputs)
24122 and then Appears_In (Spec_Inputs, Item_Id)
24123 then
24124 null;
24125
24126 -- Ensure that all of the constituents are utilized as
24127 -- outputs in pragma Refined_Depends.
24128
24129 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
24130 Check_Constituent_Usage (Item_Id);
24131 end if;
24132 end if;
24133
24134 Next_Elmt (Item_Elmt);
24135 end loop;
24136 end if;
24137 end Check_Output_States;
24138
24139 -----------------------
24140 -- Normalize_Clauses --
24141 -----------------------
24142
24143 procedure Normalize_Clauses (Clauses : List_Id) is
24144 procedure Normalize_Inputs (Clause : Node_Id);
24145 -- Normalize clause Clause by creating multiple clauses for each
24146 -- input item of Clause. It is assumed that Clause has exactly one
24147 -- output. The transformation is as follows:
24148 --
24149 -- Output => (Input_1, Input_2) -- original
24150 --
24151 -- Output => Input_1 -- normalizations
24152 -- Output => Input_2
24153
24154 procedure Normalize_Outputs (Clause : Node_Id);
24155 -- Normalize clause Clause by creating multiple clause for each
24156 -- output item of Clause. The transformation is as follows:
24157 --
24158 -- (Output_1, Output_2) => Input -- original
24159 --
24160 -- Output_1 => Input -- normalization
24161 -- Output_2 => Input
24162
24163 ----------------------
24164 -- Normalize_Inputs --
24165 ----------------------
24166
24167 procedure Normalize_Inputs (Clause : Node_Id) is
24168 Inputs : constant Node_Id := Expression (Clause);
24169 Loc : constant Source_Ptr := Sloc (Clause);
24170 Output : constant List_Id := Choices (Clause);
24171 Last_Input : Node_Id;
24172 Input : Node_Id;
24173 New_Clause : Node_Id;
24174 Next_Input : Node_Id;
24175
24176 begin
24177 -- Normalization is performed only when the original clause has
24178 -- more than one input. Multiple inputs appear as an aggregate.
24179
24180 if Nkind (Inputs) = N_Aggregate then
24181 Last_Input := Last (Expressions (Inputs));
24182
24183 -- Create a new clause for each input
24184
24185 Input := First (Expressions (Inputs));
24186 while Present (Input) loop
24187 Next_Input := Next (Input);
24188
24189 -- Unhook the current input from the original input list
24190 -- because it will be relocated to a new clause.
24191
24192 Remove (Input);
24193
24194 -- Special processing for the last input. At this point the
24195 -- original aggregate has been stripped down to one element.
24196 -- Replace the aggregate by the element itself.
24197
24198 if Input = Last_Input then
24199 Rewrite (Inputs, Input);
24200
24201 -- Generate a clause of the form:
24202 -- Output => Input
24203
24204 else
24205 New_Clause :=
24206 Make_Component_Association (Loc,
24207 Choices => New_Copy_List_Tree (Output),
24208 Expression => Input);
24209
24210 -- The new clause contains replicated content that has
24211 -- already been analyzed, mark the clause as analyzed.
24212
24213 Set_Analyzed (New_Clause);
24214 Insert_After (Clause, New_Clause);
24215 end if;
24216
24217 Input := Next_Input;
24218 end loop;
24219 end if;
24220 end Normalize_Inputs;
24221
24222 -----------------------
24223 -- Normalize_Outputs --
24224 -----------------------
24225
24226 procedure Normalize_Outputs (Clause : Node_Id) is
24227 Inputs : constant Node_Id := Expression (Clause);
24228 Loc : constant Source_Ptr := Sloc (Clause);
24229 Outputs : constant Node_Id := First (Choices (Clause));
24230 Last_Output : Node_Id;
24231 New_Clause : Node_Id;
24232 Next_Output : Node_Id;
24233 Output : Node_Id;
24234
24235 begin
24236 -- Multiple outputs appear as an aggregate. Nothing to do when
24237 -- the clause has exactly one output.
24238
24239 if Nkind (Outputs) = N_Aggregate then
24240 Last_Output := Last (Expressions (Outputs));
24241
24242 -- Create a clause for each output. Note that each time a new
24243 -- clause is created, the original output list slowly shrinks
24244 -- until there is one item left.
24245
24246 Output := First (Expressions (Outputs));
24247 while Present (Output) loop
24248 Next_Output := Next (Output);
24249
24250 -- Unhook the output from the original output list as it
24251 -- will be relocated to a new clause.
24252
24253 Remove (Output);
24254
24255 -- Special processing for the last output. At this point
24256 -- the original aggregate has been stripped down to one
24257 -- element. Replace the aggregate by the element itself.
24258
24259 if Output = Last_Output then
24260 Rewrite (Outputs, Output);
24261
24262 else
24263 -- Generate a clause of the form:
24264 -- (Output => Inputs)
24265
24266 New_Clause :=
24267 Make_Component_Association (Loc,
24268 Choices => New_List (Output),
24269 Expression => New_Copy_Tree (Inputs));
24270
24271 -- The new clause contains replicated content that has
24272 -- already been analyzed. There is not need to reanalyze
24273 -- them.
24274
24275 Set_Analyzed (New_Clause);
24276 Insert_After (Clause, New_Clause);
24277 end if;
24278
24279 Output := Next_Output;
24280 end loop;
24281 end if;
24282 end Normalize_Outputs;
24283
24284 -- Local variables
24285
24286 Clause : Node_Id;
24287
24288 -- Start of processing for Normalize_Clauses
24289
24290 begin
24291 Clause := First (Clauses);
24292 while Present (Clause) loop
24293 Normalize_Outputs (Clause);
24294 Next (Clause);
24295 end loop;
24296
24297 Clause := First (Clauses);
24298 while Present (Clause) loop
24299 Normalize_Inputs (Clause);
24300 Next (Clause);
24301 end loop;
24302 end Normalize_Clauses;
24303
24304 --------------------------
24305 -- Report_Extra_Clauses --
24306 --------------------------
24307
24308 procedure Report_Extra_Clauses is
24309 Clause : Node_Id;
24310
24311 begin
24312 -- Do not perform this check in an instance because it was already
24313 -- performed successfully in the generic template.
24314
24315 if Is_Generic_Instance (Spec_Id) then
24316 null;
24317
24318 elsif Present (Refinements) then
24319 Clause := First (Refinements);
24320 while Present (Clause) loop
24321
24322 -- Do not complain about a null input refinement, since a null
24323 -- input legitimately matches anything.
24324
24325 if Nkind (Clause) = N_Component_Association
24326 and then Nkind (Expression (Clause)) = N_Null
24327 then
24328 null;
24329
24330 else
24331 SPARK_Msg_N
24332 ("unmatched or extra clause in dependence refinement",
24333 Clause);
24334 end if;
24335
24336 Next (Clause);
24337 end loop;
24338 end if;
24339 end Report_Extra_Clauses;
24340
24341 -- Local variables
24342
24343 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24344 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
24345 Errors : constant Nat := Serious_Errors_Detected;
24346 Clause : Node_Id;
24347 Deps : Node_Id;
24348 Dummy : Boolean;
24349 Refs : Node_Id;
24350
24351 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24352
24353 begin
24354 -- Do not analyze the pragma multiple times
24355
24356 if Is_Analyzed_Pragma (N) then
24357 return;
24358 end if;
24359
24360 Spec_Id := Unique_Defining_Entity (Body_Decl);
24361
24362 -- Use the anonymous object as the proper spec when Refined_Depends
24363 -- applies to the body of a single task type. The object carries the
24364 -- proper Chars as well as all non-refined versions of pragmas.
24365
24366 if Is_Single_Concurrent_Type (Spec_Id) then
24367 Spec_Id := Anonymous_Object (Spec_Id);
24368 end if;
24369
24370 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
24371
24372 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24373 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24374
24375 if No (Depends) then
24376 SPARK_Msg_NE
24377 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
24378 & "& lacks aspect or pragma Depends"), N, Spec_Id);
24379 goto Leave;
24380 end if;
24381
24382 Deps := Expression (Get_Argument (Depends, Spec_Id));
24383
24384 -- A null dependency relation renders the refinement useless because it
24385 -- cannot possibly mention abstract states with visible refinement. Note
24386 -- that the inverse is not true as states may be refined to null
24387 -- (SPARK RM 7.2.5(2)).
24388
24389 if Nkind (Deps) = N_Null then
24390 SPARK_Msg_NE
24391 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
24392 & "depend on abstract state with visible refinement"), N, Spec_Id);
24393 goto Leave;
24394 end if;
24395
24396 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24397 -- This ensures that the categorization of all refined dependency items
24398 -- is consistent with their role.
24399
24400 Analyze_Depends_In_Decl_Part (N);
24401
24402 -- Do not match dependencies against refinements if Refined_Depends is
24403 -- illegal to avoid emitting misleading error.
24404
24405 if Serious_Errors_Detected = Errors then
24406
24407 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24408 -- the inputs and outputs of the subprogram spec and body to verify
24409 -- the use of states with visible refinement and their constituents.
24410
24411 if No (Get_Pragma (Spec_Id, Pragma_Global))
24412 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
24413 then
24414 Collect_Subprogram_Inputs_Outputs
24415 (Subp_Id => Spec_Id,
24416 Synthesize => True,
24417 Subp_Inputs => Spec_Inputs,
24418 Subp_Outputs => Spec_Outputs,
24419 Global_Seen => Dummy);
24420
24421 Collect_Subprogram_Inputs_Outputs
24422 (Subp_Id => Body_Id,
24423 Synthesize => True,
24424 Subp_Inputs => Body_Inputs,
24425 Subp_Outputs => Body_Outputs,
24426 Global_Seen => Dummy);
24427
24428 -- For an output state with a visible refinement, ensure that all
24429 -- constituents appear as outputs in the dependency refinement.
24430
24431 Check_Output_States;
24432 end if;
24433
24434 -- Matching is disabled in ASIS because clauses are not normalized as
24435 -- this is a tree altering activity similar to expansion.
24436
24437 if ASIS_Mode then
24438 goto Leave;
24439 end if;
24440
24441 -- Multiple dependency clauses appear as component associations of an
24442 -- aggregate. Note that the clauses are copied because the algorithm
24443 -- modifies them and this should not be visible in Depends.
24444
24445 pragma Assert (Nkind (Deps) = N_Aggregate);
24446 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
24447 Normalize_Clauses (Dependencies);
24448
24449 Refs := Expression (Get_Argument (N, Spec_Id));
24450
24451 if Nkind (Refs) = N_Null then
24452 Refinements := No_List;
24453
24454 -- Multiple dependency clauses appear as component associations of an
24455 -- aggregate. Note that the clauses are copied because the algorithm
24456 -- modifies them and this should not be visible in Refined_Depends.
24457
24458 else pragma Assert (Nkind (Refs) = N_Aggregate);
24459 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
24460 Normalize_Clauses (Refinements);
24461 end if;
24462
24463 -- At this point the clauses of pragmas Depends and Refined_Depends
24464 -- have been normalized into simple dependencies between one output
24465 -- and one input. Examine all clauses of pragma Depends looking for
24466 -- matching clauses in pragma Refined_Depends.
24467
24468 Clause := First (Dependencies);
24469 while Present (Clause) loop
24470 Check_Dependency_Clause (Clause);
24471 Next (Clause);
24472 end loop;
24473
24474 if Serious_Errors_Detected = Errors then
24475 Report_Extra_Clauses;
24476 end if;
24477 end if;
24478
24479 <<Leave>>
24480 Set_Is_Analyzed_Pragma (N);
24481 end Analyze_Refined_Depends_In_Decl_Part;
24482
24483 -----------------------------------------
24484 -- Analyze_Refined_Global_In_Decl_Part --
24485 -----------------------------------------
24486
24487 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
24488 Global : Node_Id;
24489 -- The corresponding Global pragma
24490
24491 Has_In_State : Boolean := False;
24492 Has_In_Out_State : Boolean := False;
24493 Has_Out_State : Boolean := False;
24494 Has_Proof_In_State : Boolean := False;
24495 -- These flags are set when the corresponding Global pragma has a state
24496 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24497 -- refinement.
24498
24499 Has_Null_State : Boolean := False;
24500 -- This flag is set when the corresponding Global pragma has at least
24501 -- one state with a null refinement.
24502
24503 In_Constits : Elist_Id := No_Elist;
24504 In_Out_Constits : Elist_Id := No_Elist;
24505 Out_Constits : Elist_Id := No_Elist;
24506 Proof_In_Constits : Elist_Id := No_Elist;
24507 -- These lists contain the entities of all Input, In_Out, Output and
24508 -- Proof_In constituents that appear in Refined_Global and participate
24509 -- in state refinement.
24510
24511 In_Items : Elist_Id := No_Elist;
24512 In_Out_Items : Elist_Id := No_Elist;
24513 Out_Items : Elist_Id := No_Elist;
24514 Proof_In_Items : Elist_Id := No_Elist;
24515 -- These list contain the entities of all Input, In_Out, Output and
24516 -- Proof_In items defined in the corresponding Global pragma.
24517
24518 Spec_Id : Entity_Id;
24519 -- The entity of the subprogram subject to pragma Refined_Global
24520
24521 States : Elist_Id := No_Elist;
24522 -- A list of all states with visible refinement found in pragma Global
24523
24524 procedure Check_In_Out_States;
24525 -- Determine whether the corresponding Global pragma mentions In_Out
24526 -- states with visible refinement and if so, ensure that one of the
24527 -- following completions apply to the constituents of the state:
24528 -- 1) there is at least one constituent of mode In_Out
24529 -- 2) there is at least one Input and one Output constituent
24530 -- 3) not all constituents are present and one of them is of mode
24531 -- Output.
24532 -- This routine may remove elements from In_Constits, In_Out_Constits,
24533 -- Out_Constits and Proof_In_Constits.
24534
24535 procedure Check_Input_States;
24536 -- Determine whether the corresponding Global pragma mentions Input
24537 -- states with visible refinement and if so, ensure that at least one of
24538 -- its constituents appears as an Input item in Refined_Global.
24539 -- This routine may remove elements from In_Constits, In_Out_Constits,
24540 -- Out_Constits and Proof_In_Constits.
24541
24542 procedure Check_Output_States;
24543 -- Determine whether the corresponding Global pragma mentions Output
24544 -- states with visible refinement and if so, ensure that all of its
24545 -- constituents appear as Output items in Refined_Global.
24546 -- This routine may remove elements from In_Constits, In_Out_Constits,
24547 -- Out_Constits and Proof_In_Constits.
24548
24549 procedure Check_Proof_In_States;
24550 -- Determine whether the corresponding Global pragma mentions Proof_In
24551 -- states with visible refinement and if so, ensure that at least one of
24552 -- its constituents appears as a Proof_In item in Refined_Global.
24553 -- This routine may remove elements from In_Constits, In_Out_Constits,
24554 -- Out_Constits and Proof_In_Constits.
24555
24556 procedure Check_Refined_Global_List
24557 (List : Node_Id;
24558 Global_Mode : Name_Id := Name_Input);
24559 -- Verify the legality of a single global list declaration. Global_Mode
24560 -- denotes the current mode in effect.
24561
24562 procedure Collect_Global_Items
24563 (List : Node_Id;
24564 Mode : Name_Id := Name_Input);
24565 -- Gather all input, in out, output and Proof_In items from node List
24566 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24567 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24568 -- and Has_Proof_In_State are set when there is at least one abstract
24569 -- state with visible refinement available in the corresponding mode.
24570 -- Flag Has_Null_State is set when at least state has a null refinement.
24571 -- Mode enotes the current global mode in effect.
24572
24573 function Present_Then_Remove
24574 (List : Elist_Id;
24575 Item : Entity_Id) return Boolean;
24576 -- Search List for a particular entity Item. If Item has been found,
24577 -- remove it from List. This routine is used to strip lists In_Constits,
24578 -- In_Out_Constits and Out_Constits of valid constituents.
24579
24580 procedure Report_Extra_Constituents;
24581 -- Emit an error for each constituent found in lists In_Constits,
24582 -- In_Out_Constits and Out_Constits.
24583
24584 -------------------------
24585 -- Check_In_Out_States --
24586 -------------------------
24587
24588 procedure Check_In_Out_States is
24589 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24590 -- Determine whether one of the following coverage scenarios is in
24591 -- effect:
24592 -- 1) there is at least one constituent of mode In_Out or Output
24593 -- 2) there is at least one pair of constituents with modes Input
24594 -- and Output, or Proof_In and Output.
24595 -- 3) there is at least one constituent of mode Output and not all
24596 -- constituents are present.
24597 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24598
24599 -----------------------------
24600 -- Check_Constituent_Usage --
24601 -----------------------------
24602
24603 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24604 Constits : constant Elist_Id :=
24605 Refinement_Constituents (State_Id);
24606 Constit_Elmt : Elmt_Id;
24607 Constit_Id : Entity_Id;
24608 Has_Missing : Boolean := False;
24609 In_Out_Seen : Boolean := False;
24610 Input_Seen : Boolean := False;
24611 Output_Seen : Boolean := False;
24612 Proof_In_Seen : Boolean := False;
24613
24614 begin
24615 -- Process all the constituents of the state and note their modes
24616 -- within the global refinement.
24617
24618 if Present (Constits) then
24619 Constit_Elmt := First_Elmt (Constits);
24620 while Present (Constit_Elmt) loop
24621 Constit_Id := Node (Constit_Elmt);
24622
24623 if Present_Then_Remove (In_Constits, Constit_Id) then
24624 Input_Seen := True;
24625
24626 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
24627 In_Out_Seen := True;
24628
24629 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
24630 Output_Seen := True;
24631
24632 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24633 then
24634 Proof_In_Seen := True;
24635
24636 else
24637 Has_Missing := True;
24638 end if;
24639
24640 Next_Elmt (Constit_Elmt);
24641 end loop;
24642 end if;
24643
24644 -- An In_Out constituent is a valid completion
24645
24646 if In_Out_Seen then
24647 null;
24648
24649 -- A pair of one Input/Proof_In and one Output constituent is a
24650 -- valid completion.
24651
24652 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
24653 null;
24654
24655 elsif Output_Seen then
24656
24657 -- A single Output constituent is a valid completion only when
24658 -- some of the other constituents are missing.
24659
24660 if Has_Missing then
24661 null;
24662
24663 -- Otherwise all constituents are of mode Output
24664
24665 else
24666 SPARK_Msg_NE
24667 ("global refinement of state & must include at least one "
24668 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24669 N, State_Id);
24670 end if;
24671
24672 -- The state lacks a completion
24673
24674 elsif not Input_Seen
24675 and not In_Out_Seen
24676 and not Output_Seen
24677 and not Proof_In_Seen
24678 then
24679 SPARK_Msg_NE
24680 ("missing global refinement of state &", N, State_Id);
24681
24682 -- Otherwise the state has a malformed completion where at least
24683 -- one of the constituents has a different mode.
24684
24685 else
24686 SPARK_Msg_NE
24687 ("global refinement of state & redefines the mode of its "
24688 & "constituents", N, State_Id);
24689 end if;
24690 end Check_Constituent_Usage;
24691
24692 -- Local variables
24693
24694 Item_Elmt : Elmt_Id;
24695 Item_Id : Entity_Id;
24696
24697 -- Start of processing for Check_In_Out_States
24698
24699 begin
24700 -- Do not perform this check in an instance because it was already
24701 -- performed successfully in the generic template.
24702
24703 if Is_Generic_Instance (Spec_Id) then
24704 null;
24705
24706 -- Inspect the In_Out items of the corresponding Global pragma
24707 -- looking for a state with a visible refinement.
24708
24709 elsif Has_In_Out_State and then Present (In_Out_Items) then
24710 Item_Elmt := First_Elmt (In_Out_Items);
24711 while Present (Item_Elmt) loop
24712 Item_Id := Node (Item_Elmt);
24713
24714 -- Ensure that one of the three coverage variants is satisfied
24715
24716 if Ekind (Item_Id) = E_Abstract_State
24717 and then Has_Non_Null_Visible_Refinement (Item_Id)
24718 then
24719 Check_Constituent_Usage (Item_Id);
24720 end if;
24721
24722 Next_Elmt (Item_Elmt);
24723 end loop;
24724 end if;
24725 end Check_In_Out_States;
24726
24727 ------------------------
24728 -- Check_Input_States --
24729 ------------------------
24730
24731 procedure Check_Input_States is
24732 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24733 -- Determine whether at least one constituent of state State_Id with
24734 -- visible refinement is used and has mode Input. Ensure that the
24735 -- remaining constituents do not have In_Out or Output modes. Emit an
24736 -- error if this is not the case (SPARK RM 7.2.4(5)).
24737
24738 -----------------------------
24739 -- Check_Constituent_Usage --
24740 -----------------------------
24741
24742 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24743 Constits : constant Elist_Id :=
24744 Refinement_Constituents (State_Id);
24745 Constit_Elmt : Elmt_Id;
24746 Constit_Id : Entity_Id;
24747 In_Seen : Boolean := False;
24748
24749 begin
24750 if Present (Constits) then
24751 Constit_Elmt := First_Elmt (Constits);
24752 while Present (Constit_Elmt) loop
24753 Constit_Id := Node (Constit_Elmt);
24754
24755 -- At least one of the constituents appears as an Input
24756
24757 if Present_Then_Remove (In_Constits, Constit_Id) then
24758 In_Seen := True;
24759
24760 -- A Proof_In constituent can refine an Input state as long
24761 -- as there is at least one Input constituent present.
24762
24763 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24764 then
24765 null;
24766
24767 -- The constituent appears in the global refinement, but has
24768 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
24769
24770 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
24771 or else Present_Then_Remove (Out_Constits, Constit_Id)
24772 then
24773 Error_Msg_Name_1 := Chars (State_Id);
24774 SPARK_Msg_NE
24775 ("constituent & of state % must have mode `Input` in "
24776 & "global refinement", N, Constit_Id);
24777 end if;
24778
24779 Next_Elmt (Constit_Elmt);
24780 end loop;
24781 end if;
24782
24783 -- Not one of the constituents appeared as Input
24784
24785 if not In_Seen then
24786 SPARK_Msg_NE
24787 ("global refinement of state & must include at least one "
24788 & "constituent of mode `Input`", N, State_Id);
24789 end if;
24790 end Check_Constituent_Usage;
24791
24792 -- Local variables
24793
24794 Item_Elmt : Elmt_Id;
24795 Item_Id : Entity_Id;
24796
24797 -- Start of processing for Check_Input_States
24798
24799 begin
24800 -- Do not perform this check in an instance because it was already
24801 -- performed successfully in the generic template.
24802
24803 if Is_Generic_Instance (Spec_Id) then
24804 null;
24805
24806 -- Inspect the Input items of the corresponding Global pragma looking
24807 -- for a state with a visible refinement.
24808
24809 elsif Has_In_State and then Present (In_Items) then
24810 Item_Elmt := First_Elmt (In_Items);
24811 while Present (Item_Elmt) loop
24812 Item_Id := Node (Item_Elmt);
24813
24814 -- Ensure that at least one of the constituents is utilized and
24815 -- is of mode Input.
24816
24817 if Ekind (Item_Id) = E_Abstract_State
24818 and then Has_Non_Null_Visible_Refinement (Item_Id)
24819 then
24820 Check_Constituent_Usage (Item_Id);
24821 end if;
24822
24823 Next_Elmt (Item_Elmt);
24824 end loop;
24825 end if;
24826 end Check_Input_States;
24827
24828 -------------------------
24829 -- Check_Output_States --
24830 -------------------------
24831
24832 procedure Check_Output_States is
24833 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24834 -- Determine whether all constituents of state State_Id with visible
24835 -- refinement are used and have mode Output. Emit an error if this is
24836 -- not the case (SPARK RM 7.2.4(5)).
24837
24838 -----------------------------
24839 -- Check_Constituent_Usage --
24840 -----------------------------
24841
24842 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24843 Constits : constant Elist_Id :=
24844 Refinement_Constituents (State_Id);
24845 Constit_Elmt : Elmt_Id;
24846 Constit_Id : Entity_Id;
24847 Posted : Boolean := False;
24848
24849 begin
24850 if Present (Constits) then
24851 Constit_Elmt := First_Elmt (Constits);
24852 while Present (Constit_Elmt) loop
24853 Constit_Id := Node (Constit_Elmt);
24854
24855 if Present_Then_Remove (Out_Constits, Constit_Id) then
24856 null;
24857
24858 -- The constituent appears in the global refinement, but has
24859 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24860
24861 elsif Present_Then_Remove (In_Constits, Constit_Id)
24862 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24863 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
24864 then
24865 Error_Msg_Name_1 := Chars (State_Id);
24866 SPARK_Msg_NE
24867 ("constituent & of state % must have mode `Output` in "
24868 & "global refinement", N, Constit_Id);
24869
24870 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24871
24872 else
24873 if not Posted then
24874 Posted := True;
24875 SPARK_Msg_NE
24876 ("`Output` state & must be replaced by all its "
24877 & "constituents in global refinement", N, State_Id);
24878 end if;
24879
24880 SPARK_Msg_NE
24881 ("\constituent & is missing in output list",
24882 N, Constit_Id);
24883 end if;
24884
24885 Next_Elmt (Constit_Elmt);
24886 end loop;
24887 end if;
24888 end Check_Constituent_Usage;
24889
24890 -- Local variables
24891
24892 Item_Elmt : Elmt_Id;
24893 Item_Id : Entity_Id;
24894
24895 -- Start of processing for Check_Output_States
24896
24897 begin
24898 -- Do not perform this check in an instance because it was already
24899 -- performed successfully in the generic template.
24900
24901 if Is_Generic_Instance (Spec_Id) then
24902 null;
24903
24904 -- Inspect the Output items of the corresponding Global pragma
24905 -- looking for a state with a visible refinement.
24906
24907 elsif Has_Out_State and then Present (Out_Items) then
24908 Item_Elmt := First_Elmt (Out_Items);
24909 while Present (Item_Elmt) loop
24910 Item_Id := Node (Item_Elmt);
24911
24912 -- Ensure that all of the constituents are utilized and they
24913 -- have mode Output.
24914
24915 if Ekind (Item_Id) = E_Abstract_State
24916 and then Has_Non_Null_Visible_Refinement (Item_Id)
24917 then
24918 Check_Constituent_Usage (Item_Id);
24919 end if;
24920
24921 Next_Elmt (Item_Elmt);
24922 end loop;
24923 end if;
24924 end Check_Output_States;
24925
24926 ---------------------------
24927 -- Check_Proof_In_States --
24928 ---------------------------
24929
24930 procedure Check_Proof_In_States is
24931 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24932 -- Determine whether at least one constituent of state State_Id with
24933 -- visible refinement is used and has mode Proof_In. Ensure that the
24934 -- remaining constituents do not have Input, In_Out or Output modes.
24935 -- Emit an error of this is not the case (SPARK RM 7.2.4(5)).
24936
24937 -----------------------------
24938 -- Check_Constituent_Usage --
24939 -----------------------------
24940
24941 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24942 Constits : constant Elist_Id :=
24943 Refinement_Constituents (State_Id);
24944 Constit_Elmt : Elmt_Id;
24945 Constit_Id : Entity_Id;
24946 Proof_In_Seen : Boolean := False;
24947
24948 begin
24949 if Present (Constits) then
24950 Constit_Elmt := First_Elmt (Constits);
24951 while Present (Constit_Elmt) loop
24952 Constit_Id := Node (Constit_Elmt);
24953
24954 -- At least one of the constituents appears as Proof_In
24955
24956 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
24957 Proof_In_Seen := True;
24958
24959 -- The constituent appears in the global refinement, but has
24960 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24961
24962 elsif Present_Then_Remove (In_Constits, Constit_Id)
24963 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24964 or else Present_Then_Remove (Out_Constits, Constit_Id)
24965 then
24966 Error_Msg_Name_1 := Chars (State_Id);
24967 SPARK_Msg_NE
24968 ("constituent & of state % must have mode `Proof_In` "
24969 & "in global refinement", N, Constit_Id);
24970 end if;
24971
24972 Next_Elmt (Constit_Elmt);
24973 end loop;
24974 end if;
24975
24976 -- Not one of the constituents appeared as Proof_In
24977
24978 if not Proof_In_Seen then
24979 SPARK_Msg_NE
24980 ("global refinement of state & must include at least one "
24981 & "constituent of mode `Proof_In`", N, State_Id);
24982 end if;
24983 end Check_Constituent_Usage;
24984
24985 -- Local variables
24986
24987 Item_Elmt : Elmt_Id;
24988 Item_Id : Entity_Id;
24989
24990 -- Start of processing for Check_Proof_In_States
24991
24992 begin
24993 -- Do not perform this check in an instance because it was already
24994 -- performed successfully in the generic template.
24995
24996 if Is_Generic_Instance (Spec_Id) then
24997 null;
24998
24999 -- Inspect the Proof_In items of the corresponding Global pragma
25000 -- looking for a state with a visible refinement.
25001
25002 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
25003 Item_Elmt := First_Elmt (Proof_In_Items);
25004 while Present (Item_Elmt) loop
25005 Item_Id := Node (Item_Elmt);
25006
25007 -- Ensure that at least one of the constituents is utilized and
25008 -- is of mode Proof_In
25009
25010 if Ekind (Item_Id) = E_Abstract_State
25011 and then Has_Non_Null_Visible_Refinement (Item_Id)
25012 then
25013 Check_Constituent_Usage (Item_Id);
25014 end if;
25015
25016 Next_Elmt (Item_Elmt);
25017 end loop;
25018 end if;
25019 end Check_Proof_In_States;
25020
25021 -------------------------------
25022 -- Check_Refined_Global_List --
25023 -------------------------------
25024
25025 procedure Check_Refined_Global_List
25026 (List : Node_Id;
25027 Global_Mode : Name_Id := Name_Input)
25028 is
25029 procedure Check_Refined_Global_Item
25030 (Item : Node_Id;
25031 Global_Mode : Name_Id);
25032 -- Verify the legality of a single global item declaration. Parameter
25033 -- Global_Mode denotes the current mode in effect.
25034
25035 -------------------------------
25036 -- Check_Refined_Global_Item --
25037 -------------------------------
25038
25039 procedure Check_Refined_Global_Item
25040 (Item : Node_Id;
25041 Global_Mode : Name_Id)
25042 is
25043 Item_Id : constant Entity_Id := Entity_Of (Item);
25044
25045 procedure Inconsistent_Mode_Error (Expect : Name_Id);
25046 -- Issue a common error message for all mode mismatches. Expect
25047 -- denotes the expected mode.
25048
25049 -----------------------------
25050 -- Inconsistent_Mode_Error --
25051 -----------------------------
25052
25053 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
25054 begin
25055 SPARK_Msg_NE
25056 ("global item & has inconsistent modes", Item, Item_Id);
25057
25058 Error_Msg_Name_1 := Global_Mode;
25059 Error_Msg_Name_2 := Expect;
25060 SPARK_Msg_N ("\expected mode %, found mode %", Item);
25061 end Inconsistent_Mode_Error;
25062
25063 -- Start of processing for Check_Refined_Global_Item
25064
25065 begin
25066 -- When the state or object acts as a constituent of another
25067 -- state with a visible refinement, collect it for the state
25068 -- completeness checks performed later on. Note that the item
25069 -- acts as a constituent only when the encapsulating state is
25070 -- present in pragma Global.
25071
25072 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
25073 and then Present (Encapsulating_State (Item_Id))
25074 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
25075 and then Contains (States, Encapsulating_State (Item_Id))
25076 then
25077 if Global_Mode = Name_Input then
25078 Append_New_Elmt (Item_Id, In_Constits);
25079
25080 elsif Global_Mode = Name_In_Out then
25081 Append_New_Elmt (Item_Id, In_Out_Constits);
25082
25083 elsif Global_Mode = Name_Output then
25084 Append_New_Elmt (Item_Id, Out_Constits);
25085
25086 elsif Global_Mode = Name_Proof_In then
25087 Append_New_Elmt (Item_Id, Proof_In_Constits);
25088 end if;
25089
25090 -- When not a constituent, ensure that both occurrences of the
25091 -- item in pragmas Global and Refined_Global match.
25092
25093 elsif Contains (In_Items, Item_Id) then
25094 if Global_Mode /= Name_Input then
25095 Inconsistent_Mode_Error (Name_Input);
25096 end if;
25097
25098 elsif Contains (In_Out_Items, Item_Id) then
25099 if Global_Mode /= Name_In_Out then
25100 Inconsistent_Mode_Error (Name_In_Out);
25101 end if;
25102
25103 elsif Contains (Out_Items, Item_Id) then
25104 if Global_Mode /= Name_Output then
25105 Inconsistent_Mode_Error (Name_Output);
25106 end if;
25107
25108 elsif Contains (Proof_In_Items, Item_Id) then
25109 null;
25110
25111 -- The item does not appear in the corresponding Global pragma,
25112 -- it must be an extra (SPARK RM 7.2.4(3)).
25113
25114 else
25115 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
25116 end if;
25117 end Check_Refined_Global_Item;
25118
25119 -- Local variables
25120
25121 Item : Node_Id;
25122
25123 -- Start of processing for Check_Refined_Global_List
25124
25125 begin
25126 -- Do not perform this check in an instance because it was already
25127 -- performed successfully in the generic template.
25128
25129 if Is_Generic_Instance (Spec_Id) then
25130 null;
25131
25132 elsif Nkind (List) = N_Null then
25133 null;
25134
25135 -- Single global item declaration
25136
25137 elsif Nkind_In (List, N_Expanded_Name,
25138 N_Identifier,
25139 N_Selected_Component)
25140 then
25141 Check_Refined_Global_Item (List, Global_Mode);
25142
25143 -- Simple global list or moded global list declaration
25144
25145 elsif Nkind (List) = N_Aggregate then
25146
25147 -- The declaration of a simple global list appear as a collection
25148 -- of expressions.
25149
25150 if Present (Expressions (List)) then
25151 Item := First (Expressions (List));
25152 while Present (Item) loop
25153 Check_Refined_Global_Item (Item, Global_Mode);
25154 Next (Item);
25155 end loop;
25156
25157 -- The declaration of a moded global list appears as a collection
25158 -- of component associations where individual choices denote
25159 -- modes.
25160
25161 elsif Present (Component_Associations (List)) then
25162 Item := First (Component_Associations (List));
25163 while Present (Item) loop
25164 Check_Refined_Global_List
25165 (List => Expression (Item),
25166 Global_Mode => Chars (First (Choices (Item))));
25167
25168 Next (Item);
25169 end loop;
25170
25171 -- Invalid tree
25172
25173 else
25174 raise Program_Error;
25175 end if;
25176
25177 -- Invalid list
25178
25179 else
25180 raise Program_Error;
25181 end if;
25182 end Check_Refined_Global_List;
25183
25184 --------------------------
25185 -- Collect_Global_Items --
25186 --------------------------
25187
25188 procedure Collect_Global_Items
25189 (List : Node_Id;
25190 Mode : Name_Id := Name_Input)
25191 is
25192 procedure Collect_Global_Item
25193 (Item : Node_Id;
25194 Item_Mode : Name_Id);
25195 -- Add a single item to the appropriate list. Item_Mode denotes the
25196 -- current mode in effect.
25197
25198 -------------------------
25199 -- Collect_Global_Item --
25200 -------------------------
25201
25202 procedure Collect_Global_Item
25203 (Item : Node_Id;
25204 Item_Mode : Name_Id)
25205 is
25206 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
25207 -- The above handles abstract views of variables and states built
25208 -- for limited with clauses.
25209
25210 begin
25211 -- Signal that the global list contains at least one abstract
25212 -- state with a visible refinement. Note that the refinement may
25213 -- be null in which case there are no constituents.
25214
25215 if Ekind (Item_Id) = E_Abstract_State then
25216 if Has_Null_Visible_Refinement (Item_Id) then
25217 Has_Null_State := True;
25218
25219 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
25220 Append_New_Elmt (Item_Id, States);
25221
25222 if Item_Mode = Name_Input then
25223 Has_In_State := True;
25224 elsif Item_Mode = Name_In_Out then
25225 Has_In_Out_State := True;
25226 elsif Item_Mode = Name_Output then
25227 Has_Out_State := True;
25228 elsif Item_Mode = Name_Proof_In then
25229 Has_Proof_In_State := True;
25230 end if;
25231 end if;
25232 end if;
25233
25234 -- Add the item to the proper list
25235
25236 if Item_Mode = Name_Input then
25237 Append_New_Elmt (Item_Id, In_Items);
25238 elsif Item_Mode = Name_In_Out then
25239 Append_New_Elmt (Item_Id, In_Out_Items);
25240 elsif Item_Mode = Name_Output then
25241 Append_New_Elmt (Item_Id, Out_Items);
25242 elsif Item_Mode = Name_Proof_In then
25243 Append_New_Elmt (Item_Id, Proof_In_Items);
25244 end if;
25245 end Collect_Global_Item;
25246
25247 -- Local variables
25248
25249 Item : Node_Id;
25250
25251 -- Start of processing for Collect_Global_Items
25252
25253 begin
25254 if Nkind (List) = N_Null then
25255 null;
25256
25257 -- Single global item declaration
25258
25259 elsif Nkind_In (List, N_Expanded_Name,
25260 N_Identifier,
25261 N_Selected_Component)
25262 then
25263 Collect_Global_Item (List, Mode);
25264
25265 -- Single global list or moded global list declaration
25266
25267 elsif Nkind (List) = N_Aggregate then
25268
25269 -- The declaration of a simple global list appear as a collection
25270 -- of expressions.
25271
25272 if Present (Expressions (List)) then
25273 Item := First (Expressions (List));
25274 while Present (Item) loop
25275 Collect_Global_Item (Item, Mode);
25276 Next (Item);
25277 end loop;
25278
25279 -- The declaration of a moded global list appears as a collection
25280 -- of component associations where individual choices denote mode.
25281
25282 elsif Present (Component_Associations (List)) then
25283 Item := First (Component_Associations (List));
25284 while Present (Item) loop
25285 Collect_Global_Items
25286 (List => Expression (Item),
25287 Mode => Chars (First (Choices (Item))));
25288
25289 Next (Item);
25290 end loop;
25291
25292 -- Invalid tree
25293
25294 else
25295 raise Program_Error;
25296 end if;
25297
25298 -- To accomodate partial decoration of disabled SPARK features, this
25299 -- routine may be called with illegal input. If this is the case, do
25300 -- not raise Program_Error.
25301
25302 else
25303 null;
25304 end if;
25305 end Collect_Global_Items;
25306
25307 -------------------------
25308 -- Present_Then_Remove --
25309 -------------------------
25310
25311 function Present_Then_Remove
25312 (List : Elist_Id;
25313 Item : Entity_Id) return Boolean
25314 is
25315 Elmt : Elmt_Id;
25316
25317 begin
25318 if Present (List) then
25319 Elmt := First_Elmt (List);
25320 while Present (Elmt) loop
25321 if Node (Elmt) = Item then
25322 Remove_Elmt (List, Elmt);
25323 return True;
25324 end if;
25325
25326 Next_Elmt (Elmt);
25327 end loop;
25328 end if;
25329
25330 return False;
25331 end Present_Then_Remove;
25332
25333 -------------------------------
25334 -- Report_Extra_Constituents --
25335 -------------------------------
25336
25337 procedure Report_Extra_Constituents is
25338 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
25339 -- Emit an error for every element of List
25340
25341 ---------------------------------------
25342 -- Report_Extra_Constituents_In_List --
25343 ---------------------------------------
25344
25345 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
25346 Constit_Elmt : Elmt_Id;
25347
25348 begin
25349 if Present (List) then
25350 Constit_Elmt := First_Elmt (List);
25351 while Present (Constit_Elmt) loop
25352 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
25353 Next_Elmt (Constit_Elmt);
25354 end loop;
25355 end if;
25356 end Report_Extra_Constituents_In_List;
25357
25358 -- Start of processing for Report_Extra_Constituents
25359
25360 begin
25361 -- Do not perform this check in an instance because it was already
25362 -- performed successfully in the generic template.
25363
25364 if Is_Generic_Instance (Spec_Id) then
25365 null;
25366
25367 else
25368 Report_Extra_Constituents_In_List (In_Constits);
25369 Report_Extra_Constituents_In_List (In_Out_Constits);
25370 Report_Extra_Constituents_In_List (Out_Constits);
25371 Report_Extra_Constituents_In_List (Proof_In_Constits);
25372 end if;
25373 end Report_Extra_Constituents;
25374
25375 -- Local variables
25376
25377 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25378 Errors : constant Nat := Serious_Errors_Detected;
25379 Items : Node_Id;
25380
25381 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25382
25383 begin
25384 -- Do not analyze the pragma multiple times
25385
25386 if Is_Analyzed_Pragma (N) then
25387 return;
25388 end if;
25389
25390 Spec_Id := Unique_Defining_Entity (Body_Decl);
25391
25392 -- Use the anonymous object as the proper spec when Refined_Global
25393 -- applies to the body of a single task type. The object carries the
25394 -- proper Chars as well as all non-refined versions of pragmas.
25395
25396 if Is_Single_Concurrent_Type (Spec_Id) then
25397 Spec_Id := Anonymous_Object (Spec_Id);
25398 end if;
25399
25400 Global := Get_Pragma (Spec_Id, Pragma_Global);
25401 Items := Expression (Get_Argument (N, Spec_Id));
25402
25403 -- The subprogram declaration lacks pragma Global. This renders
25404 -- Refined_Global useless as there is nothing to refine.
25405
25406 if No (Global) then
25407 SPARK_Msg_NE
25408 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25409 & "& lacks aspect or pragma Global"), N, Spec_Id);
25410 goto Leave;
25411 end if;
25412
25413 -- Extract all relevant items from the corresponding Global pragma
25414
25415 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
25416
25417 -- Package and subprogram bodies are instantiated individually in
25418 -- a separate compiler pass. Due to this mode of instantiation, the
25419 -- refinement of a state may no longer be visible when a subprogram
25420 -- body contract is instantiated. Since the generic template is legal,
25421 -- do not perform this check in the instance to circumvent this oddity.
25422
25423 if Is_Generic_Instance (Spec_Id) then
25424 null;
25425
25426 -- Non-instance case
25427
25428 else
25429 -- The corresponding Global pragma must mention at least one state
25430 -- witha visible refinement at the point Refined_Global is processed.
25431 -- States with null refinements need Refined_Global pragma
25432 -- (SPARK RM 7.2.4(2)).
25433
25434 if not Has_In_State
25435 and then not Has_In_Out_State
25436 and then not Has_Out_State
25437 and then not Has_Proof_In_State
25438 and then not Has_Null_State
25439 then
25440 SPARK_Msg_NE
25441 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25442 & "depend on abstract state with visible refinement"),
25443 N, Spec_Id);
25444 goto Leave;
25445
25446 -- The global refinement of inputs and outputs cannot be null when
25447 -- the corresponding Global pragma contains at least one item except
25448 -- in the case where we have states with null refinements.
25449
25450 elsif Nkind (Items) = N_Null
25451 and then
25452 (Present (In_Items)
25453 or else Present (In_Out_Items)
25454 or else Present (Out_Items)
25455 or else Present (Proof_In_Items))
25456 and then not Has_Null_State
25457 then
25458 SPARK_Msg_NE
25459 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
25460 & "global items"), N, Spec_Id);
25461 goto Leave;
25462 end if;
25463 end if;
25464
25465 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25466 -- This ensures that the categorization of all refined global items is
25467 -- consistent with their role.
25468
25469 Analyze_Global_In_Decl_Part (N);
25470
25471 -- Perform all refinement checks with respect to completeness and mode
25472 -- matching.
25473
25474 if Serious_Errors_Detected = Errors then
25475 Check_Refined_Global_List (Items);
25476 end if;
25477
25478 -- For Input states with visible refinement, at least one constituent
25479 -- must be used as an Input in the global refinement.
25480
25481 if Serious_Errors_Detected = Errors then
25482 Check_Input_States;
25483 end if;
25484
25485 -- Verify all possible completion variants for In_Out states with
25486 -- visible refinement.
25487
25488 if Serious_Errors_Detected = Errors then
25489 Check_In_Out_States;
25490 end if;
25491
25492 -- For Output states with visible refinement, all constituents must be
25493 -- used as Outputs in the global refinement.
25494
25495 if Serious_Errors_Detected = Errors then
25496 Check_Output_States;
25497 end if;
25498
25499 -- For Proof_In states with visible refinement, at least one constituent
25500 -- must be used as Proof_In in the global refinement.
25501
25502 if Serious_Errors_Detected = Errors then
25503 Check_Proof_In_States;
25504 end if;
25505
25506 -- Emit errors for all constituents that belong to other states with
25507 -- visible refinement that do not appear in Global.
25508
25509 if Serious_Errors_Detected = Errors then
25510 Report_Extra_Constituents;
25511 end if;
25512
25513 <<Leave>>
25514 Set_Is_Analyzed_Pragma (N);
25515 end Analyze_Refined_Global_In_Decl_Part;
25516
25517 ----------------------------------------
25518 -- Analyze_Refined_State_In_Decl_Part --
25519 ----------------------------------------
25520
25521 procedure Analyze_Refined_State_In_Decl_Part
25522 (N : Node_Id;
25523 Freeze_Id : Entity_Id := Empty)
25524 is
25525 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
25526 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
25527 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
25528
25529 Available_States : Elist_Id := No_Elist;
25530 -- A list of all abstract states defined in the package declaration that
25531 -- are available for refinement. The list is used to report unrefined
25532 -- states.
25533
25534 Body_States : Elist_Id := No_Elist;
25535 -- A list of all hidden states that appear in the body of the related
25536 -- package. The list is used to report unused hidden states.
25537
25538 Constituents_Seen : Elist_Id := No_Elist;
25539 -- A list that contains all constituents processed so far. The list is
25540 -- used to detect multiple uses of the same constituent.
25541
25542 Freeze_Posted : Boolean := False;
25543 -- A flag that controls the output of a freezing-related error (see use
25544 -- below).
25545
25546 Refined_States_Seen : Elist_Id := No_Elist;
25547 -- A list that contains all refined states processed so far. The list is
25548 -- used to detect duplicate refinements.
25549
25550 procedure Analyze_Refinement_Clause (Clause : Node_Id);
25551 -- Perform full analysis of a single refinement clause
25552
25553 procedure Report_Unrefined_States (States : Elist_Id);
25554 -- Emit errors for all unrefined abstract states found in list States
25555
25556 -------------------------------
25557 -- Analyze_Refinement_Clause --
25558 -------------------------------
25559
25560 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
25561 AR_Constit : Entity_Id := Empty;
25562 AW_Constit : Entity_Id := Empty;
25563 ER_Constit : Entity_Id := Empty;
25564 EW_Constit : Entity_Id := Empty;
25565 -- The entities of external constituents that contain one of the
25566 -- following enabled properties: Async_Readers, Async_Writers,
25567 -- Effective_Reads and Effective_Writes.
25568
25569 External_Constit_Seen : Boolean := False;
25570 -- Flag used to mark when at least one external constituent is part
25571 -- of the state refinement.
25572
25573 Non_Null_Seen : Boolean := False;
25574 Null_Seen : Boolean := False;
25575 -- Flags used to detect multiple uses of null in a single clause or a
25576 -- mixture of null and non-null constituents.
25577
25578 Part_Of_Constits : Elist_Id := No_Elist;
25579 -- A list of all candidate constituents subject to indicator Part_Of
25580 -- where the encapsulating state is the current state.
25581
25582 State : Node_Id;
25583 State_Id : Entity_Id;
25584 -- The current state being refined
25585
25586 procedure Analyze_Constituent (Constit : Node_Id);
25587 -- Perform full analysis of a single constituent
25588
25589 procedure Check_External_Property
25590 (Prop_Nam : Name_Id;
25591 Enabled : Boolean;
25592 Constit : Entity_Id);
25593 -- Determine whether a property denoted by name Prop_Nam is present
25594 -- in the refined state. Emit an error if this is not the case. Flag
25595 -- Enabled should be set when the property applies to the refined
25596 -- state. Constit denotes the constituent (if any) which introduces
25597 -- the property in the refinement.
25598
25599 procedure Match_State;
25600 -- Determine whether the state being refined appears in list
25601 -- Available_States. Emit an error when attempting to re-refine the
25602 -- state or when the state is not defined in the package declaration,
25603 -- otherwise remove the state from Available_States.
25604
25605 procedure Report_Unused_Constituents (Constits : Elist_Id);
25606 -- Emit errors for all unused Part_Of constituents in list Constits
25607
25608 -------------------------
25609 -- Analyze_Constituent --
25610 -------------------------
25611
25612 procedure Analyze_Constituent (Constit : Node_Id) is
25613 procedure Match_Constituent (Constit_Id : Entity_Id);
25614 -- Determine whether constituent Constit denoted by its entity
25615 -- Constit_Id appears in Body_States. Emit an error when the
25616 -- constituent is not a valid hidden state of the related package
25617 -- or when it is used more than once. Otherwise remove the
25618 -- constituent from Body_States.
25619
25620 -----------------------
25621 -- Match_Constituent --
25622 -----------------------
25623
25624 procedure Match_Constituent (Constit_Id : Entity_Id) is
25625 procedure Collect_Constituent;
25626 -- Verify the legality of constituent Constit_Id and add it to
25627 -- the refinements of State_Id.
25628
25629 -------------------------
25630 -- Collect_Constituent --
25631 -------------------------
25632
25633 procedure Collect_Constituent is
25634 Constits : Elist_Id;
25635
25636 begin
25637 -- The Ghost policy in effect at the point of abstract state
25638 -- declaration and constituent must match (SPARK RM 6.9(15))
25639
25640 Check_Ghost_Refinement
25641 (State, State_Id, Constit, Constit_Id);
25642
25643 -- A synchronized state must be refined by a synchronized
25644 -- object or another synchronized state (SPARK RM 9.6).
25645
25646 if Is_Synchronized_State (State_Id)
25647 and then not Is_Synchronized_Object (Constit_Id)
25648 and then not Is_Synchronized_State (Constit_Id)
25649 then
25650 SPARK_Msg_NE
25651 ("constituent of synchronized state & must be "
25652 & "synchronized", Constit, State_Id);
25653 end if;
25654
25655 -- Add the constituent to the list of processed items to aid
25656 -- with the detection of duplicates.
25657
25658 Append_New_Elmt (Constit_Id, Constituents_Seen);
25659
25660 -- Collect the constituent in the list of refinement items
25661 -- and establish a relation between the refined state and
25662 -- the item.
25663
25664 Constits := Refinement_Constituents (State_Id);
25665
25666 if No (Constits) then
25667 Constits := New_Elmt_List;
25668 Set_Refinement_Constituents (State_Id, Constits);
25669 end if;
25670
25671 Append_Elmt (Constit_Id, Constits);
25672 Set_Encapsulating_State (Constit_Id, State_Id);
25673
25674 -- The state has at least one legal constituent, mark the
25675 -- start of the refinement region. The region ends when the
25676 -- body declarations end (see routine Analyze_Declarations).
25677
25678 Set_Has_Visible_Refinement (State_Id);
25679
25680 -- When the constituent is external, save its relevant
25681 -- property for further checks.
25682
25683 if Async_Readers_Enabled (Constit_Id) then
25684 AR_Constit := Constit_Id;
25685 External_Constit_Seen := True;
25686 end if;
25687
25688 if Async_Writers_Enabled (Constit_Id) then
25689 AW_Constit := Constit_Id;
25690 External_Constit_Seen := True;
25691 end if;
25692
25693 if Effective_Reads_Enabled (Constit_Id) then
25694 ER_Constit := Constit_Id;
25695 External_Constit_Seen := True;
25696 end if;
25697
25698 if Effective_Writes_Enabled (Constit_Id) then
25699 EW_Constit := Constit_Id;
25700 External_Constit_Seen := True;
25701 end if;
25702 end Collect_Constituent;
25703
25704 -- Local variables
25705
25706 State_Elmt : Elmt_Id;
25707
25708 -- Start of processing for Match_Constituent
25709
25710 begin
25711 -- Detect a duplicate use of a constituent
25712
25713 if Contains (Constituents_Seen, Constit_Id) then
25714 SPARK_Msg_NE
25715 ("duplicate use of constituent &", Constit, Constit_Id);
25716 return;
25717 end if;
25718
25719 -- The constituent is subject to a Part_Of indicator
25720
25721 if Present (Encapsulating_State (Constit_Id)) then
25722 if Encapsulating_State (Constit_Id) = State_Id then
25723 Remove (Part_Of_Constits, Constit_Id);
25724 Collect_Constituent;
25725
25726 -- The constituent is part of another state and is used
25727 -- incorrectly in the refinement of the current state.
25728
25729 else
25730 Error_Msg_Name_1 := Chars (State_Id);
25731 SPARK_Msg_NE
25732 ("& cannot act as constituent of state %",
25733 Constit, Constit_Id);
25734 SPARK_Msg_NE
25735 ("\Part_Of indicator specifies encapsulator &",
25736 Constit, Encapsulating_State (Constit_Id));
25737 end if;
25738
25739 -- The only other source of legal constituents is the body
25740 -- state space of the related package.
25741
25742 else
25743 if Present (Body_States) then
25744 State_Elmt := First_Elmt (Body_States);
25745 while Present (State_Elmt) loop
25746
25747 -- Consume a valid constituent to signal that it has
25748 -- been encountered.
25749
25750 if Node (State_Elmt) = Constit_Id then
25751 Remove_Elmt (Body_States, State_Elmt);
25752 Collect_Constituent;
25753 return;
25754 end if;
25755
25756 Next_Elmt (State_Elmt);
25757 end loop;
25758 end if;
25759
25760 -- Constants are part of the hidden state of a package, but
25761 -- the compiler cannot determine whether they have variable
25762 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25763 -- hidden state. Accept the constant quietly even if it is
25764 -- a visible state or lacks a Part_Of indicator.
25765
25766 if Ekind (Constit_Id) = E_Constant then
25767 Collect_Constituent;
25768
25769 -- If we get here, then the constituent is not a hidden
25770 -- state of the related package and may not be used in a
25771 -- refinement (SPARK RM 7.2.2(9)).
25772
25773 else
25774 Error_Msg_Name_1 := Chars (Spec_Id);
25775 SPARK_Msg_NE
25776 ("cannot use & in refinement, constituent is not a "
25777 & "hidden state of package %", Constit, Constit_Id);
25778 end if;
25779 end if;
25780 end Match_Constituent;
25781
25782 -- Local variables
25783
25784 Constit_Id : Entity_Id;
25785 Constits : Elist_Id;
25786
25787 -- Start of processing for Analyze_Constituent
25788
25789 begin
25790 -- Detect multiple uses of null in a single refinement clause or a
25791 -- mixture of null and non-null constituents.
25792
25793 if Nkind (Constit) = N_Null then
25794 if Null_Seen then
25795 SPARK_Msg_N
25796 ("multiple null constituents not allowed", Constit);
25797
25798 elsif Non_Null_Seen then
25799 SPARK_Msg_N
25800 ("cannot mix null and non-null constituents", Constit);
25801
25802 else
25803 Null_Seen := True;
25804
25805 -- Collect the constituent in the list of refinement items
25806
25807 Constits := Refinement_Constituents (State_Id);
25808
25809 if No (Constits) then
25810 Constits := New_Elmt_List;
25811 Set_Refinement_Constituents (State_Id, Constits);
25812 end if;
25813
25814 Append_Elmt (Constit, Constits);
25815
25816 -- The state has at least one legal constituent, mark the
25817 -- start of the refinement region. The region ends when the
25818 -- body declarations end (see Analyze_Declarations).
25819
25820 Set_Has_Visible_Refinement (State_Id);
25821 end if;
25822
25823 -- Non-null constituents
25824
25825 else
25826 Non_Null_Seen := True;
25827
25828 if Null_Seen then
25829 SPARK_Msg_N
25830 ("cannot mix null and non-null constituents", Constit);
25831 end if;
25832
25833 Analyze (Constit);
25834 Resolve_State (Constit);
25835
25836 -- Ensure that the constituent denotes a valid state or a
25837 -- whole object (SPARK RM 7.2.2(5)).
25838
25839 if Is_Entity_Name (Constit) then
25840 Constit_Id := Entity_Of (Constit);
25841
25842 -- When a constituent is declared after a subprogram body
25843 -- that caused "freezing" of the related contract where
25844 -- pragma Refined_State resides, the constituent appears
25845 -- undefined and carries Any_Id as its entity.
25846
25847 -- package body Pack
25848 -- with Refined_State => (State => Constit)
25849 -- is
25850 -- procedure Proc
25851 -- with Refined_Global => (Input => Constit)
25852 -- is
25853 -- ...
25854 -- end Proc;
25855
25856 -- Constit : ...;
25857 -- end Pack;
25858
25859 if Constit_Id = Any_Id then
25860 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
25861
25862 -- Emit a specialized info message when the contract of
25863 -- the related package body was "frozen" by another body.
25864 -- Note that it is not possible to precisely identify why
25865 -- the constituent is undefined because it is not visible
25866 -- when pragma Refined_State is analyzed. This message is
25867 -- a reasonable approximation.
25868
25869 if Present (Freeze_Id) and then not Freeze_Posted then
25870 Freeze_Posted := True;
25871
25872 Error_Msg_Name_1 := Chars (Body_Id);
25873 Error_Msg_Sloc := Sloc (Freeze_Id);
25874 SPARK_Msg_NE
25875 ("body & declared # freezes the contract of %",
25876 N, Freeze_Id);
25877 SPARK_Msg_N
25878 ("\all constituents must be declared before body #",
25879 N);
25880
25881 -- A misplaced constituent is a critical error because
25882 -- pragma Refined_Depends or Refined_Global depends on
25883 -- the proper link between a state and a constituent.
25884 -- Stop the compilation, as this leads to a multitude
25885 -- of misleading cascaded errors.
25886
25887 raise Program_Error;
25888 end if;
25889
25890 -- The constituent is a valid state or object
25891
25892 elsif Ekind_In (Constit_Id, E_Abstract_State,
25893 E_Constant,
25894 E_Variable)
25895 then
25896 Match_Constituent (Constit_Id);
25897
25898 -- The variable may eventually become a constituent of a
25899 -- single protected/task type. Record the reference now
25900 -- and verify its legality when analyzing the contract of
25901 -- the variable (SPARK RM 9.3).
25902
25903 if Ekind (Constit_Id) = E_Variable then
25904 Record_Possible_Part_Of_Reference
25905 (Var_Id => Constit_Id,
25906 Ref => Constit);
25907 end if;
25908
25909 -- Otherwise the constituent is illegal
25910
25911 else
25912 SPARK_Msg_NE
25913 ("constituent & must denote object or state",
25914 Constit, Constit_Id);
25915 end if;
25916
25917 -- The constituent is illegal
25918
25919 else
25920 SPARK_Msg_N ("malformed constituent", Constit);
25921 end if;
25922 end if;
25923 end Analyze_Constituent;
25924
25925 -----------------------------
25926 -- Check_External_Property --
25927 -----------------------------
25928
25929 procedure Check_External_Property
25930 (Prop_Nam : Name_Id;
25931 Enabled : Boolean;
25932 Constit : Entity_Id)
25933 is
25934 begin
25935 -- The property is missing in the declaration of the state, but
25936 -- a constituent is introducing it in the state refinement
25937 -- (SPARK RM 7.2.8(2)).
25938
25939 if not Enabled and then Present (Constit) then
25940 Error_Msg_Name_1 := Prop_Nam;
25941 Error_Msg_Name_2 := Chars (State_Id);
25942 SPARK_Msg_NE
25943 ("constituent & introduces external property % in refinement "
25944 & "of state %", State, Constit);
25945
25946 Error_Msg_Sloc := Sloc (State_Id);
25947 SPARK_Msg_N
25948 ("\property is missing in abstract state declaration #",
25949 State);
25950 end if;
25951 end Check_External_Property;
25952
25953 -----------------
25954 -- Match_State --
25955 -----------------
25956
25957 procedure Match_State is
25958 State_Elmt : Elmt_Id;
25959
25960 begin
25961 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25962
25963 if Contains (Refined_States_Seen, State_Id) then
25964 SPARK_Msg_NE
25965 ("duplicate refinement of state &", State, State_Id);
25966 return;
25967 end if;
25968
25969 -- Inspect the abstract states defined in the package declaration
25970 -- looking for a match.
25971
25972 State_Elmt := First_Elmt (Available_States);
25973 while Present (State_Elmt) loop
25974
25975 -- A valid abstract state is being refined in the body. Add
25976 -- the state to the list of processed refined states to aid
25977 -- with the detection of duplicate refinements. Remove the
25978 -- state from Available_States to signal that it has already
25979 -- been refined.
25980
25981 if Node (State_Elmt) = State_Id then
25982 Append_New_Elmt (State_Id, Refined_States_Seen);
25983 Remove_Elmt (Available_States, State_Elmt);
25984 return;
25985 end if;
25986
25987 Next_Elmt (State_Elmt);
25988 end loop;
25989
25990 -- If we get here, we are refining a state that is not defined in
25991 -- the package declaration.
25992
25993 Error_Msg_Name_1 := Chars (Spec_Id);
25994 SPARK_Msg_NE
25995 ("cannot refine state, & is not defined in package %",
25996 State, State_Id);
25997 end Match_State;
25998
25999 --------------------------------
26000 -- Report_Unused_Constituents --
26001 --------------------------------
26002
26003 procedure Report_Unused_Constituents (Constits : Elist_Id) is
26004 Constit_Elmt : Elmt_Id;
26005 Constit_Id : Entity_Id;
26006 Posted : Boolean := False;
26007
26008 begin
26009 if Present (Constits) then
26010 Constit_Elmt := First_Elmt (Constits);
26011 while Present (Constit_Elmt) loop
26012 Constit_Id := Node (Constit_Elmt);
26013
26014 -- Generate an error message of the form:
26015
26016 -- state ... has unused Part_Of constituents
26017 -- abstract state ... defined at ...
26018 -- constant ... defined at ...
26019 -- variable ... defined at ...
26020
26021 if not Posted then
26022 Posted := True;
26023 SPARK_Msg_NE
26024 ("state & has unused Part_Of constituents",
26025 State, State_Id);
26026 end if;
26027
26028 Error_Msg_Sloc := Sloc (Constit_Id);
26029
26030 if Ekind (Constit_Id) = E_Abstract_State then
26031 SPARK_Msg_NE
26032 ("\abstract state & defined #", State, Constit_Id);
26033
26034 elsif Ekind (Constit_Id) = E_Constant then
26035 SPARK_Msg_NE
26036 ("\constant & defined #", State, Constit_Id);
26037
26038 else
26039 pragma Assert (Ekind (Constit_Id) = E_Variable);
26040 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
26041 end if;
26042
26043 Next_Elmt (Constit_Elmt);
26044 end loop;
26045 end if;
26046 end Report_Unused_Constituents;
26047
26048 -- Local declarations
26049
26050 Body_Ref : Node_Id;
26051 Body_Ref_Elmt : Elmt_Id;
26052 Constit : Node_Id;
26053 Extra_State : Node_Id;
26054
26055 -- Start of processing for Analyze_Refinement_Clause
26056
26057 begin
26058 -- A refinement clause appears as a component association where the
26059 -- sole choice is the state and the expressions are the constituents.
26060 -- This is a syntax error, always report.
26061
26062 if Nkind (Clause) /= N_Component_Association then
26063 Error_Msg_N ("malformed state refinement clause", Clause);
26064 return;
26065 end if;
26066
26067 -- Analyze the state name of a refinement clause
26068
26069 State := First (Choices (Clause));
26070
26071 Analyze (State);
26072 Resolve_State (State);
26073
26074 -- Ensure that the state name denotes a valid abstract state that is
26075 -- defined in the spec of the related package.
26076
26077 if Is_Entity_Name (State) then
26078 State_Id := Entity_Of (State);
26079
26080 -- When the abstract state is undefined, it appears as Any_Id. Do
26081 -- not continue with the analysis of the clause.
26082
26083 if State_Id = Any_Id then
26084 return;
26085
26086 -- Catch any attempts to re-refine a state or refine a state that
26087 -- is not defined in the package declaration.
26088
26089 elsif Ekind (State_Id) = E_Abstract_State then
26090 Match_State;
26091
26092 else
26093 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
26094 return;
26095 end if;
26096
26097 -- References to a state with visible refinement are illegal.
26098 -- When nested packages are involved, detecting such references is
26099 -- tricky because pragma Refined_State is analyzed later than the
26100 -- offending pragma Depends or Global. References that occur in
26101 -- such nested context are stored in a list. Emit errors for all
26102 -- references found in Body_References (SPARK RM 6.1.4(8)).
26103
26104 if Present (Body_References (State_Id)) then
26105 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
26106 while Present (Body_Ref_Elmt) loop
26107 Body_Ref := Node (Body_Ref_Elmt);
26108
26109 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
26110 Error_Msg_Sloc := Sloc (State);
26111 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
26112
26113 Next_Elmt (Body_Ref_Elmt);
26114 end loop;
26115 end if;
26116
26117 -- The state name is illegal. This is a syntax error, always report.
26118
26119 else
26120 Error_Msg_N ("malformed state name in refinement clause", State);
26121 return;
26122 end if;
26123
26124 -- A refinement clause may only refine one state at a time
26125
26126 Extra_State := Next (State);
26127
26128 if Present (Extra_State) then
26129 SPARK_Msg_N
26130 ("refinement clause cannot cover multiple states", Extra_State);
26131 end if;
26132
26133 -- Replicate the Part_Of constituents of the refined state because
26134 -- the algorithm will consume items.
26135
26136 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
26137
26138 -- Analyze all constituents of the refinement. Multiple constituents
26139 -- appear as an aggregate.
26140
26141 Constit := Expression (Clause);
26142
26143 if Nkind (Constit) = N_Aggregate then
26144 if Present (Component_Associations (Constit)) then
26145 SPARK_Msg_N
26146 ("constituents of refinement clause must appear in "
26147 & "positional form", Constit);
26148
26149 else pragma Assert (Present (Expressions (Constit)));
26150 Constit := First (Expressions (Constit));
26151 while Present (Constit) loop
26152 Analyze_Constituent (Constit);
26153 Next (Constit);
26154 end loop;
26155 end if;
26156
26157 -- Various forms of a single constituent. Note that these may include
26158 -- malformed constituents.
26159
26160 else
26161 Analyze_Constituent (Constit);
26162 end if;
26163
26164 -- Verify that external constituents do not introduce new external
26165 -- property in the state refinement (SPARK RM 7.2.8(2)).
26166
26167 if Is_External_State (State_Id) then
26168 Check_External_Property
26169 (Prop_Nam => Name_Async_Readers,
26170 Enabled => Async_Readers_Enabled (State_Id),
26171 Constit => AR_Constit);
26172
26173 Check_External_Property
26174 (Prop_Nam => Name_Async_Writers,
26175 Enabled => Async_Writers_Enabled (State_Id),
26176 Constit => AW_Constit);
26177
26178 Check_External_Property
26179 (Prop_Nam => Name_Effective_Reads,
26180 Enabled => Effective_Reads_Enabled (State_Id),
26181 Constit => ER_Constit);
26182
26183 Check_External_Property
26184 (Prop_Nam => Name_Effective_Writes,
26185 Enabled => Effective_Writes_Enabled (State_Id),
26186 Constit => EW_Constit);
26187
26188 -- When a refined state is not external, it should not have external
26189 -- constituents (SPARK RM 7.2.8(1)).
26190
26191 elsif External_Constit_Seen then
26192 SPARK_Msg_NE
26193 ("non-external state & cannot contain external constituents in "
26194 & "refinement", State, State_Id);
26195 end if;
26196
26197 -- Ensure that all Part_Of candidate constituents have been mentioned
26198 -- in the refinement clause.
26199
26200 Report_Unused_Constituents (Part_Of_Constits);
26201 end Analyze_Refinement_Clause;
26202
26203 -----------------------------
26204 -- Report_Unrefined_States --
26205 -----------------------------
26206
26207 procedure Report_Unrefined_States (States : Elist_Id) is
26208 State_Elmt : Elmt_Id;
26209
26210 begin
26211 if Present (States) then
26212 State_Elmt := First_Elmt (States);
26213 while Present (State_Elmt) loop
26214 SPARK_Msg_N
26215 ("abstract state & must be refined", Node (State_Elmt));
26216
26217 Next_Elmt (State_Elmt);
26218 end loop;
26219 end if;
26220 end Report_Unrefined_States;
26221
26222 -- Local declarations
26223
26224 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26225 Clause : Node_Id;
26226
26227 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26228
26229 begin
26230 -- Do not analyze the pragma multiple times
26231
26232 if Is_Analyzed_Pragma (N) then
26233 return;
26234 end if;
26235
26236 -- Replicate the abstract states declared by the package because the
26237 -- matching algorithm will consume states.
26238
26239 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
26240
26241 -- Gather all abstract states and objects declared in the visible
26242 -- state space of the package body. These items must be utilized as
26243 -- constituents in a state refinement.
26244
26245 Body_States := Collect_Body_States (Body_Id);
26246
26247 -- Multiple non-null state refinements appear as an aggregate
26248
26249 if Nkind (Clauses) = N_Aggregate then
26250 if Present (Expressions (Clauses)) then
26251 SPARK_Msg_N
26252 ("state refinements must appear as component associations",
26253 Clauses);
26254
26255 else pragma Assert (Present (Component_Associations (Clauses)));
26256 Clause := First (Component_Associations (Clauses));
26257 while Present (Clause) loop
26258 Analyze_Refinement_Clause (Clause);
26259 Next (Clause);
26260 end loop;
26261 end if;
26262
26263 -- Various forms of a single state refinement. Note that these may
26264 -- include malformed refinements.
26265
26266 else
26267 Analyze_Refinement_Clause (Clauses);
26268 end if;
26269
26270 -- List all abstract states that were left unrefined
26271
26272 Report_Unrefined_States (Available_States);
26273
26274 Set_Is_Analyzed_Pragma (N);
26275 end Analyze_Refined_State_In_Decl_Part;
26276
26277 ------------------------------------
26278 -- Analyze_Test_Case_In_Decl_Part --
26279 ------------------------------------
26280
26281 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
26282 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26283 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26284
26285 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
26286 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26287 -- denoted by Arg_Nam.
26288
26289 ------------------------------
26290 -- Preanalyze_Test_Case_Arg --
26291 ------------------------------
26292
26293 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
26294 Arg : Node_Id;
26295
26296 begin
26297 -- Preanalyze the original aspect argument for ASIS or for a generic
26298 -- subprogram to properly capture global references.
26299
26300 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
26301 Arg :=
26302 Test_Case_Arg
26303 (Prag => N,
26304 Arg_Nam => Arg_Nam,
26305 From_Aspect => True);
26306
26307 if Present (Arg) then
26308 Preanalyze_Assert_Expression
26309 (Expression (Arg), Standard_Boolean);
26310 end if;
26311 end if;
26312
26313 Arg := Test_Case_Arg (N, Arg_Nam);
26314
26315 if Present (Arg) then
26316 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
26317 end if;
26318 end Preanalyze_Test_Case_Arg;
26319
26320 -- Local variables
26321
26322 Restore_Scope : Boolean := False;
26323
26324 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26325
26326 begin
26327 -- Do not analyze the pragma multiple times
26328
26329 if Is_Analyzed_Pragma (N) then
26330 return;
26331 end if;
26332
26333 -- Ensure that the formal parameters are visible when analyzing all
26334 -- clauses. This falls out of the general rule of aspects pertaining
26335 -- to subprogram declarations.
26336
26337 if not In_Open_Scopes (Spec_Id) then
26338 Restore_Scope := True;
26339 Push_Scope (Spec_Id);
26340
26341 if Is_Generic_Subprogram (Spec_Id) then
26342 Install_Generic_Formals (Spec_Id);
26343 else
26344 Install_Formals (Spec_Id);
26345 end if;
26346 end if;
26347
26348 Preanalyze_Test_Case_Arg (Name_Requires);
26349 Preanalyze_Test_Case_Arg (Name_Ensures);
26350
26351 if Restore_Scope then
26352 End_Scope;
26353 end if;
26354
26355 -- Currently it is not possible to inline pre/postconditions on a
26356 -- subprogram subject to pragma Inline_Always.
26357
26358 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26359
26360 Set_Is_Analyzed_Pragma (N);
26361 end Analyze_Test_Case_In_Decl_Part;
26362
26363 ----------------
26364 -- Appears_In --
26365 ----------------
26366
26367 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
26368 Elmt : Elmt_Id;
26369 Id : Entity_Id;
26370
26371 begin
26372 if Present (List) then
26373 Elmt := First_Elmt (List);
26374 while Present (Elmt) loop
26375 if Nkind (Node (Elmt)) = N_Defining_Identifier then
26376 Id := Node (Elmt);
26377 else
26378 Id := Entity_Of (Node (Elmt));
26379 end if;
26380
26381 if Id = Item_Id then
26382 return True;
26383 end if;
26384
26385 Next_Elmt (Elmt);
26386 end loop;
26387 end if;
26388
26389 return False;
26390 end Appears_In;
26391
26392 --------------------------------
26393 -- Build_Classwide_Expression --
26394 --------------------------------
26395
26396 procedure Build_Classwide_Expression
26397 (Prag : Node_Id;
26398 Subp : Entity_Id;
26399 Adjust_Sloc : Boolean)
26400 is
26401 function Replace_Entity (N : Node_Id) return Traverse_Result;
26402 -- Replace reference to formal of inherited operation or to primitive
26403 -- operation of root type, with corresponding entity for derived type,
26404 -- when constructing the classwide condition of an overridding
26405 -- subprogram.
26406
26407 --------------------
26408 -- Replace_Entity --
26409 --------------------
26410
26411 function Replace_Entity (N : Node_Id) return Traverse_Result is
26412 New_E : Entity_Id;
26413
26414 begin
26415 if Adjust_Sloc then
26416 Adjust_Inherited_Pragma_Sloc (N);
26417 end if;
26418
26419 if Nkind (N) = N_Identifier
26420 and then Present (Entity (N))
26421 and then
26422 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
26423 and then
26424 (Nkind (Parent (N)) /= N_Attribute_Reference
26425 or else Attribute_Name (Parent (N)) /= Name_Class)
26426 then
26427 -- The replacement does not apply to dispatching calls within the
26428 -- condition, but only to calls whose static tag is that of the
26429 -- parent type.
26430
26431 if Is_Subprogram (Entity (N))
26432 and then Nkind (Parent (N)) = N_Function_Call
26433 and then Present (Controlling_Argument (Parent (N)))
26434 then
26435 return OK;
26436 end if;
26437
26438 -- Determine whether entity has a renaming
26439
26440 New_E := Primitives_Mapping.Get (Entity (N));
26441
26442 if Present (New_E) then
26443 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
26444 end if;
26445
26446 -- Check that there are no calls left to abstract operations if
26447 -- the current subprogram is not abstract.
26448
26449 if Nkind (Parent (N)) = N_Function_Call
26450 and then N = Name (Parent (N))
26451 then
26452 if not Is_Abstract_Subprogram (Subp)
26453 and then Is_Abstract_Subprogram (Entity (N))
26454 then
26455 Error_Msg_Sloc := Sloc (Current_Scope);
26456 Error_Msg_NE
26457 ("cannot call abstract subprogram in inherited condition "
26458 & "for&#", N, Current_Scope);
26459
26460 -- In SPARK mode, reject an inherited condition for an
26461 -- inherited operation if it contains a call to an overriding
26462 -- operation, because this implies that the pre/postcondition
26463 -- of the inherited operation have changed silently.
26464
26465 elsif SPARK_Mode = On
26466 and then Warn_On_Suspicious_Contract
26467 and then Present (Alias (Subp))
26468 and then Present (New_E)
26469 and then Comes_From_Source (New_E)
26470 then
26471 Error_Msg_N
26472 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
26473 Parent (Subp));
26474 Error_Msg_Sloc := Sloc (New_E);
26475 Error_Msg_Node_2 := Subp;
26476 Error_Msg_NE
26477 ("\overriding of&# forces overriding of&",
26478 Parent (Subp), New_E);
26479 end if;
26480 end if;
26481
26482 -- Update type of function call node, which should be the same as
26483 -- the function's return type.
26484
26485 if Is_Subprogram (Entity (N))
26486 and then Nkind (Parent (N)) = N_Function_Call
26487 then
26488 Set_Etype (Parent (N), Etype (Entity (N)));
26489 end if;
26490
26491 -- The whole expression will be reanalyzed
26492
26493 elsif Nkind (N) in N_Has_Etype then
26494 Set_Analyzed (N, False);
26495 end if;
26496
26497 return OK;
26498 end Replace_Entity;
26499
26500 procedure Replace_Condition_Entities is
26501 new Traverse_Proc (Replace_Entity);
26502
26503 -- Start of processing for Build_Classwide_Expression
26504
26505 begin
26506 Replace_Condition_Entities (Prag);
26507 end Build_Classwide_Expression;
26508
26509 -----------------------------------
26510 -- Build_Pragma_Check_Equivalent --
26511 -----------------------------------
26512
26513 function Build_Pragma_Check_Equivalent
26514 (Prag : Node_Id;
26515 Subp_Id : Entity_Id := Empty;
26516 Inher_Id : Entity_Id := Empty;
26517 Keep_Pragma_Id : Boolean := False) return Node_Id
26518 is
26519 function Suppress_Reference (N : Node_Id) return Traverse_Result;
26520 -- Detect whether node N references a formal parameter subject to
26521 -- pragma Unreferenced. If this is the case, set Comes_From_Source
26522 -- to False to suppress the generation of a reference when analyzing
26523 -- N later on.
26524
26525 ------------------------
26526 -- Suppress_Reference --
26527 ------------------------
26528
26529 function Suppress_Reference (N : Node_Id) return Traverse_Result is
26530 Formal : Entity_Id;
26531
26532 begin
26533 if Is_Entity_Name (N) and then Present (Entity (N)) then
26534 Formal := Entity (N);
26535
26536 -- The formal parameter is subject to pragma Unreferenced. Prevent
26537 -- the generation of references by resetting the Comes_From_Source
26538 -- flag.
26539
26540 if Is_Formal (Formal)
26541 and then Has_Pragma_Unreferenced (Formal)
26542 then
26543 Set_Comes_From_Source (N, False);
26544 end if;
26545 end if;
26546
26547 return OK;
26548 end Suppress_Reference;
26549
26550 procedure Suppress_References is
26551 new Traverse_Proc (Suppress_Reference);
26552
26553 -- Local variables
26554
26555 Loc : constant Source_Ptr := Sloc (Prag);
26556 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
26557 Check_Prag : Node_Id;
26558 Inher_Formal : Entity_Id;
26559 Msg_Arg : Node_Id;
26560 Nam : Name_Id;
26561 Subp_Formal : Entity_Id;
26562
26563 -- Start of processing for Build_Pragma_Check_Equivalent
26564
26565 begin
26566 -- When the pre- or postcondition is inherited, map the formals of the
26567 -- inherited subprogram to those of the current subprogram. In addition,
26568 -- map primitive operations of the parent type into the corresponding
26569 -- primitive operations of the descendant.
26570
26571 if Present (Inher_Id) then
26572 pragma Assert (Present (Subp_Id));
26573
26574 Update_Primitives_Mapping (Inher_Id, Subp_Id);
26575
26576 -- Add mapping from old formals to new formals.
26577
26578 Inher_Formal := First_Formal (Inher_Id);
26579 Subp_Formal := First_Formal (Subp_Id);
26580 while Present (Inher_Formal) and then Present (Subp_Formal) loop
26581 Primitives_Mapping.Set (Inher_Formal, Subp_Formal);
26582 Next_Formal (Inher_Formal);
26583 Next_Formal (Subp_Formal);
26584 end loop;
26585
26586 -- Use generic machinery to copy inherited pragma, as if it were an
26587 -- instantiation, resetting source locations appropriately, so that
26588 -- expressions inside the inherited pragma use chained locations.
26589 -- This is used in particular in GNATprove to locate precisely
26590 -- messages on a given inherited pragma.
26591
26592 Set_Copied_Sloc_For_Inherited_Pragma
26593 (Unit_Declaration_Node (Subp_Id), Inher_Id);
26594 Check_Prag := New_Copy_Tree (Source => Prag);
26595 Build_Classwide_Expression (Check_Prag, Subp_Id, Adjust_Sloc => True);
26596
26597 -- Otherwise simply copy the original pragma
26598
26599 else
26600 Check_Prag := New_Copy_Tree (Source => Prag);
26601 end if;
26602
26603 -- Mark the pragma as being internally generated and reset the Analyzed
26604 -- flag.
26605
26606 Set_Analyzed (Check_Prag, False);
26607 Set_Comes_From_Source (Check_Prag, False);
26608
26609 -- The tree of the original pragma may contain references to the
26610 -- formal parameters of the related subprogram. At the same time
26611 -- the corresponding body may mark the formals as unreferenced:
26612
26613 -- procedure Proc (Formal : ...)
26614 -- with Pre => Formal ...;
26615
26616 -- procedure Proc (Formal : ...) is
26617 -- pragma Unreferenced (Formal);
26618 -- ...
26619
26620 -- This creates problems because all pragma Check equivalents are
26621 -- analyzed at the end of the body declarations. Since all source
26622 -- references have already been accounted for, reset any references
26623 -- to such formals in the generated pragma Check equivalent.
26624
26625 Suppress_References (Check_Prag);
26626
26627 if Present (Corresponding_Aspect (Prag)) then
26628 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
26629 else
26630 Nam := Prag_Nam;
26631 end if;
26632
26633 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
26634 -- the copied pragma in the newly created pragma, convert the copy into
26635 -- pragma Check by correcting the name and adding a check_kind argument.
26636
26637 if not Keep_Pragma_Id then
26638 Set_Class_Present (Check_Prag, False);
26639
26640 Set_Pragma_Identifier
26641 (Check_Prag, Make_Identifier (Loc, Name_Check));
26642
26643 Prepend_To (Pragma_Argument_Associations (Check_Prag),
26644 Make_Pragma_Argument_Association (Loc,
26645 Expression => Make_Identifier (Loc, Nam)));
26646 end if;
26647
26648 -- Update the error message when the pragma is inherited
26649
26650 if Present (Inher_Id) then
26651 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
26652
26653 if Chars (Msg_Arg) = Name_Message then
26654 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
26655
26656 -- Insert "inherited" to improve the error message
26657
26658 if Name_Buffer (1 .. 8) = "failed p" then
26659 Insert_Str_In_Name_Buffer ("inherited ", 8);
26660 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
26661 end if;
26662 end if;
26663 end if;
26664
26665 return Check_Prag;
26666 end Build_Pragma_Check_Equivalent;
26667
26668 -----------------------------
26669 -- Check_Applicable_Policy --
26670 -----------------------------
26671
26672 procedure Check_Applicable_Policy (N : Node_Id) is
26673 PP : Node_Id;
26674 Policy : Name_Id;
26675
26676 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
26677
26678 begin
26679 -- No effect if not valid assertion kind name
26680
26681 if not Is_Valid_Assertion_Kind (Ename) then
26682 return;
26683 end if;
26684
26685 -- Loop through entries in check policy list
26686
26687 PP := Opt.Check_Policy_List;
26688 while Present (PP) loop
26689 declare
26690 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26691 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26692
26693 begin
26694 if Ename = Pnm
26695 or else Pnm = Name_Assertion
26696 or else (Pnm = Name_Statement_Assertions
26697 and then Nam_In (Ename, Name_Assert,
26698 Name_Assert_And_Cut,
26699 Name_Assume,
26700 Name_Loop_Invariant,
26701 Name_Loop_Variant))
26702 then
26703 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
26704
26705 case Policy is
26706 when Name_Off | Name_Ignore =>
26707 Set_Is_Ignored (N, True);
26708 Set_Is_Checked (N, False);
26709
26710 when Name_On | Name_Check =>
26711 Set_Is_Checked (N, True);
26712 Set_Is_Ignored (N, False);
26713
26714 when Name_Disable =>
26715 Set_Is_Ignored (N, True);
26716 Set_Is_Checked (N, False);
26717 Set_Is_Disabled (N, True);
26718
26719 -- That should be exhaustive, the null here is a defence
26720 -- against a malformed tree from previous errors.
26721
26722 when others =>
26723 null;
26724 end case;
26725
26726 return;
26727 end if;
26728
26729 PP := Next_Pragma (PP);
26730 end;
26731 end loop;
26732
26733 -- If there are no specific entries that matched, then we let the
26734 -- setting of assertions govern. Note that this provides the needed
26735 -- compatibility with the RM for the cases of assertion, invariant,
26736 -- precondition, predicate, and postcondition.
26737
26738 if Assertions_Enabled then
26739 Set_Is_Checked (N, True);
26740 Set_Is_Ignored (N, False);
26741 else
26742 Set_Is_Checked (N, False);
26743 Set_Is_Ignored (N, True);
26744 end if;
26745 end Check_Applicable_Policy;
26746
26747 -------------------------------
26748 -- Check_External_Properties --
26749 -------------------------------
26750
26751 procedure Check_External_Properties
26752 (Item : Node_Id;
26753 AR : Boolean;
26754 AW : Boolean;
26755 ER : Boolean;
26756 EW : Boolean)
26757 is
26758 begin
26759 -- All properties enabled
26760
26761 if AR and AW and ER and EW then
26762 null;
26763
26764 -- Async_Readers + Effective_Writes
26765 -- Async_Readers + Async_Writers + Effective_Writes
26766
26767 elsif AR and EW and not ER then
26768 null;
26769
26770 -- Async_Writers + Effective_Reads
26771 -- Async_Readers + Async_Writers + Effective_Reads
26772
26773 elsif AW and ER and not EW then
26774 null;
26775
26776 -- Async_Readers + Async_Writers
26777
26778 elsif AR and AW and not ER and not EW then
26779 null;
26780
26781 -- Async_Readers
26782
26783 elsif AR and not AW and not ER and not EW then
26784 null;
26785
26786 -- Async_Writers
26787
26788 elsif AW and not AR and not ER and not EW then
26789 null;
26790
26791 else
26792 SPARK_Msg_N
26793 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26794 Item);
26795 end if;
26796 end Check_External_Properties;
26797
26798 ----------------
26799 -- Check_Kind --
26800 ----------------
26801
26802 function Check_Kind (Nam : Name_Id) return Name_Id is
26803 PP : Node_Id;
26804
26805 begin
26806 -- Loop through entries in check policy list
26807
26808 PP := Opt.Check_Policy_List;
26809 while Present (PP) loop
26810 declare
26811 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26812 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26813
26814 begin
26815 if Nam = Pnm
26816 or else (Pnm = Name_Assertion
26817 and then Is_Valid_Assertion_Kind (Nam))
26818 or else (Pnm = Name_Statement_Assertions
26819 and then Nam_In (Nam, Name_Assert,
26820 Name_Assert_And_Cut,
26821 Name_Assume,
26822 Name_Loop_Invariant,
26823 Name_Loop_Variant))
26824 then
26825 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
26826 when Name_On | Name_Check =>
26827 return Name_Check;
26828 when Name_Off | Name_Ignore =>
26829 return Name_Ignore;
26830 when Name_Disable =>
26831 return Name_Disable;
26832 when others =>
26833 raise Program_Error;
26834 end case;
26835
26836 else
26837 PP := Next_Pragma (PP);
26838 end if;
26839 end;
26840 end loop;
26841
26842 -- If there are no specific entries that matched, then we let the
26843 -- setting of assertions govern. Note that this provides the needed
26844 -- compatibility with the RM for the cases of assertion, invariant,
26845 -- precondition, predicate, and postcondition.
26846
26847 if Assertions_Enabled then
26848 return Name_Check;
26849 else
26850 return Name_Ignore;
26851 end if;
26852 end Check_Kind;
26853
26854 ---------------------------
26855 -- Check_Missing_Part_Of --
26856 ---------------------------
26857
26858 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
26859 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
26860 -- Determine whether a package denoted by Pack_Id declares at least one
26861 -- visible state.
26862
26863 -----------------------
26864 -- Has_Visible_State --
26865 -----------------------
26866
26867 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
26868 Item_Id : Entity_Id;
26869
26870 begin
26871 -- Traverse the entity chain of the package trying to find at least
26872 -- one visible abstract state, variable or a package [instantiation]
26873 -- that declares a visible state.
26874
26875 Item_Id := First_Entity (Pack_Id);
26876 while Present (Item_Id)
26877 and then not In_Private_Part (Item_Id)
26878 loop
26879 -- Do not consider internally generated items
26880
26881 if not Comes_From_Source (Item_Id) then
26882 null;
26883
26884 -- A visible state has been found
26885
26886 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
26887 return True;
26888
26889 -- Recursively peek into nested packages and instantiations
26890
26891 elsif Ekind (Item_Id) = E_Package
26892 and then Has_Visible_State (Item_Id)
26893 then
26894 return True;
26895 end if;
26896
26897 Next_Entity (Item_Id);
26898 end loop;
26899
26900 return False;
26901 end Has_Visible_State;
26902
26903 -- Local variables
26904
26905 Pack_Id : Entity_Id;
26906 Placement : State_Space_Kind;
26907
26908 -- Start of processing for Check_Missing_Part_Of
26909
26910 begin
26911 -- Do not consider abstract states, variables or package instantiations
26912 -- coming from an instance as those always inherit the Part_Of indicator
26913 -- of the instance itself.
26914
26915 if In_Instance then
26916 return;
26917
26918 -- Do not consider internally generated entities as these can never
26919 -- have a Part_Of indicator.
26920
26921 elsif not Comes_From_Source (Item_Id) then
26922 return;
26923
26924 -- Perform these checks only when SPARK_Mode is enabled as they will
26925 -- interfere with standard Ada rules and produce false positives.
26926
26927 elsif SPARK_Mode /= On then
26928 return;
26929
26930 -- Do not consider constants, because the compiler cannot accurately
26931 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26932 -- act as a hidden state of a package.
26933
26934 elsif Ekind (Item_Id) = E_Constant then
26935 return;
26936 end if;
26937
26938 -- Find where the abstract state, variable or package instantiation
26939 -- lives with respect to the state space.
26940
26941 Find_Placement_In_State_Space
26942 (Item_Id => Item_Id,
26943 Placement => Placement,
26944 Pack_Id => Pack_Id);
26945
26946 -- Items that appear in a non-package construct (subprogram, block, etc)
26947 -- do not require a Part_Of indicator because they can never act as a
26948 -- hidden state.
26949
26950 if Placement = Not_In_Package then
26951 null;
26952
26953 -- An item declared in the body state space of a package always act as a
26954 -- constituent and does not need explicit Part_Of indicator.
26955
26956 elsif Placement = Body_State_Space then
26957 null;
26958
26959 -- In general an item declared in the visible state space of a package
26960 -- does not require a Part_Of indicator. The only exception is when the
26961 -- related package is a private child unit in which case Part_Of must
26962 -- denote a state in the parent unit or in one of its descendants.
26963
26964 elsif Placement = Visible_State_Space then
26965 if Is_Child_Unit (Pack_Id)
26966 and then Is_Private_Descendant (Pack_Id)
26967 then
26968 -- A package instantiation does not need a Part_Of indicator when
26969 -- the related generic template has no visible state.
26970
26971 if Ekind (Item_Id) = E_Package
26972 and then Is_Generic_Instance (Item_Id)
26973 and then not Has_Visible_State (Item_Id)
26974 then
26975 null;
26976
26977 -- All other cases require Part_Of
26978
26979 else
26980 Error_Msg_N
26981 ("indicator Part_Of is required in this context "
26982 & "(SPARK RM 7.2.6(3))", Item_Id);
26983 Error_Msg_Name_1 := Chars (Pack_Id);
26984 Error_Msg_N
26985 ("\& is declared in the visible part of private child "
26986 & "unit %", Item_Id);
26987 end if;
26988 end if;
26989
26990 -- When the item appears in the private state space of a packge, it must
26991 -- be a part of some state declared by the said package.
26992
26993 else pragma Assert (Placement = Private_State_Space);
26994
26995 -- The related package does not declare a state, the item cannot act
26996 -- as a Part_Of constituent.
26997
26998 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
26999 null;
27000
27001 -- A package instantiation does not need a Part_Of indicator when the
27002 -- related generic template has no visible state.
27003
27004 elsif Ekind (Pack_Id) = E_Package
27005 and then Is_Generic_Instance (Pack_Id)
27006 and then not Has_Visible_State (Pack_Id)
27007 then
27008 null;
27009
27010 -- All other cases require Part_Of
27011
27012 else
27013 Error_Msg_N
27014 ("indicator Part_Of is required in this context "
27015 & "(SPARK RM 7.2.6(2))", Item_Id);
27016 Error_Msg_Name_1 := Chars (Pack_Id);
27017 Error_Msg_N
27018 ("\& is declared in the private part of package %", Item_Id);
27019 end if;
27020 end if;
27021 end Check_Missing_Part_Of;
27022
27023 ---------------------------------------------------
27024 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27025 ---------------------------------------------------
27026
27027 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27028 (Prag : Node_Id;
27029 Spec_Id : Entity_Id)
27030 is
27031 begin
27032 if Warn_On_Redundant_Constructs
27033 and then Has_Pragma_Inline_Always (Spec_Id)
27034 then
27035 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27036
27037 if From_Aspect_Specification (Prag) then
27038 Error_Msg_NE
27039 ("aspect % not enforced on inlined subprogram &?r?",
27040 Corresponding_Aspect (Prag), Spec_Id);
27041 else
27042 Error_Msg_NE
27043 ("pragma % not enforced on inlined subprogram &?r?",
27044 Prag, Spec_Id);
27045 end if;
27046 end if;
27047 end Check_Postcondition_Use_In_Inlined_Subprogram;
27048
27049 -------------------------------------
27050 -- Check_State_And_Constituent_Use --
27051 -------------------------------------
27052
27053 procedure Check_State_And_Constituent_Use
27054 (States : Elist_Id;
27055 Constits : Elist_Id;
27056 Context : Node_Id)
27057 is
27058 function Find_Encapsulating_State
27059 (Constit_Id : Entity_Id) return Entity_Id;
27060 -- Given the entity of a constituent, try to find a corresponding
27061 -- encapsulating state that appears in the same context. The routine
27062 -- returns Empty is no such state is found.
27063
27064 ------------------------------
27065 -- Find_Encapsulating_State --
27066 ------------------------------
27067
27068 function Find_Encapsulating_State
27069 (Constit_Id : Entity_Id) return Entity_Id
27070 is
27071 State_Id : Entity_Id;
27072
27073 begin
27074 -- Since a constituent may be part of a larger constituent set, climb
27075 -- the encapsulating state chain looking for a state that appears in
27076 -- the same context.
27077
27078 State_Id := Encapsulating_State (Constit_Id);
27079 while Present (State_Id) loop
27080 if Contains (States, State_Id) then
27081 return State_Id;
27082 end if;
27083
27084 State_Id := Encapsulating_State (State_Id);
27085 end loop;
27086
27087 return Empty;
27088 end Find_Encapsulating_State;
27089
27090 -- Local variables
27091
27092 Constit_Elmt : Elmt_Id;
27093 Constit_Id : Entity_Id;
27094 State_Id : Entity_Id;
27095
27096 -- Start of processing for Check_State_And_Constituent_Use
27097
27098 begin
27099 -- Nothing to do if there are no states or constituents
27100
27101 if No (States) or else No (Constits) then
27102 return;
27103 end if;
27104
27105 -- Inspect the list of constituents and try to determine whether its
27106 -- encapsulating state is in list States.
27107
27108 Constit_Elmt := First_Elmt (Constits);
27109 while Present (Constit_Elmt) loop
27110 Constit_Id := Node (Constit_Elmt);
27111
27112 -- Determine whether the constituent is part of an encapsulating
27113 -- state that appears in the same context and if this is the case,
27114 -- emit an error (SPARK RM 7.2.6(7)).
27115
27116 State_Id := Find_Encapsulating_State (Constit_Id);
27117
27118 if Present (State_Id) then
27119 Error_Msg_Name_1 := Chars (Constit_Id);
27120 SPARK_Msg_NE
27121 ("cannot mention state & and its constituent % in the same "
27122 & "context", Context, State_Id);
27123 exit;
27124 end if;
27125
27126 Next_Elmt (Constit_Elmt);
27127 end loop;
27128 end Check_State_And_Constituent_Use;
27129
27130 ---------------------------------------------
27131 -- Collect_Inherited_Class_Wide_Conditions --
27132 ---------------------------------------------
27133
27134 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
27135 Parent_Subp : constant Entity_Id := Overridden_Operation (Subp);
27136 Prags : constant Node_Id := Contract (Parent_Subp);
27137 In_Spec_Expr : Boolean;
27138 Installed : Boolean;
27139 Prag : Node_Id;
27140 New_Prag : Node_Id;
27141
27142 begin
27143 Installed := False;
27144
27145 -- Iterate over the contract of the overridden subprogram to find all
27146 -- inherited class-wide pre- and postconditions.
27147
27148 if Present (Prags) then
27149 Prag := Pre_Post_Conditions (Prags);
27150
27151 while Present (Prag) loop
27152 if Nam_In (Pragma_Name (Prag), Name_Precondition,
27153 Name_Postcondition)
27154 and then Class_Present (Prag)
27155 then
27156 -- The generated pragma must be analyzed in the context of
27157 -- the subprogram, to make its formals visible. In addition,
27158 -- we must inhibit freezing and full analysis because the
27159 -- controlling type of the subprogram is not frozen yet, and
27160 -- may have further primitives.
27161
27162 if not Installed then
27163 Installed := True;
27164 Push_Scope (Subp);
27165 Install_Formals (Subp);
27166 In_Spec_Expr := In_Spec_Expression;
27167 In_Spec_Expression := True;
27168 end if;
27169
27170 New_Prag :=
27171 Build_Pragma_Check_Equivalent
27172 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
27173
27174 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
27175 Preanalyze (New_Prag);
27176
27177 -- Prevent further analysis in subsequent processing of the
27178 -- current list of declarations
27179
27180 Set_Analyzed (New_Prag);
27181 end if;
27182
27183 Prag := Next_Pragma (Prag);
27184 end loop;
27185
27186 if Installed then
27187 In_Spec_Expression := In_Spec_Expr;
27188 End_Scope;
27189 end if;
27190 end if;
27191 end Collect_Inherited_Class_Wide_Conditions;
27192
27193 ---------------------------------------
27194 -- Collect_Subprogram_Inputs_Outputs --
27195 ---------------------------------------
27196
27197 procedure Collect_Subprogram_Inputs_Outputs
27198 (Subp_Id : Entity_Id;
27199 Synthesize : Boolean := False;
27200 Subp_Inputs : in out Elist_Id;
27201 Subp_Outputs : in out Elist_Id;
27202 Global_Seen : out Boolean)
27203 is
27204 procedure Collect_Dependency_Clause (Clause : Node_Id);
27205 -- Collect all relevant items from a dependency clause
27206
27207 procedure Collect_Global_List
27208 (List : Node_Id;
27209 Mode : Name_Id := Name_Input);
27210 -- Collect all relevant items from a global list
27211
27212 -------------------------------
27213 -- Collect_Dependency_Clause --
27214 -------------------------------
27215
27216 procedure Collect_Dependency_Clause (Clause : Node_Id) is
27217 procedure Collect_Dependency_Item
27218 (Item : Node_Id;
27219 Is_Input : Boolean);
27220 -- Add an item to the proper subprogram input or output collection
27221
27222 -----------------------------
27223 -- Collect_Dependency_Item --
27224 -----------------------------
27225
27226 procedure Collect_Dependency_Item
27227 (Item : Node_Id;
27228 Is_Input : Boolean)
27229 is
27230 Extra : Node_Id;
27231
27232 begin
27233 -- Nothing to collect when the item is null
27234
27235 if Nkind (Item) = N_Null then
27236 null;
27237
27238 -- Ditto for attribute 'Result
27239
27240 elsif Is_Attribute_Result (Item) then
27241 null;
27242
27243 -- Multiple items appear as an aggregate
27244
27245 elsif Nkind (Item) = N_Aggregate then
27246 Extra := First (Expressions (Item));
27247 while Present (Extra) loop
27248 Collect_Dependency_Item (Extra, Is_Input);
27249 Next (Extra);
27250 end loop;
27251
27252 -- Otherwise this is a solitary item
27253
27254 else
27255 if Is_Input then
27256 Append_New_Elmt (Item, Subp_Inputs);
27257 else
27258 Append_New_Elmt (Item, Subp_Outputs);
27259 end if;
27260 end if;
27261 end Collect_Dependency_Item;
27262
27263 -- Start of processing for Collect_Dependency_Clause
27264
27265 begin
27266 if Nkind (Clause) = N_Null then
27267 null;
27268
27269 -- A dependency cause appears as component association
27270
27271 elsif Nkind (Clause) = N_Component_Association then
27272 Collect_Dependency_Item
27273 (Item => Expression (Clause),
27274 Is_Input => True);
27275
27276 Collect_Dependency_Item
27277 (Item => First (Choices (Clause)),
27278 Is_Input => False);
27279
27280 -- To accomodate partial decoration of disabled SPARK features, this
27281 -- routine may be called with illegal input. If this is the case, do
27282 -- not raise Program_Error.
27283
27284 else
27285 null;
27286 end if;
27287 end Collect_Dependency_Clause;
27288
27289 -------------------------
27290 -- Collect_Global_List --
27291 -------------------------
27292
27293 procedure Collect_Global_List
27294 (List : Node_Id;
27295 Mode : Name_Id := Name_Input)
27296 is
27297 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
27298 -- Add an item to the proper subprogram input or output collection
27299
27300 -------------------------
27301 -- Collect_Global_Item --
27302 -------------------------
27303
27304 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
27305 begin
27306 if Nam_In (Mode, Name_In_Out, Name_Input) then
27307 Append_New_Elmt (Item, Subp_Inputs);
27308 end if;
27309
27310 if Nam_In (Mode, Name_In_Out, Name_Output) then
27311 Append_New_Elmt (Item, Subp_Outputs);
27312 end if;
27313 end Collect_Global_Item;
27314
27315 -- Local variables
27316
27317 Assoc : Node_Id;
27318 Item : Node_Id;
27319
27320 -- Start of processing for Collect_Global_List
27321
27322 begin
27323 if Nkind (List) = N_Null then
27324 null;
27325
27326 -- Single global item declaration
27327
27328 elsif Nkind_In (List, N_Expanded_Name,
27329 N_Identifier,
27330 N_Selected_Component)
27331 then
27332 Collect_Global_Item (List, Mode);
27333
27334 -- Simple global list or moded global list declaration
27335
27336 elsif Nkind (List) = N_Aggregate then
27337 if Present (Expressions (List)) then
27338 Item := First (Expressions (List));
27339 while Present (Item) loop
27340 Collect_Global_Item (Item, Mode);
27341 Next (Item);
27342 end loop;
27343
27344 else
27345 Assoc := First (Component_Associations (List));
27346 while Present (Assoc) loop
27347 Collect_Global_List
27348 (List => Expression (Assoc),
27349 Mode => Chars (First (Choices (Assoc))));
27350 Next (Assoc);
27351 end loop;
27352 end if;
27353
27354 -- To accomodate partial decoration of disabled SPARK features, this
27355 -- routine may be called with illegal input. If this is the case, do
27356 -- not raise Program_Error.
27357
27358 else
27359 null;
27360 end if;
27361 end Collect_Global_List;
27362
27363 -- Local variables
27364
27365 Clause : Node_Id;
27366 Clauses : Node_Id;
27367 Depends : Node_Id;
27368 Formal : Entity_Id;
27369 Global : Node_Id;
27370 Spec_Id : Entity_Id;
27371 Subp_Decl : Node_Id;
27372 Typ : Entity_Id;
27373
27374 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27375
27376 begin
27377 Global_Seen := False;
27378
27379 -- Process all formal parameters of entries, [generic] subprograms, and
27380 -- their bodies.
27381
27382 if Ekind_In (Subp_Id, E_Entry,
27383 E_Entry_Family,
27384 E_Function,
27385 E_Generic_Function,
27386 E_Generic_Procedure,
27387 E_Procedure,
27388 E_Subprogram_Body)
27389 then
27390 Subp_Decl := Unit_Declaration_Node (Subp_Id);
27391 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27392
27393 -- Process all [generic] formal parameters
27394
27395 Formal := First_Entity (Spec_Id);
27396 while Present (Formal) loop
27397 if Ekind_In (Formal, E_Generic_In_Parameter,
27398 E_In_Out_Parameter,
27399 E_In_Parameter)
27400 then
27401 Append_New_Elmt (Formal, Subp_Inputs);
27402 end if;
27403
27404 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
27405 E_In_Out_Parameter,
27406 E_Out_Parameter)
27407 then
27408 Append_New_Elmt (Formal, Subp_Outputs);
27409
27410 -- Out parameters can act as inputs when the related type is
27411 -- tagged, unconstrained array, unconstrained record, or record
27412 -- with unconstrained components.
27413
27414 if Ekind (Formal) = E_Out_Parameter
27415 and then Is_Unconstrained_Or_Tagged_Item (Formal)
27416 then
27417 Append_New_Elmt (Formal, Subp_Inputs);
27418 end if;
27419 end if;
27420
27421 Next_Entity (Formal);
27422 end loop;
27423
27424 -- Otherwise the input denotes a task type, a task body, or the
27425 -- anonymous object created for a single task type.
27426
27427 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
27428 or else Is_Single_Task_Object (Subp_Id)
27429 then
27430 Subp_Decl := Declaration_Node (Subp_Id);
27431 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27432 end if;
27433
27434 -- When processing an entry, subprogram or task body, look for pragmas
27435 -- Refined_Depends and Refined_Global as they specify the inputs and
27436 -- outputs.
27437
27438 if Is_Entry_Body (Subp_Id)
27439 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
27440 then
27441 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
27442 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
27443
27444 -- Subprogram declaration or stand alone body case, look for pragmas
27445 -- Depends and Global
27446
27447 else
27448 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
27449 Global := Get_Pragma (Spec_Id, Pragma_Global);
27450 end if;
27451
27452 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27453 -- because it provides finer granularity of inputs and outputs.
27454
27455 if Present (Global) then
27456 Global_Seen := True;
27457 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
27458
27459 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27460 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27461 -- the inputs and outputs from [Refined_]Depends.
27462
27463 elsif Synthesize and then Present (Depends) then
27464 Clauses := Expression (Get_Argument (Depends, Spec_Id));
27465
27466 -- Multiple dependency clauses appear as an aggregate
27467
27468 if Nkind (Clauses) = N_Aggregate then
27469 Clause := First (Component_Associations (Clauses));
27470 while Present (Clause) loop
27471 Collect_Dependency_Clause (Clause);
27472 Next (Clause);
27473 end loop;
27474
27475 -- Otherwise this is a single dependency clause
27476
27477 else
27478 Collect_Dependency_Clause (Clauses);
27479 end if;
27480 end if;
27481
27482 -- The current instance of a protected type acts as a formal parameter
27483 -- of mode IN for functions and IN OUT for entries and procedures
27484 -- (SPARK RM 6.1.4).
27485
27486 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
27487 Typ := Scope (Spec_Id);
27488
27489 -- Use the anonymous object when the type is single protected
27490
27491 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27492 Typ := Anonymous_Object (Typ);
27493 end if;
27494
27495 Append_New_Elmt (Typ, Subp_Inputs);
27496
27497 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
27498 Append_New_Elmt (Typ, Subp_Outputs);
27499 end if;
27500
27501 -- The current instance of a task type acts as a formal parameter of
27502 -- mode IN OUT (SPARK RM 6.1.4).
27503
27504 elsif Ekind (Spec_Id) = E_Task_Type then
27505 Typ := Spec_Id;
27506
27507 -- Use the anonymous object when the type is single task
27508
27509 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27510 Typ := Anonymous_Object (Typ);
27511 end if;
27512
27513 Append_New_Elmt (Typ, Subp_Inputs);
27514 Append_New_Elmt (Typ, Subp_Outputs);
27515
27516 elsif Is_Single_Task_Object (Spec_Id) then
27517 Append_New_Elmt (Spec_Id, Subp_Inputs);
27518 Append_New_Elmt (Spec_Id, Subp_Outputs);
27519 end if;
27520 end Collect_Subprogram_Inputs_Outputs;
27521
27522 ---------------------------
27523 -- Contract_Freeze_Error --
27524 ---------------------------
27525
27526 procedure Contract_Freeze_Error
27527 (Contract_Id : Entity_Id;
27528 Freeze_Id : Entity_Id)
27529 is
27530 begin
27531 Error_Msg_Name_1 := Chars (Contract_Id);
27532 Error_Msg_Sloc := Sloc (Freeze_Id);
27533
27534 SPARK_Msg_NE
27535 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
27536 SPARK_Msg_N
27537 ("\all contractual items must be declared before body #", Contract_Id);
27538 end Contract_Freeze_Error;
27539
27540 ---------------------------------
27541 -- Delay_Config_Pragma_Analyze --
27542 ---------------------------------
27543
27544 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
27545 begin
27546 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
27547 Name_Priority_Specific_Dispatching);
27548 end Delay_Config_Pragma_Analyze;
27549
27550 -----------------------
27551 -- Duplication_Error --
27552 -----------------------
27553
27554 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
27555 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
27556 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
27557
27558 begin
27559 Error_Msg_Sloc := Sloc (Prev);
27560 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27561
27562 -- Emit a precise message to distinguish between source pragmas and
27563 -- pragmas generated from aspects. The ordering of the two pragmas is
27564 -- the following:
27565
27566 -- Prev -- ok
27567 -- Prag -- duplicate
27568
27569 -- No error is emitted when both pragmas come from aspects because this
27570 -- is already detected by the general aspect analysis mechanism.
27571
27572 if Prag_From_Asp and Prev_From_Asp then
27573 null;
27574 elsif Prag_From_Asp then
27575 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
27576 elsif Prev_From_Asp then
27577 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
27578 else
27579 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
27580 end if;
27581 end Duplication_Error;
27582
27583 -----------------
27584 -- Entity_Hash --
27585 -----------------
27586
27587 function Entity_Hash (E : Entity_Id) return Num_Primitives is
27588 begin
27589 return Num_Primitives (E mod 511);
27590 end Entity_Hash;
27591
27592 --------------------------
27593 -- Find_Related_Context --
27594 --------------------------
27595
27596 function Find_Related_Context
27597 (Prag : Node_Id;
27598 Do_Checks : Boolean := False) return Node_Id
27599 is
27600 Stmt : Node_Id;
27601
27602 begin
27603 Stmt := Prev (Prag);
27604 while Present (Stmt) loop
27605
27606 -- Skip prior pragmas, but check for duplicates
27607
27608 if Nkind (Stmt) = N_Pragma then
27609 if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
27610 Duplication_Error
27611 (Prag => Prag,
27612 Prev => Stmt);
27613 end if;
27614
27615 -- Skip internally generated code
27616
27617 elsif not Comes_From_Source (Stmt) then
27618
27619 -- The anonymous object created for a single concurrent type is a
27620 -- suitable context.
27621
27622 if Nkind (Stmt) = N_Object_Declaration
27623 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27624 then
27625 return Stmt;
27626 end if;
27627
27628 -- Return the current source construct
27629
27630 else
27631 return Stmt;
27632 end if;
27633
27634 Prev (Stmt);
27635 end loop;
27636
27637 return Empty;
27638 end Find_Related_Context;
27639
27640 --------------------------------------
27641 -- Find_Related_Declaration_Or_Body --
27642 --------------------------------------
27643
27644 function Find_Related_Declaration_Or_Body
27645 (Prag : Node_Id;
27646 Do_Checks : Boolean := False) return Node_Id
27647 is
27648 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
27649
27650 procedure Expression_Function_Error;
27651 -- Emit an error concerning pragma Prag that illegaly applies to an
27652 -- expression function.
27653
27654 -------------------------------
27655 -- Expression_Function_Error --
27656 -------------------------------
27657
27658 procedure Expression_Function_Error is
27659 begin
27660 Error_Msg_Name_1 := Prag_Nam;
27661
27662 -- Emit a precise message to distinguish between source pragmas and
27663 -- pragmas generated from aspects.
27664
27665 if From_Aspect_Specification (Prag) then
27666 Error_Msg_N
27667 ("aspect % cannot apply to a stand alone expression function",
27668 Prag);
27669 else
27670 Error_Msg_N
27671 ("pragma % cannot apply to a stand alone expression function",
27672 Prag);
27673 end if;
27674 end Expression_Function_Error;
27675
27676 -- Local variables
27677
27678 Context : constant Node_Id := Parent (Prag);
27679 Stmt : Node_Id;
27680
27681 Look_For_Body : constant Boolean :=
27682 Nam_In (Prag_Nam, Name_Refined_Depends,
27683 Name_Refined_Global,
27684 Name_Refined_Post);
27685 -- Refinement pragmas must be associated with a subprogram body [stub]
27686
27687 -- Start of processing for Find_Related_Declaration_Or_Body
27688
27689 begin
27690 Stmt := Prev (Prag);
27691 while Present (Stmt) loop
27692
27693 -- Skip prior pragmas, but check for duplicates. Pragmas produced
27694 -- by splitting a complex pre/postcondition are not considered to
27695 -- be duplicates.
27696
27697 if Nkind (Stmt) = N_Pragma then
27698 if Do_Checks
27699 and then not Split_PPC (Stmt)
27700 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
27701 then
27702 Duplication_Error
27703 (Prag => Prag,
27704 Prev => Stmt);
27705 end if;
27706
27707 -- Emit an error when a refinement pragma appears on an expression
27708 -- function without a completion.
27709
27710 elsif Do_Checks
27711 and then Look_For_Body
27712 and then Nkind (Stmt) = N_Subprogram_Declaration
27713 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
27714 and then not Has_Completion (Defining_Entity (Stmt))
27715 then
27716 Expression_Function_Error;
27717 return Empty;
27718
27719 -- The refinement pragma applies to a subprogram body stub
27720
27721 elsif Look_For_Body
27722 and then Nkind (Stmt) = N_Subprogram_Body_Stub
27723 then
27724 return Stmt;
27725
27726 -- Skip internally generated code
27727
27728 elsif not Comes_From_Source (Stmt) then
27729
27730 -- The anonymous object created for a single concurrent type is a
27731 -- suitable context.
27732
27733 if Nkind (Stmt) = N_Object_Declaration
27734 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27735 then
27736 return Stmt;
27737
27738 elsif Nkind (Stmt) = N_Subprogram_Declaration then
27739
27740 -- The subprogram declaration is an internally generated spec
27741 -- for an expression function.
27742
27743 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27744 return Stmt;
27745
27746 -- The subprogram is actually an instance housed within an
27747 -- anonymous wrapper package.
27748
27749 elsif Present (Generic_Parent (Specification (Stmt))) then
27750 return Stmt;
27751 end if;
27752 end if;
27753
27754 -- Return the current construct which is either a subprogram body,
27755 -- a subprogram declaration or is illegal.
27756
27757 else
27758 return Stmt;
27759 end if;
27760
27761 Prev (Stmt);
27762 end loop;
27763
27764 -- If we fall through, then the pragma was either the first declaration
27765 -- or it was preceded by other pragmas and no source constructs.
27766
27767 -- The pragma is associated with a library-level subprogram
27768
27769 if Nkind (Context) = N_Compilation_Unit_Aux then
27770 return Unit (Parent (Context));
27771
27772 -- The pragma appears inside the declarations of an entry body
27773
27774 elsif Nkind (Context) = N_Entry_Body then
27775 return Context;
27776
27777 -- The pragma appears inside the statements of a subprogram body. This
27778 -- placement is the result of subprogram contract expansion.
27779
27780 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
27781 return Parent (Context);
27782
27783 -- The pragma appears inside the declarative part of a subprogram body
27784
27785 elsif Nkind (Context) = N_Subprogram_Body then
27786 return Context;
27787
27788 -- The pragma appears inside the declarative part of a task body
27789
27790 elsif Nkind (Context) = N_Task_Body then
27791 return Context;
27792
27793 -- The pragma is a byproduct of aspect expansion, return the related
27794 -- context of the original aspect. This case has a lower priority as
27795 -- the above circuitry pinpoints precisely the related context.
27796
27797 elsif Present (Corresponding_Aspect (Prag)) then
27798 return Parent (Corresponding_Aspect (Prag));
27799
27800 -- No candidate subprogram [body] found
27801
27802 else
27803 return Empty;
27804 end if;
27805 end Find_Related_Declaration_Or_Body;
27806
27807 ----------------------------------
27808 -- Find_Related_Package_Or_Body --
27809 ----------------------------------
27810
27811 function Find_Related_Package_Or_Body
27812 (Prag : Node_Id;
27813 Do_Checks : Boolean := False) return Node_Id
27814 is
27815 Context : constant Node_Id := Parent (Prag);
27816 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27817 Stmt : Node_Id;
27818
27819 begin
27820 Stmt := Prev (Prag);
27821 while Present (Stmt) loop
27822
27823 -- Skip prior pragmas, but check for duplicates
27824
27825 if Nkind (Stmt) = N_Pragma then
27826 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
27827 Duplication_Error
27828 (Prag => Prag,
27829 Prev => Stmt);
27830 end if;
27831
27832 -- Skip internally generated code
27833
27834 elsif not Comes_From_Source (Stmt) then
27835 if Nkind (Stmt) = N_Subprogram_Declaration then
27836
27837 -- The subprogram declaration is an internally generated spec
27838 -- for an expression function.
27839
27840 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27841 return Stmt;
27842
27843 -- The subprogram is actually an instance housed within an
27844 -- anonymous wrapper package.
27845
27846 elsif Present (Generic_Parent (Specification (Stmt))) then
27847 return Stmt;
27848 end if;
27849 end if;
27850
27851 -- Return the current source construct which is illegal
27852
27853 else
27854 return Stmt;
27855 end if;
27856
27857 Prev (Stmt);
27858 end loop;
27859
27860 -- If we fall through, then the pragma was either the first declaration
27861 -- or it was preceded by other pragmas and no source constructs.
27862
27863 -- The pragma is associated with a package. The immediate context in
27864 -- this case is the specification of the package.
27865
27866 if Nkind (Context) = N_Package_Specification then
27867 return Parent (Context);
27868
27869 -- The pragma appears in the declarations of a package body
27870
27871 elsif Nkind (Context) = N_Package_Body then
27872 return Context;
27873
27874 -- The pragma appears in the statements of a package body
27875
27876 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
27877 and then Nkind (Parent (Context)) = N_Package_Body
27878 then
27879 return Parent (Context);
27880
27881 -- The pragma is a byproduct of aspect expansion, return the related
27882 -- context of the original aspect. This case has a lower priority as
27883 -- the above circuitry pinpoints precisely the related context.
27884
27885 elsif Present (Corresponding_Aspect (Prag)) then
27886 return Parent (Corresponding_Aspect (Prag));
27887
27888 -- No candidate packge [body] found
27889
27890 else
27891 return Empty;
27892 end if;
27893 end Find_Related_Package_Or_Body;
27894
27895 ------------------
27896 -- Get_Argument --
27897 ------------------
27898
27899 function Get_Argument
27900 (Prag : Node_Id;
27901 Context_Id : Entity_Id := Empty) return Node_Id
27902 is
27903 Args : constant List_Id := Pragma_Argument_Associations (Prag);
27904
27905 begin
27906 -- Use the expression of the original aspect when compiling for ASIS or
27907 -- when analyzing the template of a generic unit. In both cases the
27908 -- aspect's tree must be decorated to allow for ASIS queries or to save
27909 -- the global references in the generic context.
27910
27911 if From_Aspect_Specification (Prag)
27912 and then (ASIS_Mode or else (Present (Context_Id)
27913 and then Is_Generic_Unit (Context_Id)))
27914 then
27915 return Corresponding_Aspect (Prag);
27916
27917 -- Otherwise use the expression of the pragma
27918
27919 elsif Present (Args) then
27920 return First (Args);
27921
27922 else
27923 return Empty;
27924 end if;
27925 end Get_Argument;
27926
27927 -------------------------
27928 -- Get_Base_Subprogram --
27929 -------------------------
27930
27931 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
27932 Result : Entity_Id;
27933
27934 begin
27935 -- Follow subprogram renaming chain
27936
27937 Result := Def_Id;
27938
27939 if Is_Subprogram (Result)
27940 and then
27941 Nkind (Parent (Declaration_Node (Result))) =
27942 N_Subprogram_Renaming_Declaration
27943 and then Present (Alias (Result))
27944 then
27945 Result := Alias (Result);
27946 end if;
27947
27948 return Result;
27949 end Get_Base_Subprogram;
27950
27951 -----------------------
27952 -- Get_SPARK_Mode_Type --
27953 -----------------------
27954
27955 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
27956 begin
27957 if N = Name_On then
27958 return On;
27959 elsif N = Name_Off then
27960 return Off;
27961
27962 -- Any other argument is illegal
27963
27964 else
27965 raise Program_Error;
27966 end if;
27967 end Get_SPARK_Mode_Type;
27968
27969 ------------------------------------
27970 -- Get_SPARK_Mode_From_Annotation --
27971 ------------------------------------
27972
27973 function Get_SPARK_Mode_From_Annotation
27974 (N : Node_Id) return SPARK_Mode_Type
27975 is
27976 Mode : Node_Id;
27977
27978 begin
27979 if Nkind (N) = N_Aspect_Specification then
27980 Mode := Expression (N);
27981
27982 else pragma Assert (Nkind (N) = N_Pragma);
27983 Mode := First (Pragma_Argument_Associations (N));
27984
27985 if Present (Mode) then
27986 Mode := Get_Pragma_Arg (Mode);
27987 end if;
27988 end if;
27989
27990 -- Aspect or pragma SPARK_Mode specifies an explicit mode
27991
27992 if Present (Mode) then
27993 if Nkind (Mode) = N_Identifier then
27994 return Get_SPARK_Mode_Type (Chars (Mode));
27995
27996 -- In case of a malformed aspect or pragma, return the default None
27997
27998 else
27999 return None;
28000 end if;
28001
28002 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28003
28004 else
28005 return On;
28006 end if;
28007 end Get_SPARK_Mode_From_Annotation;
28008
28009 ---------------------------
28010 -- Has_Extra_Parentheses --
28011 ---------------------------
28012
28013 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
28014 Expr : Node_Id;
28015
28016 begin
28017 -- The aggregate should not have an expression list because a clause
28018 -- is always interpreted as a component association. The only way an
28019 -- expression list can sneak in is by adding extra parentheses around
28020 -- the individual clauses:
28021
28022 -- Depends (Output => Input) -- proper form
28023 -- Depends ((Output => Input)) -- extra parentheses
28024
28025 -- Since the extra parentheses are not allowed by the syntax of the
28026 -- pragma, flag them now to avoid emitting misleading errors down the
28027 -- line.
28028
28029 if Nkind (Clause) = N_Aggregate
28030 and then Present (Expressions (Clause))
28031 then
28032 Expr := First (Expressions (Clause));
28033 while Present (Expr) loop
28034
28035 -- A dependency clause surrounded by extra parentheses appears
28036 -- as an aggregate of component associations with an optional
28037 -- Paren_Count set.
28038
28039 if Nkind (Expr) = N_Aggregate
28040 and then Present (Component_Associations (Expr))
28041 then
28042 SPARK_Msg_N
28043 ("dependency clause contains extra parentheses", Expr);
28044
28045 -- Otherwise the expression is a malformed construct
28046
28047 else
28048 SPARK_Msg_N ("malformed dependency clause", Expr);
28049 end if;
28050
28051 Next (Expr);
28052 end loop;
28053
28054 return True;
28055 end if;
28056
28057 return False;
28058 end Has_Extra_Parentheses;
28059
28060 ----------------
28061 -- Initialize --
28062 ----------------
28063
28064 procedure Initialize is
28065 begin
28066 Externals.Init;
28067 end Initialize;
28068
28069 --------
28070 -- ip --
28071 --------
28072
28073 procedure ip is
28074 begin
28075 Dummy := Dummy + 1;
28076 end ip;
28077
28078 -----------------------------
28079 -- Is_Config_Static_String --
28080 -----------------------------
28081
28082 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
28083
28084 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
28085 -- This is an internal recursive function that is just like the outer
28086 -- function except that it adds the string to the name buffer rather
28087 -- than placing the string in the name buffer.
28088
28089 ------------------------------
28090 -- Add_Config_Static_String --
28091 ------------------------------
28092
28093 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
28094 N : Node_Id;
28095 C : Char_Code;
28096
28097 begin
28098 N := Arg;
28099
28100 if Nkind (N) = N_Op_Concat then
28101 if Add_Config_Static_String (Left_Opnd (N)) then
28102 N := Right_Opnd (N);
28103 else
28104 return False;
28105 end if;
28106 end if;
28107
28108 if Nkind (N) /= N_String_Literal then
28109 Error_Msg_N ("string literal expected for pragma argument", N);
28110 return False;
28111
28112 else
28113 for J in 1 .. String_Length (Strval (N)) loop
28114 C := Get_String_Char (Strval (N), J);
28115
28116 if not In_Character_Range (C) then
28117 Error_Msg
28118 ("string literal contains invalid wide character",
28119 Sloc (N) + 1 + Source_Ptr (J));
28120 return False;
28121 end if;
28122
28123 Add_Char_To_Name_Buffer (Get_Character (C));
28124 end loop;
28125 end if;
28126
28127 return True;
28128 end Add_Config_Static_String;
28129
28130 -- Start of processing for Is_Config_Static_String
28131
28132 begin
28133 Name_Len := 0;
28134
28135 return Add_Config_Static_String (Arg);
28136 end Is_Config_Static_String;
28137
28138 ---------------------
28139 -- Is_CCT_Instance --
28140 ---------------------
28141
28142 function Is_CCT_Instance
28143 (Ref_Id : Entity_Id;
28144 Context_Id : Entity_Id) return Boolean
28145 is
28146 S : Entity_Id;
28147 Typ : Entity_Id;
28148
28149 begin
28150 -- When the reference denotes a single protected type, the context is
28151 -- either a protected subprogram or its body.
28152
28153 if Is_Single_Protected_Object (Ref_Id) then
28154 Typ := Scope (Context_Id);
28155
28156 return
28157 Ekind (Typ) = E_Protected_Type
28158 and then Present (Anonymous_Object (Typ))
28159 and then Anonymous_Object (Typ) = Ref_Id;
28160
28161 -- When the reference denotes a single task type, the context is either
28162 -- the same type or if inside the body, the anonymous task type.
28163
28164 elsif Is_Single_Task_Object (Ref_Id) then
28165 if Ekind (Context_Id) = E_Task_Type then
28166 return
28167 Present (Anonymous_Object (Context_Id))
28168 and then Anonymous_Object (Context_Id) = Ref_Id;
28169 else
28170 return Ref_Id = Context_Id;
28171 end if;
28172
28173 -- Otherwise the reference denotes a protected or a task type. Climb the
28174 -- scope chain looking for an enclosing concurrent type that matches the
28175 -- referenced entity.
28176
28177 else
28178 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
28179
28180 S := Current_Scope;
28181 while Present (S) and then S /= Standard_Standard loop
28182 if Ekind_In (S, E_Protected_Type, E_Task_Type)
28183 and then S = Ref_Id
28184 then
28185 return True;
28186 end if;
28187
28188 S := Scope (S);
28189 end loop;
28190 end if;
28191
28192 return False;
28193 end Is_CCT_Instance;
28194
28195 -------------------------------
28196 -- Is_Elaboration_SPARK_Mode --
28197 -------------------------------
28198
28199 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
28200 begin
28201 pragma Assert
28202 (Nkind (N) = N_Pragma
28203 and then Pragma_Name (N) = Name_SPARK_Mode
28204 and then Is_List_Member (N));
28205
28206 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28207 -- appears in the statement part of the body.
28208
28209 return
28210 Present (Parent (N))
28211 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
28212 and then List_Containing (N) = Statements (Parent (N))
28213 and then Present (Parent (Parent (N)))
28214 and then Nkind (Parent (Parent (N))) = N_Package_Body;
28215 end Is_Elaboration_SPARK_Mode;
28216
28217 -----------------------
28218 -- Is_Enabled_Pragma --
28219 -----------------------
28220
28221 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
28222 Arg : Node_Id;
28223
28224 begin
28225 if Present (Prag) then
28226 Arg := First (Pragma_Argument_Associations (Prag));
28227
28228 if Present (Arg) then
28229 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
28230
28231 -- The lack of a Boolean argument automatically enables the pragma
28232
28233 else
28234 return True;
28235 end if;
28236
28237 -- The pragma is missing, therefore it is not enabled
28238
28239 else
28240 return False;
28241 end if;
28242 end Is_Enabled_Pragma;
28243
28244 -----------------------------------------
28245 -- Is_Non_Significant_Pragma_Reference --
28246 -----------------------------------------
28247
28248 -- This function makes use of the following static table which indicates
28249 -- whether appearance of some name in a given pragma is to be considered
28250 -- as a reference for the purposes of warnings about unreferenced objects.
28251
28252 -- -1 indicates that appearence in any argument is significant
28253 -- 0 indicates that appearance in any argument is not significant
28254 -- +n indicates that appearance as argument n is significant, but all
28255 -- other arguments are not significant
28256 -- 9n arguments from n on are significant, before n insignificant
28257
28258 Sig_Flags : constant array (Pragma_Id) of Int :=
28259 (Pragma_Abort_Defer => -1,
28260 Pragma_Abstract_State => -1,
28261 Pragma_Ada_83 => -1,
28262 Pragma_Ada_95 => -1,
28263 Pragma_Ada_05 => -1,
28264 Pragma_Ada_2005 => -1,
28265 Pragma_Ada_12 => -1,
28266 Pragma_Ada_2012 => -1,
28267 Pragma_All_Calls_Remote => -1,
28268 Pragma_Allow_Integer_Address => -1,
28269 Pragma_Annotate => 93,
28270 Pragma_Assert => -1,
28271 Pragma_Assert_And_Cut => -1,
28272 Pragma_Assertion_Policy => 0,
28273 Pragma_Assume => -1,
28274 Pragma_Assume_No_Invalid_Values => 0,
28275 Pragma_Async_Readers => 0,
28276 Pragma_Async_Writers => 0,
28277 Pragma_Asynchronous => 0,
28278 Pragma_Atomic => 0,
28279 Pragma_Atomic_Components => 0,
28280 Pragma_Attach_Handler => -1,
28281 Pragma_Attribute_Definition => 92,
28282 Pragma_Check => -1,
28283 Pragma_Check_Float_Overflow => 0,
28284 Pragma_Check_Name => 0,
28285 Pragma_Check_Policy => 0,
28286 Pragma_CPP_Class => 0,
28287 Pragma_CPP_Constructor => 0,
28288 Pragma_CPP_Virtual => 0,
28289 Pragma_CPP_Vtable => 0,
28290 Pragma_CPU => -1,
28291 Pragma_C_Pass_By_Copy => 0,
28292 Pragma_Comment => -1,
28293 Pragma_Common_Object => 0,
28294 Pragma_Compile_Time_Error => -1,
28295 Pragma_Compile_Time_Warning => -1,
28296 Pragma_Compiler_Unit => -1,
28297 Pragma_Compiler_Unit_Warning => -1,
28298 Pragma_Complete_Representation => 0,
28299 Pragma_Complex_Representation => 0,
28300 Pragma_Component_Alignment => 0,
28301 Pragma_Constant_After_Elaboration => 0,
28302 Pragma_Contract_Cases => -1,
28303 Pragma_Controlled => 0,
28304 Pragma_Convention => 0,
28305 Pragma_Convention_Identifier => 0,
28306 Pragma_Debug => -1,
28307 Pragma_Debug_Policy => 0,
28308 Pragma_Detect_Blocking => 0,
28309 Pragma_Default_Initial_Condition => -1,
28310 Pragma_Default_Scalar_Storage_Order => 0,
28311 Pragma_Default_Storage_Pool => 0,
28312 Pragma_Depends => -1,
28313 Pragma_Disable_Atomic_Synchronization => 0,
28314 Pragma_Discard_Names => 0,
28315 Pragma_Dispatching_Domain => -1,
28316 Pragma_Effective_Reads => 0,
28317 Pragma_Effective_Writes => 0,
28318 Pragma_Elaborate => 0,
28319 Pragma_Elaborate_All => 0,
28320 Pragma_Elaborate_Body => 0,
28321 Pragma_Elaboration_Checks => 0,
28322 Pragma_Eliminate => 0,
28323 Pragma_Enable_Atomic_Synchronization => 0,
28324 Pragma_Export => -1,
28325 Pragma_Export_Function => -1,
28326 Pragma_Export_Object => -1,
28327 Pragma_Export_Procedure => -1,
28328 Pragma_Export_Value => -1,
28329 Pragma_Export_Valued_Procedure => -1,
28330 Pragma_Extend_System => -1,
28331 Pragma_Extensions_Allowed => 0,
28332 Pragma_Extensions_Visible => 0,
28333 Pragma_External => -1,
28334 Pragma_Favor_Top_Level => 0,
28335 Pragma_External_Name_Casing => 0,
28336 Pragma_Fast_Math => 0,
28337 Pragma_Finalize_Storage_Only => 0,
28338 Pragma_Ghost => 0,
28339 Pragma_Global => -1,
28340 Pragma_Ident => -1,
28341 Pragma_Ignore_Pragma => 0,
28342 Pragma_Implementation_Defined => -1,
28343 Pragma_Implemented => -1,
28344 Pragma_Implicit_Packing => 0,
28345 Pragma_Import => 93,
28346 Pragma_Import_Function => 0,
28347 Pragma_Import_Object => 0,
28348 Pragma_Import_Procedure => 0,
28349 Pragma_Import_Valued_Procedure => 0,
28350 Pragma_Independent => 0,
28351 Pragma_Independent_Components => 0,
28352 Pragma_Initial_Condition => -1,
28353 Pragma_Initialize_Scalars => 0,
28354 Pragma_Initializes => -1,
28355 Pragma_Inline => 0,
28356 Pragma_Inline_Always => 0,
28357 Pragma_Inline_Generic => 0,
28358 Pragma_Inspection_Point => -1,
28359 Pragma_Interface => 92,
28360 Pragma_Interface_Name => 0,
28361 Pragma_Interrupt_Handler => -1,
28362 Pragma_Interrupt_Priority => -1,
28363 Pragma_Interrupt_State => -1,
28364 Pragma_Invariant => -1,
28365 Pragma_Keep_Names => 0,
28366 Pragma_License => 0,
28367 Pragma_Link_With => -1,
28368 Pragma_Linker_Alias => -1,
28369 Pragma_Linker_Constructor => -1,
28370 Pragma_Linker_Destructor => -1,
28371 Pragma_Linker_Options => -1,
28372 Pragma_Linker_Section => 0,
28373 Pragma_List => 0,
28374 Pragma_Lock_Free => 0,
28375 Pragma_Locking_Policy => 0,
28376 Pragma_Loop_Invariant => -1,
28377 Pragma_Loop_Optimize => 0,
28378 Pragma_Loop_Variant => -1,
28379 Pragma_Machine_Attribute => -1,
28380 Pragma_Main => -1,
28381 Pragma_Main_Storage => -1,
28382 Pragma_Memory_Size => 0,
28383 Pragma_No_Return => 0,
28384 Pragma_No_Body => 0,
28385 Pragma_No_Elaboration_Code_All => 0,
28386 Pragma_No_Inline => 0,
28387 Pragma_No_Run_Time => -1,
28388 Pragma_No_Strict_Aliasing => -1,
28389 Pragma_No_Tagged_Streams => 0,
28390 Pragma_Normalize_Scalars => 0,
28391 Pragma_Obsolescent => 0,
28392 Pragma_Optimize => 0,
28393 Pragma_Optimize_Alignment => 0,
28394 Pragma_Overflow_Mode => 0,
28395 Pragma_Overriding_Renamings => 0,
28396 Pragma_Ordered => 0,
28397 Pragma_Pack => 0,
28398 Pragma_Page => 0,
28399 Pragma_Part_Of => 0,
28400 Pragma_Partition_Elaboration_Policy => 0,
28401 Pragma_Passive => 0,
28402 Pragma_Persistent_BSS => 0,
28403 Pragma_Polling => 0,
28404 Pragma_Prefix_Exception_Messages => 0,
28405 Pragma_Post => -1,
28406 Pragma_Postcondition => -1,
28407 Pragma_Post_Class => -1,
28408 Pragma_Pre => -1,
28409 Pragma_Precondition => -1,
28410 Pragma_Predicate => -1,
28411 Pragma_Predicate_Failure => -1,
28412 Pragma_Preelaborable_Initialization => -1,
28413 Pragma_Preelaborate => 0,
28414 Pragma_Pre_Class => -1,
28415 Pragma_Priority => -1,
28416 Pragma_Priority_Specific_Dispatching => 0,
28417 Pragma_Profile => 0,
28418 Pragma_Profile_Warnings => 0,
28419 Pragma_Propagate_Exceptions => 0,
28420 Pragma_Provide_Shift_Operators => 0,
28421 Pragma_Psect_Object => 0,
28422 Pragma_Pure => 0,
28423 Pragma_Pure_Function => 0,
28424 Pragma_Queuing_Policy => 0,
28425 Pragma_Rational => 0,
28426 Pragma_Ravenscar => 0,
28427 Pragma_Refined_Depends => -1,
28428 Pragma_Refined_Global => -1,
28429 Pragma_Refined_Post => -1,
28430 Pragma_Refined_State => -1,
28431 Pragma_Relative_Deadline => 0,
28432 Pragma_Remote_Access_Type => -1,
28433 Pragma_Remote_Call_Interface => -1,
28434 Pragma_Remote_Types => -1,
28435 Pragma_Restricted_Run_Time => 0,
28436 Pragma_Restriction_Warnings => 0,
28437 Pragma_Restrictions => 0,
28438 Pragma_Reviewable => -1,
28439 Pragma_Short_Circuit_And_Or => 0,
28440 Pragma_Share_Generic => 0,
28441 Pragma_Shared => 0,
28442 Pragma_Shared_Passive => 0,
28443 Pragma_Short_Descriptors => 0,
28444 Pragma_Simple_Storage_Pool_Type => 0,
28445 Pragma_Source_File_Name => 0,
28446 Pragma_Source_File_Name_Project => 0,
28447 Pragma_Source_Reference => 0,
28448 Pragma_SPARK_Mode => 0,
28449 Pragma_Storage_Size => -1,
28450 Pragma_Storage_Unit => 0,
28451 Pragma_Static_Elaboration_Desired => 0,
28452 Pragma_Stream_Convert => 0,
28453 Pragma_Style_Checks => 0,
28454 Pragma_Subtitle => 0,
28455 Pragma_Suppress => 0,
28456 Pragma_Suppress_Exception_Locations => 0,
28457 Pragma_Suppress_All => 0,
28458 Pragma_Suppress_Debug_Info => 0,
28459 Pragma_Suppress_Initialization => 0,
28460 Pragma_System_Name => 0,
28461 Pragma_Task_Dispatching_Policy => 0,
28462 Pragma_Task_Info => -1,
28463 Pragma_Task_Name => -1,
28464 Pragma_Task_Storage => -1,
28465 Pragma_Test_Case => -1,
28466 Pragma_Thread_Local_Storage => -1,
28467 Pragma_Time_Slice => -1,
28468 Pragma_Title => 0,
28469 Pragma_Type_Invariant => -1,
28470 Pragma_Type_Invariant_Class => -1,
28471 Pragma_Unchecked_Union => 0,
28472 Pragma_Unevaluated_Use_Of_Old => 0,
28473 Pragma_Unimplemented_Unit => 0,
28474 Pragma_Universal_Aliasing => 0,
28475 Pragma_Universal_Data => 0,
28476 Pragma_Unmodified => 0,
28477 Pragma_Unreferenced => 0,
28478 Pragma_Unreferenced_Objects => 0,
28479 Pragma_Unreserve_All_Interrupts => 0,
28480 Pragma_Unsuppress => 0,
28481 Pragma_Unused => 0,
28482 Pragma_Use_VADS_Size => 0,
28483 Pragma_Validity_Checks => 0,
28484 Pragma_Volatile => 0,
28485 Pragma_Volatile_Components => 0,
28486 Pragma_Volatile_Full_Access => 0,
28487 Pragma_Volatile_Function => 0,
28488 Pragma_Warning_As_Error => 0,
28489 Pragma_Warnings => 0,
28490 Pragma_Weak_External => 0,
28491 Pragma_Wide_Character_Encoding => 0,
28492 Unknown_Pragma => 0);
28493
28494 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
28495 Id : Pragma_Id;
28496 P : Node_Id;
28497 C : Int;
28498 AN : Nat;
28499
28500 function Arg_No return Nat;
28501 -- Returns an integer showing what argument we are in. A value of
28502 -- zero means we are not in any of the arguments.
28503
28504 ------------
28505 -- Arg_No --
28506 ------------
28507
28508 function Arg_No return Nat is
28509 A : Node_Id;
28510 N : Nat;
28511
28512 begin
28513 A := First (Pragma_Argument_Associations (Parent (P)));
28514 N := 1;
28515 loop
28516 if No (A) then
28517 return 0;
28518 elsif A = P then
28519 return N;
28520 end if;
28521
28522 Next (A);
28523 N := N + 1;
28524 end loop;
28525 end Arg_No;
28526
28527 -- Start of processing for Non_Significant_Pragma_Reference
28528
28529 begin
28530 P := Parent (N);
28531
28532 if Nkind (P) /= N_Pragma_Argument_Association then
28533 return False;
28534
28535 else
28536 Id := Get_Pragma_Id (Parent (P));
28537 C := Sig_Flags (Id);
28538 AN := Arg_No;
28539
28540 if AN = 0 then
28541 return False;
28542 end if;
28543
28544 case C is
28545 when -1 =>
28546 return False;
28547
28548 when 0 =>
28549 return True;
28550
28551 when 92 .. 99 =>
28552 return AN < (C - 90);
28553
28554 when others =>
28555 return AN /= C;
28556 end case;
28557 end if;
28558 end Is_Non_Significant_Pragma_Reference;
28559
28560 ------------------------------
28561 -- Is_Pragma_String_Literal --
28562 ------------------------------
28563
28564 -- This function returns true if the corresponding pragma argument is a
28565 -- static string expression. These are the only cases in which string
28566 -- literals can appear as pragma arguments. We also allow a string literal
28567 -- as the first argument to pragma Assert (although it will of course
28568 -- always generate a type error).
28569
28570 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
28571 Pragn : constant Node_Id := Parent (Par);
28572 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
28573 Pname : constant Name_Id := Pragma_Name (Pragn);
28574 Argn : Natural;
28575 N : Node_Id;
28576
28577 begin
28578 Argn := 1;
28579 N := First (Assoc);
28580 loop
28581 exit when N = Par;
28582 Argn := Argn + 1;
28583 Next (N);
28584 end loop;
28585
28586 if Pname = Name_Assert then
28587 return True;
28588
28589 elsif Pname = Name_Export then
28590 return Argn > 2;
28591
28592 elsif Pname = Name_Ident then
28593 return Argn = 1;
28594
28595 elsif Pname = Name_Import then
28596 return Argn > 2;
28597
28598 elsif Pname = Name_Interface_Name then
28599 return Argn > 1;
28600
28601 elsif Pname = Name_Linker_Alias then
28602 return Argn = 2;
28603
28604 elsif Pname = Name_Linker_Section then
28605 return Argn = 2;
28606
28607 elsif Pname = Name_Machine_Attribute then
28608 return Argn = 2;
28609
28610 elsif Pname = Name_Source_File_Name then
28611 return True;
28612
28613 elsif Pname = Name_Source_Reference then
28614 return Argn = 2;
28615
28616 elsif Pname = Name_Title then
28617 return True;
28618
28619 elsif Pname = Name_Subtitle then
28620 return True;
28621
28622 else
28623 return False;
28624 end if;
28625 end Is_Pragma_String_Literal;
28626
28627 ---------------------------
28628 -- Is_Private_SPARK_Mode --
28629 ---------------------------
28630
28631 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
28632 begin
28633 pragma Assert
28634 (Nkind (N) = N_Pragma
28635 and then Pragma_Name (N) = Name_SPARK_Mode
28636 and then Is_List_Member (N));
28637
28638 -- For pragma SPARK_Mode to be private, it has to appear in the private
28639 -- declarations of a package.
28640
28641 return
28642 Present (Parent (N))
28643 and then Nkind (Parent (N)) = N_Package_Specification
28644 and then List_Containing (N) = Private_Declarations (Parent (N));
28645 end Is_Private_SPARK_Mode;
28646
28647 -------------------------------------
28648 -- Is_Unconstrained_Or_Tagged_Item --
28649 -------------------------------------
28650
28651 function Is_Unconstrained_Or_Tagged_Item
28652 (Item : Entity_Id) return Boolean
28653 is
28654 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
28655 -- Determine whether record type Typ has at least one unconstrained
28656 -- component.
28657
28658 ---------------------------------
28659 -- Has_Unconstrained_Component --
28660 ---------------------------------
28661
28662 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
28663 Comp : Entity_Id;
28664
28665 begin
28666 Comp := First_Component (Typ);
28667 while Present (Comp) loop
28668 if Is_Unconstrained_Or_Tagged_Item (Comp) then
28669 return True;
28670 end if;
28671
28672 Next_Component (Comp);
28673 end loop;
28674
28675 return False;
28676 end Has_Unconstrained_Component;
28677
28678 -- Local variables
28679
28680 Typ : constant Entity_Id := Etype (Item);
28681
28682 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
28683
28684 begin
28685 if Is_Tagged_Type (Typ) then
28686 return True;
28687
28688 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
28689 return True;
28690
28691 elsif Is_Record_Type (Typ) then
28692 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
28693 return True;
28694 else
28695 return Has_Unconstrained_Component (Typ);
28696 end if;
28697
28698 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
28699 return True;
28700
28701 else
28702 return False;
28703 end if;
28704 end Is_Unconstrained_Or_Tagged_Item;
28705
28706 -----------------------------
28707 -- Is_Valid_Assertion_Kind --
28708 -----------------------------
28709
28710 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
28711 begin
28712 case Nam is
28713 when
28714 -- RM defined
28715
28716 Name_Assert |
28717 Name_Assertion_Policy |
28718 Name_Static_Predicate |
28719 Name_Dynamic_Predicate |
28720 Name_Pre |
28721 Name_uPre |
28722 Name_Post |
28723 Name_uPost |
28724 Name_Type_Invariant |
28725 Name_uType_Invariant |
28726
28727 -- Impl defined
28728
28729 Name_Assert_And_Cut |
28730 Name_Assume |
28731 Name_Contract_Cases |
28732 Name_Debug |
28733 Name_Default_Initial_Condition |
28734 Name_Ghost |
28735 Name_Initial_Condition |
28736 Name_Invariant |
28737 Name_uInvariant |
28738 Name_Loop_Invariant |
28739 Name_Loop_Variant |
28740 Name_Postcondition |
28741 Name_Precondition |
28742 Name_Predicate |
28743 Name_Refined_Post |
28744 Name_Statement_Assertions => return True;
28745
28746 when others => return False;
28747 end case;
28748 end Is_Valid_Assertion_Kind;
28749
28750 --------------------------------------
28751 -- Process_Compilation_Unit_Pragmas --
28752 --------------------------------------
28753
28754 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
28755 begin
28756 -- A special check for pragma Suppress_All, a very strange DEC pragma,
28757 -- strange because it comes at the end of the unit. Rational has the
28758 -- same name for a pragma, but treats it as a program unit pragma, In
28759 -- GNAT we just decide to allow it anywhere at all. If it appeared then
28760 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
28761 -- node, and we insert a pragma Suppress (All_Checks) at the start of
28762 -- the context clause to ensure the correct processing.
28763
28764 if Has_Pragma_Suppress_All (N) then
28765 Prepend_To (Context_Items (N),
28766 Make_Pragma (Sloc (N),
28767 Chars => Name_Suppress,
28768 Pragma_Argument_Associations => New_List (
28769 Make_Pragma_Argument_Association (Sloc (N),
28770 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
28771 end if;
28772
28773 -- Nothing else to do at the current time
28774
28775 end Process_Compilation_Unit_Pragmas;
28776
28777 ------------------------------------
28778 -- Record_Possible_Body_Reference --
28779 ------------------------------------
28780
28781 procedure Record_Possible_Body_Reference
28782 (State_Id : Entity_Id;
28783 Ref : Node_Id)
28784 is
28785 Context : Node_Id;
28786 Spec_Id : Entity_Id;
28787
28788 begin
28789 -- Ensure that we are dealing with a reference to a state
28790
28791 pragma Assert (Ekind (State_Id) = E_Abstract_State);
28792
28793 -- Climb the tree starting from the reference looking for a package body
28794 -- whose spec declares the referenced state. This criteria automatically
28795 -- excludes references in package specs which are legal. Note that it is
28796 -- not wise to emit an error now as the package body may lack pragma
28797 -- Refined_State or the referenced state may not be mentioned in the
28798 -- refinement. This approach avoids the generation of misleading errors.
28799
28800 Context := Ref;
28801 while Present (Context) loop
28802 if Nkind (Context) = N_Package_Body then
28803 Spec_Id := Corresponding_Spec (Context);
28804
28805 if Present (Abstract_States (Spec_Id))
28806 and then Contains (Abstract_States (Spec_Id), State_Id)
28807 then
28808 if No (Body_References (State_Id)) then
28809 Set_Body_References (State_Id, New_Elmt_List);
28810 end if;
28811
28812 Append_Elmt (Ref, To => Body_References (State_Id));
28813 exit;
28814 end if;
28815 end if;
28816
28817 Context := Parent (Context);
28818 end loop;
28819 end Record_Possible_Body_Reference;
28820
28821 ------------------------------------------
28822 -- Relocate_Pragmas_To_Anonymous_Object --
28823 ------------------------------------------
28824
28825 procedure Relocate_Pragmas_To_Anonymous_Object
28826 (Typ_Decl : Node_Id;
28827 Obj_Decl : Node_Id)
28828 is
28829 Decl : Node_Id;
28830 Def : Node_Id;
28831 Next_Decl : Node_Id;
28832
28833 begin
28834 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
28835 Def := Protected_Definition (Typ_Decl);
28836 else
28837 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
28838 Def := Task_Definition (Typ_Decl);
28839 end if;
28840
28841 -- The concurrent definition has a visible declaration list. Inspect it
28842 -- and relocate all canidate pragmas.
28843
28844 if Present (Def) and then Present (Visible_Declarations (Def)) then
28845 Decl := First (Visible_Declarations (Def));
28846 while Present (Decl) loop
28847
28848 -- Preserve the following declaration for iteration purposes due
28849 -- to possible relocation of a pragma.
28850
28851 Next_Decl := Next (Decl);
28852
28853 if Nkind (Decl) = N_Pragma
28854 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
28855 then
28856 Remove (Decl);
28857 Insert_After (Obj_Decl, Decl);
28858
28859 -- Skip internally generated code
28860
28861 elsif not Comes_From_Source (Decl) then
28862 null;
28863
28864 -- No candidate pragmas are available for relocation
28865
28866 else
28867 exit;
28868 end if;
28869
28870 Decl := Next_Decl;
28871 end loop;
28872 end if;
28873 end Relocate_Pragmas_To_Anonymous_Object;
28874
28875 ------------------------------
28876 -- Relocate_Pragmas_To_Body --
28877 ------------------------------
28878
28879 procedure Relocate_Pragmas_To_Body
28880 (Subp_Body : Node_Id;
28881 Target_Body : Node_Id := Empty)
28882 is
28883 procedure Relocate_Pragma (Prag : Node_Id);
28884 -- Remove a single pragma from its current list and add it to the
28885 -- declarations of the proper body (either Subp_Body or Target_Body).
28886
28887 ---------------------
28888 -- Relocate_Pragma --
28889 ---------------------
28890
28891 procedure Relocate_Pragma (Prag : Node_Id) is
28892 Decls : List_Id;
28893 Target : Node_Id;
28894
28895 begin
28896 -- When subprogram stubs or expression functions are involves, the
28897 -- destination declaration list belongs to the proper body.
28898
28899 if Present (Target_Body) then
28900 Target := Target_Body;
28901 else
28902 Target := Subp_Body;
28903 end if;
28904
28905 Decls := Declarations (Target);
28906
28907 if No (Decls) then
28908 Decls := New_List;
28909 Set_Declarations (Target, Decls);
28910 end if;
28911
28912 -- Unhook the pragma from its current list
28913
28914 Remove (Prag);
28915 Prepend (Prag, Decls);
28916 end Relocate_Pragma;
28917
28918 -- Local variables
28919
28920 Body_Id : constant Entity_Id :=
28921 Defining_Unit_Name (Specification (Subp_Body));
28922 Next_Stmt : Node_Id;
28923 Stmt : Node_Id;
28924
28925 -- Start of processing for Relocate_Pragmas_To_Body
28926
28927 begin
28928 -- Do not process a body that comes from a separate unit as no construct
28929 -- can possibly follow it.
28930
28931 if not Is_List_Member (Subp_Body) then
28932 return;
28933
28934 -- Do not relocate pragmas that follow a stub if the stub does not have
28935 -- a proper body.
28936
28937 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
28938 and then No (Target_Body)
28939 then
28940 return;
28941
28942 -- Do not process internally generated routine _Postconditions
28943
28944 elsif Ekind (Body_Id) = E_Procedure
28945 and then Chars (Body_Id) = Name_uPostconditions
28946 then
28947 return;
28948 end if;
28949
28950 -- Look at what is following the body. We are interested in certain kind
28951 -- of pragmas (either from source or byproducts of expansion) that can
28952 -- apply to a body [stub].
28953
28954 Stmt := Next (Subp_Body);
28955 while Present (Stmt) loop
28956
28957 -- Preserve the following statement for iteration purposes due to a
28958 -- possible relocation of a pragma.
28959
28960 Next_Stmt := Next (Stmt);
28961
28962 -- Move a candidate pragma following the body to the declarations of
28963 -- the body.
28964
28965 if Nkind (Stmt) = N_Pragma
28966 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
28967 then
28968 Relocate_Pragma (Stmt);
28969
28970 -- Skip internally generated code
28971
28972 elsif not Comes_From_Source (Stmt) then
28973 null;
28974
28975 -- No candidate pragmas are available for relocation
28976
28977 else
28978 exit;
28979 end if;
28980
28981 Stmt := Next_Stmt;
28982 end loop;
28983 end Relocate_Pragmas_To_Body;
28984
28985 -------------------
28986 -- Resolve_State --
28987 -------------------
28988
28989 procedure Resolve_State (N : Node_Id) is
28990 Func : Entity_Id;
28991 State : Entity_Id;
28992
28993 begin
28994 if Is_Entity_Name (N) and then Present (Entity (N)) then
28995 Func := Entity (N);
28996
28997 -- Handle overloading of state names by functions. Traverse the
28998 -- homonym chain looking for an abstract state.
28999
29000 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
29001 State := Homonym (Func);
29002 while Present (State) loop
29003
29004 -- Resolve the overloading by setting the proper entity of the
29005 -- reference to that of the state.
29006
29007 if Ekind (State) = E_Abstract_State then
29008 Set_Etype (N, Standard_Void_Type);
29009 Set_Entity (N, State);
29010 Set_Associated_Node (N, State);
29011 return;
29012 end if;
29013
29014 State := Homonym (State);
29015 end loop;
29016
29017 -- A function can never act as a state. If the homonym chain does
29018 -- not contain a corresponding state, then something went wrong in
29019 -- the overloading mechanism.
29020
29021 raise Program_Error;
29022 end if;
29023 end if;
29024 end Resolve_State;
29025
29026 ----------------------------
29027 -- Rewrite_Assertion_Kind --
29028 ----------------------------
29029
29030 procedure Rewrite_Assertion_Kind (N : Node_Id) is
29031 Nam : Name_Id;
29032
29033 begin
29034 if Nkind (N) = N_Attribute_Reference
29035 and then Attribute_Name (N) = Name_Class
29036 and then Nkind (Prefix (N)) = N_Identifier
29037 then
29038 case Chars (Prefix (N)) is
29039 when Name_Pre =>
29040 Nam := Name_uPre;
29041 when Name_Post =>
29042 Nam := Name_uPost;
29043 when Name_Type_Invariant =>
29044 Nam := Name_uType_Invariant;
29045 when Name_Invariant =>
29046 Nam := Name_uInvariant;
29047 when others =>
29048 return;
29049 end case;
29050
29051 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
29052 end if;
29053 end Rewrite_Assertion_Kind;
29054
29055 --------
29056 -- rv --
29057 --------
29058
29059 procedure rv is
29060 begin
29061 Dummy := Dummy + 1;
29062 end rv;
29063
29064 --------------------------------
29065 -- Set_Encoded_Interface_Name --
29066 --------------------------------
29067
29068 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
29069 Str : constant String_Id := Strval (S);
29070 Len : constant Nat := String_Length (Str);
29071 CC : Char_Code;
29072 C : Character;
29073 J : Pos;
29074
29075 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
29076
29077 procedure Encode;
29078 -- Stores encoded value of character code CC. The encoding we use an
29079 -- underscore followed by four lower case hex digits.
29080
29081 ------------
29082 -- Encode --
29083 ------------
29084
29085 procedure Encode is
29086 begin
29087 Store_String_Char (Get_Char_Code ('_'));
29088 Store_String_Char
29089 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
29090 Store_String_Char
29091 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
29092 Store_String_Char
29093 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
29094 Store_String_Char
29095 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
29096 end Encode;
29097
29098 -- Start of processing for Set_Encoded_Interface_Name
29099
29100 begin
29101 -- If first character is asterisk, this is a link name, and we leave it
29102 -- completely unmodified. We also ignore null strings (the latter case
29103 -- happens only in error cases).
29104
29105 if Len = 0
29106 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
29107 then
29108 Set_Interface_Name (E, S);
29109
29110 else
29111 J := 1;
29112 loop
29113 CC := Get_String_Char (Str, J);
29114
29115 exit when not In_Character_Range (CC);
29116
29117 C := Get_Character (CC);
29118
29119 exit when C /= '_' and then C /= '$'
29120 and then C not in '0' .. '9'
29121 and then C not in 'a' .. 'z'
29122 and then C not in 'A' .. 'Z';
29123
29124 if J = Len then
29125 Set_Interface_Name (E, S);
29126 return;
29127
29128 else
29129 J := J + 1;
29130 end if;
29131 end loop;
29132
29133 -- Here we need to encode. The encoding we use as follows:
29134 -- three underscores + four hex digits (lower case)
29135
29136 Start_String;
29137
29138 for J in 1 .. String_Length (Str) loop
29139 CC := Get_String_Char (Str, J);
29140
29141 if not In_Character_Range (CC) then
29142 Encode;
29143 else
29144 C := Get_Character (CC);
29145
29146 if C = '_' or else C = '$'
29147 or else C in '0' .. '9'
29148 or else C in 'a' .. 'z'
29149 or else C in 'A' .. 'Z'
29150 then
29151 Store_String_Char (CC);
29152 else
29153 Encode;
29154 end if;
29155 end if;
29156 end loop;
29157
29158 Set_Interface_Name (E,
29159 Make_String_Literal (Sloc (S),
29160 Strval => End_String));
29161 end if;
29162 end Set_Encoded_Interface_Name;
29163
29164 ------------------------
29165 -- Set_Elab_Unit_Name --
29166 ------------------------
29167
29168 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
29169 Pref : Node_Id;
29170 Scop : Entity_Id;
29171
29172 begin
29173 if Nkind (N) = N_Identifier
29174 and then Nkind (With_Item) = N_Identifier
29175 then
29176 Set_Entity (N, Entity (With_Item));
29177
29178 elsif Nkind (N) = N_Selected_Component then
29179 Change_Selected_Component_To_Expanded_Name (N);
29180 Set_Entity (N, Entity (With_Item));
29181 Set_Entity (Selector_Name (N), Entity (N));
29182
29183 Pref := Prefix (N);
29184 Scop := Scope (Entity (N));
29185 while Nkind (Pref) = N_Selected_Component loop
29186 Change_Selected_Component_To_Expanded_Name (Pref);
29187 Set_Entity (Selector_Name (Pref), Scop);
29188 Set_Entity (Pref, Scop);
29189 Pref := Prefix (Pref);
29190 Scop := Scope (Scop);
29191 end loop;
29192
29193 Set_Entity (Pref, Scop);
29194 end if;
29195
29196 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
29197 end Set_Elab_Unit_Name;
29198
29199 -------------------
29200 -- Test_Case_Arg --
29201 -------------------
29202
29203 function Test_Case_Arg
29204 (Prag : Node_Id;
29205 Arg_Nam : Name_Id;
29206 From_Aspect : Boolean := False) return Node_Id
29207 is
29208 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
29209 Arg : Node_Id;
29210 Args : Node_Id;
29211
29212 begin
29213 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
29214 Name_Mode,
29215 Name_Name,
29216 Name_Requires));
29217
29218 -- The caller requests the aspect argument
29219
29220 if From_Aspect then
29221 if Present (Aspect)
29222 and then Nkind (Expression (Aspect)) = N_Aggregate
29223 then
29224 Args := Expression (Aspect);
29225
29226 -- "Name" and "Mode" may appear without an identifier as a
29227 -- positional association.
29228
29229 if Present (Expressions (Args)) then
29230 Arg := First (Expressions (Args));
29231
29232 if Present (Arg) and then Arg_Nam = Name_Name then
29233 return Arg;
29234 end if;
29235
29236 -- Skip "Name"
29237
29238 Arg := Next (Arg);
29239
29240 if Present (Arg) and then Arg_Nam = Name_Mode then
29241 return Arg;
29242 end if;
29243 end if;
29244
29245 -- Some or all arguments may appear as component associatons
29246
29247 if Present (Component_Associations (Args)) then
29248 Arg := First (Component_Associations (Args));
29249 while Present (Arg) loop
29250 if Chars (First (Choices (Arg))) = Arg_Nam then
29251 return Arg;
29252 end if;
29253
29254 Next (Arg);
29255 end loop;
29256 end if;
29257 end if;
29258
29259 -- Otherwise retrieve the argument directly from the pragma
29260
29261 else
29262 Arg := First (Pragma_Argument_Associations (Prag));
29263
29264 if Present (Arg) and then Arg_Nam = Name_Name then
29265 return Arg;
29266 end if;
29267
29268 -- Skip argument "Name"
29269
29270 Arg := Next (Arg);
29271
29272 if Present (Arg) and then Arg_Nam = Name_Mode then
29273 return Arg;
29274 end if;
29275
29276 -- Skip argument "Mode"
29277
29278 Arg := Next (Arg);
29279
29280 -- Arguments "Requires" and "Ensures" are optional and may not be
29281 -- present at all.
29282
29283 while Present (Arg) loop
29284 if Chars (Arg) = Arg_Nam then
29285 return Arg;
29286 end if;
29287
29288 Next (Arg);
29289 end loop;
29290 end if;
29291
29292 return Empty;
29293 end Test_Case_Arg;
29294
29295 -------------------------------
29296 -- Update_Primitives_Mapping --
29297 -------------------------------
29298
29299 procedure Update_Primitives_Mapping
29300 (Inher_Id : Entity_Id;
29301 Subp_Id : Entity_Id)
29302 is
29303 function Overridden_Ancestor (S : Entity_Id) return Entity_Id;
29304 -- ??? what does this routine do?
29305
29306 -------------------------
29307 -- Overridden_Ancestor --
29308 -------------------------
29309
29310 function Overridden_Ancestor (S : Entity_Id) return Entity_Id is
29311 Par : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
29312 Anc : Entity_Id;
29313
29314 begin
29315 Anc := S;
29316
29317 -- Locate the ancestor subprogram with the proper controlling type
29318
29319 while Present (Overridden_Operation (Anc)) loop
29320 Anc := Overridden_Operation (Anc);
29321 exit when Find_Dispatching_Type (Anc) = Par;
29322 end loop;
29323
29324 return Anc;
29325 end Overridden_Ancestor;
29326
29327 -- Local variables
29328
29329 Old_Typ : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
29330 Typ : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
29331 Decl : Node_Id;
29332 Old_Elmt : Elmt_Id;
29333 Old_Prim : Entity_Id;
29334 Prim : Entity_Id;
29335
29336 -- Start of processing for Primitive_Mapping
29337
29338 begin
29339 -- If the types are already in the map, it has been previously built for
29340 -- some other overriding primitive.
29341
29342 if Primitives_Mapping.Get (Old_Typ) = Typ then
29343 return;
29344
29345 else
29346 -- Initialize new mapping with the primitive operations
29347
29348 Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id)));
29349
29350 -- Look for primitive operations of the current type that have
29351 -- overridden an operation of the type related to the original
29352 -- class-wide precondition. There may be several intermediate
29353 -- overridings between them.
29354
29355 while Present (Decl) loop
29356 if Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
29357 N_Subprogram_Declaration)
29358 then
29359 Prim := Defining_Entity (Decl);
29360
29361 if Is_Subprogram (Prim)
29362 and then Present (Overridden_Operation (Prim))
29363 and then Find_Dispatching_Type (Prim) = Typ
29364 then
29365 Old_Prim := Overridden_Ancestor (Prim);
29366
29367 Primitives_Mapping.Set (Old_Prim, Prim);
29368 end if;
29369 end if;
29370
29371 Next (Decl);
29372 end loop;
29373
29374 -- Now examine inherited operations. these do not override, but have
29375 -- an alias, which is the entity used in a call. That alias may be
29376 -- inherited or come from source, in which case it may override an
29377 -- earlier operation. We only need to examine inherited functions,
29378 -- that can appear within the inherited expression.
29379
29380 Prim := First_Entity (Scope (Subp_Id));
29381 while Present (Prim) loop
29382 if not Comes_From_Source (Prim)
29383 and then Ekind (Prim) = E_Function
29384 and then Present (Alias (Prim))
29385 then
29386 Old_Prim := Alias (Prim);
29387
29388 if Comes_From_Source (Old_Prim) then
29389 Old_Prim := Overridden_Ancestor (Old_Prim);
29390
29391 else
29392 while Present (Alias (Old_Prim))
29393 and then Scope (Old_Prim) /= Scope (Inher_Id)
29394 loop
29395 Old_Prim := Alias (Old_Prim);
29396
29397 if Comes_From_Source (Old_Prim) then
29398 Old_Prim := Overridden_Ancestor (Old_Prim);
29399 exit;
29400 end if;
29401 end loop;
29402 end if;
29403
29404 Primitives_Mapping.Set (Old_Prim, Prim);
29405 end if;
29406
29407 Next_Entity (Prim);
29408 end loop;
29409
29410 -- If the parent operation is an interface operation, the overriding
29411 -- indicator is not present. Instead, we get from the interface
29412 -- operation the primitive of the current type that implements it.
29413
29414 if Is_Interface (Old_Typ) then
29415 Old_Elmt := First_Elmt (Collect_Primitive_Operations (Old_Typ));
29416 while Present (Old_Elmt) loop
29417 Old_Prim := Node (Old_Elmt);
29418 Prim := Find_Primitive_Covering_Interface (Typ, Old_Prim);
29419
29420 if Present (Prim) then
29421 Primitives_Mapping.Set (Old_Prim, Prim);
29422 end if;
29423
29424 Next_Elmt (Old_Elmt);
29425 end loop;
29426 end if;
29427 end if;
29428
29429 -- Map the types themselves, so that the process is not repeated for
29430 -- other overriding primitives.
29431
29432 Primitives_Mapping.Set (Old_Typ, Typ);
29433 end Update_Primitives_Mapping;
29434
29435 end Sem_Prag;