PR target/58115
[official-gcc.git] / gcc / ada / sem_prag.adb
blob19d88778715fe5b4099d7ffbf811464c58e060ab
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-2013, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Csets; use Csets;
37 with Debug; use Debug;
38 with Einfo; use Einfo;
39 with Elists; use Elists;
40 with Errout; use Errout;
41 with Exp_Dist; use Exp_Dist;
42 with Exp_Util; use Exp_Util;
43 with Freeze; use Freeze;
44 with Lib; use Lib;
45 with Lib.Writ; use Lib.Writ;
46 with Lib.Xref; use Lib.Xref;
47 with Namet.Sp; use Namet.Sp;
48 with Nlists; use Nlists;
49 with Nmake; use Nmake;
50 with Opt; use Opt;
51 with Output; use Output;
52 with Par_SCO; use Par_SCO;
53 with Restrict; use Restrict;
54 with Rident; use Rident;
55 with Rtsfind; use Rtsfind;
56 with Sem; use Sem;
57 with Sem_Aux; use Sem_Aux;
58 with Sem_Ch3; use Sem_Ch3;
59 with Sem_Ch6; use Sem_Ch6;
60 with Sem_Ch8; use Sem_Ch8;
61 with Sem_Ch12; use Sem_Ch12;
62 with Sem_Ch13; use Sem_Ch13;
63 with Sem_Disp; use Sem_Disp;
64 with Sem_Dist; use Sem_Dist;
65 with Sem_Elim; use Sem_Elim;
66 with Sem_Eval; use Sem_Eval;
67 with Sem_Intr; use Sem_Intr;
68 with Sem_Mech; use Sem_Mech;
69 with Sem_Res; use Sem_Res;
70 with Sem_Type; use Sem_Type;
71 with Sem_Util; use Sem_Util;
72 with Sem_VFpt; use Sem_VFpt;
73 with Sem_Warn; use Sem_Warn;
74 with Stand; use Stand;
75 with Sinfo; use Sinfo;
76 with Sinfo.CN; use Sinfo.CN;
77 with Sinput; use Sinput;
78 with Stringt; use Stringt;
79 with Stylesw; use Stylesw;
80 with Table;
81 with Targparm; use Targparm;
82 with Tbuild; use Tbuild;
83 with Ttypes;
84 with Uintp; use Uintp;
85 with Uname; use Uname;
86 with Urealp; use Urealp;
87 with Validsw; use Validsw;
88 with Warnsw; use Warnsw;
90 package body Sem_Prag is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
100 -- pragma Export_xxx
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
105 -- pragma Import_xxx
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
111 -- IDENTIFIER
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all upper case letters for OpenVMS versions of GNAT, and to all
130 -- lower case letters for all other versions
132 -- Note: the external name specified or implied by any of these special
133 -- Import_xxx or Export_xxx pragmas override an external or link name
134 -- specified in a previous Import or Export pragma.
136 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
137 -- named notation, following the standard rules for subprogram calls, i.e.
138 -- parameters can be given in any order if named notation is used, and
139 -- positional and named notation can be mixed, subject to the rule that all
140 -- positional parameters must appear first.
142 -- Note: All these pragmas are implemented exactly following the DEC design
143 -- and implementation and are intended to be fully compatible with the use
144 -- of these pragmas in the DEC Ada compiler.
146 --------------------------------------------
147 -- Checking for Duplicated External Names --
148 --------------------------------------------
150 -- It is suspicious if two separate Export pragmas use the same external
151 -- name. The following table is used to diagnose this situation so that
152 -- an appropriate warning can be issued.
154 -- The Node_Id stored is for the N_String_Literal node created to hold
155 -- the value of the external name. The Sloc of this node is used to
156 -- cross-reference the location of the duplication.
158 package Externals is new Table.Table (
159 Table_Component_Type => Node_Id,
160 Table_Index_Type => Int,
161 Table_Low_Bound => 0,
162 Table_Initial => 100,
163 Table_Increment => 100,
164 Table_Name => "Name_Externals");
166 -------------------------------------
167 -- Local Subprograms and Variables --
168 -------------------------------------
170 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
171 -- Subsidiary routine to the analysis of pragmas Depends, Global and
172 -- Refined_State. Append an entity to a list. If the list is empty, create
173 -- a new list.
175 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
176 -- This routine is used for possible casing adjustment of an explicit
177 -- external name supplied as a string literal (the node N), according to
178 -- the casing requirement of Opt.External_Name_Casing. If this is set to
179 -- As_Is, then the string literal is returned unchanged, but if it is set
180 -- to Uppercase or Lowercase, then a new string literal with appropriate
181 -- casing is constructed.
183 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
184 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
185 -- whether a particular item appears in a mixed list of nodes and entities.
186 -- It is assumed that all nodes in the list have entities.
188 function Check_Kind (Nam : Name_Id) return Name_Id;
189 -- This function is used in connection with pragmas Assert, Check,
190 -- and assertion aspects and pragmas, to determine if Check pragmas
191 -- (or corresponding assertion aspects or pragmas) are currently active
192 -- as determined by the presence of -gnata on the command line (which
193 -- sets the default), and the appearance of pragmas Check_Policy and
194 -- Assertion_Policy as configuration pragmas either in a configuration
195 -- pragma file, or at the start of the current unit, or locally given
196 -- Check_Policy and Assertion_Policy pragmas that are currently active.
198 -- The value returned is one of the names Check, Ignore, Disable (On
199 -- returns Check, and Off returns Ignore).
201 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
202 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
203 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
204 -- _Post, _Invariant, or _Type_Invariant, which are special names used
205 -- in identifiers to represent these attribute references.
207 procedure Collect_Global_Items
208 (Prag : Node_Id;
209 In_Items : in out Elist_Id;
210 In_Out_Items : in out Elist_Id;
211 Out_Items : in out Elist_Id;
212 Has_In_State : out Boolean;
213 Has_In_Out_State : out Boolean;
214 Has_Out_State : out Boolean;
215 Has_Null_State : out Boolean);
216 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
217 -- Prag denotes pragma [Refined_]Global. Gather all input, in out and
218 -- output items of Prag in lists In_Items, In_Out_Items and Out_Items.
219 -- Flags Has_In_State, Has_In_Out_State and Has_Out_State are set when
220 -- there is at least one abstract state with visible refinement available
221 -- in the corresponding mode. Flag Has_Null_State is set when at least
222 -- state has a null refinement.
224 procedure Collect_Subprogram_Inputs_Outputs
225 (Subp_Id : Entity_Id;
226 Subp_Inputs : in out Elist_Id;
227 Subp_Outputs : in out Elist_Id;
228 Global_Seen : out Boolean);
229 -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends
230 -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id
231 -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram
232 -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen
233 -- is set when the related subprogram has pragma [Refined_]Global.
235 function Find_Related_Subprogram_Or_Body
236 (Prag : Node_Id;
237 Do_Checks : Boolean := False) return Node_Id;
238 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
239 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
240 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
241 -- Do_Checks is set, the routine reports duplicate pragmas and detects
242 -- improper use of refinement pragmas in stand alone expression functions.
243 -- The returned value depends on the related pragma as follows:
244 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
245 -- N_Subprogram_Declaration node or if the pragma applies to a stand
246 -- alone body, the N_Subprogram_Body node or Empty if illegal.
247 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
248 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
249 -- illegal.
251 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
252 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
253 -- original one, following the renaming chain) is returned. Otherwise the
254 -- entity is returned unchanged. Should be in Einfo???
256 function Get_SPARK_Mode_Id (N : Name_Id) return SPARK_Mode_Id;
257 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
258 -- Get_SPARK_Mode_Id. Convert a name into a corresponding value of type
259 -- SPARK_Mode_Id.
261 function Is_Part_Of
262 (State : Entity_Id;
263 Ancestor : Entity_Id) return Boolean;
264 -- Subsidiary to the processing of pragma Refined_Depends and pragma
265 -- Refined_Global. Determine whether abstract state State is part of an
266 -- ancestor abstract state Ancestor. For this relationship to hold, State
267 -- must have option Part_Of in its Abstract_State definition.
269 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
270 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
271 -- pragma Depends. Determine whether the type of dependency item Item is
272 -- tagged, unconstrained array, unconstrained record or a record with at
273 -- least one unconstrained component.
275 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id);
276 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
277 -- of a Test_Case pragma if present (possibly Empty). We treat these as
278 -- spec expressions (i.e. similar to a default expression).
280 procedure Record_Possible_Body_Reference
281 (Item : Node_Id;
282 Item_Id : Entity_Id);
283 -- Given an entity reference (Item) and the corresponding Entity (Item_Id),
284 -- determines if we have a body reference to an abstract state, which may
285 -- be illegal if the state is refined within the body.
287 procedure Rewrite_Assertion_Kind (N : Node_Id);
288 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
289 -- then it is rewritten as an identifier with the corresponding special
290 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
291 -- Check, Check_Policy.
293 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
294 -- Place semantic information on the argument of an Elaborate/Elaborate_All
295 -- pragma. Entity name for unit and its parents is taken from item in
296 -- previous with_clause that mentions the unit.
298 procedure rv;
299 -- This is a dummy function called by the processing for pragma Reviewable.
300 -- It is there for assisting front end debugging. By placing a Reviewable
301 -- pragma in the source program, a breakpoint on rv catches this place in
302 -- the source, allowing convenient stepping to the point of interest.
304 --------------
305 -- Add_Item --
306 --------------
308 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
309 begin
310 if No (To_List) then
311 To_List := New_Elmt_List;
312 end if;
314 Append_Elmt (Item, To_List);
315 end Add_Item;
317 -------------------------------
318 -- Adjust_External_Name_Case --
319 -------------------------------
321 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
322 CC : Char_Code;
324 begin
325 -- Adjust case of literal if required
327 if Opt.External_Name_Exp_Casing = As_Is then
328 return N;
330 else
331 -- Copy existing string
333 Start_String;
335 -- Set proper casing
337 for J in 1 .. String_Length (Strval (N)) loop
338 CC := Get_String_Char (Strval (N), J);
340 if Opt.External_Name_Exp_Casing = Uppercase
341 and then CC >= Get_Char_Code ('a')
342 and then CC <= Get_Char_Code ('z')
343 then
344 Store_String_Char (CC - 32);
346 elsif Opt.External_Name_Exp_Casing = Lowercase
347 and then CC >= Get_Char_Code ('A')
348 and then CC <= Get_Char_Code ('Z')
349 then
350 Store_String_Char (CC + 32);
352 else
353 Store_String_Char (CC);
354 end if;
355 end loop;
357 return
358 Make_String_Literal (Sloc (N),
359 Strval => End_String);
360 end if;
361 end Adjust_External_Name_Case;
363 -----------------------------------------
364 -- Analyze_Contract_Cases_In_Decl_Part --
365 -----------------------------------------
367 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is
368 Others_Seen : Boolean := False;
370 procedure Analyze_Contract_Case (CCase : Node_Id);
371 -- Verify the legality of a single contract case
373 ---------------------------
374 -- Analyze_Contract_Case --
375 ---------------------------
377 procedure Analyze_Contract_Case (CCase : Node_Id) is
378 Case_Guard : Node_Id;
379 Conseq : Node_Id;
380 Extra_Guard : Node_Id;
382 begin
383 if Nkind (CCase) = N_Component_Association then
384 Case_Guard := First (Choices (CCase));
385 Conseq := Expression (CCase);
387 -- Each contract case must have exactly one case guard
389 Extra_Guard := Next (Case_Guard);
391 if Present (Extra_Guard) then
392 Error_Msg_N
393 ("contract case may have only one case guard", Extra_Guard);
394 end if;
396 -- Check the placement of "others" (if available)
398 if Nkind (Case_Guard) = N_Others_Choice then
399 if Others_Seen then
400 Error_Msg_N
401 ("only one others choice allowed in aspect Contract_Cases",
402 Case_Guard);
403 else
404 Others_Seen := True;
405 end if;
407 elsif Others_Seen then
408 Error_Msg_N
409 ("others must be the last choice in aspect Contract_Cases",
411 end if;
413 -- Preanalyze the case guard and consequence
415 if Nkind (Case_Guard) /= N_Others_Choice then
416 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
417 end if;
419 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
421 -- The contract case is malformed
423 else
424 Error_Msg_N ("wrong syntax in contract case", CCase);
425 end if;
426 end Analyze_Contract_Case;
428 -- Local variables
430 All_Cases : Node_Id;
431 CCase : Node_Id;
432 Subp_Decl : Node_Id;
433 Subp_Id : Entity_Id;
435 Restore_Scope : Boolean := False;
436 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
438 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
440 begin
441 Set_Analyzed (N);
443 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
444 Subp_Id := Defining_Entity (Subp_Decl);
445 All_Cases := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
447 -- Multiple contract cases appear in aggregate form
449 if Nkind (All_Cases) = N_Aggregate then
450 if No (Component_Associations (All_Cases)) then
451 Error_Msg_N ("wrong syntax for aspect Contract_Cases", N);
453 -- Individual contract cases appear as component associations
455 else
456 -- Ensure that the formal parameters are visible when analyzing
457 -- all clauses. This falls out of the general rule of aspects
458 -- pertaining to subprogram declarations. Skip the installation
459 -- for subprogram bodies because the formals are already visible.
461 if not In_Open_Scopes (Subp_Id) then
462 Restore_Scope := True;
463 Push_Scope (Subp_Id);
464 Install_Formals (Subp_Id);
465 end if;
467 CCase := First (Component_Associations (All_Cases));
468 while Present (CCase) loop
469 Analyze_Contract_Case (CCase);
470 Next (CCase);
471 end loop;
473 if Restore_Scope then
474 End_Scope;
475 end if;
476 end if;
478 else
479 Error_Msg_N ("wrong syntax for aspect Contract_Cases", N);
480 end if;
481 end Analyze_Contract_Cases_In_Decl_Part;
483 ----------------------------------
484 -- Analyze_Depends_In_Decl_Part --
485 ----------------------------------
487 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
488 Loc : constant Source_Ptr := Sloc (N);
490 All_Inputs_Seen : Elist_Id := No_Elist;
491 -- A list containing the entities of all the inputs processed so far.
492 -- The list is populated with unique entities because the same input
493 -- may appear in multiple input lists.
495 All_Outputs_Seen : Elist_Id := No_Elist;
496 -- A list containing the entities of all the outputs processed so far.
497 -- The list is populated with unique entities because output items are
498 -- unique in a dependence relation.
500 Global_Seen : Boolean := False;
501 -- A flag set when pragma Global has been processed
503 Null_Output_Seen : Boolean := False;
504 -- A flag used to track the legality of a null output
506 Result_Seen : Boolean := False;
507 -- A flag set when Subp_Id'Result is processed
509 Spec_Id : Entity_Id;
510 -- The entity of the subprogram subject to pragma [Refined_]Depends
512 Subp_Id : Entity_Id;
513 -- The entity of the subprogram [body or stub] subject to pragma
514 -- [Refined_]Depends.
516 Subp_Inputs : Elist_Id := No_Elist;
517 Subp_Outputs : Elist_Id := No_Elist;
518 -- Two lists containing the full set of inputs and output of the related
519 -- subprograms. Note that these lists contain both nodes and entities.
521 procedure Analyze_Dependency_Clause
522 (Clause : Node_Id;
523 Is_Last : Boolean);
524 -- Verify the legality of a single dependency clause. Flag Is_Last
525 -- denotes whether Clause is the last clause in the relation.
527 procedure Check_Function_Return;
528 -- Verify that Funtion'Result appears as one of the outputs
530 procedure Check_Mode
531 (Item : Node_Id;
532 Item_Id : Entity_Id;
533 Is_Input : Boolean;
534 Self_Ref : Boolean);
535 -- Ensure that an item has a proper IN, IN OUT, or OUT mode depending
536 -- on its function. If this is not the case, emit an error. Item and
537 -- Item_Id denote the attributes of an item. Flag Is_Input should be set
538 -- when item comes from an input list. Flag Self_Ref should be set when
539 -- the item is an output and the dependency clause has operator "+".
541 procedure Check_Usage
542 (Subp_Items : Elist_Id;
543 Used_Items : Elist_Id;
544 Is_Input : Boolean);
545 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
546 -- error if this is not the case.
548 procedure Normalize_Clause (Clause : Node_Id);
549 -- Remove a self-dependency "+" from the input list of a clause. Split
550 -- a clause with multiple outputs into multiple clauses with a single
551 -- output.
553 -------------------------------
554 -- Analyze_Dependency_Clause --
555 -------------------------------
557 procedure Analyze_Dependency_Clause
558 (Clause : Node_Id;
559 Is_Last : Boolean)
561 procedure Analyze_Input_List (Inputs : Node_Id);
562 -- Verify the legality of a single input list
564 procedure Analyze_Input_Output
565 (Item : Node_Id;
566 Is_Input : Boolean;
567 Self_Ref : Boolean;
568 Top_Level : Boolean;
569 Seen : in out Elist_Id;
570 Null_Seen : in out Boolean;
571 Non_Null_Seen : in out Boolean);
572 -- Verify the legality of a single input or output item. Flag
573 -- Is_Input should be set whenever Item is an input, False when it
574 -- denotes an output. Flag Self_Ref should be set when the item is an
575 -- output and the dependency clause has a "+". Flag Top_Level should
576 -- be set whenever Item appears immediately within an input or output
577 -- list. Seen is a collection of all abstract states, variables and
578 -- formals processed so far. Flag Null_Seen denotes whether a null
579 -- input or output has been encountered. Flag Non_Null_Seen denotes
580 -- whether a non-null input or output has been encountered.
582 ------------------------
583 -- Analyze_Input_List --
584 ------------------------
586 procedure Analyze_Input_List (Inputs : Node_Id) is
587 Inputs_Seen : Elist_Id := No_Elist;
588 -- A list containing the entities of all inputs that appear in the
589 -- current input list.
591 Non_Null_Input_Seen : Boolean := False;
592 Null_Input_Seen : Boolean := False;
593 -- Flags used to check the legality of an input list
595 Input : Node_Id;
597 begin
598 -- Multiple inputs appear as an aggregate
600 if Nkind (Inputs) = N_Aggregate then
601 if Present (Component_Associations (Inputs)) then
602 Error_Msg_N
603 ("nested dependency relations not allowed", Inputs);
605 elsif Present (Expressions (Inputs)) then
606 Input := First (Expressions (Inputs));
607 while Present (Input) loop
608 Analyze_Input_Output
609 (Item => Input,
610 Is_Input => True,
611 Self_Ref => False,
612 Top_Level => False,
613 Seen => Inputs_Seen,
614 Null_Seen => Null_Input_Seen,
615 Non_Null_Seen => Non_Null_Input_Seen);
617 Next (Input);
618 end loop;
620 else
621 Error_Msg_N ("malformed input dependency list", Inputs);
622 end if;
624 -- Process a solitary input
626 else
627 Analyze_Input_Output
628 (Item => Inputs,
629 Is_Input => True,
630 Self_Ref => False,
631 Top_Level => False,
632 Seen => Inputs_Seen,
633 Null_Seen => Null_Input_Seen,
634 Non_Null_Seen => Non_Null_Input_Seen);
635 end if;
637 -- Detect an illegal dependency clause of the form
639 -- (null =>[+] null)
641 if Null_Output_Seen and then Null_Input_Seen then
642 Error_Msg_N
643 ("null dependency clause cannot have a null input list",
644 Inputs);
645 end if;
646 end Analyze_Input_List;
648 --------------------------
649 -- Analyze_Input_Output --
650 --------------------------
652 procedure Analyze_Input_Output
653 (Item : Node_Id;
654 Is_Input : Boolean;
655 Self_Ref : Boolean;
656 Top_Level : Boolean;
657 Seen : in out Elist_Id;
658 Null_Seen : in out Boolean;
659 Non_Null_Seen : in out Boolean)
661 Is_Output : constant Boolean := not Is_Input;
662 Grouped : Node_Id;
663 Item_Id : Entity_Id;
665 begin
666 -- Multiple input or output items appear as an aggregate
668 if Nkind (Item) = N_Aggregate then
669 if not Top_Level then
670 Error_Msg_N ("nested grouping of items not allowed", Item);
672 elsif Present (Component_Associations (Item)) then
673 Error_Msg_N
674 ("nested dependency relations not allowed", Item);
676 -- Recursively analyze the grouped items
678 elsif Present (Expressions (Item)) then
679 Grouped := First (Expressions (Item));
680 while Present (Grouped) loop
681 Analyze_Input_Output
682 (Item => Grouped,
683 Is_Input => Is_Input,
684 Self_Ref => Self_Ref,
685 Top_Level => False,
686 Seen => Seen,
687 Null_Seen => Null_Seen,
688 Non_Null_Seen => Non_Null_Seen);
690 Next (Grouped);
691 end loop;
693 else
694 Error_Msg_N ("malformed dependency list", Item);
695 end if;
697 -- Process Function'Result in the context of a dependency clause
699 elsif Is_Attribute_Result (Item) then
700 Non_Null_Seen := True;
702 -- It is sufficent to analyze the prefix of 'Result in order to
703 -- establish legality of the attribute.
705 Analyze (Prefix (Item));
707 -- The prefix of 'Result must denote the function for which
708 -- pragma Depends applies.
710 if not Is_Entity_Name (Prefix (Item))
711 or else Ekind (Spec_Id) /= E_Function
712 or else Entity (Prefix (Item)) /= Spec_Id
713 then
714 Error_Msg_Name_1 := Name_Result;
715 Error_Msg_N
716 ("prefix of attribute % must denote the enclosing "
717 & "function", Item);
719 -- Function'Result is allowed to appear on the output side of a
720 -- dependency clause.
722 elsif Is_Input then
723 Error_Msg_N ("function result cannot act as input", Item);
725 elsif Null_Seen then
726 Error_Msg_N
727 ("cannot mix null and non-null dependency items", Item);
729 else
730 Result_Seen := True;
731 end if;
733 -- Detect multiple uses of null in a single dependency list or
734 -- throughout the whole relation. Verify the placement of a null
735 -- output list relative to the other clauses.
737 elsif Nkind (Item) = N_Null then
738 if Null_Seen then
739 Error_Msg_N
740 ("multiple null dependency relations not allowed", Item);
742 elsif Non_Null_Seen then
743 Error_Msg_N
744 ("cannot mix null and non-null dependency items", Item);
746 else
747 Null_Seen := True;
749 if Is_Output then
750 if not Is_Last then
751 Error_Msg_N
752 ("null output list must be the last clause in a "
753 & "dependency relation", Item);
755 -- Catch a useless dependence of the form:
756 -- null =>+ ...
758 elsif Self_Ref then
759 Error_Msg_N
760 ("useless dependence, null depends on itself", Item);
761 end if;
762 end if;
763 end if;
765 -- Default case
767 else
768 Non_Null_Seen := True;
770 if Null_Seen then
771 Error_Msg_N ("cannot mix null and non-null items", Item);
772 end if;
774 Analyze (Item);
776 -- Find the entity of the item. If this is a renaming, climb
777 -- the renaming chain to reach the root object. Renamings of
778 -- non-entire objects do not yield an entity (Empty).
780 Item_Id := Entity_Of (Item);
782 Record_Possible_Body_Reference (Item, Item_Id);
784 if Present (Item_Id) then
785 if Ekind_In (Item_Id, E_Abstract_State,
786 E_In_Parameter,
787 E_In_Out_Parameter,
788 E_Out_Parameter,
789 E_Variable)
790 then
791 -- Ensure that the item is of the correct mode depending
792 -- on its function.
794 Check_Mode (Item, Item_Id, Is_Input, Self_Ref);
796 -- Detect multiple uses of the same state, variable or
797 -- formal parameter. If this is not the case, add the
798 -- item to the list of processed relations.
800 if Contains (Seen, Item_Id) then
801 Error_Msg_N ("duplicate use of item", Item);
802 else
803 Add_Item (Item_Id, Seen);
804 end if;
806 -- Detect illegal use of an input related to a null
807 -- output. Such input items cannot appear in other
808 -- input lists.
810 if Is_Input
811 and then Null_Output_Seen
812 and then Contains (All_Inputs_Seen, Item_Id)
813 then
814 Error_Msg_N
815 ("input of a null output list appears in multiple "
816 & "input lists", Item);
817 end if;
819 -- Add an input or a self-referential output to the list
820 -- of all processed inputs.
822 if Is_Input or else Self_Ref then
823 Add_Item (Item_Id, All_Inputs_Seen);
824 end if;
826 if Ekind (Item_Id) = E_Abstract_State then
828 -- The state acts as a constituent of some other
829 -- state. Ensure that the other state is a proper
830 -- ancestor of the item.
832 if Present (Refined_State (Item_Id)) then
833 if not Is_Part_Of
834 (Item_Id, Refined_State (Item_Id))
835 then
836 Error_Msg_Name_1 :=
837 Chars (Refined_State (Item_Id));
838 Error_Msg_NE
839 ("state & is not a valid constituent of "
840 & "ancestor state %", Item, Item_Id);
841 return;
842 end if;
844 -- An abstract state with visible refinement cannot
845 -- appear in pragma [Refined_]Global as its place must
846 -- be taken by some of its constituents.
848 elsif Has_Visible_Refinement (Item_Id) then
849 Error_Msg_NE
850 ("cannot mention state & in global refinement, "
851 & "use its constituents instead", Item, Item_Id);
852 return;
853 end if;
854 end if;
856 -- When the item renames an entire object, replace the
857 -- item with a reference to the object.
859 if Present (Renamed_Object (Entity (Item))) then
860 Rewrite (Item,
861 New_Reference_To (Item_Id, Sloc (Item)));
862 Analyze (Item);
863 end if;
865 -- All other input/output items are illegal
867 else
868 Error_Msg_N
869 ("item must denote variable, state or formal "
870 & "parameter", Item);
871 end if;
873 -- All other input/output items are illegal
875 else
876 Error_Msg_N
877 ("item must denote variable, state or formal parameter",
878 Item);
879 end if;
880 end if;
881 end Analyze_Input_Output;
883 -- Local variables
885 Inputs : Node_Id;
886 Output : Node_Id;
887 Self_Ref : Boolean;
889 Non_Null_Output_Seen : Boolean := False;
890 -- Flag used to check the legality of an output list
892 -- Start of processing for Analyze_Dependency_Clause
894 begin
895 Inputs := Expression (Clause);
896 Self_Ref := False;
898 -- An input list with a self-dependency appears as operator "+" where
899 -- the actuals inputs are the right operand.
901 if Nkind (Inputs) = N_Op_Plus then
902 Inputs := Right_Opnd (Inputs);
903 Self_Ref := True;
904 end if;
906 -- Process the output_list of a dependency_clause
908 Output := First (Choices (Clause));
909 while Present (Output) loop
910 Analyze_Input_Output
911 (Item => Output,
912 Is_Input => False,
913 Self_Ref => Self_Ref,
914 Top_Level => True,
915 Seen => All_Outputs_Seen,
916 Null_Seen => Null_Output_Seen,
917 Non_Null_Seen => Non_Null_Output_Seen);
919 Next (Output);
920 end loop;
922 -- Process the input_list of a dependency_clause
924 Analyze_Input_List (Inputs);
925 end Analyze_Dependency_Clause;
927 ----------------------------
928 -- Check_Function_Return --
929 ----------------------------
931 procedure Check_Function_Return is
932 begin
933 if Ekind (Spec_Id) = E_Function and then not Result_Seen then
934 Error_Msg_NE
935 ("result of & must appear in exactly one output list",
936 N, Spec_Id);
937 end if;
938 end Check_Function_Return;
940 ----------------
941 -- Check_Mode --
942 ----------------
944 procedure Check_Mode
945 (Item : Node_Id;
946 Item_Id : Entity_Id;
947 Is_Input : Boolean;
948 Self_Ref : Boolean)
950 begin
951 -- Input
953 if Is_Input then
955 -- IN and IN OUT parameters already have the proper mode to act
956 -- as input. OUT parameters are valid inputs only when their type
957 -- is unconstrained or tagged as their discriminants, array bouns
958 -- or tags can be read. In general, states and variables are
959 -- considered to have mode IN OUT unless they are classified by
960 -- pragma [Refined_]Global. In that case, the item must appear in
961 -- an input global list.
963 if (Ekind (Item_Id) = E_Out_Parameter
964 and then not Is_Unconstrained_Or_Tagged_Item (Item_Id))
965 or else
966 (Global_Seen and then not Appears_In (Subp_Inputs, Item_Id))
967 then
968 Error_Msg_NE
969 ("item & must have mode IN or `IN OUT`", Item, Item_Id);
970 end if;
972 -- Self-referential output
974 elsif Self_Ref then
976 -- In general, states and variables are considered to have mode
977 -- IN OUT unless they are explicitly moded by pragma [Refined_]
978 -- Global. If this is the case, then the item must appear in both
979 -- an input and output global list.
981 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
982 if Global_Seen
983 and then not
984 (Appears_In (Subp_Inputs, Item_Id)
985 and then
986 Appears_In (Subp_Outputs, Item_Id))
987 then
988 Error_Msg_NE
989 ("item & must have mode `IN OUT`", Item, Item_Id);
990 end if;
992 -- A self-referential OUT parameter of an unconstrained or tagged
993 -- type acts as an input because the discriminants, array bounds
994 -- or the tag may be read. Note that the presence of [Refined_]
995 -- Global is not significant here because the item is a parameter.
997 elsif Ekind (Item_Id) = E_Out_Parameter
998 and then Is_Unconstrained_Or_Tagged_Item (Item_Id)
999 then
1000 null;
1002 -- The remaining cases are IN, IN OUT, and OUT parameters. To
1003 -- qualify as self-referential item, the parameter must be of
1004 -- mode IN OUT.
1006 elsif Ekind (Item_Id) /= E_In_Out_Parameter then
1007 Error_Msg_NE ("item & must have mode `IN OUT`", Item, Item_Id);
1008 end if;
1010 -- Output
1012 -- IN OUT and OUT parameters already have the proper mode to act as
1013 -- output. In general, states and variables are considered to have
1014 -- mode IN OUT unless they are moded by pragma [Refined_]Global. In
1015 -- that case, the item must appear in an output global list.
1017 elsif Ekind (Item_Id) = E_In_Parameter
1018 or else
1019 (Global_Seen and then not Appears_In (Subp_Outputs, Item_Id))
1020 then
1021 Error_Msg_NE
1022 ("item & must have mode OUT or `IN OUT`", Item, Item_Id);
1023 end if;
1024 end Check_Mode;
1026 -----------------
1027 -- Check_Usage --
1028 -----------------
1030 procedure Check_Usage
1031 (Subp_Items : Elist_Id;
1032 Used_Items : Elist_Id;
1033 Is_Input : Boolean)
1035 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
1036 -- Emit an error concerning the erroneous usage of an item
1038 -----------------
1039 -- Usage_Error --
1040 -----------------
1042 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
1043 begin
1044 if Is_Input then
1045 Error_Msg_NE
1046 ("item & must appear in at least one input list of aspect "
1047 & "Depends", Item, Item_Id);
1048 else
1049 Error_Msg_NE
1050 ("item & must appear in exactly one output list of aspect "
1051 & "Depends", Item, Item_Id);
1052 end if;
1053 end Usage_Error;
1055 -- Local variables
1057 Elmt : Elmt_Id;
1058 Item : Node_Id;
1059 Item_Id : Entity_Id;
1061 -- Start of processing for Check_Usage
1063 begin
1064 if No (Subp_Items) then
1065 return;
1066 end if;
1068 -- Each input or output of the subprogram must appear in a dependency
1069 -- relation.
1071 Elmt := First_Elmt (Subp_Items);
1072 while Present (Elmt) loop
1073 Item := Node (Elmt);
1075 if Nkind (Item) = N_Defining_Identifier then
1076 Item_Id := Item;
1077 else
1078 Item_Id := Entity (Item);
1079 end if;
1081 -- The item does not appear in a dependency
1083 if not Contains (Used_Items, Item_Id) then
1084 if Is_Formal (Item_Id) then
1085 Usage_Error (Item, Item_Id);
1087 -- States and global variables are not used properly only when
1088 -- the subprogram is subject to pragma Global.
1090 elsif Global_Seen then
1091 Usage_Error (Item, Item_Id);
1092 end if;
1093 end if;
1095 Next_Elmt (Elmt);
1096 end loop;
1097 end Check_Usage;
1099 ----------------------
1100 -- Normalize_Clause --
1101 ----------------------
1103 procedure Normalize_Clause (Clause : Node_Id) is
1104 procedure Create_Or_Modify_Clause
1105 (Output : Node_Id;
1106 Outputs : Node_Id;
1107 Inputs : Node_Id;
1108 After : Node_Id;
1109 In_Place : Boolean;
1110 Multiple : Boolean);
1111 -- Create a brand new clause to represent the self-reference or
1112 -- modify the input and/or output lists of an existing clause. Output
1113 -- denotes a self-referencial output. Outputs is the output list of a
1114 -- clause. Inputs is the input list of a clause. After denotes the
1115 -- clause after which the new clause is to be inserted. Flag In_Place
1116 -- should be set when normalizing the last output of an output list.
1117 -- Flag Multiple should be set when Output comes from a list with
1118 -- multiple items.
1120 procedure Split_Multiple_Outputs;
1121 -- If Clause contains more than one output, split the clause into
1122 -- multiple clauses with a single output. All new clauses are added
1123 -- after Clause.
1125 -----------------------------
1126 -- Create_Or_Modify_Clause --
1127 -----------------------------
1129 procedure Create_Or_Modify_Clause
1130 (Output : Node_Id;
1131 Outputs : Node_Id;
1132 Inputs : Node_Id;
1133 After : Node_Id;
1134 In_Place : Boolean;
1135 Multiple : Boolean)
1137 procedure Propagate_Output
1138 (Output : Node_Id;
1139 Inputs : Node_Id);
1140 -- Handle the various cases of output propagation to the input
1141 -- list. Output denotes a self-referencial output item. Inputs is
1142 -- the input list of a clause.
1144 ----------------------
1145 -- Propagate_Output --
1146 ----------------------
1148 procedure Propagate_Output
1149 (Output : Node_Id;
1150 Inputs : Node_Id)
1152 function In_Input_List
1153 (Item : Entity_Id;
1154 Inputs : List_Id) return Boolean;
1155 -- Determine whether a particulat item appears in the input
1156 -- list of a clause.
1158 -------------------
1159 -- In_Input_List --
1160 -------------------
1162 function In_Input_List
1163 (Item : Entity_Id;
1164 Inputs : List_Id) return Boolean
1166 Elmt : Node_Id;
1168 begin
1169 Elmt := First (Inputs);
1170 while Present (Elmt) loop
1171 if Entity_Of (Elmt) = Item then
1172 return True;
1173 end if;
1175 Next (Elmt);
1176 end loop;
1178 return False;
1179 end In_Input_List;
1181 -- Local variables
1183 Output_Id : constant Entity_Id := Entity_Of (Output);
1184 Grouped : List_Id;
1186 -- Start of processing for Propagate_Output
1188 begin
1189 -- The clause is of the form:
1191 -- (Output =>+ null)
1193 -- Remove the null input and replace it with a copy of the
1194 -- output:
1196 -- (Output => Output)
1198 if Nkind (Inputs) = N_Null then
1199 Rewrite (Inputs, New_Copy_Tree (Output));
1201 -- The clause is of the form:
1203 -- (Output =>+ (Input1, ..., InputN))
1205 -- Determine whether the output is not already mentioned in the
1206 -- input list and if not, add it to the list of inputs:
1208 -- (Output => (Output, Input1, ..., InputN))
1210 elsif Nkind (Inputs) = N_Aggregate then
1211 Grouped := Expressions (Inputs);
1213 if not In_Input_List
1214 (Item => Output_Id,
1215 Inputs => Grouped)
1216 then
1217 Prepend_To (Grouped, New_Copy_Tree (Output));
1218 end if;
1220 -- The clause is of the form:
1222 -- (Output =>+ Input)
1224 -- If the input does not mention the output, group the two
1225 -- together:
1227 -- (Output => (Output, Input))
1229 elsif Entity_Of (Inputs) /= Output_Id then
1230 Rewrite (Inputs,
1231 Make_Aggregate (Loc,
1232 Expressions => New_List (
1233 New_Copy_Tree (Output),
1234 New_Copy_Tree (Inputs))));
1235 end if;
1236 end Propagate_Output;
1238 -- Local variables
1240 Loc : constant Source_Ptr := Sloc (Clause);
1241 New_Clause : Node_Id;
1243 -- Start of processing for Create_Or_Modify_Clause
1245 begin
1246 -- A null output depending on itself does not require any
1247 -- normalization.
1249 if Nkind (Output) = N_Null then
1250 return;
1252 -- A function result cannot depend on itself because it cannot
1253 -- appear in the input list of a relation.
1255 elsif Is_Attribute_Result (Output) then
1256 Error_Msg_N ("function result cannot depend on itself", Output);
1257 return;
1258 end if;
1260 -- When performing the transformation in place, simply add the
1261 -- output to the list of inputs (if not already there). This case
1262 -- arises when dealing with the last output of an output list -
1263 -- we perform the normalization in place to avoid generating a
1264 -- malformed tree.
1266 if In_Place then
1267 Propagate_Output (Output, Inputs);
1269 -- A list with multiple outputs is slowly trimmed until only
1270 -- one element remains. When this happens, replace the
1271 -- aggregate with the element itself.
1273 if Multiple then
1274 Remove (Output);
1275 Rewrite (Outputs, Output);
1276 end if;
1278 -- Default case
1280 else
1281 -- Unchain the output from its output list as it will appear in
1282 -- a new clause. Note that we cannot simply rewrite the output
1283 -- as null because this will violate the semantics of pragma
1284 -- Depends.
1286 Remove (Output);
1288 -- Generate a new clause of the form:
1289 -- (Output => Inputs)
1291 New_Clause :=
1292 Make_Component_Association (Loc,
1293 Choices => New_List (Output),
1294 Expression => New_Copy_Tree (Inputs));
1296 -- The new clause contains replicated content that has already
1297 -- been analyzed. There is not need to reanalyze it or
1298 -- renormalize it again.
1300 Set_Analyzed (New_Clause);
1302 Propagate_Output
1303 (Output => First (Choices (New_Clause)),
1304 Inputs => Expression (New_Clause));
1306 Insert_After (After, New_Clause);
1307 end if;
1308 end Create_Or_Modify_Clause;
1310 ----------------------------
1311 -- Split_Multiple_Outputs --
1312 ----------------------------
1314 procedure Split_Multiple_Outputs is
1315 Inputs : constant Node_Id := Expression (Clause);
1316 Loc : constant Source_Ptr := Sloc (Clause);
1317 Outputs : constant Node_Id := First (Choices (Clause));
1318 Last_Output : Node_Id;
1319 Next_Output : Node_Id;
1320 Output : Node_Id;
1321 Split : Node_Id;
1323 -- Start of processing for Split_Multiple_Outputs
1325 begin
1326 -- Multiple outputs appear as an aggregate. Nothing to do when
1327 -- the clause has exactly one output.
1329 if Nkind (Outputs) = N_Aggregate then
1330 Last_Output := Last (Expressions (Outputs));
1332 -- Create a clause for each output. Note that each time a new
1333 -- clause is created, the original output list slowly shrinks
1334 -- until there is one item left.
1336 Output := First (Expressions (Outputs));
1337 while Present (Output) loop
1338 Next_Output := Next (Output);
1340 -- Unhook the output from the original output list as it
1341 -- will be relocated to a new clause.
1343 Remove (Output);
1345 -- Special processing for the last output. At this point
1346 -- the original aggregate has been stripped down to one
1347 -- element. Replace the aggregate by the element itself.
1349 if Output = Last_Output then
1350 Rewrite (Outputs, Output);
1352 else
1353 -- Generate a clause of the form:
1354 -- (Output => Inputs)
1356 Split :=
1357 Make_Component_Association (Loc,
1358 Choices => New_List (Output),
1359 Expression => New_Copy_Tree (Inputs));
1361 -- The new clause contains replicated content that has
1362 -- already been analyzed. There is not need to reanalyze
1363 -- them.
1365 Set_Analyzed (Split);
1366 Insert_After (Clause, Split);
1367 end if;
1369 Output := Next_Output;
1370 end loop;
1371 end if;
1372 end Split_Multiple_Outputs;
1374 -- Local variables
1376 Outputs : constant Node_Id := First (Choices (Clause));
1377 Inputs : Node_Id;
1378 Last_Output : Node_Id;
1379 Next_Output : Node_Id;
1380 Output : Node_Id;
1382 -- Start of processing for Normalize_Clause
1384 begin
1385 -- A self-dependency appears as operator "+". Remove the "+" from the
1386 -- tree by moving the real inputs to their proper place.
1388 if Nkind (Expression (Clause)) = N_Op_Plus then
1389 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1390 Inputs := Expression (Clause);
1392 -- Multiple outputs appear as an aggregate
1394 if Nkind (Outputs) = N_Aggregate then
1395 Last_Output := Last (Expressions (Outputs));
1397 Output := First (Expressions (Outputs));
1398 while Present (Output) loop
1400 -- Normalization may remove an output from its list,
1401 -- preserve the subsequent output now.
1403 Next_Output := Next (Output);
1405 Create_Or_Modify_Clause
1406 (Output => Output,
1407 Outputs => Outputs,
1408 Inputs => Inputs,
1409 After => Clause,
1410 In_Place => Output = Last_Output,
1411 Multiple => True);
1413 Output := Next_Output;
1414 end loop;
1416 -- Solitary output
1418 else
1419 Create_Or_Modify_Clause
1420 (Output => Outputs,
1421 Outputs => Empty,
1422 Inputs => Inputs,
1423 After => Empty,
1424 In_Place => True,
1425 Multiple => False);
1426 end if;
1427 end if;
1429 -- Split a clause with multiple outputs into multiple clauses with a
1430 -- single output.
1432 Split_Multiple_Outputs;
1433 end Normalize_Clause;
1435 -- Local variables
1437 Clause : Node_Id;
1438 Errors : Nat;
1439 Last_Clause : Node_Id;
1440 Subp_Decl : Node_Id;
1442 Restore_Scope : Boolean := False;
1443 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1445 -- Start of processing for Analyze_Depends_In_Decl_Part
1447 begin
1448 Set_Analyzed (N);
1450 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
1451 Subp_Id := Defining_Entity (Subp_Decl);
1453 -- The logic in this routine is used to analyze both pragma Depends and
1454 -- pragma Refined_Depends since they have the same syntax and base
1455 -- semantics. Find the entity of the corresponding spec when analyzing
1456 -- Refined_Depends.
1458 if Nkind (Subp_Decl) = N_Subprogram_Body
1459 and then not Acts_As_Spec (Subp_Decl)
1460 then
1461 Spec_Id := Corresponding_Spec (Subp_Decl);
1463 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
1464 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
1466 else
1467 Spec_Id := Subp_Id;
1468 end if;
1470 Clause := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
1472 -- Empty dependency list
1474 if Nkind (Clause) = N_Null then
1476 -- Gather all states, variables and formal parameters that the
1477 -- subprogram may depend on. These items are obtained from the
1478 -- parameter profile or pragma [Refined_]Global (if available).
1480 Collect_Subprogram_Inputs_Outputs
1481 (Subp_Id => Subp_Id,
1482 Subp_Inputs => Subp_Inputs,
1483 Subp_Outputs => Subp_Outputs,
1484 Global_Seen => Global_Seen);
1486 -- Verify that every input or output of the subprogram appear in a
1487 -- dependency.
1489 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1490 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1491 Check_Function_Return;
1493 -- Dependency clauses appear as component associations of an aggregate
1495 elsif Nkind (Clause) = N_Aggregate
1496 and then Present (Component_Associations (Clause))
1497 then
1498 Last_Clause := Last (Component_Associations (Clause));
1500 -- Gather all states, variables and formal parameters that the
1501 -- subprogram may depend on. These items are obtained from the
1502 -- parameter profile or pragma [Refined_]Global (if available).
1504 Collect_Subprogram_Inputs_Outputs
1505 (Subp_Id => Subp_Id,
1506 Subp_Inputs => Subp_Inputs,
1507 Subp_Outputs => Subp_Outputs,
1508 Global_Seen => Global_Seen);
1510 -- Ensure that the formal parameters are visible when analyzing all
1511 -- clauses. This falls out of the general rule of aspects pertaining
1512 -- to subprogram declarations. Skip the installation for subprogram
1513 -- bodies because the formals are already visible.
1515 if not In_Open_Scopes (Spec_Id) then
1516 Restore_Scope := True;
1517 Push_Scope (Spec_Id);
1518 Install_Formals (Spec_Id);
1519 end if;
1521 Clause := First (Component_Associations (Clause));
1522 while Present (Clause) loop
1523 Errors := Serious_Errors_Detected;
1525 -- Normalization may create extra clauses that contain replicated
1526 -- input and output names. There is no need to reanalyze them.
1528 if not Analyzed (Clause) then
1529 Set_Analyzed (Clause);
1531 Analyze_Dependency_Clause
1532 (Clause => Clause,
1533 Is_Last => Clause = Last_Clause);
1534 end if;
1536 -- Do not normalize an erroneous clause because the inputs and/or
1537 -- outputs may denote illegal items.
1539 if Serious_Errors_Detected = Errors then
1540 Normalize_Clause (Clause);
1541 end if;
1543 Next (Clause);
1544 end loop;
1546 if Restore_Scope then
1547 End_Scope;
1548 end if;
1550 -- Verify that every input or output of the subprogram appear in a
1551 -- dependency.
1553 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1554 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1555 Check_Function_Return;
1557 -- The top level dependency relation is malformed
1559 else
1560 Error_Msg_N ("malformed dependency relation", Clause);
1561 end if;
1562 end Analyze_Depends_In_Decl_Part;
1564 ---------------------------------
1565 -- Analyze_Global_In_Decl_Part --
1566 ---------------------------------
1568 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
1569 Seen : Elist_Id := No_Elist;
1570 -- A list containing the entities of all the items processed so far. It
1571 -- plays a role in detecting distinct entities.
1573 Spec_Id : Entity_Id;
1574 -- The entity of the subprogram subject to pragma [Refined_]Global
1576 Subp_Id : Entity_Id;
1577 -- The entity of the subprogram [body or stub] subject to pragma
1578 -- [Refined_]Global.
1580 In_Out_Seen : Boolean := False;
1581 Input_Seen : Boolean := False;
1582 Output_Seen : Boolean := False;
1583 Proof_Seen : Boolean := False;
1584 -- Flags used to verify the consistency of modes
1586 procedure Analyze_Global_List
1587 (List : Node_Id;
1588 Global_Mode : Name_Id := Name_Input);
1589 -- Verify the legality of a single global list declaration. Global_Mode
1590 -- denotes the current mode in effect.
1592 -------------------------
1593 -- Analyze_Global_List --
1594 -------------------------
1596 procedure Analyze_Global_List
1597 (List : Node_Id;
1598 Global_Mode : Name_Id := Name_Input)
1600 procedure Analyze_Global_Item
1601 (Item : Node_Id;
1602 Global_Mode : Name_Id);
1603 -- Verify the legality of a single global item declaration.
1604 -- Global_Mode denotes the current mode in effect.
1606 procedure Check_Duplicate_Mode
1607 (Mode : Node_Id;
1608 Status : in out Boolean);
1609 -- Flag Status denotes whether a particular mode has been seen while
1610 -- processing a global list. This routine verifies that Mode is not a
1611 -- duplicate mode and sets the flag Status.
1613 procedure Check_Mode_Restriction_In_Enclosing_Context
1614 (Item : Node_Id;
1615 Item_Id : Entity_Id);
1616 -- Verify that an item of mode In_Out or Output does not appear as an
1617 -- input in the Global aspect of an enclosing subprogram. If this is
1618 -- the case, emit an error. Item and Item_Id are respectively the
1619 -- item and its entity.
1621 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
1622 -- Mode denotes either In_Out or Output. Depending on the kind of the
1623 -- related subprogram, emit an error if those two modes apply to a
1624 -- function.
1626 -------------------------
1627 -- Analyze_Global_Item --
1628 -------------------------
1630 procedure Analyze_Global_Item
1631 (Item : Node_Id;
1632 Global_Mode : Name_Id)
1634 Item_Id : Entity_Id;
1636 begin
1637 -- Detect one of the following cases
1639 -- with Global => (null, Name)
1640 -- with Global => (Name_1, null, Name_2)
1641 -- with Global => (Name, null)
1643 if Nkind (Item) = N_Null then
1644 Error_Msg_N ("cannot mix null and non-null global items", Item);
1645 return;
1646 end if;
1648 Analyze (Item);
1650 -- Find the entity of the item. If this is a renaming, climb the
1651 -- renaming chain to reach the root object. Renamings of non-
1652 -- entire objects do not yield an entity (Empty).
1654 Item_Id := Entity_Of (Item);
1656 if Present (Item_Id) then
1657 Record_Possible_Body_Reference (Item, Item_Id);
1659 -- A global item may denote a formal parameter of an enclosing
1660 -- subprogram. Do this check first to provide a better error
1661 -- diagnostic.
1663 if Is_Formal (Item_Id) then
1664 if Scope (Item_Id) = Spec_Id then
1665 Error_Msg_N
1666 ("global item cannot reference formal parameter", Item);
1667 return;
1668 end if;
1670 -- The only legal references are those to abstract states and
1671 -- variables.
1673 elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
1674 Error_Msg_N
1675 ("global item must denote variable or state", Item);
1676 return;
1677 end if;
1679 if Ekind (Item_Id) = E_Abstract_State then
1681 -- The state acts as a constituent of some other state.
1682 -- Ensure that the other state is a proper ancestor of the
1683 -- item.
1685 if Present (Refined_State (Item_Id)) then
1686 if not Is_Part_Of (Item_Id, Refined_State (Item_Id)) then
1687 Error_Msg_Name_1 := Chars (Refined_State (Item_Id));
1688 Error_Msg_NE
1689 ("state & is not a valid constituent of ancestor "
1690 & "state %", Item, Item_Id);
1691 return;
1692 end if;
1694 -- An abstract state with visible refinement cannot appear
1695 -- in pragma [Refined_]Global as its place must be taken by
1696 -- some of its constituents.
1698 elsif Has_Visible_Refinement (Item_Id) then
1699 Error_Msg_NE
1700 ("cannot mention state & in global refinement, use its "
1701 & "constituents instead", Item, Item_Id);
1702 return;
1703 end if;
1704 end if;
1706 -- When the item renames an entire object, replace the item
1707 -- with a reference to the object.
1709 if Present (Renamed_Object (Entity (Item))) then
1710 Rewrite (Item, New_Reference_To (Item_Id, Sloc (Item)));
1711 Analyze (Item);
1712 end if;
1714 -- Some form of illegal construct masquerading as a name
1716 else
1717 Error_Msg_N ("global item must denote variable or state", Item);
1718 return;
1719 end if;
1721 -- At this point we know that the global item is one of the two
1722 -- valid choices. Perform mode- and usage-specific checks.
1724 if Ekind (Item_Id) = E_Abstract_State
1725 and then Is_External_State (Item_Id)
1726 then
1727 -- A global item of mode In_Out or Output cannot denote an
1728 -- external Input_Only state.
1730 if Is_Input_Only_State (Item_Id)
1731 and then Nam_In (Global_Mode, Name_In_Out, Name_Output)
1732 then
1733 Error_Msg_N
1734 ("global item of mode In_Out or Output cannot reference "
1735 & "External Input_Only state", Item);
1737 -- A global item of mode In_Out or Input cannot reference an
1738 -- external Output_Only state.
1740 elsif Is_Output_Only_State (Item_Id)
1741 and then Nam_In (Global_Mode, Name_In_Out, Name_Input)
1742 then
1743 Error_Msg_N
1744 ("global item of mode In_Out or Input cannot reference "
1745 & "External Output_Only state", Item);
1746 end if;
1747 end if;
1749 -- Verify that an output does not appear as an input in an
1750 -- enclosing subprogram.
1752 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
1753 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
1754 end if;
1756 -- The same entity might be referenced through various way. Check
1757 -- the entity of the item rather than the item itself.
1759 if Contains (Seen, Item_Id) then
1760 Error_Msg_N ("duplicate global item", Item);
1762 -- Add the entity of the current item to the list of processed
1763 -- items.
1765 else
1766 Add_Item (Item_Id, Seen);
1767 end if;
1768 end Analyze_Global_Item;
1770 --------------------------
1771 -- Check_Duplicate_Mode --
1772 --------------------------
1774 procedure Check_Duplicate_Mode
1775 (Mode : Node_Id;
1776 Status : in out Boolean)
1778 begin
1779 if Status then
1780 Error_Msg_N ("duplicate global mode", Mode);
1781 end if;
1783 Status := True;
1784 end Check_Duplicate_Mode;
1786 -------------------------------------------------
1787 -- Check_Mode_Restriction_In_Enclosing_Context --
1788 -------------------------------------------------
1790 procedure Check_Mode_Restriction_In_Enclosing_Context
1791 (Item : Node_Id;
1792 Item_Id : Entity_Id)
1794 Context : Entity_Id;
1795 Dummy : Boolean;
1796 Inputs : Elist_Id := No_Elist;
1797 Outputs : Elist_Id := No_Elist;
1799 begin
1800 -- Traverse the scope stack looking for enclosing subprograms
1801 -- subject to pragma [Refined_]Global.
1803 Context := Scope (Subp_Id);
1804 while Present (Context) and then Context /= Standard_Standard loop
1805 if Is_Subprogram (Context)
1806 and then Present (Get_Pragma (Context, Pragma_Global))
1807 then
1808 Collect_Subprogram_Inputs_Outputs
1809 (Subp_Id => Context,
1810 Subp_Inputs => Inputs,
1811 Subp_Outputs => Outputs,
1812 Global_Seen => Dummy);
1814 -- The item is classified as In_Out or Output but appears as
1815 -- an Input in an enclosing subprogram.
1817 if Appears_In (Inputs, Item_Id)
1818 and then not Appears_In (Outputs, Item_Id)
1819 then
1820 Error_Msg_NE
1821 ("global item & cannot have mode In_Out or Output",
1822 Item, Item_Id);
1823 Error_Msg_NE
1824 ("\item already appears as input of subprogram &",
1825 Item, Context);
1827 -- Stop the traversal once an error has been detected
1829 exit;
1830 end if;
1831 end if;
1833 Context := Scope (Context);
1834 end loop;
1835 end Check_Mode_Restriction_In_Enclosing_Context;
1837 ----------------------------------------
1838 -- Check_Mode_Restriction_In_Function --
1839 ----------------------------------------
1841 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
1842 begin
1843 if Ekind (Spec_Id) = E_Function then
1844 Error_Msg_N
1845 ("global mode & not applicable to functions", Mode);
1846 end if;
1847 end Check_Mode_Restriction_In_Function;
1849 -- Local variables
1851 Assoc : Node_Id;
1852 Item : Node_Id;
1853 Mode : Node_Id;
1855 -- Start of processing for Analyze_Global_List
1857 begin
1858 if Nkind (List) = N_Null then
1859 Set_Analyzed (List);
1861 -- Single global item declaration
1863 elsif Nkind_In (List, N_Expanded_Name,
1864 N_Identifier,
1865 N_Selected_Component)
1866 then
1867 Analyze_Global_Item (List, Global_Mode);
1869 -- Simple global list or moded global list declaration
1871 elsif Nkind (List) = N_Aggregate then
1872 Set_Analyzed (List);
1874 -- The declaration of a simple global list appear as a collection
1875 -- of expressions.
1877 if Present (Expressions (List)) then
1878 if Present (Component_Associations (List)) then
1879 Error_Msg_N
1880 ("cannot mix moded and non-moded global lists", List);
1881 end if;
1883 Item := First (Expressions (List));
1884 while Present (Item) loop
1885 Analyze_Global_Item (Item, Global_Mode);
1887 Next (Item);
1888 end loop;
1890 -- The declaration of a moded global list appears as a collection
1891 -- of component associations where individual choices denote
1892 -- modes.
1894 elsif Present (Component_Associations (List)) then
1895 if Present (Expressions (List)) then
1896 Error_Msg_N
1897 ("cannot mix moded and non-moded global lists", List);
1898 end if;
1900 Assoc := First (Component_Associations (List));
1901 while Present (Assoc) loop
1902 Mode := First (Choices (Assoc));
1904 if Nkind (Mode) = N_Identifier then
1905 if Chars (Mode) = Name_In_Out then
1906 Check_Duplicate_Mode (Mode, In_Out_Seen);
1907 Check_Mode_Restriction_In_Function (Mode);
1909 elsif Chars (Mode) = Name_Input then
1910 Check_Duplicate_Mode (Mode, Input_Seen);
1912 elsif Chars (Mode) = Name_Output then
1913 Check_Duplicate_Mode (Mode, Output_Seen);
1914 Check_Mode_Restriction_In_Function (Mode);
1916 elsif Chars (Mode) = Name_Proof_In then
1917 Check_Duplicate_Mode (Mode, Proof_Seen);
1919 else
1920 Error_Msg_N ("invalid mode selector", Mode);
1921 end if;
1923 else
1924 Error_Msg_N ("invalid mode selector", Mode);
1925 end if;
1927 -- Items in a moded list appear as a collection of
1928 -- expressions. Reuse the existing machinery to analyze
1929 -- them.
1931 Analyze_Global_List
1932 (List => Expression (Assoc),
1933 Global_Mode => Chars (Mode));
1935 Next (Assoc);
1936 end loop;
1938 -- Invalid tree
1940 else
1941 raise Program_Error;
1942 end if;
1944 -- Any other attempt to declare a global item is erroneous
1946 else
1947 Error_Msg_N ("malformed global list declaration", List);
1948 end if;
1949 end Analyze_Global_List;
1951 -- Local variables
1953 Items : Node_Id;
1954 Subp_Decl : Node_Id;
1956 Restore_Scope : Boolean := False;
1957 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
1959 -- Start of processing for Analyze_Global_In_Decl_List
1961 begin
1962 Set_Analyzed (N);
1964 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
1965 Subp_Id := Defining_Entity (Subp_Decl);
1967 -- The logic in this routine is used to analyze both pragma Global and
1968 -- pragma Refined_Global since they have the same syntax and base
1969 -- semantics. Find the entity of the corresponding spec when analyzing
1970 -- Refined_Global.
1972 if Nkind (Subp_Decl) = N_Subprogram_Body
1973 and then not Acts_As_Spec (Subp_Decl)
1974 then
1975 Spec_Id := Corresponding_Spec (Subp_Decl);
1977 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
1978 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
1980 else
1981 Spec_Id := Subp_Id;
1982 end if;
1984 Items := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
1986 -- There is nothing to be done for a null global list
1988 if Nkind (Items) = N_Null then
1989 Set_Analyzed (Items);
1991 -- Analyze the various forms of global lists and items. Note that some
1992 -- of these may be malformed in which case the analysis emits error
1993 -- messages.
1995 else
1996 -- Ensure that the formal parameters are visible when processing an
1997 -- item. This falls out of the general rule of aspects pertaining to
1998 -- subprogram declarations.
2000 if not In_Open_Scopes (Spec_Id) then
2001 Restore_Scope := True;
2002 Push_Scope (Spec_Id);
2003 Install_Formals (Spec_Id);
2004 end if;
2006 Analyze_Global_List (Items);
2008 if Restore_Scope then
2009 End_Scope;
2010 end if;
2011 end if;
2012 end Analyze_Global_In_Decl_Part;
2014 --------------------------------------------
2015 -- Analyze_Initial_Condition_In_Decl_Part --
2016 --------------------------------------------
2018 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2019 Pack_Id : constant Entity_Id := Defining_Entity (Parent (Parent (N)));
2020 Prag_Init : constant Node_Id :=
2021 Get_Pragma (Pack_Id, Pragma_Initializes);
2022 -- The related pragma Initializes
2024 Vars : Elist_Id := No_Elist;
2025 -- A list of all variables declared in pragma Initializes
2027 procedure Collect_Variables;
2028 -- Inspect the initialization list of pragma Initializes and collect the
2029 -- entities of all variables declared within the related package.
2031 function Match_Variable (N : Node_Id) return Traverse_Result;
2032 -- Determine whether arbitrary node N denotes a variable declared in the
2033 -- visible declarations of the related package.
2035 procedure Report_Unused_Variables;
2036 -- Emit errors for all variables found in list Vars
2038 -----------------------
2039 -- Collect_Variables --
2040 -----------------------
2042 procedure Collect_Variables is
2043 procedure Collect_Variable (Item : Node_Id);
2044 -- Determine whether Item denotes a variable that appears in the
2045 -- related package and if it does, add it to list Vars.
2047 ----------------------
2048 -- Collect_Variable --
2049 ----------------------
2051 procedure Collect_Variable (Item : Node_Id) is
2052 Item_Id : Entity_Id;
2054 begin
2055 if Is_Entity_Name (Item) and then Present (Entity (Item)) then
2056 Item_Id := Entity (Item);
2058 -- The item is a variable declared in the related package
2060 if Ekind (Item_Id) = E_Variable
2061 and then Scope (Item_Id) = Pack_Id
2062 then
2063 Add_Item (Item_Id, Vars);
2064 end if;
2065 end if;
2066 end Collect_Variable;
2068 -- Local variables
2070 Inits : constant Node_Id :=
2071 Get_Pragma_Arg
2072 (First (Pragma_Argument_Associations (Prag_Init)));
2073 Init : Node_Id;
2075 -- Start of processing for Collect_Variables
2077 begin
2078 -- Multiple initialization items appear as an aggregate
2080 if Nkind (Inits) = N_Aggregate
2081 and then Present (Expressions (Inits))
2082 then
2083 Init := First (Expressions (Inits));
2084 while Present (Init) loop
2085 Collect_Variable (Init);
2087 Next (Init);
2088 end loop;
2090 -- Single initialization item
2092 else
2093 Collect_Variable (Inits);
2094 end if;
2095 end Collect_Variables;
2097 --------------------
2098 -- Match_Variable --
2099 --------------------
2101 function Match_Variable (N : Node_Id) return Traverse_Result is
2102 Var_Id : Entity_Id;
2104 begin
2105 -- Find a variable declared within the related package and try to
2106 -- remove it from the list of collected variables found in pragma
2107 -- Initializes.
2109 if Is_Entity_Name (N)
2110 and then Present (Entity (N))
2111 then
2112 Var_Id := Entity (N);
2114 if Ekind (Var_Id) = E_Variable
2115 and then Scope (Var_Id) = Pack_Id
2116 then
2117 Remove (Vars, Var_Id);
2118 end if;
2119 end if;
2121 return OK;
2122 end Match_Variable;
2124 procedure Match_Variables is new Traverse_Proc (Match_Variable);
2126 -----------------------------
2127 -- Report_Unused_Variables --
2128 -----------------------------
2130 procedure Report_Unused_Variables is
2131 Posted : Boolean := False;
2132 Var_Elmt : Elmt_Id;
2133 Var_Id : Entity_Id;
2135 begin
2136 if Present (Vars) then
2137 Var_Elmt := First_Elmt (Vars);
2138 while Present (Var_Elmt) loop
2139 Var_Id := Node (Var_Elmt);
2141 if not Posted then
2142 Posted := True;
2143 Error_Msg_Name_1 := Name_Initial_Condition;
2144 Error_Msg_N
2145 ("expression of % must mention the following variables",
2147 end if;
2149 Error_Msg_Sloc := Sloc (Var_Id);
2150 Error_Msg_NE ("\ & declared #", N, Var_Id);
2152 Next_Elmt (Var_Elmt);
2153 end loop;
2154 end if;
2155 end Report_Unused_Variables;
2157 Expr : constant Node_Id :=
2158 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2159 Errors : constant Nat := Serious_Errors_Detected;
2161 -- Start of processing for Analyze_Initial_Condition_In_Decl_Part
2163 begin
2164 Set_Analyzed (N);
2166 -- Pragma Initial_Condition depends on the names enumerated in pragma
2167 -- Initializes. Without those, the analysis cannot take place.
2169 if No (Prag_Init) then
2170 Error_Msg_Name_1 := Name_Initial_Condition;
2171 Error_Msg_Name_2 := Name_Initializes;
2173 Error_Msg_N ("% requires the presence of aspect or pragma %", N);
2174 return;
2175 end if;
2177 -- The expression is preanalyzed because it has not been moved to its
2178 -- final place yet. A direct analysis may generate sife effects and this
2179 -- is not desired at this point.
2181 Preanalyze_And_Resolve (Expr, Standard_Boolean);
2183 -- Perform variable matching only when the expression is legal
2185 if Serious_Errors_Detected = Errors then
2186 Collect_Variables;
2188 -- Verify that all variables mentioned in pragma Initializes are used
2189 -- in the expression of pragma Initial_Condition.
2191 Match_Variables (Expr);
2192 end if;
2194 -- Emit errors for all variables that should participate in the
2195 -- expression of pragma Initial_Condition.
2197 if Serious_Errors_Detected = Errors then
2198 Report_Unused_Variables;
2199 end if;
2200 end Analyze_Initial_Condition_In_Decl_Part;
2202 --------------------------------------
2203 -- Analyze_Initializes_In_Decl_Part --
2204 --------------------------------------
2206 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2207 Pack_Spec : constant Node_Id := Parent (N);
2208 Pack_Id : constant Entity_Id := Defining_Entity (Parent (Pack_Spec));
2210 Items_Seen : Elist_Id := No_Elist;
2211 -- A list of all initialization items processed so far. This list is
2212 -- used to detect duplicate items.
2214 Non_Null_Seen : Boolean := False;
2215 Null_Seen : Boolean := False;
2216 -- Flags used to check the legality of a null initialization list
2218 States_And_Vars : Elist_Id := No_Elist;
2219 -- A list of all abstract states and variables declared in the visible
2220 -- declarations of the related package. This list is used to detect the
2221 -- legality of initialization items.
2223 procedure Analyze_Initialization_Item (Item : Node_Id);
2224 -- Verify the legality of a single initialization item
2226 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2227 -- Verify the legality of a single initialization item followed by a
2228 -- list of input items.
2230 procedure Collect_States_And_Variables;
2231 -- Inspect the visible declarations of the related package and gather
2232 -- the entities of all abstract states and variables in States_And_Vars.
2234 ---------------------------------
2235 -- Analyze_Initialization_Item --
2236 ---------------------------------
2238 procedure Analyze_Initialization_Item (Item : Node_Id) is
2239 Item_Id : Entity_Id;
2241 begin
2242 -- Null initialization list
2244 if Nkind (Item) = N_Null then
2245 if Null_Seen then
2246 Error_Msg_N ("multiple null initializations not allowed", Item);
2248 elsif Non_Null_Seen then
2249 Error_Msg_N
2250 ("cannot mix null and non-null initialization items", Item);
2251 else
2252 Null_Seen := True;
2253 end if;
2255 -- Initialization item
2257 else
2258 Non_Null_Seen := True;
2260 if Null_Seen then
2261 Error_Msg_N
2262 ("cannot mix null and non-null initialization items", Item);
2263 end if;
2265 Analyze (Item);
2267 if Is_Entity_Name (Item) then
2268 Item_Id := Entity (Item);
2270 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
2272 -- The state or variable must be declared in the visible
2273 -- declarations of the package.
2275 if not Contains (States_And_Vars, Item_Id) then
2276 Error_Msg_Name_1 := Chars (Pack_Id);
2277 Error_Msg_NE
2278 ("initialization item & must appear in the visible "
2279 & "declarations of package %", Item, Item_Id);
2281 -- Detect a duplicate use of the same initialization item
2283 elsif Contains (Items_Seen, Item_Id) then
2284 Error_Msg_N ("duplicate initialization item", Item);
2286 -- The item is legal, add it to the list of processed states
2287 -- and variables.
2289 else
2290 Add_Item (Item_Id, Items_Seen);
2291 end if;
2293 -- The item references something that is not a state or a
2294 -- variable.
2296 else
2297 Error_Msg_N
2298 ("initialization item must denote variable or state",
2299 Item);
2300 end if;
2302 -- Some form of illegal construct masquerading as a name
2304 else
2305 Error_Msg_N
2306 ("initialization item must denote variable or state", Item);
2307 end if;
2308 end if;
2309 end Analyze_Initialization_Item;
2311 ---------------------------------------------
2312 -- Analyze_Initialization_Item_With_Inputs --
2313 ---------------------------------------------
2315 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2316 Inputs_Seen : Elist_Id := No_Elist;
2317 -- A list of all inputs processed so far. This list is used to detect
2318 -- duplicate uses of an input.
2320 Non_Null_Seen : Boolean := False;
2321 Null_Seen : Boolean := False;
2322 -- Flags used to check the legality of an input list
2324 procedure Analyze_Input_Item (Input : Node_Id);
2325 -- Verify the legality of a single input item
2327 ------------------------
2328 -- Analyze_Input_Item --
2329 ------------------------
2331 procedure Analyze_Input_Item (Input : Node_Id) is
2332 Input_Id : Entity_Id;
2334 begin
2335 -- Null input list
2337 if Nkind (Input) = N_Null then
2338 if Null_Seen then
2339 Error_Msg_N
2340 ("multiple null initializations not allowed", Item);
2342 elsif Non_Null_Seen then
2343 Error_Msg_N
2344 ("cannot mix null and non-null initialization item", Item);
2345 else
2346 Null_Seen := True;
2347 end if;
2349 -- Input item
2351 else
2352 Non_Null_Seen := True;
2354 if Null_Seen then
2355 Error_Msg_N
2356 ("cannot mix null and non-null initialization item", Item);
2357 end if;
2359 Analyze (Input);
2361 if Is_Entity_Name (Input) then
2362 Input_Id := Entity (Input);
2364 if Ekind_In (Input_Id, E_Abstract_State, E_Variable) then
2366 -- The input cannot denote states or variables declared
2367 -- within the related package.
2369 if In_Same_Code_Unit (Item, Input_Id) then
2370 Error_Msg_Name_1 := Chars (Pack_Id);
2371 Error_Msg_NE
2372 ("input item & cannot denote a visible variable or "
2373 & "state of package %", Input, Input_Id);
2375 -- Detect a duplicate use of the same input item
2377 elsif Contains (Inputs_Seen, Input_Id) then
2378 Error_Msg_N ("duplicate input item", Input);
2380 -- Input is legal, add it to the list of processed inputs
2382 else
2383 Add_Item (Input_Id, Inputs_Seen);
2384 end if;
2386 -- The input references something that is not a state or a
2387 -- variable.
2389 else
2390 Error_Msg_N
2391 ("input item must denote variable or state", Input);
2392 end if;
2394 -- Some form of illegal construct masquerading as a name
2396 else
2397 Error_Msg_N
2398 ("input item must denote variable or state", Input);
2399 end if;
2400 end if;
2401 end Analyze_Input_Item;
2403 -- Local variables
2405 Inputs : constant Node_Id := Expression (Item);
2406 Elmt : Node_Id;
2407 Input : Node_Id;
2409 Name_Seen : Boolean := False;
2410 -- A flag used to detect multiple item names
2412 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2414 begin
2415 -- Inspect the name of an item with inputs
2417 Elmt := First (Choices (Item));
2418 while Present (Elmt) loop
2419 if Name_Seen then
2420 Error_Msg_N ("only one item allowed in initialization", Elmt);
2421 else
2422 Name_Seen := True;
2423 Analyze_Initialization_Item (Elmt);
2424 end if;
2426 Next (Elmt);
2427 end loop;
2429 -- Multiple input items appear as an aggregate
2431 if Nkind (Inputs) = N_Aggregate then
2432 if Present (Expressions (Inputs)) then
2433 Input := First (Expressions (Inputs));
2434 while Present (Input) loop
2435 Analyze_Input_Item (Input);
2436 Next (Input);
2437 end loop;
2438 end if;
2440 if Present (Component_Associations (Inputs)) then
2441 Error_Msg_N
2442 ("inputs must appear in named association form", Inputs);
2443 end if;
2445 -- Single input item
2447 else
2448 Analyze_Input_Item (Inputs);
2449 end if;
2450 end Analyze_Initialization_Item_With_Inputs;
2452 ----------------------------------
2453 -- Collect_States_And_Variables --
2454 ----------------------------------
2456 procedure Collect_States_And_Variables is
2457 Decl : Node_Id;
2459 begin
2460 -- Collect the abstract states defined in the package (if any)
2462 if Present (Abstract_States (Pack_Id)) then
2463 States_And_Vars := New_Copy_Elist (Abstract_States (Pack_Id));
2464 end if;
2466 -- Collect all variables the appear in the visible declarations of
2467 -- the related package.
2469 if Present (Visible_Declarations (Pack_Spec)) then
2470 Decl := First (Visible_Declarations (Pack_Spec));
2471 while Present (Decl) loop
2472 if Nkind (Decl) = N_Object_Declaration
2473 and then Ekind (Defining_Entity (Decl)) = E_Variable
2474 and then Comes_From_Source (Decl)
2475 then
2476 Add_Item (Defining_Entity (Decl), States_And_Vars);
2477 end if;
2479 Next (Decl);
2480 end loop;
2481 end if;
2482 end Collect_States_And_Variables;
2484 -- Local variables
2486 Inits : constant Node_Id :=
2487 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2488 Init : Node_Id;
2490 -- Start of processing for Analyze_Initializes_In_Decl_Part
2492 begin
2493 Set_Analyzed (N);
2495 -- Initialize the various lists used during analysis
2497 Collect_States_And_Variables;
2499 -- Multiple initialization clauses appear as an aggregate
2501 if Nkind (Inits) = N_Aggregate then
2502 if Present (Expressions (Inits)) then
2503 Init := First (Expressions (Inits));
2504 while Present (Init) loop
2505 Analyze_Initialization_Item (Init);
2507 Next (Init);
2508 end loop;
2509 end if;
2511 if Present (Component_Associations (Inits)) then
2512 Init := First (Component_Associations (Inits));
2513 while Present (Init) loop
2514 Analyze_Initialization_Item_With_Inputs (Init);
2516 Next (Init);
2517 end loop;
2518 end if;
2520 -- Various forms of a single initialization clause. Note that these may
2521 -- include malformed initializations.
2523 else
2524 Analyze_Initialization_Item (Inits);
2525 end if;
2526 end Analyze_Initializes_In_Decl_Part;
2528 --------------------
2529 -- Analyze_Pragma --
2530 --------------------
2532 procedure Analyze_Pragma (N : Node_Id) is
2533 Loc : constant Source_Ptr := Sloc (N);
2534 Prag_Id : Pragma_Id;
2536 Pname : Name_Id;
2537 -- Name of the source pragma, or name of the corresponding aspect for
2538 -- pragmas which originate in a source aspect. In the latter case, the
2539 -- name may be different from the pragma name.
2541 Pragma_Exit : exception;
2542 -- This exception is used to exit pragma processing completely. It is
2543 -- used when an error is detected, and no further processing is
2544 -- required. It is also used if an earlier error has left the tree in
2545 -- a state where the pragma should not be processed.
2547 Arg_Count : Nat;
2548 -- Number of pragma argument associations
2550 Arg1 : Node_Id;
2551 Arg2 : Node_Id;
2552 Arg3 : Node_Id;
2553 Arg4 : Node_Id;
2554 -- First four pragma arguments (pragma argument association nodes, or
2555 -- Empty if the corresponding argument does not exist).
2557 type Name_List is array (Natural range <>) of Name_Id;
2558 type Args_List is array (Natural range <>) of Node_Id;
2559 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2561 procedure Ada_2005_Pragma;
2562 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2563 -- Ada 95 mode, these are implementation defined pragmas, so should be
2564 -- caught by the No_Implementation_Pragmas restriction.
2566 procedure Ada_2012_Pragma;
2567 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2568 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2569 -- should be caught by the No_Implementation_Pragmas restriction.
2571 procedure Analyze_Refined_Pragma
2572 (Spec_Id : out Entity_Id;
2573 Body_Id : out Entity_Id;
2574 Legal : out Boolean);
2575 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2576 -- Refined_Global and Refined_Post. Check the placement and related
2577 -- context of the pragma. Spec_Id is the entity of the related
2578 -- subprogram. Body_Id is the entity of the subprogram body. Flag Legal
2579 -- is set when the pragma is properly placed.
2581 procedure Check_Ada_83_Warning;
2582 -- Issues a warning message for the current pragma if operating in Ada
2583 -- 83 mode (used for language pragmas that are not a standard part of
2584 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2585 -- of 95 pragma.
2587 procedure Check_Arg_Count (Required : Nat);
2588 -- Check argument count for pragma is equal to given parameter. If not,
2589 -- then issue an error message and raise Pragma_Exit.
2591 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2592 -- Arg which can either be a pragma argument association, in which case
2593 -- the check is applied to the expression of the association or an
2594 -- expression directly.
2596 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
2597 -- Check that an argument has the right form for an EXTERNAL_NAME
2598 -- parameter of an extended import/export pragma. The rule is that the
2599 -- name must be an identifier or string literal (in Ada 83 mode) or a
2600 -- static string expression (in Ada 95 mode).
2602 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
2603 -- Check the specified argument Arg to make sure that it is an
2604 -- identifier. If not give error and raise Pragma_Exit.
2606 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
2607 -- Check the specified argument Arg to make sure that it is an integer
2608 -- literal. If not give error and raise Pragma_Exit.
2610 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
2611 -- Check the specified argument Arg to make sure that it has the proper
2612 -- syntactic form for a local name and meets the semantic requirements
2613 -- for a local name. The local name is analyzed as part of the
2614 -- processing for this call. In addition, the local name is required
2615 -- to represent an entity at the library level.
2617 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
2618 -- Check the specified argument Arg to make sure that it has the proper
2619 -- syntactic form for a local name and meets the semantic requirements
2620 -- for a local name. The local name is analyzed as part of the
2621 -- processing for this call.
2623 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
2624 -- Check the specified argument Arg to make sure that it is a valid
2625 -- locking policy name. If not give error and raise Pragma_Exit.
2627 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
2628 -- Check the specified argument Arg to make sure that it is a valid
2629 -- elaboration policy name. If not give error and raise Pragma_Exit.
2631 procedure Check_Arg_Is_One_Of
2632 (Arg : Node_Id;
2633 N1, N2 : Name_Id);
2634 procedure Check_Arg_Is_One_Of
2635 (Arg : Node_Id;
2636 N1, N2, N3 : Name_Id);
2637 procedure Check_Arg_Is_One_Of
2638 (Arg : Node_Id;
2639 N1, N2, N3, N4 : Name_Id);
2640 procedure Check_Arg_Is_One_Of
2641 (Arg : Node_Id;
2642 N1, N2, N3, N4, N5 : Name_Id);
2643 -- Check the specified argument Arg to make sure that it is an
2644 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2645 -- present). If not then give error and raise Pragma_Exit.
2647 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
2648 -- Check the specified argument Arg to make sure that it is a valid
2649 -- queuing policy name. If not give error and raise Pragma_Exit.
2651 procedure Check_Arg_Is_Static_Expression
2652 (Arg : Node_Id;
2653 Typ : Entity_Id := Empty);
2654 -- Check the specified argument Arg to make sure that it is a static
2655 -- expression of the given type (i.e. it will be analyzed and resolved
2656 -- using this type, which can be any valid argument to Resolve, e.g.
2657 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2658 -- Typ is left Empty, then any static expression is allowed.
2660 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
2661 -- Check the specified argument Arg to make sure that it is a valid task
2662 -- dispatching policy name. If not give error and raise Pragma_Exit.
2664 procedure Check_Arg_Order (Names : Name_List);
2665 -- Checks for an instance of two arguments with identifiers for the
2666 -- current pragma which are not in the sequence indicated by Names,
2667 -- and if so, generates a fatal message about bad order of arguments.
2669 procedure Check_At_Least_N_Arguments (N : Nat);
2670 -- Check there are at least N arguments present
2672 procedure Check_At_Most_N_Arguments (N : Nat);
2673 -- Check there are no more than N arguments present
2675 procedure Check_Component
2676 (Comp : Node_Id;
2677 UU_Typ : Entity_Id;
2678 In_Variant_Part : Boolean := False);
2679 -- Examine an Unchecked_Union component for correct use of per-object
2680 -- constrained subtypes, and for restrictions on finalizable components.
2681 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2682 -- should be set when Comp comes from a record variant.
2684 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id);
2685 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2686 -- Initial_Condition and Initializes. Determine whether pragma First
2687 -- appears before pragma Second. If this is not the case, emit an error.
2689 procedure Check_Duplicate_Pragma (E : Entity_Id);
2690 -- Check if a rep item of the same name as the current pragma is already
2691 -- chained as a rep pragma to the given entity. If so give a message
2692 -- about the duplicate, and then raise Pragma_Exit so does not return.
2694 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
2695 -- Nam is an N_String_Literal node containing the external name set by
2696 -- an Import or Export pragma (or extended Import or Export pragma).
2697 -- This procedure checks for possible duplications if this is the export
2698 -- case, and if found, issues an appropriate error message.
2700 procedure Check_Expr_Is_Static_Expression
2701 (Expr : Node_Id;
2702 Typ : Entity_Id := Empty);
2703 -- Check the specified expression Expr to make sure that it is a static
2704 -- expression of the given type (i.e. it will be analyzed and resolved
2705 -- using this type, which can be any valid argument to Resolve, e.g.
2706 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2707 -- Typ is left Empty, then any static expression is allowed.
2709 procedure Check_First_Subtype (Arg : Node_Id);
2710 -- Checks that Arg, whose expression is an entity name, references a
2711 -- first subtype.
2713 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
2714 -- Checks that the given argument has an identifier, and if so, requires
2715 -- it to match the given identifier name. If there is no identifier, or
2716 -- a non-matching identifier, then an error message is given and
2717 -- Pragma_Exit is raised.
2719 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
2720 -- Checks that the given argument has an identifier, and if so, requires
2721 -- it to match one of the given identifier names. If there is no
2722 -- identifier, or a non-matching identifier, then an error message is
2723 -- given and Pragma_Exit is raised.
2725 procedure Check_In_Main_Program;
2726 -- Common checks for pragmas that appear within a main program
2727 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2729 procedure Check_Interrupt_Or_Attach_Handler;
2730 -- Common processing for first argument of pragma Interrupt_Handler or
2731 -- pragma Attach_Handler.
2733 procedure Check_Loop_Pragma_Placement;
2734 -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant
2735 -- appear immediately within a construct restricted to loops.
2737 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
2738 -- Check that pragma appears in a declarative part, or in a package
2739 -- specification, i.e. that it does not occur in a statement sequence
2740 -- in a body.
2742 procedure Check_No_Identifier (Arg : Node_Id);
2743 -- Checks that the given argument does not have an identifier. If
2744 -- an identifier is present, then an error message is issued, and
2745 -- Pragma_Exit is raised.
2747 procedure Check_No_Identifiers;
2748 -- Checks that none of the arguments to the pragma has an identifier.
2749 -- If any argument has an identifier, then an error message is issued,
2750 -- and Pragma_Exit is raised.
2752 procedure Check_No_Link_Name;
2753 -- Checks that no link name is specified
2755 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
2756 -- Checks if the given argument has an identifier, and if so, requires
2757 -- it to match the given identifier name. If there is a non-matching
2758 -- identifier, then an error message is given and Pragma_Exit is raised.
2760 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
2761 -- Checks if the given argument has an identifier, and if so, requires
2762 -- it to match the given identifier name. If there is a non-matching
2763 -- identifier, then an error message is given and Pragma_Exit is raised.
2764 -- In this version of the procedure, the identifier name is given as
2765 -- a string with lower case letters.
2767 procedure Check_Pre_Post;
2768 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
2769 -- pragmas. These are processed by transformation to equivalent
2770 -- Precondition and Postcondition pragmas, but Pre and Post need an
2771 -- additional check that they are not used in a subprogram body when
2772 -- there is a separate spec present.
2774 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
2775 -- Called to process a precondition or postcondition pragma. There are
2776 -- three cases:
2778 -- The pragma appears after a subprogram spec
2780 -- If the corresponding check is not enabled, the pragma is analyzed
2781 -- but otherwise ignored and control returns with In_Body set False.
2783 -- If the check is enabled, then the first step is to analyze the
2784 -- pragma, but this is skipped if the subprogram spec appears within
2785 -- a package specification (because this is the case where we delay
2786 -- analysis till the end of the spec). Then (whether or not it was
2787 -- analyzed), the pragma is chained to the subprogram in question
2788 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
2789 -- to the caller with In_Body set False.
2791 -- The pragma appears at the start of subprogram body declarations
2793 -- In this case an immediate return to the caller is made with
2794 -- In_Body set True, and the pragma is NOT analyzed.
2796 -- In all other cases, an error message for bad placement is given
2798 procedure Check_Static_Constraint (Constr : Node_Id);
2799 -- Constr is a constraint from an N_Subtype_Indication node from a
2800 -- component constraint in an Unchecked_Union type. This routine checks
2801 -- that the constraint is static as required by the restrictions for
2802 -- Unchecked_Union.
2804 procedure Check_Test_Case;
2805 -- Called to process a test-case pragma. It starts with checking pragma
2806 -- arguments, and the rest of the treatment is similar to the one for
2807 -- pre- and postcondition in Check_Precondition_Postcondition, except
2808 -- the placement rules for the test-case pragma are stricter. These
2809 -- pragmas may only occur after a subprogram spec declared directly
2810 -- in a package spec unit. In this case, the pragma is chained to the
2811 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
2812 -- and analysis of the pragma is delayed till the end of the spec. In
2813 -- all other cases, an error message for bad placement is given.
2815 procedure Check_Valid_Configuration_Pragma;
2816 -- Legality checks for placement of a configuration pragma
2818 procedure Check_Valid_Library_Unit_Pragma;
2819 -- Legality checks for library unit pragmas. A special case arises for
2820 -- pragmas in generic instances that come from copies of the original
2821 -- library unit pragmas in the generic templates. In the case of other
2822 -- than library level instantiations these can appear in contexts which
2823 -- would normally be invalid (they only apply to the original template
2824 -- and to library level instantiations), and they are simply ignored,
2825 -- which is implemented by rewriting them as null statements.
2827 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
2828 -- Check an Unchecked_Union variant for lack of nested variants and
2829 -- presence of at least one component. UU_Typ is the related Unchecked_
2830 -- Union type.
2832 procedure Error_Pragma (Msg : String);
2833 pragma No_Return (Error_Pragma);
2834 -- Outputs error message for current pragma. The message contains a %
2835 -- that will be replaced with the pragma name, and the flag is placed
2836 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2837 -- calls Fix_Error (see spec of that procedure for details).
2839 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
2840 pragma No_Return (Error_Pragma_Arg);
2841 -- Outputs error message for current pragma. The message may contain
2842 -- a % that will be replaced with the pragma name. The parameter Arg
2843 -- may either be a pragma argument association, in which case the flag
2844 -- is placed on the expression of this association, or an expression,
2845 -- in which case the flag is placed directly on the expression. The
2846 -- message is placed using Error_Msg_N, so the message may also contain
2847 -- an & insertion character which will reference the given Arg value.
2848 -- After placing the message, Pragma_Exit is raised. Note: this routine
2849 -- calls Fix_Error (see spec of that procedure for details).
2851 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
2852 pragma No_Return (Error_Pragma_Arg);
2853 -- Similar to above form of Error_Pragma_Arg except that two messages
2854 -- are provided, the second is a continuation comment starting with \.
2856 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
2857 pragma No_Return (Error_Pragma_Arg_Ident);
2858 -- Outputs error message for current pragma. The message may contain
2859 -- a % that will be replaced with the pragma name. The parameter Arg
2860 -- must be a pragma argument association with a non-empty identifier
2861 -- (i.e. its Chars field must be set), and the error message is placed
2862 -- on the identifier. The message is placed using Error_Msg_N so
2863 -- the message may also contain an & insertion character which will
2864 -- reference the identifier. After placing the message, Pragma_Exit
2865 -- is raised. Note: this routine calls Fix_Error (see spec of that
2866 -- procedure for details).
2868 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
2869 pragma No_Return (Error_Pragma_Ref);
2870 -- Outputs error message for current pragma. The message may contain
2871 -- a % that will be replaced with the pragma name. The parameter Ref
2872 -- must be an entity whose name can be referenced by & and sloc by #.
2873 -- After placing the message, Pragma_Exit is raised. Note: this routine
2874 -- calls Fix_Error (see spec of that procedure for details).
2876 function Find_Lib_Unit_Name return Entity_Id;
2877 -- Used for a library unit pragma to find the entity to which the
2878 -- library unit pragma applies, returns the entity found.
2880 procedure Find_Program_Unit_Name (Id : Node_Id);
2881 -- If the pragma is a compilation unit pragma, the id must denote the
2882 -- compilation unit in the same compilation, and the pragma must appear
2883 -- in the list of preceding or trailing pragmas. If it is a program
2884 -- unit pragma that is not a compilation unit pragma, then the
2885 -- identifier must be visible.
2887 function Find_Unique_Parameterless_Procedure
2888 (Name : Entity_Id;
2889 Arg : Node_Id) return Entity_Id;
2890 -- Used for a procedure pragma to find the unique parameterless
2891 -- procedure identified by Name, returns it if it exists, otherwise
2892 -- errors out and uses Arg as the pragma argument for the message.
2894 procedure Fix_Error (Msg : in out String);
2895 -- This is called prior to issuing an error message. Msg is a string
2896 -- that typically contains the substring "pragma". If the pragma comes
2897 -- from an aspect, each such "pragma" substring is replaced with the
2898 -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
2899 -- aspect (which may be different from the pragma name). If the current
2900 -- pragma results from rewriting another pragma, then Error_Msg_Name_1
2901 -- is set to the original pragma name.
2903 procedure Gather_Associations
2904 (Names : Name_List;
2905 Args : out Args_List);
2906 -- This procedure is used to gather the arguments for a pragma that
2907 -- permits arbitrary ordering of parameters using the normal rules
2908 -- for named and positional parameters. The Names argument is a list
2909 -- of Name_Id values that corresponds to the allowed pragma argument
2910 -- association identifiers in order. The result returned in Args is
2911 -- a list of corresponding expressions that are the pragma arguments.
2912 -- Note that this is a list of expressions, not of pragma argument
2913 -- associations (Gather_Associations has completely checked all the
2914 -- optional identifiers when it returns). An entry in Args is Empty
2915 -- on return if the corresponding argument is not present.
2917 procedure GNAT_Pragma;
2918 -- Called for all GNAT defined pragmas to check the relevant restriction
2919 -- (No_Implementation_Pragmas).
2921 procedure S14_Pragma;
2922 -- Called for all pragmas defined for formal verification to check that
2923 -- the S14_Extensions flag is set.
2924 -- This name needs fixing ??? There is no such thing as an
2925 -- "S14_Extensions" flag ???
2927 function Is_Before_First_Decl
2928 (Pragma_Node : Node_Id;
2929 Decls : List_Id) return Boolean;
2930 -- Return True if Pragma_Node is before the first declarative item in
2931 -- Decls where Decls is the list of declarative items.
2933 function Is_Configuration_Pragma return Boolean;
2934 -- Determines if the placement of the current pragma is appropriate
2935 -- for a configuration pragma.
2937 function Is_In_Context_Clause return Boolean;
2938 -- Returns True if pragma appears within the context clause of a unit,
2939 -- and False for any other placement (does not generate any messages).
2941 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
2942 -- Analyzes the argument, and determines if it is a static string
2943 -- expression, returns True if so, False if non-static or not String.
2945 procedure Pragma_Misplaced;
2946 pragma No_Return (Pragma_Misplaced);
2947 -- Issue fatal error message for misplaced pragma
2949 procedure Process_Atomic_Shared_Volatile;
2950 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
2951 -- Shared is an obsolete Ada 83 pragma, treated as being identical
2952 -- in effect to pragma Atomic.
2954 procedure Process_Compile_Time_Warning_Or_Error;
2955 -- Common processing for Compile_Time_Error and Compile_Time_Warning
2957 procedure Process_Convention
2958 (C : out Convention_Id;
2959 Ent : out Entity_Id);
2960 -- Common processing for Convention, Interface, Import and Export.
2961 -- Checks first two arguments of pragma, and sets the appropriate
2962 -- convention value in the specified entity or entities. On return
2963 -- C is the convention, Ent is the referenced entity.
2965 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
2966 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
2967 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
2969 procedure Process_Extended_Import_Export_Exception_Pragma
2970 (Arg_Internal : Node_Id;
2971 Arg_External : Node_Id;
2972 Arg_Form : Node_Id;
2973 Arg_Code : Node_Id);
2974 -- Common processing for the pragmas Import/Export_Exception. The three
2975 -- arguments correspond to the three named parameters of the pragma. An
2976 -- argument is empty if the corresponding parameter is not present in
2977 -- the pragma.
2979 procedure Process_Extended_Import_Export_Object_Pragma
2980 (Arg_Internal : Node_Id;
2981 Arg_External : Node_Id;
2982 Arg_Size : Node_Id);
2983 -- Common processing for the pragmas Import/Export_Object. The three
2984 -- arguments correspond to the three named parameters of the pragmas. An
2985 -- argument is empty if the corresponding parameter is not present in
2986 -- the pragma.
2988 procedure Process_Extended_Import_Export_Internal_Arg
2989 (Arg_Internal : Node_Id := Empty);
2990 -- Common processing for all extended Import and Export pragmas. The
2991 -- argument is the pragma parameter for the Internal argument. If
2992 -- Arg_Internal is empty or inappropriate, an error message is posted.
2993 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
2994 -- set to identify the referenced entity.
2996 procedure Process_Extended_Import_Export_Subprogram_Pragma
2997 (Arg_Internal : Node_Id;
2998 Arg_External : Node_Id;
2999 Arg_Parameter_Types : Node_Id;
3000 Arg_Result_Type : Node_Id := Empty;
3001 Arg_Mechanism : Node_Id;
3002 Arg_Result_Mechanism : Node_Id := Empty;
3003 Arg_First_Optional_Parameter : Node_Id := Empty);
3004 -- Common processing for all extended Import and Export pragmas applying
3005 -- to subprograms. The caller omits any arguments that do not apply to
3006 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3007 -- only in the Import_Function and Export_Function cases). The argument
3008 -- names correspond to the allowed pragma association identifiers.
3010 procedure Process_Generic_List;
3011 -- Common processing for Share_Generic and Inline_Generic
3013 procedure Process_Import_Or_Interface;
3014 -- Common processing for Import of Interface
3016 procedure Process_Import_Predefined_Type;
3017 -- Processing for completing a type with pragma Import. This is used
3018 -- to declare types that match predefined C types, especially for cases
3019 -- without corresponding Ada predefined type.
3021 type Inline_Status is (Suppressed, Disabled, Enabled);
3022 -- Inline status of a subprogram, indicated as follows:
3023 -- Suppressed: inlining is suppressed for the subprogram
3024 -- Disabled: no inlining is requested for the subprogram
3025 -- Enabled: inlining is requested/required for the subprogram
3027 procedure Process_Inline (Status : Inline_Status);
3028 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3029 -- indicates the inline status specified by the pragma.
3031 procedure Process_Interface_Name
3032 (Subprogram_Def : Entity_Id;
3033 Ext_Arg : Node_Id;
3034 Link_Arg : Node_Id);
3035 -- Given the last two arguments of pragma Import, pragma Export, or
3036 -- pragma Interface_Name, performs validity checks and sets the
3037 -- Interface_Name field of the given subprogram entity to the
3038 -- appropriate external or link name, depending on the arguments given.
3039 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3040 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3041 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3042 -- nor Link_Arg is present, the interface name is set to the default
3043 -- from the subprogram name.
3045 procedure Process_Interrupt_Or_Attach_Handler;
3046 -- Common processing for Interrupt and Attach_Handler pragmas
3048 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3049 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3050 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3051 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3052 -- is not set in the Restrictions case.
3054 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3055 -- Common processing for Suppress and Unsuppress. The boolean parameter
3056 -- Suppress_Case is True for the Suppress case, and False for the
3057 -- Unsuppress case.
3059 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3060 -- This procedure sets the Is_Exported flag for the given entity,
3061 -- checking that the entity was not previously imported. Arg is
3062 -- the argument that specified the entity. A check is also made
3063 -- for exporting inappropriate entities.
3065 procedure Set_Extended_Import_Export_External_Name
3066 (Internal_Ent : Entity_Id;
3067 Arg_External : Node_Id);
3068 -- Common processing for all extended import export pragmas. The first
3069 -- argument, Internal_Ent, is the internal entity, which has already
3070 -- been checked for validity by the caller. Arg_External is from the
3071 -- Import or Export pragma, and may be null if no External parameter
3072 -- was present. If Arg_External is present and is a non-null string
3073 -- (a null string is treated as the default), then the Interface_Name
3074 -- field of Internal_Ent is set appropriately.
3076 procedure Set_Imported (E : Entity_Id);
3077 -- This procedure sets the Is_Imported flag for the given entity,
3078 -- checking that it is not previously exported or imported.
3080 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3081 -- Mech is a parameter passing mechanism (see Import_Function syntax
3082 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3083 -- has the right form, and if not issues an error message. If the
3084 -- argument has the right form then the Mechanism field of Ent is
3085 -- set appropriately.
3087 procedure Set_Rational_Profile;
3088 -- Activate the set of configuration pragmas and permissions that make
3089 -- up the Rational profile.
3091 procedure Set_Ravenscar_Profile (N : Node_Id);
3092 -- Activate the set of configuration pragmas and restrictions that make
3093 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3094 -- is used for error messages on any constructs that violate the
3095 -- profile.
3097 ---------------------
3098 -- Ada_2005_Pragma --
3099 ---------------------
3101 procedure Ada_2005_Pragma is
3102 begin
3103 if Ada_Version <= Ada_95 then
3104 Check_Restriction (No_Implementation_Pragmas, N);
3105 end if;
3106 end Ada_2005_Pragma;
3108 ---------------------
3109 -- Ada_2012_Pragma --
3110 ---------------------
3112 procedure Ada_2012_Pragma is
3113 begin
3114 if Ada_Version <= Ada_2005 then
3115 Check_Restriction (No_Implementation_Pragmas, N);
3116 end if;
3117 end Ada_2012_Pragma;
3119 ----------------------------
3120 -- Analyze_Refined_Pragma --
3121 ----------------------------
3123 procedure Analyze_Refined_Pragma
3124 (Spec_Id : out Entity_Id;
3125 Body_Id : out Entity_Id;
3126 Legal : out Boolean)
3128 Body_Decl : Node_Id;
3129 Pack_Spec : Node_Id;
3130 Spec_Decl : Node_Id;
3132 begin
3133 -- Assume that the pragma is illegal
3135 Spec_Id := Empty;
3136 Body_Id := Empty;
3137 Legal := False;
3139 GNAT_Pragma;
3140 Check_Arg_Count (1);
3141 Check_No_Identifiers;
3143 -- Verify the placement of the pragma and check for duplicates. The
3144 -- pragma must apply to a subprogram body [stub].
3146 Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
3148 if not Nkind_In (Body_Decl, N_Subprogram_Body,
3149 N_Subprogram_Body_Stub)
3150 then
3151 Pragma_Misplaced;
3152 return;
3153 end if;
3155 Body_Id := Defining_Entity (Body_Decl);
3157 -- The body [stub] must not act as a spec, in other words it has to
3158 -- be paired with a corresponding spec.
3160 if Nkind (Body_Decl) = N_Subprogram_Body then
3161 Spec_Id := Corresponding_Spec (Body_Decl);
3162 else
3163 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
3164 end if;
3166 if No (Spec_Id) then
3167 Error_Pragma ("pragma % cannot apply to a stand alone body");
3168 return;
3169 end if;
3171 -- The pragma may only apply to the body [stub] of a subprogram
3172 -- declared in the visible part of a package. Retrieve the context of
3173 -- the subprogram declaration.
3175 Spec_Decl := Parent (Parent (Spec_Id));
3177 pragma Assert
3178 (Nkind_In (Spec_Decl, N_Abstract_Subprogram_Declaration,
3179 N_Generic_Subprogram_Declaration,
3180 N_Subprogram_Declaration));
3182 Pack_Spec := Parent (Spec_Decl);
3184 if Nkind (Pack_Spec) /= N_Package_Specification
3185 or else List_Containing (Spec_Decl) /=
3186 Visible_Declarations (Pack_Spec)
3187 then
3188 Error_Pragma
3189 ("pragma % must apply to the body of a visible subprogram");
3190 return;
3191 end if;
3193 -- If we get here, then the pragma is legal
3195 Legal := True;
3196 end Analyze_Refined_Pragma;
3198 --------------------------
3199 -- Check_Ada_83_Warning --
3200 --------------------------
3202 procedure Check_Ada_83_Warning is
3203 begin
3204 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3205 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
3206 end if;
3207 end Check_Ada_83_Warning;
3209 ---------------------
3210 -- Check_Arg_Count --
3211 ---------------------
3213 procedure Check_Arg_Count (Required : Nat) is
3214 begin
3215 if Arg_Count /= Required then
3216 Error_Pragma ("wrong number of arguments for pragma%");
3217 end if;
3218 end Check_Arg_Count;
3220 --------------------------------
3221 -- Check_Arg_Is_External_Name --
3222 --------------------------------
3224 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
3225 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3227 begin
3228 if Nkind (Argx) = N_Identifier then
3229 return;
3231 else
3232 Analyze_And_Resolve (Argx, Standard_String);
3234 if Is_OK_Static_Expression (Argx) then
3235 return;
3237 elsif Etype (Argx) = Any_Type then
3238 raise Pragma_Exit;
3240 -- An interesting special case, if we have a string literal and
3241 -- we are in Ada 83 mode, then we allow it even though it will
3242 -- not be flagged as static. This allows expected Ada 83 mode
3243 -- use of external names which are string literals, even though
3244 -- technically these are not static in Ada 83.
3246 elsif Ada_Version = Ada_83
3247 and then Nkind (Argx) = N_String_Literal
3248 then
3249 return;
3251 -- Static expression that raises Constraint_Error. This has
3252 -- already been flagged, so just exit from pragma processing.
3254 elsif Is_Static_Expression (Argx) then
3255 raise Pragma_Exit;
3257 -- Here we have a real error (non-static expression)
3259 else
3260 Error_Msg_Name_1 := Pname;
3262 declare
3263 Msg : String :=
3264 "argument for pragma% must be a identifier or "
3265 & "static string expression!";
3266 begin
3267 Fix_Error (Msg);
3268 Flag_Non_Static_Expr (Msg, Argx);
3269 raise Pragma_Exit;
3270 end;
3271 end if;
3272 end if;
3273 end Check_Arg_Is_External_Name;
3275 -----------------------------
3276 -- Check_Arg_Is_Identifier --
3277 -----------------------------
3279 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
3280 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3281 begin
3282 if Nkind (Argx) /= N_Identifier then
3283 Error_Pragma_Arg
3284 ("argument for pragma% must be identifier", Argx);
3285 end if;
3286 end Check_Arg_Is_Identifier;
3288 ----------------------------------
3289 -- Check_Arg_Is_Integer_Literal --
3290 ----------------------------------
3292 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
3293 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3294 begin
3295 if Nkind (Argx) /= N_Integer_Literal then
3296 Error_Pragma_Arg
3297 ("argument for pragma% must be integer literal", Argx);
3298 end if;
3299 end Check_Arg_Is_Integer_Literal;
3301 -------------------------------------------
3302 -- Check_Arg_Is_Library_Level_Local_Name --
3303 -------------------------------------------
3305 -- LOCAL_NAME ::=
3306 -- DIRECT_NAME
3307 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3308 -- | library_unit_NAME
3310 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
3311 begin
3312 Check_Arg_Is_Local_Name (Arg);
3314 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
3315 and then Comes_From_Source (N)
3316 then
3317 Error_Pragma_Arg
3318 ("argument for pragma% must be library level entity", Arg);
3319 end if;
3320 end Check_Arg_Is_Library_Level_Local_Name;
3322 -----------------------------
3323 -- Check_Arg_Is_Local_Name --
3324 -----------------------------
3326 -- LOCAL_NAME ::=
3327 -- DIRECT_NAME
3328 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3329 -- | library_unit_NAME
3331 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
3332 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3334 begin
3335 Analyze (Argx);
3337 if Nkind (Argx) not in N_Direct_Name
3338 and then (Nkind (Argx) /= N_Attribute_Reference
3339 or else Present (Expressions (Argx))
3340 or else Nkind (Prefix (Argx)) /= N_Identifier)
3341 and then (not Is_Entity_Name (Argx)
3342 or else not Is_Compilation_Unit (Entity (Argx)))
3343 then
3344 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
3345 end if;
3347 -- No further check required if not an entity name
3349 if not Is_Entity_Name (Argx) then
3350 null;
3352 else
3353 declare
3354 OK : Boolean;
3355 Ent : constant Entity_Id := Entity (Argx);
3356 Scop : constant Entity_Id := Scope (Ent);
3358 begin
3359 -- Case of a pragma applied to a compilation unit: pragma must
3360 -- occur immediately after the program unit in the compilation.
3362 if Is_Compilation_Unit (Ent) then
3363 declare
3364 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
3366 begin
3367 -- Case of pragma placed immediately after spec
3369 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
3370 OK := True;
3372 -- Case of pragma placed immediately after body
3374 elsif Nkind (Decl) = N_Subprogram_Declaration
3375 and then Present (Corresponding_Body (Decl))
3376 then
3377 OK := Parent (N) =
3378 Aux_Decls_Node
3379 (Parent (Unit_Declaration_Node
3380 (Corresponding_Body (Decl))));
3382 -- All other cases are illegal
3384 else
3385 OK := False;
3386 end if;
3387 end;
3389 -- Special restricted placement rule from 10.2.1(11.8/2)
3391 elsif Is_Generic_Formal (Ent)
3392 and then Prag_Id = Pragma_Preelaborable_Initialization
3393 then
3394 OK := List_Containing (N) =
3395 Generic_Formal_Declarations
3396 (Unit_Declaration_Node (Scop));
3398 -- Default case, just check that the pragma occurs in the scope
3399 -- of the entity denoted by the name.
3401 else
3402 OK := Current_Scope = Scop;
3403 end if;
3405 if not OK then
3406 Error_Pragma_Arg
3407 ("pragma% argument must be in same declarative part", Arg);
3408 end if;
3409 end;
3410 end if;
3411 end Check_Arg_Is_Local_Name;
3413 ---------------------------------
3414 -- Check_Arg_Is_Locking_Policy --
3415 ---------------------------------
3417 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
3418 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3420 begin
3421 Check_Arg_Is_Identifier (Argx);
3423 if not Is_Locking_Policy_Name (Chars (Argx)) then
3424 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
3425 end if;
3426 end Check_Arg_Is_Locking_Policy;
3428 -----------------------------------------------
3429 -- Check_Arg_Is_Partition_Elaboration_Policy --
3430 -----------------------------------------------
3432 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
3433 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3435 begin
3436 Check_Arg_Is_Identifier (Argx);
3438 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
3439 Error_Pragma_Arg
3440 ("& is not a valid partition elaboration policy name", Argx);
3441 end if;
3442 end Check_Arg_Is_Partition_Elaboration_Policy;
3444 -------------------------
3445 -- Check_Arg_Is_One_Of --
3446 -------------------------
3448 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3449 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3451 begin
3452 Check_Arg_Is_Identifier (Argx);
3454 if not Nam_In (Chars (Argx), N1, N2) then
3455 Error_Msg_Name_2 := N1;
3456 Error_Msg_Name_3 := N2;
3457 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
3458 end if;
3459 end Check_Arg_Is_One_Of;
3461 procedure Check_Arg_Is_One_Of
3462 (Arg : Node_Id;
3463 N1, N2, N3 : Name_Id)
3465 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3467 begin
3468 Check_Arg_Is_Identifier (Argx);
3470 if not Nam_In (Chars (Argx), N1, N2, N3) then
3471 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3472 end if;
3473 end Check_Arg_Is_One_Of;
3475 procedure Check_Arg_Is_One_Of
3476 (Arg : Node_Id;
3477 N1, N2, N3, N4 : Name_Id)
3479 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3481 begin
3482 Check_Arg_Is_Identifier (Argx);
3484 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
3485 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3486 end if;
3487 end Check_Arg_Is_One_Of;
3489 procedure Check_Arg_Is_One_Of
3490 (Arg : Node_Id;
3491 N1, N2, N3, N4, N5 : Name_Id)
3493 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3495 begin
3496 Check_Arg_Is_Identifier (Argx);
3498 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
3499 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3500 end if;
3501 end Check_Arg_Is_One_Of;
3503 ---------------------------------
3504 -- Check_Arg_Is_Queuing_Policy --
3505 ---------------------------------
3507 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
3508 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3510 begin
3511 Check_Arg_Is_Identifier (Argx);
3513 if not Is_Queuing_Policy_Name (Chars (Argx)) then
3514 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
3515 end if;
3516 end Check_Arg_Is_Queuing_Policy;
3518 ------------------------------------
3519 -- Check_Arg_Is_Static_Expression --
3520 ------------------------------------
3522 procedure Check_Arg_Is_Static_Expression
3523 (Arg : Node_Id;
3524 Typ : Entity_Id := Empty)
3526 begin
3527 Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
3528 end Check_Arg_Is_Static_Expression;
3530 ------------------------------------------
3531 -- Check_Arg_Is_Task_Dispatching_Policy --
3532 ------------------------------------------
3534 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
3535 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3537 begin
3538 Check_Arg_Is_Identifier (Argx);
3540 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
3541 Error_Pragma_Arg
3542 ("& is not a valid task dispatching policy name", Argx);
3543 end if;
3544 end Check_Arg_Is_Task_Dispatching_Policy;
3546 ---------------------
3547 -- Check_Arg_Order --
3548 ---------------------
3550 procedure Check_Arg_Order (Names : Name_List) is
3551 Arg : Node_Id;
3553 Highest_So_Far : Natural := 0;
3554 -- Highest index in Names seen do far
3556 begin
3557 Arg := Arg1;
3558 for J in 1 .. Arg_Count loop
3559 if Chars (Arg) /= No_Name then
3560 for K in Names'Range loop
3561 if Chars (Arg) = Names (K) then
3562 if K < Highest_So_Far then
3563 Error_Msg_Name_1 := Pname;
3564 Error_Msg_N
3565 ("parameters out of order for pragma%", Arg);
3566 Error_Msg_Name_1 := Names (K);
3567 Error_Msg_Name_2 := Names (Highest_So_Far);
3568 Error_Msg_N ("\% must appear before %", Arg);
3569 raise Pragma_Exit;
3571 else
3572 Highest_So_Far := K;
3573 end if;
3574 end if;
3575 end loop;
3576 end if;
3578 Arg := Next (Arg);
3579 end loop;
3580 end Check_Arg_Order;
3582 --------------------------------
3583 -- Check_At_Least_N_Arguments --
3584 --------------------------------
3586 procedure Check_At_Least_N_Arguments (N : Nat) is
3587 begin
3588 if Arg_Count < N then
3589 Error_Pragma ("too few arguments for pragma%");
3590 end if;
3591 end Check_At_Least_N_Arguments;
3593 -------------------------------
3594 -- Check_At_Most_N_Arguments --
3595 -------------------------------
3597 procedure Check_At_Most_N_Arguments (N : Nat) is
3598 Arg : Node_Id;
3599 begin
3600 if Arg_Count > N then
3601 Arg := Arg1;
3602 for J in 1 .. N loop
3603 Next (Arg);
3604 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
3605 end loop;
3606 end if;
3607 end Check_At_Most_N_Arguments;
3609 ---------------------
3610 -- Check_Component --
3611 ---------------------
3613 procedure Check_Component
3614 (Comp : Node_Id;
3615 UU_Typ : Entity_Id;
3616 In_Variant_Part : Boolean := False)
3618 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
3619 Sindic : constant Node_Id :=
3620 Subtype_Indication (Component_Definition (Comp));
3621 Typ : constant Entity_Id := Etype (Comp_Id);
3623 begin
3624 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
3625 -- object constraint, then the component type shall be an Unchecked_
3626 -- Union.
3628 if Nkind (Sindic) = N_Subtype_Indication
3629 and then Has_Per_Object_Constraint (Comp_Id)
3630 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
3631 then
3632 Error_Msg_N
3633 ("component subtype subject to per-object constraint "
3634 & "must be an Unchecked_Union", Comp);
3636 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
3637 -- the body of a generic unit, or within the body of any of its
3638 -- descendant library units, no part of the type of a component
3639 -- declared in a variant_part of the unchecked union type shall be of
3640 -- a formal private type or formal private extension declared within
3641 -- the formal part of the generic unit.
3643 elsif Ada_Version >= Ada_2012
3644 and then In_Generic_Body (UU_Typ)
3645 and then In_Variant_Part
3646 and then Is_Private_Type (Typ)
3647 and then Is_Generic_Type (Typ)
3648 then
3649 Error_Msg_N
3650 ("component of unchecked union cannot be of generic type", Comp);
3652 elsif Needs_Finalization (Typ) then
3653 Error_Msg_N
3654 ("component of unchecked union cannot be controlled", Comp);
3656 elsif Has_Task (Typ) then
3657 Error_Msg_N
3658 ("component of unchecked union cannot have tasks", Comp);
3659 end if;
3660 end Check_Component;
3662 -----------------------------
3663 -- Check_Declaration_Order --
3664 -----------------------------
3666 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id) is
3667 procedure Check_Aspect_Specification_Order;
3668 -- Inspect the aspect specifications of the context to determine the
3669 -- proper order.
3671 --------------------------------------
3672 -- Check_Aspect_Specification_Order --
3673 --------------------------------------
3675 procedure Check_Aspect_Specification_Order is
3676 Asp_First : constant Node_Id := Corresponding_Aspect (First);
3677 Asp_Second : constant Node_Id := Corresponding_Aspect (Second);
3678 Asp : Node_Id;
3680 begin
3681 -- Both aspects must be part of the same aspect specification list
3683 pragma Assert
3684 (List_Containing (Asp_First) = List_Containing (Asp_Second));
3686 -- Try to reach Second starting from First in a left to right
3687 -- traversal of the aspect specifications.
3689 Asp := Next (Asp_First);
3690 while Present (Asp) loop
3692 -- The order is ok, First is followed by Second
3694 if Asp = Asp_Second then
3695 return;
3696 end if;
3698 Next (Asp);
3699 end loop;
3701 -- If we get here, then the aspects are out of order
3703 Error_Msg_N ("aspect % cannot come after aspect %", First);
3704 end Check_Aspect_Specification_Order;
3706 -- Local variables
3708 Stmt : Node_Id;
3710 -- Start of processing for Check_Declaration_Order
3712 begin
3713 -- Cannot check the order if one of the pragmas is missing
3715 if No (First) or else No (Second) then
3716 return;
3717 end if;
3719 -- Set up the error names in case the order is incorrect
3721 Error_Msg_Name_1 := Pragma_Name (First);
3722 Error_Msg_Name_2 := Pragma_Name (Second);
3724 if From_Aspect_Specification (First) then
3726 -- Both pragmas are actually aspects, check their declaration
3727 -- order in the associated aspect specification list. Otherwise
3728 -- First is an aspect and Second a source pragma.
3730 if From_Aspect_Specification (Second) then
3731 Check_Aspect_Specification_Order;
3732 end if;
3734 -- Abstract_States is a source pragma
3736 else
3737 if From_Aspect_Specification (Second) then
3738 Error_Msg_N ("pragma % cannot come after aspect %", First);
3740 -- Both pragmas are source constructs. Try to reach First from
3741 -- Second by traversing the declarations backwards.
3743 else
3744 Stmt := Prev (Second);
3745 while Present (Stmt) loop
3747 -- The order is ok, First is followed by Second
3749 if Stmt = First then
3750 return;
3751 end if;
3753 Prev (Stmt);
3754 end loop;
3756 -- If we get here, then the pragmas are out of order
3758 Error_Msg_N ("pragma % cannot come after pragma %", First);
3759 end if;
3760 end if;
3761 end Check_Declaration_Order;
3763 ----------------------------
3764 -- Check_Duplicate_Pragma --
3765 ----------------------------
3767 procedure Check_Duplicate_Pragma (E : Entity_Id) is
3768 Id : Entity_Id := E;
3769 P : Node_Id;
3771 begin
3772 -- Nothing to do if this pragma comes from an aspect specification,
3773 -- since we could not be duplicating a pragma, and we dealt with the
3774 -- case of duplicated aspects in Analyze_Aspect_Specifications.
3776 if From_Aspect_Specification (N) then
3777 return;
3778 end if;
3780 -- Otherwise current pragma may duplicate previous pragma or a
3781 -- previously given aspect specification or attribute definition
3782 -- clause for the same pragma.
3784 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
3786 if Present (P) then
3787 Error_Msg_Name_1 := Pragma_Name (N);
3788 Error_Msg_Sloc := Sloc (P);
3790 -- For a single protected or a single task object, the error is
3791 -- issued on the original entity.
3793 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
3794 Id := Defining_Identifier (Original_Node (Parent (Id)));
3795 end if;
3797 if Nkind (P) = N_Aspect_Specification
3798 or else From_Aspect_Specification (P)
3799 then
3800 Error_Msg_NE ("aspect% for & previously given#", N, Id);
3801 else
3802 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
3803 end if;
3805 raise Pragma_Exit;
3806 end if;
3807 end Check_Duplicate_Pragma;
3809 ----------------------------------
3810 -- Check_Duplicated_Export_Name --
3811 ----------------------------------
3813 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
3814 String_Val : constant String_Id := Strval (Nam);
3816 begin
3817 -- We are only interested in the export case, and in the case of
3818 -- generics, it is the instance, not the template, that is the
3819 -- problem (the template will generate a warning in any case).
3821 if not Inside_A_Generic
3822 and then (Prag_Id = Pragma_Export
3823 or else
3824 Prag_Id = Pragma_Export_Procedure
3825 or else
3826 Prag_Id = Pragma_Export_Valued_Procedure
3827 or else
3828 Prag_Id = Pragma_Export_Function)
3829 then
3830 for J in Externals.First .. Externals.Last loop
3831 if String_Equal (String_Val, Strval (Externals.Table (J))) then
3832 Error_Msg_Sloc := Sloc (Externals.Table (J));
3833 Error_Msg_N ("external name duplicates name given#", Nam);
3834 exit;
3835 end if;
3836 end loop;
3838 Externals.Append (Nam);
3839 end if;
3840 end Check_Duplicated_Export_Name;
3842 -------------------------------------
3843 -- Check_Expr_Is_Static_Expression --
3844 -------------------------------------
3846 procedure Check_Expr_Is_Static_Expression
3847 (Expr : Node_Id;
3848 Typ : Entity_Id := Empty)
3850 begin
3851 if Present (Typ) then
3852 Analyze_And_Resolve (Expr, Typ);
3853 else
3854 Analyze_And_Resolve (Expr);
3855 end if;
3857 if Is_OK_Static_Expression (Expr) then
3858 return;
3860 elsif Etype (Expr) = Any_Type then
3861 raise Pragma_Exit;
3863 -- An interesting special case, if we have a string literal and we
3864 -- are in Ada 83 mode, then we allow it even though it will not be
3865 -- flagged as static. This allows the use of Ada 95 pragmas like
3866 -- Import in Ada 83 mode. They will of course be flagged with
3867 -- warnings as usual, but will not cause errors.
3869 elsif Ada_Version = Ada_83
3870 and then Nkind (Expr) = N_String_Literal
3871 then
3872 return;
3874 -- Static expression that raises Constraint_Error. This has already
3875 -- been flagged, so just exit from pragma processing.
3877 elsif Is_Static_Expression (Expr) then
3878 raise Pragma_Exit;
3880 -- Finally, we have a real error
3882 else
3883 Error_Msg_Name_1 := Pname;
3885 declare
3886 Msg : String :=
3887 "argument for pragma% must be a static expression!";
3888 begin
3889 Fix_Error (Msg);
3890 Flag_Non_Static_Expr (Msg, Expr);
3891 end;
3893 raise Pragma_Exit;
3894 end if;
3895 end Check_Expr_Is_Static_Expression;
3897 -------------------------
3898 -- Check_First_Subtype --
3899 -------------------------
3901 procedure Check_First_Subtype (Arg : Node_Id) is
3902 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3903 Ent : constant Entity_Id := Entity (Argx);
3905 begin
3906 if Is_First_Subtype (Ent) then
3907 null;
3909 elsif Is_Type (Ent) then
3910 Error_Pragma_Arg
3911 ("pragma% cannot apply to subtype", Argx);
3913 elsif Is_Object (Ent) then
3914 Error_Pragma_Arg
3915 ("pragma% cannot apply to object, requires a type", Argx);
3917 else
3918 Error_Pragma_Arg
3919 ("pragma% cannot apply to&, requires a type", Argx);
3920 end if;
3921 end Check_First_Subtype;
3923 ----------------------
3924 -- Check_Identifier --
3925 ----------------------
3927 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
3928 begin
3929 if Present (Arg)
3930 and then Nkind (Arg) = N_Pragma_Argument_Association
3931 then
3932 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
3933 Error_Msg_Name_1 := Pname;
3934 Error_Msg_Name_2 := Id;
3935 Error_Msg_N ("pragma% argument expects identifier%", Arg);
3936 raise Pragma_Exit;
3937 end if;
3938 end if;
3939 end Check_Identifier;
3941 --------------------------------
3942 -- Check_Identifier_Is_One_Of --
3943 --------------------------------
3945 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3946 begin
3947 if Present (Arg)
3948 and then Nkind (Arg) = N_Pragma_Argument_Association
3949 then
3950 if Chars (Arg) = No_Name then
3951 Error_Msg_Name_1 := Pname;
3952 Error_Msg_N ("pragma% argument expects an identifier", Arg);
3953 raise Pragma_Exit;
3955 elsif Chars (Arg) /= N1
3956 and then Chars (Arg) /= N2
3957 then
3958 Error_Msg_Name_1 := Pname;
3959 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
3960 raise Pragma_Exit;
3961 end if;
3962 end if;
3963 end Check_Identifier_Is_One_Of;
3965 ---------------------------
3966 -- Check_In_Main_Program --
3967 ---------------------------
3969 procedure Check_In_Main_Program is
3970 P : constant Node_Id := Parent (N);
3972 begin
3973 -- Must be at in subprogram body
3975 if Nkind (P) /= N_Subprogram_Body then
3976 Error_Pragma ("% pragma allowed only in subprogram");
3978 -- Otherwise warn if obviously not main program
3980 elsif Present (Parameter_Specifications (Specification (P)))
3981 or else not Is_Compilation_Unit (Defining_Entity (P))
3982 then
3983 Error_Msg_Name_1 := Pname;
3984 Error_Msg_N
3985 ("??pragma% is only effective in main program", N);
3986 end if;
3987 end Check_In_Main_Program;
3989 ---------------------------------------
3990 -- Check_Interrupt_Or_Attach_Handler --
3991 ---------------------------------------
3993 procedure Check_Interrupt_Or_Attach_Handler is
3994 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
3995 Handler_Proc, Proc_Scope : Entity_Id;
3997 begin
3998 Analyze (Arg1_X);
4000 if Prag_Id = Pragma_Interrupt_Handler then
4001 Check_Restriction (No_Dynamic_Attachment, N);
4002 end if;
4004 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
4005 Proc_Scope := Scope (Handler_Proc);
4007 -- On AAMP only, a pragma Interrupt_Handler is supported for
4008 -- nonprotected parameterless procedures.
4010 if not AAMP_On_Target
4011 or else Prag_Id = Pragma_Attach_Handler
4012 then
4013 if Ekind (Proc_Scope) /= E_Protected_Type then
4014 Error_Pragma_Arg
4015 ("argument of pragma% must be protected procedure", Arg1);
4016 end if;
4018 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
4019 Error_Pragma ("pragma% must be in protected definition");
4020 end if;
4021 end if;
4023 if not Is_Library_Level_Entity (Proc_Scope)
4024 or else (AAMP_On_Target
4025 and then not Is_Library_Level_Entity (Handler_Proc))
4026 then
4027 Error_Pragma_Arg
4028 ("argument for pragma% must be library level entity", Arg1);
4029 end if;
4031 -- AI05-0033: A pragma cannot appear within a generic body, because
4032 -- instance can be in a nested scope. The check that protected type
4033 -- is itself a library-level declaration is done elsewhere.
4035 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4036 -- handle code prior to AI-0033. Analysis tools typically are not
4037 -- interested in this pragma in any case, so no need to worry too
4038 -- much about its placement.
4040 if Inside_A_Generic then
4041 if Ekind (Scope (Current_Scope)) = E_Generic_Package
4042 and then In_Package_Body (Scope (Current_Scope))
4043 and then not Relaxed_RM_Semantics
4044 then
4045 Error_Pragma ("pragma% cannot be used inside a generic");
4046 end if;
4047 end if;
4048 end Check_Interrupt_Or_Attach_Handler;
4050 ---------------------------------
4051 -- Check_Loop_Pragma_Placement --
4052 ---------------------------------
4054 procedure Check_Loop_Pragma_Placement is
4055 procedure Placement_Error (Constr : Node_Id);
4056 pragma No_Return (Placement_Error);
4057 -- Node Constr denotes the last loop restricted construct before we
4058 -- encountered an illegal relation between enclosing constructs. Emit
4059 -- an error depending on what Constr was.
4061 ---------------------
4062 -- Placement_Error --
4063 ---------------------
4065 procedure Placement_Error (Constr : Node_Id) is
4066 begin
4067 if Nkind (Constr) = N_Pragma then
4068 Error_Pragma
4069 ("pragma % must appear immediately within the statements "
4070 & "of a loop");
4071 else
4072 Error_Pragma_Arg
4073 ("block containing pragma % must appear immediately within "
4074 & "the statements of a loop", Constr);
4075 end if;
4076 end Placement_Error;
4078 -- Local declarations
4080 Prev : Node_Id;
4081 Stmt : Node_Id;
4083 -- Start of processing for Check_Loop_Pragma_Placement
4085 begin
4086 Prev := N;
4087 Stmt := Parent (N);
4088 while Present (Stmt) loop
4090 -- The pragma or previous block must appear immediately within the
4091 -- current block's declarative or statement part.
4093 if Nkind (Stmt) = N_Block_Statement then
4094 if (No (Declarations (Stmt))
4095 or else List_Containing (Prev) /= Declarations (Stmt))
4096 and then
4097 List_Containing (Prev) /=
4098 Statements (Handled_Statement_Sequence (Stmt))
4099 then
4100 Placement_Error (Prev);
4101 return;
4103 -- Keep inspecting the parents because we are now within a
4104 -- chain of nested blocks.
4106 else
4107 Prev := Stmt;
4108 Stmt := Parent (Stmt);
4109 end if;
4111 -- The pragma or previous block must appear immediately within the
4112 -- statements of the loop.
4114 elsif Nkind (Stmt) = N_Loop_Statement then
4115 if List_Containing (Prev) /= Statements (Stmt) then
4116 Placement_Error (Prev);
4117 end if;
4119 -- Stop the traversal because we reached the innermost loop
4120 -- regardless of whether we encountered an error or not.
4122 return;
4124 -- Ignore a handled statement sequence. Note that this node may
4125 -- be related to a subprogram body in which case we will emit an
4126 -- error on the next iteration of the search.
4128 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
4129 Stmt := Parent (Stmt);
4131 -- Any other statement breaks the chain from the pragma to the
4132 -- loop.
4134 else
4135 Placement_Error (Prev);
4136 return;
4137 end if;
4138 end loop;
4139 end Check_Loop_Pragma_Placement;
4141 -------------------------------------------
4142 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4143 -------------------------------------------
4145 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
4146 P : Node_Id;
4148 begin
4149 P := Parent (N);
4150 loop
4151 if No (P) then
4152 exit;
4154 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
4155 exit;
4157 elsif Nkind_In (P, N_Package_Specification,
4158 N_Block_Statement)
4159 then
4160 return;
4162 -- Note: the following tests seem a little peculiar, because
4163 -- they test for bodies, but if we were in the statement part
4164 -- of the body, we would already have hit the handled statement
4165 -- sequence, so the only way we get here is by being in the
4166 -- declarative part of the body.
4168 elsif Nkind_In (P, N_Subprogram_Body,
4169 N_Package_Body,
4170 N_Task_Body,
4171 N_Entry_Body)
4172 then
4173 return;
4174 end if;
4176 P := Parent (P);
4177 end loop;
4179 Error_Pragma ("pragma% is not in declarative part or package spec");
4180 end Check_Is_In_Decl_Part_Or_Package_Spec;
4182 -------------------------
4183 -- Check_No_Identifier --
4184 -------------------------
4186 procedure Check_No_Identifier (Arg : Node_Id) is
4187 begin
4188 if Nkind (Arg) = N_Pragma_Argument_Association
4189 and then Chars (Arg) /= No_Name
4190 then
4191 Error_Pragma_Arg_Ident
4192 ("pragma% does not permit identifier& here", Arg);
4193 end if;
4194 end Check_No_Identifier;
4196 --------------------------
4197 -- Check_No_Identifiers --
4198 --------------------------
4200 procedure Check_No_Identifiers is
4201 Arg_Node : Node_Id;
4202 begin
4203 Arg_Node := Arg1;
4204 for J in 1 .. Arg_Count loop
4205 Check_No_Identifier (Arg_Node);
4206 Next (Arg_Node);
4207 end loop;
4208 end Check_No_Identifiers;
4210 ------------------------
4211 -- Check_No_Link_Name --
4212 ------------------------
4214 procedure Check_No_Link_Name is
4215 begin
4216 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
4217 Arg4 := Arg3;
4218 end if;
4220 if Present (Arg4) then
4221 Error_Pragma_Arg
4222 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
4223 end if;
4224 end Check_No_Link_Name;
4226 -------------------------------
4227 -- Check_Optional_Identifier --
4228 -------------------------------
4230 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
4231 begin
4232 if Present (Arg)
4233 and then Nkind (Arg) = N_Pragma_Argument_Association
4234 and then Chars (Arg) /= No_Name
4235 then
4236 if Chars (Arg) /= Id then
4237 Error_Msg_Name_1 := Pname;
4238 Error_Msg_Name_2 := Id;
4239 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4240 raise Pragma_Exit;
4241 end if;
4242 end if;
4243 end Check_Optional_Identifier;
4245 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
4246 begin
4247 Name_Buffer (1 .. Id'Length) := Id;
4248 Name_Len := Id'Length;
4249 Check_Optional_Identifier (Arg, Name_Find);
4250 end Check_Optional_Identifier;
4252 --------------------
4253 -- Check_Pre_Post --
4254 --------------------
4256 procedure Check_Pre_Post is
4257 P : Node_Id;
4258 PO : Node_Id;
4260 begin
4261 if not Is_List_Member (N) then
4262 Pragma_Misplaced;
4263 end if;
4265 -- If we are within an inlined body, the legality of the pragma
4266 -- has been checked already.
4268 if In_Inlined_Body then
4269 return;
4270 end if;
4272 -- Search prior declarations
4274 P := N;
4275 while Present (Prev (P)) loop
4276 P := Prev (P);
4278 -- If the previous node is a generic subprogram, do not go to to
4279 -- the original node, which is the unanalyzed tree: we need to
4280 -- attach the pre/postconditions to the analyzed version at this
4281 -- point. They get propagated to the original tree when analyzing
4282 -- the corresponding body.
4284 if Nkind (P) not in N_Generic_Declaration then
4285 PO := Original_Node (P);
4286 else
4287 PO := P;
4288 end if;
4290 -- Skip past prior pragma
4292 if Nkind (PO) = N_Pragma then
4293 null;
4295 -- Skip stuff not coming from source
4297 elsif not Comes_From_Source (PO) then
4299 -- The condition may apply to a subprogram instantiation
4301 if Nkind (PO) = N_Subprogram_Declaration
4302 and then Present (Generic_Parent (Specification (PO)))
4303 then
4304 return;
4306 elsif Nkind (PO) = N_Subprogram_Declaration
4307 and then In_Instance
4308 then
4309 return;
4311 -- For all other cases of non source code, do nothing
4313 else
4314 null;
4315 end if;
4317 -- Only remaining possibility is subprogram declaration
4319 else
4320 return;
4321 end if;
4322 end loop;
4324 -- If we fall through loop, pragma is at start of list, so see if it
4325 -- is at the start of declarations of a subprogram body.
4327 PO := Parent (N);
4329 if Nkind (PO) = N_Subprogram_Body
4330 and then List_Containing (N) = Declarations (PO)
4331 then
4332 -- This is only allowed if there is no separate specification
4334 if Present (Corresponding_Spec (PO)) then
4335 Error_Pragma
4336 ("pragma% must apply to subprogram specification");
4337 end if;
4339 return;
4340 end if;
4341 end Check_Pre_Post;
4343 --------------------------------------
4344 -- Check_Precondition_Postcondition --
4345 --------------------------------------
4347 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
4348 P : Node_Id;
4349 PO : Node_Id;
4351 procedure Chain_PPC (PO : Node_Id);
4352 -- If PO is an entry or a [generic] subprogram declaration node, then
4353 -- the precondition/postcondition applies to this subprogram and the
4354 -- processing for the pragma is completed. Otherwise the pragma is
4355 -- misplaced.
4357 ---------------
4358 -- Chain_PPC --
4359 ---------------
4361 procedure Chain_PPC (PO : Node_Id) is
4362 S : Entity_Id;
4364 begin
4365 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
4366 if not From_Aspect_Specification (N) then
4367 Error_Pragma
4368 ("pragma% cannot be applied to abstract subprogram");
4370 elsif Class_Present (N) then
4371 null;
4373 else
4374 Error_Pragma
4375 ("aspect % requires ''Class for abstract subprogram");
4376 end if;
4378 -- AI05-0230: The same restriction applies to null procedures. For
4379 -- compatibility with earlier uses of the Ada pragma, apply this
4380 -- rule only to aspect specifications.
4382 -- The above discrepency needs documentation. Robert is dubious
4383 -- about whether it is a good idea ???
4385 elsif Nkind (PO) = N_Subprogram_Declaration
4386 and then Nkind (Specification (PO)) = N_Procedure_Specification
4387 and then Null_Present (Specification (PO))
4388 and then From_Aspect_Specification (N)
4389 and then not Class_Present (N)
4390 then
4391 Error_Pragma
4392 ("aspect % requires ''Class for null procedure");
4394 -- Pre/postconditions are legal on a subprogram body if it is not
4395 -- a completion of a declaration. They are also legal on a stub
4396 -- with no previous declarations (this is checked when processing
4397 -- the corresponding aspects).
4399 elsif Nkind (PO) = N_Subprogram_Body
4400 and then Acts_As_Spec (PO)
4401 then
4402 null;
4404 elsif Nkind (PO) = N_Subprogram_Body_Stub then
4405 null;
4407 elsif not Nkind_In (PO, N_Subprogram_Declaration,
4408 N_Expression_Function,
4409 N_Generic_Subprogram_Declaration,
4410 N_Entry_Declaration)
4411 then
4412 Pragma_Misplaced;
4413 end if;
4415 -- Here if we have [generic] subprogram or entry declaration
4417 if Nkind (PO) = N_Entry_Declaration then
4418 S := Defining_Entity (PO);
4419 else
4420 S := Defining_Unit_Name (Specification (PO));
4422 if Nkind (S) = N_Defining_Program_Unit_Name then
4423 S := Defining_Identifier (S);
4424 end if;
4425 end if;
4427 -- Note: we do not analyze the pragma at this point. Instead we
4428 -- delay this analysis until the end of the declarative part in
4429 -- which the pragma appears. This implements the required delay
4430 -- in this analysis, allowing forward references. The analysis
4431 -- happens at the end of Analyze_Declarations.
4433 -- Chain spec PPC pragma to list for subprogram
4435 Add_Contract_Item (N, S);
4437 -- Return indicating spec case
4439 In_Body := False;
4440 return;
4441 end Chain_PPC;
4443 -- Start of processing for Check_Precondition_Postcondition
4445 begin
4446 if not Is_List_Member (N) then
4447 Pragma_Misplaced;
4448 end if;
4450 -- Preanalyze message argument if present. Visibility in this
4451 -- argument is established at the point of pragma occurrence.
4453 if Arg_Count = 2 then
4454 Check_Optional_Identifier (Arg2, Name_Message);
4455 Preanalyze_Spec_Expression
4456 (Get_Pragma_Arg (Arg2), Standard_String);
4457 end if;
4459 -- For a pragma PPC in the extended main source unit, record enabled
4460 -- status in SCO.
4462 if Is_Checked (N) and then not Split_PPC (N) then
4463 Set_SCO_Pragma_Enabled (Loc);
4464 end if;
4466 -- If we are within an inlined body, the legality of the pragma
4467 -- has been checked already.
4469 if In_Inlined_Body then
4470 In_Body := True;
4471 return;
4472 end if;
4474 -- Search prior declarations
4476 P := N;
4477 while Present (Prev (P)) loop
4478 P := Prev (P);
4480 -- If the previous node is a generic subprogram, do not go to to
4481 -- the original node, which is the unanalyzed tree: we need to
4482 -- attach the pre/postconditions to the analyzed version at this
4483 -- point. They get propagated to the original tree when analyzing
4484 -- the corresponding body.
4486 if Nkind (P) not in N_Generic_Declaration then
4487 PO := Original_Node (P);
4488 else
4489 PO := P;
4490 end if;
4492 -- Skip past prior pragma
4494 if Nkind (PO) = N_Pragma then
4495 null;
4497 -- Skip stuff not coming from source
4499 elsif not Comes_From_Source (PO) then
4501 -- The condition may apply to a subprogram instantiation
4503 if Nkind (PO) = N_Subprogram_Declaration
4504 and then Present (Generic_Parent (Specification (PO)))
4505 then
4506 Chain_PPC (PO);
4507 return;
4509 elsif Nkind (PO) = N_Subprogram_Declaration
4510 and then In_Instance
4511 then
4512 Chain_PPC (PO);
4513 return;
4515 -- For all other cases of non source code, do nothing
4517 else
4518 null;
4519 end if;
4521 -- Only remaining possibility is subprogram declaration
4523 else
4524 Chain_PPC (PO);
4525 return;
4526 end if;
4527 end loop;
4529 -- If we fall through loop, pragma is at start of list, so see if it
4530 -- is at the start of declarations of a subprogram body.
4532 PO := Parent (N);
4534 if Nkind (PO) = N_Subprogram_Body
4535 and then List_Containing (N) = Declarations (PO)
4536 then
4537 if Operating_Mode /= Generate_Code or else Inside_A_Generic then
4539 -- Analyze pragma expression for correctness and for ASIS use
4541 Preanalyze_Assert_Expression
4542 (Get_Pragma_Arg (Arg1), Standard_Boolean);
4544 -- In ASIS mode, for a pragma generated from a source aspect,
4545 -- also analyze the original aspect expression.
4547 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
4548 Preanalyze_Assert_Expression
4549 (Expression (Corresponding_Aspect (N)), Standard_Boolean);
4550 end if;
4551 end if;
4553 -- Retain a copy of the pre- or postcondition pragma for formal
4554 -- verification purposes. The copy is needed because the pragma is
4555 -- expanded into other constructs which are not acceptable in the
4556 -- N_Contract node.
4558 if Acts_As_Spec (PO)
4559 and then (SPARK_Mode or Formal_Extensions)
4560 then
4561 declare
4562 Prag : constant Node_Id := New_Copy_Tree (N);
4564 begin
4565 -- Preanalyze the pragma
4567 Preanalyze_Assert_Expression
4568 (Get_Pragma_Arg
4569 (First (Pragma_Argument_Associations (Prag))),
4570 Standard_Boolean);
4572 -- Preanalyze the corresponding aspect (if any)
4574 if Present (Corresponding_Aspect (Prag)) then
4575 Preanalyze_Assert_Expression
4576 (Expression (Corresponding_Aspect (Prag)),
4577 Standard_Boolean);
4578 end if;
4580 -- Chain the copy on the contract of the body
4582 Add_Contract_Item
4583 (Prag, Defining_Unit_Name (Specification (PO)));
4584 end;
4585 end if;
4587 In_Body := True;
4588 return;
4590 -- See if it is in the pragmas after a library level subprogram
4592 elsif Nkind (PO) = N_Compilation_Unit_Aux then
4594 -- In formal verification mode, analyze pragma expression for
4595 -- correctness, as it is not expanded later. Ditto in ASIS_Mode
4596 -- where there is no later point at which the aspect will be
4597 -- analyzed.
4599 if SPARK_Mode or else ASIS_Mode then
4600 Analyze_Pre_Post_Condition_In_Decl_Part
4601 (N, Defining_Entity (Unit (Parent (PO))));
4602 end if;
4604 Chain_PPC (Unit (Parent (PO)));
4605 return;
4606 end if;
4608 -- If we fall through, pragma was misplaced
4610 Pragma_Misplaced;
4611 end Check_Precondition_Postcondition;
4613 -----------------------------
4614 -- Check_Static_Constraint --
4615 -----------------------------
4617 -- Note: for convenience in writing this procedure, in addition to
4618 -- the officially (i.e. by spec) allowed argument which is always a
4619 -- constraint, it also allows ranges and discriminant associations.
4620 -- Above is not clear ???
4622 procedure Check_Static_Constraint (Constr : Node_Id) is
4624 procedure Require_Static (E : Node_Id);
4625 -- Require given expression to be static expression
4627 --------------------
4628 -- Require_Static --
4629 --------------------
4631 procedure Require_Static (E : Node_Id) is
4632 begin
4633 if not Is_OK_Static_Expression (E) then
4634 Flag_Non_Static_Expr
4635 ("non-static constraint not allowed in Unchecked_Union!", E);
4636 raise Pragma_Exit;
4637 end if;
4638 end Require_Static;
4640 -- Start of processing for Check_Static_Constraint
4642 begin
4643 case Nkind (Constr) is
4644 when N_Discriminant_Association =>
4645 Require_Static (Expression (Constr));
4647 when N_Range =>
4648 Require_Static (Low_Bound (Constr));
4649 Require_Static (High_Bound (Constr));
4651 when N_Attribute_Reference =>
4652 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
4653 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
4655 when N_Range_Constraint =>
4656 Check_Static_Constraint (Range_Expression (Constr));
4658 when N_Index_Or_Discriminant_Constraint =>
4659 declare
4660 IDC : Entity_Id;
4661 begin
4662 IDC := First (Constraints (Constr));
4663 while Present (IDC) loop
4664 Check_Static_Constraint (IDC);
4665 Next (IDC);
4666 end loop;
4667 end;
4669 when others =>
4670 null;
4671 end case;
4672 end Check_Static_Constraint;
4674 ---------------------
4675 -- Check_Test_Case --
4676 ---------------------
4678 procedure Check_Test_Case is
4679 P : Node_Id;
4680 PO : Node_Id;
4682 procedure Chain_CTC (PO : Node_Id);
4683 -- If PO is a [generic] subprogram declaration node, then the
4684 -- test-case applies to this subprogram and the processing for
4685 -- the pragma is completed. Otherwise the pragma is misplaced.
4687 ---------------
4688 -- Chain_CTC --
4689 ---------------
4691 procedure Chain_CTC (PO : Node_Id) is
4692 S : Entity_Id;
4694 begin
4695 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
4696 Error_Pragma
4697 ("pragma% cannot be applied to abstract subprogram");
4699 elsif Nkind (PO) = N_Entry_Declaration then
4700 Error_Pragma ("pragma% cannot be applied to entry");
4702 elsif not Nkind_In (PO, N_Subprogram_Declaration,
4703 N_Generic_Subprogram_Declaration)
4704 then
4705 Pragma_Misplaced;
4706 end if;
4708 -- Here if we have [generic] subprogram declaration
4710 S := Defining_Unit_Name (Specification (PO));
4712 -- Note: we do not analyze the pragma at this point. Instead we
4713 -- delay this analysis until the end of the declarative part in
4714 -- which the pragma appears. This implements the required delay
4715 -- in this analysis, allowing forward references. The analysis
4716 -- happens at the end of Analyze_Declarations.
4718 -- There should not be another test-case with the same name
4719 -- associated to this subprogram.
4721 declare
4722 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
4723 CTC : Node_Id;
4725 begin
4726 CTC := Contract_Test_Cases (Contract (S));
4727 while Present (CTC) loop
4729 -- Omit pragma Contract_Cases because it does not introduce
4730 -- a unique case name and it does not follow the syntax of
4731 -- Test_Case.
4733 if Pragma_Name (CTC) = Name_Contract_Cases then
4734 null;
4736 elsif String_Equal
4737 (Name, Get_Name_From_CTC_Pragma (CTC))
4738 then
4739 Error_Msg_Sloc := Sloc (CTC);
4740 Error_Pragma ("name for pragma% is already used#");
4741 end if;
4743 CTC := Next_Pragma (CTC);
4744 end loop;
4745 end;
4747 -- Chain spec CTC pragma to list for subprogram
4749 Add_Contract_Item (N, S);
4750 end Chain_CTC;
4752 -- Start of processing for Check_Test_Case
4754 begin
4755 -- First check pragma arguments
4757 Check_At_Least_N_Arguments (2);
4758 Check_At_Most_N_Arguments (4);
4759 Check_Arg_Order
4760 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
4762 Check_Optional_Identifier (Arg1, Name_Name);
4763 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
4765 -- In ASIS mode, for a pragma generated from a source aspect, also
4766 -- analyze the original aspect expression.
4768 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
4769 Check_Expr_Is_Static_Expression
4770 (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
4771 end if;
4773 Check_Optional_Identifier (Arg2, Name_Mode);
4774 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
4776 if Arg_Count = 4 then
4777 Check_Identifier (Arg3, Name_Requires);
4778 Check_Identifier (Arg4, Name_Ensures);
4780 elsif Arg_Count = 3 then
4781 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
4782 end if;
4784 -- Check pragma placement
4786 if not Is_List_Member (N) then
4787 Pragma_Misplaced;
4788 end if;
4790 -- Test-case should only appear in package spec unit
4792 if Get_Source_Unit (N) = No_Unit
4793 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
4794 N_Package_Declaration,
4795 N_Generic_Package_Declaration)
4796 then
4797 Pragma_Misplaced;
4798 end if;
4800 -- Search prior declarations
4802 P := N;
4803 while Present (Prev (P)) loop
4804 P := Prev (P);
4806 -- If the previous node is a generic subprogram, do not go to to
4807 -- the original node, which is the unanalyzed tree: we need to
4808 -- attach the test-case to the analyzed version at this point.
4809 -- They get propagated to the original tree when analyzing the
4810 -- corresponding body.
4812 if Nkind (P) not in N_Generic_Declaration then
4813 PO := Original_Node (P);
4814 else
4815 PO := P;
4816 end if;
4818 -- Skip past prior pragma
4820 if Nkind (PO) = N_Pragma then
4821 null;
4823 -- Skip stuff not coming from source
4825 elsif not Comes_From_Source (PO) then
4826 null;
4828 -- Only remaining possibility is subprogram declaration. First
4829 -- check that it is declared directly in a package declaration.
4830 -- This may be either the package declaration for the current unit
4831 -- being defined or a local package declaration.
4833 elsif not Present (Parent (Parent (PO)))
4834 or else not Present (Parent (Parent (Parent (PO))))
4835 or else not Nkind_In (Parent (Parent (PO)),
4836 N_Package_Declaration,
4837 N_Generic_Package_Declaration)
4838 then
4839 Pragma_Misplaced;
4841 else
4842 Chain_CTC (PO);
4843 return;
4844 end if;
4845 end loop;
4847 -- If we fall through, pragma was misplaced
4849 Pragma_Misplaced;
4850 end Check_Test_Case;
4852 --------------------------------------
4853 -- Check_Valid_Configuration_Pragma --
4854 --------------------------------------
4856 -- A configuration pragma must appear in the context clause of a
4857 -- compilation unit, and only other pragmas may precede it. Note that
4858 -- the test also allows use in a configuration pragma file.
4860 procedure Check_Valid_Configuration_Pragma is
4861 begin
4862 if not Is_Configuration_Pragma then
4863 Error_Pragma ("incorrect placement for configuration pragma%");
4864 end if;
4865 end Check_Valid_Configuration_Pragma;
4867 -------------------------------------
4868 -- Check_Valid_Library_Unit_Pragma --
4869 -------------------------------------
4871 procedure Check_Valid_Library_Unit_Pragma is
4872 Plist : List_Id;
4873 Parent_Node : Node_Id;
4874 Unit_Name : Entity_Id;
4875 Unit_Kind : Node_Kind;
4876 Unit_Node : Node_Id;
4877 Sindex : Source_File_Index;
4879 begin
4880 if not Is_List_Member (N) then
4881 Pragma_Misplaced;
4883 else
4884 Plist := List_Containing (N);
4885 Parent_Node := Parent (Plist);
4887 if Parent_Node = Empty then
4888 Pragma_Misplaced;
4890 -- Case of pragma appearing after a compilation unit. In this case
4891 -- it must have an argument with the corresponding name and must
4892 -- be part of the following pragmas of its parent.
4894 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
4895 if Plist /= Pragmas_After (Parent_Node) then
4896 Pragma_Misplaced;
4898 elsif Arg_Count = 0 then
4899 Error_Pragma
4900 ("argument required if outside compilation unit");
4902 else
4903 Check_No_Identifiers;
4904 Check_Arg_Count (1);
4905 Unit_Node := Unit (Parent (Parent_Node));
4906 Unit_Kind := Nkind (Unit_Node);
4908 Analyze (Get_Pragma_Arg (Arg1));
4910 if Unit_Kind = N_Generic_Subprogram_Declaration
4911 or else Unit_Kind = N_Subprogram_Declaration
4912 then
4913 Unit_Name := Defining_Entity (Unit_Node);
4915 elsif Unit_Kind in N_Generic_Instantiation then
4916 Unit_Name := Defining_Entity (Unit_Node);
4918 else
4919 Unit_Name := Cunit_Entity (Current_Sem_Unit);
4920 end if;
4922 if Chars (Unit_Name) /=
4923 Chars (Entity (Get_Pragma_Arg (Arg1)))
4924 then
4925 Error_Pragma_Arg
4926 ("pragma% argument is not current unit name", Arg1);
4927 end if;
4929 if Ekind (Unit_Name) = E_Package
4930 and then Present (Renamed_Entity (Unit_Name))
4931 then
4932 Error_Pragma ("pragma% not allowed for renamed package");
4933 end if;
4934 end if;
4936 -- Pragma appears other than after a compilation unit
4938 else
4939 -- Here we check for the generic instantiation case and also
4940 -- for the case of processing a generic formal package. We
4941 -- detect these cases by noting that the Sloc on the node
4942 -- does not belong to the current compilation unit.
4944 Sindex := Source_Index (Current_Sem_Unit);
4946 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
4947 Rewrite (N, Make_Null_Statement (Loc));
4948 return;
4950 -- If before first declaration, the pragma applies to the
4951 -- enclosing unit, and the name if present must be this name.
4953 elsif Is_Before_First_Decl (N, Plist) then
4954 Unit_Node := Unit_Declaration_Node (Current_Scope);
4955 Unit_Kind := Nkind (Unit_Node);
4957 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
4958 Pragma_Misplaced;
4960 elsif Unit_Kind = N_Subprogram_Body
4961 and then not Acts_As_Spec (Unit_Node)
4962 then
4963 Pragma_Misplaced;
4965 elsif Nkind (Parent_Node) = N_Package_Body then
4966 Pragma_Misplaced;
4968 elsif Nkind (Parent_Node) = N_Package_Specification
4969 and then Plist = Private_Declarations (Parent_Node)
4970 then
4971 Pragma_Misplaced;
4973 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
4974 or else Nkind (Parent_Node) =
4975 N_Generic_Subprogram_Declaration)
4976 and then Plist = Generic_Formal_Declarations (Parent_Node)
4977 then
4978 Pragma_Misplaced;
4980 elsif Arg_Count > 0 then
4981 Analyze (Get_Pragma_Arg (Arg1));
4983 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
4984 Error_Pragma_Arg
4985 ("name in pragma% must be enclosing unit", Arg1);
4986 end if;
4988 -- It is legal to have no argument in this context
4990 else
4991 return;
4992 end if;
4994 -- Error if not before first declaration. This is because a
4995 -- library unit pragma argument must be the name of a library
4996 -- unit (RM 10.1.5(7)), but the only names permitted in this
4997 -- context are (RM 10.1.5(6)) names of subprogram declarations,
4998 -- generic subprogram declarations or generic instantiations.
5000 else
5001 Error_Pragma
5002 ("pragma% misplaced, must be before first declaration");
5003 end if;
5004 end if;
5005 end if;
5006 end Check_Valid_Library_Unit_Pragma;
5008 -------------------
5009 -- Check_Variant --
5010 -------------------
5012 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5013 Clist : constant Node_Id := Component_List (Variant);
5014 Comp : Node_Id;
5016 begin
5017 Comp := First (Component_Items (Clist));
5018 while Present (Comp) loop
5019 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5020 Next (Comp);
5021 end loop;
5022 end Check_Variant;
5024 ------------------
5025 -- Error_Pragma --
5026 ------------------
5028 procedure Error_Pragma (Msg : String) is
5029 MsgF : String := Msg;
5030 begin
5031 Error_Msg_Name_1 := Pname;
5032 Fix_Error (MsgF);
5033 Error_Msg_N (MsgF, N);
5034 raise Pragma_Exit;
5035 end Error_Pragma;
5037 ----------------------
5038 -- Error_Pragma_Arg --
5039 ----------------------
5041 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5042 MsgF : String := Msg;
5043 begin
5044 Error_Msg_Name_1 := Pname;
5045 Fix_Error (MsgF);
5046 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
5047 raise Pragma_Exit;
5048 end Error_Pragma_Arg;
5050 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
5051 MsgF : String := Msg1;
5052 begin
5053 Error_Msg_Name_1 := Pname;
5054 Fix_Error (MsgF);
5055 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
5056 Error_Pragma_Arg (Msg2, Arg);
5057 end Error_Pragma_Arg;
5059 ----------------------------
5060 -- Error_Pragma_Arg_Ident --
5061 ----------------------------
5063 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
5064 MsgF : String := Msg;
5065 begin
5066 Error_Msg_Name_1 := Pname;
5067 Fix_Error (MsgF);
5068 Error_Msg_N (MsgF, Arg);
5069 raise Pragma_Exit;
5070 end Error_Pragma_Arg_Ident;
5072 ----------------------
5073 -- Error_Pragma_Ref --
5074 ----------------------
5076 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
5077 MsgF : String := Msg;
5078 begin
5079 Error_Msg_Name_1 := Pname;
5080 Fix_Error (MsgF);
5081 Error_Msg_Sloc := Sloc (Ref);
5082 Error_Msg_NE (MsgF, N, Ref);
5083 raise Pragma_Exit;
5084 end Error_Pragma_Ref;
5086 ------------------------
5087 -- Find_Lib_Unit_Name --
5088 ------------------------
5090 function Find_Lib_Unit_Name return Entity_Id is
5091 begin
5092 -- Return inner compilation unit entity, for case of nested
5093 -- categorization pragmas. This happens in generic unit.
5095 if Nkind (Parent (N)) = N_Package_Specification
5096 and then Defining_Entity (Parent (N)) /= Current_Scope
5097 then
5098 return Defining_Entity (Parent (N));
5099 else
5100 return Current_Scope;
5101 end if;
5102 end Find_Lib_Unit_Name;
5104 ----------------------------
5105 -- Find_Program_Unit_Name --
5106 ----------------------------
5108 procedure Find_Program_Unit_Name (Id : Node_Id) is
5109 Unit_Name : Entity_Id;
5110 Unit_Kind : Node_Kind;
5111 P : constant Node_Id := Parent (N);
5113 begin
5114 if Nkind (P) = N_Compilation_Unit then
5115 Unit_Kind := Nkind (Unit (P));
5117 if Unit_Kind = N_Subprogram_Declaration
5118 or else Unit_Kind = N_Package_Declaration
5119 or else Unit_Kind in N_Generic_Declaration
5120 then
5121 Unit_Name := Defining_Entity (Unit (P));
5123 if Chars (Id) = Chars (Unit_Name) then
5124 Set_Entity (Id, Unit_Name);
5125 Set_Etype (Id, Etype (Unit_Name));
5126 else
5127 Set_Etype (Id, Any_Type);
5128 Error_Pragma
5129 ("cannot find program unit referenced by pragma%");
5130 end if;
5132 else
5133 Set_Etype (Id, Any_Type);
5134 Error_Pragma ("pragma% inapplicable to this unit");
5135 end if;
5137 else
5138 Analyze (Id);
5139 end if;
5140 end Find_Program_Unit_Name;
5142 -----------------------------------------
5143 -- Find_Unique_Parameterless_Procedure --
5144 -----------------------------------------
5146 function Find_Unique_Parameterless_Procedure
5147 (Name : Entity_Id;
5148 Arg : Node_Id) return Entity_Id
5150 Proc : Entity_Id := Empty;
5152 begin
5153 -- The body of this procedure needs some comments ???
5155 if not Is_Entity_Name (Name) then
5156 Error_Pragma_Arg
5157 ("argument of pragma% must be entity name", Arg);
5159 elsif not Is_Overloaded (Name) then
5160 Proc := Entity (Name);
5162 if Ekind (Proc) /= E_Procedure
5163 or else Present (First_Formal (Proc))
5164 then
5165 Error_Pragma_Arg
5166 ("argument of pragma% must be parameterless procedure", Arg);
5167 end if;
5169 else
5170 declare
5171 Found : Boolean := False;
5172 It : Interp;
5173 Index : Interp_Index;
5175 begin
5176 Get_First_Interp (Name, Index, It);
5177 while Present (It.Nam) loop
5178 Proc := It.Nam;
5180 if Ekind (Proc) = E_Procedure
5181 and then No (First_Formal (Proc))
5182 then
5183 if not Found then
5184 Found := True;
5185 Set_Entity (Name, Proc);
5186 Set_Is_Overloaded (Name, False);
5187 else
5188 Error_Pragma_Arg
5189 ("ambiguous handler name for pragma% ", Arg);
5190 end if;
5191 end if;
5193 Get_Next_Interp (Index, It);
5194 end loop;
5196 if not Found then
5197 Error_Pragma_Arg
5198 ("argument of pragma% must be parameterless procedure",
5199 Arg);
5200 else
5201 Proc := Entity (Name);
5202 end if;
5203 end;
5204 end if;
5206 return Proc;
5207 end Find_Unique_Parameterless_Procedure;
5209 ---------------
5210 -- Fix_Error --
5211 ---------------
5213 procedure Fix_Error (Msg : in out String) is
5214 begin
5215 -- If we have a rewriting of another pragma, go to that pragma
5217 if Is_Rewrite_Substitution (N)
5218 and then Nkind (Original_Node (N)) = N_Pragma
5219 then
5220 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
5221 end if;
5223 -- Case where pragma comes from an aspect specification
5225 if From_Aspect_Specification (N) then
5227 -- Change appearence of "pragma" in message to "aspect"
5229 for J in Msg'First .. Msg'Last - 5 loop
5230 if Msg (J .. J + 5) = "pragma" then
5231 Msg (J .. J + 5) := "aspect";
5232 end if;
5233 end loop;
5235 -- Get name from corresponding aspect
5237 Error_Msg_Name_1 := Original_Aspect_Name (N);
5238 end if;
5239 end Fix_Error;
5241 -------------------------
5242 -- Gather_Associations --
5243 -------------------------
5245 procedure Gather_Associations
5246 (Names : Name_List;
5247 Args : out Args_List)
5249 Arg : Node_Id;
5251 begin
5252 -- Initialize all parameters to Empty
5254 for J in Args'Range loop
5255 Args (J) := Empty;
5256 end loop;
5258 -- That's all we have to do if there are no argument associations
5260 if No (Pragma_Argument_Associations (N)) then
5261 return;
5262 end if;
5264 -- Otherwise first deal with any positional parameters present
5266 Arg := First (Pragma_Argument_Associations (N));
5267 for Index in Args'Range loop
5268 exit when No (Arg) or else Chars (Arg) /= No_Name;
5269 Args (Index) := Get_Pragma_Arg (Arg);
5270 Next (Arg);
5271 end loop;
5273 -- Positional parameters all processed, if any left, then we
5274 -- have too many positional parameters.
5276 if Present (Arg) and then Chars (Arg) = No_Name then
5277 Error_Pragma_Arg
5278 ("too many positional associations for pragma%", Arg);
5279 end if;
5281 -- Process named parameters if any are present
5283 while Present (Arg) loop
5284 if Chars (Arg) = No_Name then
5285 Error_Pragma_Arg
5286 ("positional association cannot follow named association",
5287 Arg);
5289 else
5290 for Index in Names'Range loop
5291 if Names (Index) = Chars (Arg) then
5292 if Present (Args (Index)) then
5293 Error_Pragma_Arg
5294 ("duplicate argument association for pragma%", Arg);
5295 else
5296 Args (Index) := Get_Pragma_Arg (Arg);
5297 exit;
5298 end if;
5299 end if;
5301 if Index = Names'Last then
5302 Error_Msg_Name_1 := Pname;
5303 Error_Msg_N ("pragma% does not allow & argument", Arg);
5305 -- Check for possible misspelling
5307 for Index1 in Names'Range loop
5308 if Is_Bad_Spelling_Of
5309 (Chars (Arg), Names (Index1))
5310 then
5311 Error_Msg_Name_1 := Names (Index1);
5312 Error_Msg_N -- CODEFIX
5313 ("\possible misspelling of%", Arg);
5314 exit;
5315 end if;
5316 end loop;
5318 raise Pragma_Exit;
5319 end if;
5320 end loop;
5321 end if;
5323 Next (Arg);
5324 end loop;
5325 end Gather_Associations;
5327 -----------------
5328 -- GNAT_Pragma --
5329 -----------------
5331 procedure GNAT_Pragma is
5332 begin
5333 -- We need to check the No_Implementation_Pragmas restriction for
5334 -- the case of a pragma from source. Note that the case of aspects
5335 -- generating corresponding pragmas marks these pragmas as not being
5336 -- from source, so this test also catches that case.
5338 if Comes_From_Source (N) then
5339 Check_Restriction (No_Implementation_Pragmas, N);
5340 end if;
5341 end GNAT_Pragma;
5343 --------------------------
5344 -- Is_Before_First_Decl --
5345 --------------------------
5347 function Is_Before_First_Decl
5348 (Pragma_Node : Node_Id;
5349 Decls : List_Id) return Boolean
5351 Item : Node_Id := First (Decls);
5353 begin
5354 -- Only other pragmas can come before this pragma
5356 loop
5357 if No (Item) or else Nkind (Item) /= N_Pragma then
5358 return False;
5360 elsif Item = Pragma_Node then
5361 return True;
5362 end if;
5364 Next (Item);
5365 end loop;
5366 end Is_Before_First_Decl;
5368 -----------------------------
5369 -- Is_Configuration_Pragma --
5370 -----------------------------
5372 -- A configuration pragma must appear in the context clause of a
5373 -- compilation unit, and only other pragmas may precede it. Note that
5374 -- the test below also permits use in a configuration pragma file.
5376 function Is_Configuration_Pragma return Boolean is
5377 Lis : constant List_Id := List_Containing (N);
5378 Par : constant Node_Id := Parent (N);
5379 Prg : Node_Id;
5381 begin
5382 -- If no parent, then we are in the configuration pragma file,
5383 -- so the placement is definitely appropriate.
5385 if No (Par) then
5386 return True;
5388 -- Otherwise we must be in the context clause of a compilation unit
5389 -- and the only thing allowed before us in the context list is more
5390 -- configuration pragmas.
5392 elsif Nkind (Par) = N_Compilation_Unit
5393 and then Context_Items (Par) = Lis
5394 then
5395 Prg := First (Lis);
5397 loop
5398 if Prg = N then
5399 return True;
5400 elsif Nkind (Prg) /= N_Pragma then
5401 return False;
5402 end if;
5404 Next (Prg);
5405 end loop;
5407 else
5408 return False;
5409 end if;
5410 end Is_Configuration_Pragma;
5412 --------------------------
5413 -- Is_In_Context_Clause --
5414 --------------------------
5416 function Is_In_Context_Clause return Boolean is
5417 Plist : List_Id;
5418 Parent_Node : Node_Id;
5420 begin
5421 if not Is_List_Member (N) then
5422 return False;
5424 else
5425 Plist := List_Containing (N);
5426 Parent_Node := Parent (Plist);
5428 if Parent_Node = Empty
5429 or else Nkind (Parent_Node) /= N_Compilation_Unit
5430 or else Context_Items (Parent_Node) /= Plist
5431 then
5432 return False;
5433 end if;
5434 end if;
5436 return True;
5437 end Is_In_Context_Clause;
5439 ---------------------------------
5440 -- Is_Static_String_Expression --
5441 ---------------------------------
5443 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
5444 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5446 begin
5447 Analyze_And_Resolve (Argx);
5448 return Is_OK_Static_Expression (Argx)
5449 and then Nkind (Argx) = N_String_Literal;
5450 end Is_Static_String_Expression;
5452 ----------------------
5453 -- Pragma_Misplaced --
5454 ----------------------
5456 procedure Pragma_Misplaced is
5457 begin
5458 Error_Pragma ("incorrect placement of pragma%");
5459 end Pragma_Misplaced;
5461 ------------------------------------
5462 -- Process_Atomic_Shared_Volatile --
5463 ------------------------------------
5465 procedure Process_Atomic_Shared_Volatile is
5466 E_Id : Node_Id;
5467 E : Entity_Id;
5468 D : Node_Id;
5469 K : Node_Kind;
5470 Utyp : Entity_Id;
5472 procedure Set_Atomic (E : Entity_Id);
5473 -- Set given type as atomic, and if no explicit alignment was given,
5474 -- set alignment to unknown, since back end knows what the alignment
5475 -- requirements are for atomic arrays. Note: this step is necessary
5476 -- for derived types.
5478 ----------------
5479 -- Set_Atomic --
5480 ----------------
5482 procedure Set_Atomic (E : Entity_Id) is
5483 begin
5484 Set_Is_Atomic (E);
5486 if not Has_Alignment_Clause (E) then
5487 Set_Alignment (E, Uint_0);
5488 end if;
5489 end Set_Atomic;
5491 -- Start of processing for Process_Atomic_Shared_Volatile
5493 begin
5494 Check_Ada_83_Warning;
5495 Check_No_Identifiers;
5496 Check_Arg_Count (1);
5497 Check_Arg_Is_Local_Name (Arg1);
5498 E_Id := Get_Pragma_Arg (Arg1);
5500 if Etype (E_Id) = Any_Type then
5501 return;
5502 end if;
5504 E := Entity (E_Id);
5505 D := Declaration_Node (E);
5506 K := Nkind (D);
5508 -- Check duplicate before we chain ourselves!
5510 Check_Duplicate_Pragma (E);
5512 -- Now check appropriateness of the entity
5514 if Is_Type (E) then
5515 if Rep_Item_Too_Early (E, N)
5516 or else
5517 Rep_Item_Too_Late (E, N)
5518 then
5519 return;
5520 else
5521 Check_First_Subtype (Arg1);
5522 end if;
5524 if Prag_Id /= Pragma_Volatile then
5525 Set_Atomic (E);
5526 Set_Atomic (Underlying_Type (E));
5527 Set_Atomic (Base_Type (E));
5528 end if;
5530 -- Attribute belongs on the base type. If the view of the type is
5531 -- currently private, it also belongs on the underlying type.
5533 Set_Is_Volatile (Base_Type (E));
5534 Set_Is_Volatile (Underlying_Type (E));
5536 Set_Treat_As_Volatile (E);
5537 Set_Treat_As_Volatile (Underlying_Type (E));
5539 elsif K = N_Object_Declaration
5540 or else (K = N_Component_Declaration
5541 and then Original_Record_Component (E) = E)
5542 then
5543 if Rep_Item_Too_Late (E, N) then
5544 return;
5545 end if;
5547 if Prag_Id /= Pragma_Volatile then
5548 Set_Is_Atomic (E);
5550 -- If the object declaration has an explicit initialization, a
5551 -- temporary may have to be created to hold the expression, to
5552 -- ensure that access to the object remain atomic.
5554 if Nkind (Parent (E)) = N_Object_Declaration
5555 and then Present (Expression (Parent (E)))
5556 then
5557 Set_Has_Delayed_Freeze (E);
5558 end if;
5560 -- An interesting improvement here. If an object of composite
5561 -- type X is declared atomic, and the type X isn't, that's a
5562 -- pity, since it may not have appropriate alignment etc. We
5563 -- can rescue this in the special case where the object and
5564 -- type are in the same unit by just setting the type as
5565 -- atomic, so that the back end will process it as atomic.
5567 -- Note: we used to do this for elementary types as well,
5568 -- but that turns out to be a bad idea and can have unwanted
5569 -- effects, most notably if the type is elementary, the object
5570 -- a simple component within a record, and both are in a spec:
5571 -- every object of this type in the entire program will be
5572 -- treated as atomic, thus incurring a potentially costly
5573 -- synchronization operation for every access.
5575 -- Of course it would be best if the back end could just adjust
5576 -- the alignment etc for the specific object, but that's not
5577 -- something we are capable of doing at this point.
5579 Utyp := Underlying_Type (Etype (E));
5581 if Present (Utyp)
5582 and then Is_Composite_Type (Utyp)
5583 and then Sloc (E) > No_Location
5584 and then Sloc (Utyp) > No_Location
5585 and then
5586 Get_Source_File_Index (Sloc (E)) =
5587 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
5588 then
5589 Set_Is_Atomic (Underlying_Type (Etype (E)));
5590 end if;
5591 end if;
5593 Set_Is_Volatile (E);
5594 Set_Treat_As_Volatile (E);
5596 else
5597 Error_Pragma_Arg
5598 ("inappropriate entity for pragma%", Arg1);
5599 end if;
5600 end Process_Atomic_Shared_Volatile;
5602 -------------------------------------------
5603 -- Process_Compile_Time_Warning_Or_Error --
5604 -------------------------------------------
5606 procedure Process_Compile_Time_Warning_Or_Error is
5607 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
5609 begin
5610 Check_Arg_Count (2);
5611 Check_No_Identifiers;
5612 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
5613 Analyze_And_Resolve (Arg1x, Standard_Boolean);
5615 if Compile_Time_Known_Value (Arg1x) then
5616 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
5617 declare
5618 Str : constant String_Id :=
5619 Strval (Get_Pragma_Arg (Arg2));
5620 Len : constant Int := String_Length (Str);
5621 Cont : Boolean;
5622 Ptr : Nat;
5623 CC : Char_Code;
5624 C : Character;
5625 Cent : constant Entity_Id :=
5626 Cunit_Entity (Current_Sem_Unit);
5628 Force : constant Boolean :=
5629 Prag_Id = Pragma_Compile_Time_Warning
5630 and then
5631 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
5632 and then (Ekind (Cent) /= E_Package
5633 or else not In_Private_Part (Cent));
5634 -- Set True if this is the warning case, and we are in the
5635 -- visible part of a package spec, or in a subprogram spec,
5636 -- in which case we want to force the client to see the
5637 -- warning, even though it is not in the main unit.
5639 begin
5640 -- Loop through segments of message separated by line feeds.
5641 -- We output these segments as separate messages with
5642 -- continuation marks for all but the first.
5644 Cont := False;
5645 Ptr := 1;
5646 loop
5647 Error_Msg_Strlen := 0;
5649 -- Loop to copy characters from argument to error message
5650 -- string buffer.
5652 loop
5653 exit when Ptr > Len;
5654 CC := Get_String_Char (Str, Ptr);
5655 Ptr := Ptr + 1;
5657 -- Ignore wide chars ??? else store character
5659 if In_Character_Range (CC) then
5660 C := Get_Character (CC);
5661 exit when C = ASCII.LF;
5662 Error_Msg_Strlen := Error_Msg_Strlen + 1;
5663 Error_Msg_String (Error_Msg_Strlen) := C;
5664 end if;
5665 end loop;
5667 -- Here with one line ready to go
5669 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
5671 -- If this is a warning in a spec, then we want clients
5672 -- to see the warning, so mark the message with the
5673 -- special sequence !! to force the warning. In the case
5674 -- of a package spec, we do not force this if we are in
5675 -- the private part of the spec.
5677 if Force then
5678 if Cont = False then
5679 Error_Msg_N ("<~!!", Arg1);
5680 Cont := True;
5681 else
5682 Error_Msg_N ("\<~!!", Arg1);
5683 end if;
5685 -- Error, rather than warning, or in a body, so we do not
5686 -- need to force visibility for client (error will be
5687 -- output in any case, and this is the situation in which
5688 -- we do not want a client to get a warning, since the
5689 -- warning is in the body or the spec private part).
5691 else
5692 if Cont = False then
5693 Error_Msg_N ("<~", Arg1);
5694 Cont := True;
5695 else
5696 Error_Msg_N ("\<~", Arg1);
5697 end if;
5698 end if;
5700 exit when Ptr > Len;
5701 end loop;
5702 end;
5703 end if;
5704 end if;
5705 end Process_Compile_Time_Warning_Or_Error;
5707 ------------------------
5708 -- Process_Convention --
5709 ------------------------
5711 procedure Process_Convention
5712 (C : out Convention_Id;
5713 Ent : out Entity_Id)
5715 Id : Node_Id;
5716 E : Entity_Id;
5717 E1 : Entity_Id;
5718 Cname : Name_Id;
5719 Comp_Unit : Unit_Number_Type;
5721 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
5722 -- Called if we have more than one Export/Import/Convention pragma.
5723 -- This is generally illegal, but we have a special case of allowing
5724 -- Import and Interface to coexist if they specify the convention in
5725 -- a consistent manner. We are allowed to do this, since Interface is
5726 -- an implementation defined pragma, and we choose to do it since we
5727 -- know Rational allows this combination. S is the entity id of the
5728 -- subprogram in question. This procedure also sets the special flag
5729 -- Import_Interface_Present in both pragmas in the case where we do
5730 -- have matching Import and Interface pragmas.
5732 procedure Set_Convention_From_Pragma (E : Entity_Id);
5733 -- Set convention in entity E, and also flag that the entity has a
5734 -- convention pragma. If entity is for a private or incomplete type,
5735 -- also set convention and flag on underlying type. This procedure
5736 -- also deals with the special case of C_Pass_By_Copy convention.
5738 -------------------------------
5739 -- Diagnose_Multiple_Pragmas --
5740 -------------------------------
5742 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
5743 Pdec : constant Node_Id := Declaration_Node (S);
5744 Decl : Node_Id;
5745 Err : Boolean;
5747 function Same_Convention (Decl : Node_Id) return Boolean;
5748 -- Decl is a pragma node. This function returns True if this
5749 -- pragma has a first argument that is an identifier with a
5750 -- Chars field corresponding to the Convention_Id C.
5752 function Same_Name (Decl : Node_Id) return Boolean;
5753 -- Decl is a pragma node. This function returns True if this
5754 -- pragma has a second argument that is an identifier with a
5755 -- Chars field that matches the Chars of the current subprogram.
5757 ---------------------
5758 -- Same_Convention --
5759 ---------------------
5761 function Same_Convention (Decl : Node_Id) return Boolean is
5762 Arg1 : constant Node_Id :=
5763 First (Pragma_Argument_Associations (Decl));
5765 begin
5766 if Present (Arg1) then
5767 declare
5768 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
5769 begin
5770 if Nkind (Arg) = N_Identifier
5771 and then Is_Convention_Name (Chars (Arg))
5772 and then Get_Convention_Id (Chars (Arg)) = C
5773 then
5774 return True;
5775 end if;
5776 end;
5777 end if;
5779 return False;
5780 end Same_Convention;
5782 ---------------
5783 -- Same_Name --
5784 ---------------
5786 function Same_Name (Decl : Node_Id) return Boolean is
5787 Arg1 : constant Node_Id :=
5788 First (Pragma_Argument_Associations (Decl));
5789 Arg2 : Node_Id;
5791 begin
5792 if No (Arg1) then
5793 return False;
5794 end if;
5796 Arg2 := Next (Arg1);
5798 if No (Arg2) then
5799 return False;
5800 end if;
5802 declare
5803 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
5804 begin
5805 if Nkind (Arg) = N_Identifier
5806 and then Chars (Arg) = Chars (S)
5807 then
5808 return True;
5809 end if;
5810 end;
5812 return False;
5813 end Same_Name;
5815 -- Start of processing for Diagnose_Multiple_Pragmas
5817 begin
5818 Err := True;
5820 -- Definitely give message if we have Convention/Export here
5822 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
5823 null;
5825 -- If we have an Import or Export, scan back from pragma to
5826 -- find any previous pragma applying to the same procedure.
5827 -- The scan will be terminated by the start of the list, or
5828 -- hitting the subprogram declaration. This won't allow one
5829 -- pragma to appear in the public part and one in the private
5830 -- part, but that seems very unlikely in practice.
5832 else
5833 Decl := Prev (N);
5834 while Present (Decl) and then Decl /= Pdec loop
5836 -- Look for pragma with same name as us
5838 if Nkind (Decl) = N_Pragma
5839 and then Same_Name (Decl)
5840 then
5841 -- Give error if same as our pragma or Export/Convention
5843 if Nam_In (Pragma_Name (Decl), Name_Export,
5844 Name_Convention,
5845 Pragma_Name (N))
5846 then
5847 exit;
5849 -- Case of Import/Interface or the other way round
5851 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
5852 Name_Import)
5853 then
5854 -- Here we know that we have Import and Interface. It
5855 -- doesn't matter which way round they are. See if
5856 -- they specify the same convention. If so, all OK,
5857 -- and set special flags to stop other messages
5859 if Same_Convention (Decl) then
5860 Set_Import_Interface_Present (N);
5861 Set_Import_Interface_Present (Decl);
5862 Err := False;
5864 -- If different conventions, special message
5866 else
5867 Error_Msg_Sloc := Sloc (Decl);
5868 Error_Pragma_Arg
5869 ("convention differs from that given#", Arg1);
5870 return;
5871 end if;
5872 end if;
5873 end if;
5875 Next (Decl);
5876 end loop;
5877 end if;
5879 -- Give message if needed if we fall through those tests
5880 -- except on Relaxed_RM_Semantics where we let go: either this
5881 -- is a case accepted/ignored by other Ada compilers (e.g.
5882 -- a mix of Convention and Import), or another error will be
5883 -- generated later (e.g. using both Import and Export).
5885 if Err and not Relaxed_RM_Semantics then
5886 Error_Pragma_Arg
5887 ("at most one Convention/Export/Import pragma is allowed",
5888 Arg2);
5889 end if;
5890 end Diagnose_Multiple_Pragmas;
5892 --------------------------------
5893 -- Set_Convention_From_Pragma --
5894 --------------------------------
5896 procedure Set_Convention_From_Pragma (E : Entity_Id) is
5897 begin
5898 -- Ada 2005 (AI-430): Check invalid attempt to change convention
5899 -- for an overridden dispatching operation. Technically this is
5900 -- an amendment and should only be done in Ada 2005 mode. However,
5901 -- this is clearly a mistake, since the problem that is addressed
5902 -- by this AI is that there is a clear gap in the RM!
5904 if Is_Dispatching_Operation (E)
5905 and then Present (Overridden_Operation (E))
5906 and then C /= Convention (Overridden_Operation (E))
5907 then
5908 -- An attempt to override a subprogram with a ghost subprogram
5909 -- appears as a mismatch in conventions.
5911 if C = Convention_Ghost then
5912 Error_Msg_N ("ghost subprogram & cannot be overriding", E);
5913 else
5914 Error_Pragma_Arg
5915 ("cannot change convention for overridden dispatching "
5916 & "operation", Arg1);
5917 end if;
5918 end if;
5920 -- Special checks for Convention_Stdcall
5922 if C = Convention_Stdcall then
5924 -- A dispatching call is not allowed. A dispatching subprogram
5925 -- cannot be used to interface to the Win32 API, so in fact
5926 -- this check does not impose any effective restriction.
5928 if Is_Dispatching_Operation (E) then
5929 Error_Msg_Sloc := Sloc (E);
5931 -- Note: make this unconditional so that if there is more
5932 -- than one call to which the pragma applies, we get a
5933 -- message for each call. Also don't use Error_Pragma,
5934 -- so that we get multiple messages!
5936 Error_Msg_N
5937 ("dispatching subprogram# cannot use Stdcall convention!",
5938 Arg1);
5940 -- Subprogram is allowed, but not a generic subprogram
5942 elsif not Is_Subprogram (E)
5943 and then not Is_Generic_Subprogram (E)
5945 -- A variable is OK
5947 and then Ekind (E) /= E_Variable
5949 -- An access to subprogram is also allowed
5951 and then not
5952 (Is_Access_Type (E)
5953 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
5955 -- Allow internal call to set convention of subprogram type
5957 and then not (Ekind (E) = E_Subprogram_Type)
5958 then
5959 Error_Pragma_Arg
5960 ("second argument of pragma% must be subprogram (type)",
5961 Arg2);
5962 end if;
5963 end if;
5965 -- Set the convention
5967 Set_Convention (E, C);
5968 Set_Has_Convention_Pragma (E);
5970 if Is_Incomplete_Or_Private_Type (E)
5971 and then Present (Underlying_Type (E))
5972 then
5973 Set_Convention (Underlying_Type (E), C);
5974 Set_Has_Convention_Pragma (Underlying_Type (E), True);
5975 end if;
5977 -- A class-wide type should inherit the convention of the specific
5978 -- root type (although this isn't specified clearly by the RM).
5980 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
5981 Set_Convention (Class_Wide_Type (E), C);
5982 end if;
5984 -- If the entity is a record type, then check for special case of
5985 -- C_Pass_By_Copy, which is treated the same as C except that the
5986 -- special record flag is set. This convention is only permitted
5987 -- on record types (see AI95-00131).
5989 if Cname = Name_C_Pass_By_Copy then
5990 if Is_Record_Type (E) then
5991 Set_C_Pass_By_Copy (Base_Type (E));
5992 elsif Is_Incomplete_Or_Private_Type (E)
5993 and then Is_Record_Type (Underlying_Type (E))
5994 then
5995 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
5996 else
5997 Error_Pragma_Arg
5998 ("C_Pass_By_Copy convention allowed only for record type",
5999 Arg2);
6000 end if;
6001 end if;
6003 -- If the entity is a derived boolean type, check for the special
6004 -- case of convention C, C++, or Fortran, where we consider any
6005 -- nonzero value to represent true.
6007 if Is_Discrete_Type (E)
6008 and then Root_Type (Etype (E)) = Standard_Boolean
6009 and then
6010 (C = Convention_C
6011 or else
6012 C = Convention_CPP
6013 or else
6014 C = Convention_Fortran)
6015 then
6016 Set_Nonzero_Is_True (Base_Type (E));
6017 end if;
6018 end Set_Convention_From_Pragma;
6020 -- Start of processing for Process_Convention
6022 begin
6023 Check_At_Least_N_Arguments (2);
6024 Check_Optional_Identifier (Arg1, Name_Convention);
6025 Check_Arg_Is_Identifier (Arg1);
6026 Cname := Chars (Get_Pragma_Arg (Arg1));
6028 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6029 -- tested again below to set the critical flag).
6031 if Cname = Name_C_Pass_By_Copy then
6032 C := Convention_C;
6034 -- Otherwise we must have something in the standard convention list
6036 elsif Is_Convention_Name (Cname) then
6037 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
6039 -- In DEC VMS, it seems that there is an undocumented feature that
6040 -- any unrecognized convention is treated as the default, which for
6041 -- us is convention C. It does not seem so terrible to do this
6042 -- unconditionally, silently in the VMS case, and with a warning
6043 -- in the non-VMS case.
6045 else
6046 if Warn_On_Export_Import and not OpenVMS_On_Target then
6047 Error_Msg_N
6048 ("??unrecognized convention name, C assumed",
6049 Get_Pragma_Arg (Arg1));
6050 end if;
6052 C := Convention_C;
6053 end if;
6055 Check_Optional_Identifier (Arg2, Name_Entity);
6056 Check_Arg_Is_Local_Name (Arg2);
6058 Id := Get_Pragma_Arg (Arg2);
6059 Analyze (Id);
6061 if not Is_Entity_Name (Id) then
6062 Error_Pragma_Arg ("entity name required", Arg2);
6063 end if;
6065 E := Entity (Id);
6067 -- Set entity to return
6069 Ent := E;
6071 -- Ada_Pass_By_Copy special checking
6073 if C = Convention_Ada_Pass_By_Copy then
6074 if not Is_First_Subtype (E) then
6075 Error_Pragma_Arg
6076 ("convention `Ada_Pass_By_Copy` only allowed for types",
6077 Arg2);
6078 end if;
6080 if Is_By_Reference_Type (E) then
6081 Error_Pragma_Arg
6082 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6083 & "type", Arg1);
6084 end if;
6085 end if;
6087 -- Ada_Pass_By_Reference special checking
6089 if C = Convention_Ada_Pass_By_Reference then
6090 if not Is_First_Subtype (E) then
6091 Error_Pragma_Arg
6092 ("convention `Ada_Pass_By_Reference` only allowed for types",
6093 Arg2);
6094 end if;
6096 if Is_By_Copy_Type (E) then
6097 Error_Pragma_Arg
6098 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6099 & "type", Arg1);
6100 end if;
6101 end if;
6103 -- Ghost special checking
6105 if Is_Ghost_Subprogram (E)
6106 and then Present (Overridden_Operation (E))
6107 then
6108 Error_Msg_N ("ghost subprogram & cannot be overriding", E);
6109 end if;
6111 -- Go to renamed subprogram if present, since convention applies to
6112 -- the actual renamed entity, not to the renaming entity. If the
6113 -- subprogram is inherited, go to parent subprogram.
6115 if Is_Subprogram (E)
6116 and then Present (Alias (E))
6117 then
6118 if Nkind (Parent (Declaration_Node (E))) =
6119 N_Subprogram_Renaming_Declaration
6120 then
6121 if Scope (E) /= Scope (Alias (E)) then
6122 Error_Pragma_Ref
6123 ("cannot apply pragma% to non-local entity&#", E);
6124 end if;
6126 E := Alias (E);
6128 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
6129 N_Private_Extension_Declaration)
6130 and then Scope (E) = Scope (Alias (E))
6131 then
6132 E := Alias (E);
6134 -- Return the parent subprogram the entity was inherited from
6136 Ent := E;
6137 end if;
6138 end if;
6140 -- Check that we are not applying this to a specless body
6141 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
6142 -- compilers.
6144 if Is_Subprogram (E)
6145 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
6146 and then not Relaxed_RM_Semantics
6147 then
6148 Error_Pragma
6149 ("pragma% requires separate spec and must come before body");
6150 end if;
6152 -- Check that we are not applying this to a named constant
6154 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
6155 Error_Msg_Name_1 := Pname;
6156 Error_Msg_N
6157 ("cannot apply pragma% to named constant!",
6158 Get_Pragma_Arg (Arg2));
6159 Error_Pragma_Arg
6160 ("\supply appropriate type for&!", Arg2);
6161 end if;
6163 if Ekind (E) = E_Enumeration_Literal then
6164 Error_Pragma ("enumeration literal not allowed for pragma%");
6165 end if;
6167 -- Check for rep item appearing too early or too late
6169 if Etype (E) = Any_Type
6170 or else Rep_Item_Too_Early (E, N)
6171 then
6172 raise Pragma_Exit;
6174 elsif Present (Underlying_Type (E)) then
6175 E := Underlying_Type (E);
6176 end if;
6178 if Rep_Item_Too_Late (E, N) then
6179 raise Pragma_Exit;
6180 end if;
6182 if Has_Convention_Pragma (E) then
6183 Diagnose_Multiple_Pragmas (E);
6185 elsif Convention (E) = Convention_Protected
6186 or else Ekind (Scope (E)) = E_Protected_Type
6187 then
6188 Error_Pragma_Arg
6189 ("a protected operation cannot be given a different convention",
6190 Arg2);
6191 end if;
6193 -- For Intrinsic, a subprogram is required
6195 if C = Convention_Intrinsic
6196 and then not Is_Subprogram (E)
6197 and then not Is_Generic_Subprogram (E)
6198 then
6199 Error_Pragma_Arg
6200 ("second argument of pragma% must be a subprogram", Arg2);
6201 end if;
6203 -- Deal with non-subprogram cases
6205 if not Is_Subprogram (E)
6206 and then not Is_Generic_Subprogram (E)
6207 then
6208 Set_Convention_From_Pragma (E);
6210 if Is_Type (E) then
6211 Check_First_Subtype (Arg2);
6212 Set_Convention_From_Pragma (Base_Type (E));
6214 -- For access subprograms, we must set the convention on the
6215 -- internally generated directly designated type as well.
6217 if Ekind (E) = E_Access_Subprogram_Type then
6218 Set_Convention_From_Pragma (Directly_Designated_Type (E));
6219 end if;
6220 end if;
6222 -- For the subprogram case, set proper convention for all homonyms
6223 -- in same scope and the same declarative part, i.e. the same
6224 -- compilation unit.
6226 else
6227 Comp_Unit := Get_Source_Unit (E);
6228 Set_Convention_From_Pragma (E);
6230 -- Treat a pragma Import as an implicit body, and pragma import
6231 -- as implicit reference (for navigation in GPS).
6233 if Prag_Id = Pragma_Import then
6234 Generate_Reference (E, Id, 'b');
6236 -- For exported entities we restrict the generation of references
6237 -- to entities exported to foreign languages since entities
6238 -- exported to Ada do not provide further information to GPS and
6239 -- add undesired references to the output of the gnatxref tool.
6241 elsif Prag_Id = Pragma_Export
6242 and then Convention (E) /= Convention_Ada
6243 then
6244 Generate_Reference (E, Id, 'i');
6245 end if;
6247 -- If the pragma comes from from an aspect, it only applies to the
6248 -- given entity, not its homonyms.
6250 if From_Aspect_Specification (N) then
6251 return;
6252 end if;
6254 -- Otherwise Loop through the homonyms of the pragma argument's
6255 -- entity, an apply convention to those in the current scope.
6257 E1 := Ent;
6259 loop
6260 E1 := Homonym (E1);
6261 exit when No (E1) or else Scope (E1) /= Current_Scope;
6263 -- Ignore entry for which convention is already set
6265 if Has_Convention_Pragma (E1) then
6266 goto Continue;
6267 end if;
6269 -- Do not set the pragma on inherited operations or on formal
6270 -- subprograms.
6272 if Comes_From_Source (E1)
6273 and then Comp_Unit = Get_Source_Unit (E1)
6274 and then not Is_Formal_Subprogram (E1)
6275 and then Nkind (Original_Node (Parent (E1))) /=
6276 N_Full_Type_Declaration
6277 then
6278 if Present (Alias (E1))
6279 and then Scope (E1) /= Scope (Alias (E1))
6280 then
6281 Error_Pragma_Ref
6282 ("cannot apply pragma% to non-local entity& declared#",
6283 E1);
6284 end if;
6286 Set_Convention_From_Pragma (E1);
6288 if Prag_Id = Pragma_Import then
6289 Generate_Reference (E1, Id, 'b');
6290 end if;
6291 end if;
6293 <<Continue>>
6294 null;
6295 end loop;
6296 end if;
6297 end Process_Convention;
6299 ----------------------------------------
6300 -- Process_Disable_Enable_Atomic_Sync --
6301 ----------------------------------------
6303 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
6304 begin
6305 Check_No_Identifiers;
6306 Check_At_Most_N_Arguments (1);
6308 -- Modeled internally as
6309 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
6311 Rewrite (N,
6312 Make_Pragma (Loc,
6313 Pragma_Identifier =>
6314 Make_Identifier (Loc, Nam),
6315 Pragma_Argument_Associations => New_List (
6316 Make_Pragma_Argument_Association (Loc,
6317 Expression =>
6318 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
6320 if Present (Arg1) then
6321 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
6322 end if;
6324 Analyze (N);
6325 end Process_Disable_Enable_Atomic_Sync;
6327 -----------------------------------------------------
6328 -- Process_Extended_Import_Export_Exception_Pragma --
6329 -----------------------------------------------------
6331 procedure Process_Extended_Import_Export_Exception_Pragma
6332 (Arg_Internal : Node_Id;
6333 Arg_External : Node_Id;
6334 Arg_Form : Node_Id;
6335 Arg_Code : Node_Id)
6337 Def_Id : Entity_Id;
6338 Code_Val : Uint;
6340 begin
6341 if not OpenVMS_On_Target then
6342 Error_Pragma
6343 ("??pragma% ignored (applies only to Open'V'M'S)");
6344 end if;
6346 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6347 Def_Id := Entity (Arg_Internal);
6349 if Ekind (Def_Id) /= E_Exception then
6350 Error_Pragma_Arg
6351 ("pragma% must refer to declared exception", Arg_Internal);
6352 end if;
6354 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
6356 if Present (Arg_Form) then
6357 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
6358 end if;
6360 if Present (Arg_Form)
6361 and then Chars (Arg_Form) = Name_Ada
6362 then
6363 null;
6364 else
6365 Set_Is_VMS_Exception (Def_Id);
6366 Set_Exception_Code (Def_Id, No_Uint);
6367 end if;
6369 if Present (Arg_Code) then
6370 if not Is_VMS_Exception (Def_Id) then
6371 Error_Pragma_Arg
6372 ("Code option for pragma% not allowed for Ada case",
6373 Arg_Code);
6374 end if;
6376 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
6377 Code_Val := Expr_Value (Arg_Code);
6379 if not UI_Is_In_Int_Range (Code_Val) then
6380 Error_Pragma_Arg
6381 ("Code option for pragma% must be in 32-bit range",
6382 Arg_Code);
6384 else
6385 Set_Exception_Code (Def_Id, Code_Val);
6386 end if;
6387 end if;
6388 end Process_Extended_Import_Export_Exception_Pragma;
6390 -------------------------------------------------
6391 -- Process_Extended_Import_Export_Internal_Arg --
6392 -------------------------------------------------
6394 procedure Process_Extended_Import_Export_Internal_Arg
6395 (Arg_Internal : Node_Id := Empty)
6397 begin
6398 if No (Arg_Internal) then
6399 Error_Pragma ("Internal parameter required for pragma%");
6400 end if;
6402 if Nkind (Arg_Internal) = N_Identifier then
6403 null;
6405 elsif Nkind (Arg_Internal) = N_Operator_Symbol
6406 and then (Prag_Id = Pragma_Import_Function
6407 or else
6408 Prag_Id = Pragma_Export_Function)
6409 then
6410 null;
6412 else
6413 Error_Pragma_Arg
6414 ("wrong form for Internal parameter for pragma%", Arg_Internal);
6415 end if;
6417 Check_Arg_Is_Local_Name (Arg_Internal);
6418 end Process_Extended_Import_Export_Internal_Arg;
6420 --------------------------------------------------
6421 -- Process_Extended_Import_Export_Object_Pragma --
6422 --------------------------------------------------
6424 procedure Process_Extended_Import_Export_Object_Pragma
6425 (Arg_Internal : Node_Id;
6426 Arg_External : Node_Id;
6427 Arg_Size : Node_Id)
6429 Def_Id : Entity_Id;
6431 begin
6432 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6433 Def_Id := Entity (Arg_Internal);
6435 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
6436 Error_Pragma_Arg
6437 ("pragma% must designate an object", Arg_Internal);
6438 end if;
6440 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
6441 or else
6442 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
6443 then
6444 Error_Pragma_Arg
6445 ("previous Common/Psect_Object applies, pragma % not permitted",
6446 Arg_Internal);
6447 end if;
6449 if Rep_Item_Too_Late (Def_Id, N) then
6450 raise Pragma_Exit;
6451 end if;
6453 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
6455 if Present (Arg_Size) then
6456 Check_Arg_Is_External_Name (Arg_Size);
6457 end if;
6459 -- Export_Object case
6461 if Prag_Id = Pragma_Export_Object then
6462 if not Is_Library_Level_Entity (Def_Id) then
6463 Error_Pragma_Arg
6464 ("argument for pragma% must be library level entity",
6465 Arg_Internal);
6466 end if;
6468 if Ekind (Current_Scope) = E_Generic_Package then
6469 Error_Pragma ("pragma& cannot appear in a generic unit");
6470 end if;
6472 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
6473 Error_Pragma_Arg
6474 ("exported object must have compile time known size",
6475 Arg_Internal);
6476 end if;
6478 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
6479 Error_Msg_N ("??duplicate Export_Object pragma", N);
6480 else
6481 Set_Exported (Def_Id, Arg_Internal);
6482 end if;
6484 -- Import_Object case
6486 else
6487 if Is_Concurrent_Type (Etype (Def_Id)) then
6488 Error_Pragma_Arg
6489 ("cannot use pragma% for task/protected object",
6490 Arg_Internal);
6491 end if;
6493 if Ekind (Def_Id) = E_Constant then
6494 Error_Pragma_Arg
6495 ("cannot import a constant", Arg_Internal);
6496 end if;
6498 if Warn_On_Export_Import
6499 and then Has_Discriminants (Etype (Def_Id))
6500 then
6501 Error_Msg_N
6502 ("imported value must be initialized??", Arg_Internal);
6503 end if;
6505 if Warn_On_Export_Import
6506 and then Is_Access_Type (Etype (Def_Id))
6507 then
6508 Error_Pragma_Arg
6509 ("cannot import object of an access type??", Arg_Internal);
6510 end if;
6512 if Warn_On_Export_Import
6513 and then Is_Imported (Def_Id)
6514 then
6515 Error_Msg_N ("??duplicate Import_Object pragma", N);
6517 -- Check for explicit initialization present. Note that an
6518 -- initialization generated by the code generator, e.g. for an
6519 -- access type, does not count here.
6521 elsif Present (Expression (Parent (Def_Id)))
6522 and then
6523 Comes_From_Source
6524 (Original_Node (Expression (Parent (Def_Id))))
6525 then
6526 Error_Msg_Sloc := Sloc (Def_Id);
6527 Error_Pragma_Arg
6528 ("imported entities cannot be initialized (RM B.1(24))",
6529 "\no initialization allowed for & declared#", Arg1);
6530 else
6531 Set_Imported (Def_Id);
6532 Note_Possible_Modification (Arg_Internal, Sure => False);
6533 end if;
6534 end if;
6535 end Process_Extended_Import_Export_Object_Pragma;
6537 ------------------------------------------------------
6538 -- Process_Extended_Import_Export_Subprogram_Pragma --
6539 ------------------------------------------------------
6541 procedure Process_Extended_Import_Export_Subprogram_Pragma
6542 (Arg_Internal : Node_Id;
6543 Arg_External : Node_Id;
6544 Arg_Parameter_Types : Node_Id;
6545 Arg_Result_Type : Node_Id := Empty;
6546 Arg_Mechanism : Node_Id;
6547 Arg_Result_Mechanism : Node_Id := Empty;
6548 Arg_First_Optional_Parameter : Node_Id := Empty)
6550 Ent : Entity_Id;
6551 Def_Id : Entity_Id;
6552 Hom_Id : Entity_Id;
6553 Formal : Entity_Id;
6554 Ambiguous : Boolean;
6555 Match : Boolean;
6556 Dval : Node_Id;
6558 function Same_Base_Type
6559 (Ptype : Node_Id;
6560 Formal : Entity_Id) return Boolean;
6561 -- Determines if Ptype references the type of Formal. Note that only
6562 -- the base types need to match according to the spec. Ptype here is
6563 -- the argument from the pragma, which is either a type name, or an
6564 -- access attribute.
6566 --------------------
6567 -- Same_Base_Type --
6568 --------------------
6570 function Same_Base_Type
6571 (Ptype : Node_Id;
6572 Formal : Entity_Id) return Boolean
6574 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
6575 Pref : Node_Id;
6577 begin
6578 -- Case where pragma argument is typ'Access
6580 if Nkind (Ptype) = N_Attribute_Reference
6581 and then Attribute_Name (Ptype) = Name_Access
6582 then
6583 Pref := Prefix (Ptype);
6584 Find_Type (Pref);
6586 if not Is_Entity_Name (Pref)
6587 or else Entity (Pref) = Any_Type
6588 then
6589 raise Pragma_Exit;
6590 end if;
6592 -- We have a match if the corresponding argument is of an
6593 -- anonymous access type, and its designated type matches the
6594 -- type of the prefix of the access attribute
6596 return Ekind (Ftyp) = E_Anonymous_Access_Type
6597 and then Base_Type (Entity (Pref)) =
6598 Base_Type (Etype (Designated_Type (Ftyp)));
6600 -- Case where pragma argument is a type name
6602 else
6603 Find_Type (Ptype);
6605 if not Is_Entity_Name (Ptype)
6606 or else Entity (Ptype) = Any_Type
6607 then
6608 raise Pragma_Exit;
6609 end if;
6611 -- We have a match if the corresponding argument is of the type
6612 -- given in the pragma (comparing base types)
6614 return Base_Type (Entity (Ptype)) = Ftyp;
6615 end if;
6616 end Same_Base_Type;
6618 -- Start of processing for
6619 -- Process_Extended_Import_Export_Subprogram_Pragma
6621 begin
6622 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6623 Ent := Empty;
6624 Ambiguous := False;
6626 -- Loop through homonyms (overloadings) of the entity
6628 Hom_Id := Entity (Arg_Internal);
6629 while Present (Hom_Id) loop
6630 Def_Id := Get_Base_Subprogram (Hom_Id);
6632 -- We need a subprogram in the current scope
6634 if not Is_Subprogram (Def_Id)
6635 or else Scope (Def_Id) /= Current_Scope
6636 then
6637 null;
6639 else
6640 Match := True;
6642 -- Pragma cannot apply to subprogram body
6644 if Is_Subprogram (Def_Id)
6645 and then Nkind (Parent (Declaration_Node (Def_Id))) =
6646 N_Subprogram_Body
6647 then
6648 Error_Pragma
6649 ("pragma% requires separate spec"
6650 & " and must come before body");
6651 end if;
6653 -- Test result type if given, note that the result type
6654 -- parameter can only be present for the function cases.
6656 if Present (Arg_Result_Type)
6657 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
6658 then
6659 Match := False;
6661 elsif Etype (Def_Id) /= Standard_Void_Type
6662 and then
6663 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
6664 then
6665 Match := False;
6667 -- Test parameter types if given. Note that this parameter
6668 -- has not been analyzed (and must not be, since it is
6669 -- semantic nonsense), so we get it as the parser left it.
6671 elsif Present (Arg_Parameter_Types) then
6672 Check_Matching_Types : declare
6673 Formal : Entity_Id;
6674 Ptype : Node_Id;
6676 begin
6677 Formal := First_Formal (Def_Id);
6679 if Nkind (Arg_Parameter_Types) = N_Null then
6680 if Present (Formal) then
6681 Match := False;
6682 end if;
6684 -- A list of one type, e.g. (List) is parsed as
6685 -- a parenthesized expression.
6687 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
6688 and then Paren_Count (Arg_Parameter_Types) = 1
6689 then
6690 if No (Formal)
6691 or else Present (Next_Formal (Formal))
6692 then
6693 Match := False;
6694 else
6695 Match :=
6696 Same_Base_Type (Arg_Parameter_Types, Formal);
6697 end if;
6699 -- A list of more than one type is parsed as a aggregate
6701 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
6702 and then Paren_Count (Arg_Parameter_Types) = 0
6703 then
6704 Ptype := First (Expressions (Arg_Parameter_Types));
6705 while Present (Ptype) or else Present (Formal) loop
6706 if No (Ptype)
6707 or else No (Formal)
6708 or else not Same_Base_Type (Ptype, Formal)
6709 then
6710 Match := False;
6711 exit;
6712 else
6713 Next_Formal (Formal);
6714 Next (Ptype);
6715 end if;
6716 end loop;
6718 -- Anything else is of the wrong form
6720 else
6721 Error_Pragma_Arg
6722 ("wrong form for Parameter_Types parameter",
6723 Arg_Parameter_Types);
6724 end if;
6725 end Check_Matching_Types;
6726 end if;
6728 -- Match is now False if the entry we found did not match
6729 -- either a supplied Parameter_Types or Result_Types argument
6731 if Match then
6732 if No (Ent) then
6733 Ent := Def_Id;
6735 -- Ambiguous case, the flag Ambiguous shows if we already
6736 -- detected this and output the initial messages.
6738 else
6739 if not Ambiguous then
6740 Ambiguous := True;
6741 Error_Msg_Name_1 := Pname;
6742 Error_Msg_N
6743 ("pragma% does not uniquely identify subprogram!",
6745 Error_Msg_Sloc := Sloc (Ent);
6746 Error_Msg_N ("matching subprogram #!", N);
6747 Ent := Empty;
6748 end if;
6750 Error_Msg_Sloc := Sloc (Def_Id);
6751 Error_Msg_N ("matching subprogram #!", N);
6752 end if;
6753 end if;
6754 end if;
6756 Hom_Id := Homonym (Hom_Id);
6757 end loop;
6759 -- See if we found an entry
6761 if No (Ent) then
6762 if not Ambiguous then
6763 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
6764 Error_Pragma
6765 ("pragma% cannot be given for generic subprogram");
6766 else
6767 Error_Pragma
6768 ("pragma% does not identify local subprogram");
6769 end if;
6770 end if;
6772 return;
6773 end if;
6775 -- Import pragmas must be for imported entities
6777 if Prag_Id = Pragma_Import_Function
6778 or else
6779 Prag_Id = Pragma_Import_Procedure
6780 or else
6781 Prag_Id = Pragma_Import_Valued_Procedure
6782 then
6783 if not Is_Imported (Ent) then
6784 Error_Pragma
6785 ("pragma Import or Interface must precede pragma%");
6786 end if;
6788 -- Here we have the Export case which can set the entity as exported
6790 -- But does not do so if the specified external name is null, since
6791 -- that is taken as a signal in DEC Ada 83 (with which we want to be
6792 -- compatible) to request no external name.
6794 elsif Nkind (Arg_External) = N_String_Literal
6795 and then String_Length (Strval (Arg_External)) = 0
6796 then
6797 null;
6799 -- In all other cases, set entity as exported
6801 else
6802 Set_Exported (Ent, Arg_Internal);
6803 end if;
6805 -- Special processing for Valued_Procedure cases
6807 if Prag_Id = Pragma_Import_Valued_Procedure
6808 or else
6809 Prag_Id = Pragma_Export_Valued_Procedure
6810 then
6811 Formal := First_Formal (Ent);
6813 if No (Formal) then
6814 Error_Pragma ("at least one parameter required for pragma%");
6816 elsif Ekind (Formal) /= E_Out_Parameter then
6817 Error_Pragma ("first parameter must have mode out for pragma%");
6819 else
6820 Set_Is_Valued_Procedure (Ent);
6821 end if;
6822 end if;
6824 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
6826 -- Process Result_Mechanism argument if present. We have already
6827 -- checked that this is only allowed for the function case.
6829 if Present (Arg_Result_Mechanism) then
6830 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
6831 end if;
6833 -- Process Mechanism parameter if present. Note that this parameter
6834 -- is not analyzed, and must not be analyzed since it is semantic
6835 -- nonsense, so we get it in exactly as the parser left it.
6837 if Present (Arg_Mechanism) then
6838 declare
6839 Formal : Entity_Id;
6840 Massoc : Node_Id;
6841 Mname : Node_Id;
6842 Choice : Node_Id;
6844 begin
6845 -- A single mechanism association without a formal parameter
6846 -- name is parsed as a parenthesized expression. All other
6847 -- cases are parsed as aggregates, so we rewrite the single
6848 -- parameter case as an aggregate for consistency.
6850 if Nkind (Arg_Mechanism) /= N_Aggregate
6851 and then Paren_Count (Arg_Mechanism) = 1
6852 then
6853 Rewrite (Arg_Mechanism,
6854 Make_Aggregate (Sloc (Arg_Mechanism),
6855 Expressions => New_List (
6856 Relocate_Node (Arg_Mechanism))));
6857 end if;
6859 -- Case of only mechanism name given, applies to all formals
6861 if Nkind (Arg_Mechanism) /= N_Aggregate then
6862 Formal := First_Formal (Ent);
6863 while Present (Formal) loop
6864 Set_Mechanism_Value (Formal, Arg_Mechanism);
6865 Next_Formal (Formal);
6866 end loop;
6868 -- Case of list of mechanism associations given
6870 else
6871 if Null_Record_Present (Arg_Mechanism) then
6872 Error_Pragma_Arg
6873 ("inappropriate form for Mechanism parameter",
6874 Arg_Mechanism);
6875 end if;
6877 -- Deal with positional ones first
6879 Formal := First_Formal (Ent);
6881 if Present (Expressions (Arg_Mechanism)) then
6882 Mname := First (Expressions (Arg_Mechanism));
6883 while Present (Mname) loop
6884 if No (Formal) then
6885 Error_Pragma_Arg
6886 ("too many mechanism associations", Mname);
6887 end if;
6889 Set_Mechanism_Value (Formal, Mname);
6890 Next_Formal (Formal);
6891 Next (Mname);
6892 end loop;
6893 end if;
6895 -- Deal with named entries
6897 if Present (Component_Associations (Arg_Mechanism)) then
6898 Massoc := First (Component_Associations (Arg_Mechanism));
6899 while Present (Massoc) loop
6900 Choice := First (Choices (Massoc));
6902 if Nkind (Choice) /= N_Identifier
6903 or else Present (Next (Choice))
6904 then
6905 Error_Pragma_Arg
6906 ("incorrect form for mechanism association",
6907 Massoc);
6908 end if;
6910 Formal := First_Formal (Ent);
6911 loop
6912 if No (Formal) then
6913 Error_Pragma_Arg
6914 ("parameter name & not present", Choice);
6915 end if;
6917 if Chars (Choice) = Chars (Formal) then
6918 Set_Mechanism_Value
6919 (Formal, Expression (Massoc));
6921 -- Set entity on identifier (needed by ASIS)
6923 Set_Entity (Choice, Formal);
6925 exit;
6926 end if;
6928 Next_Formal (Formal);
6929 end loop;
6931 Next (Massoc);
6932 end loop;
6933 end if;
6934 end if;
6935 end;
6936 end if;
6938 -- Process First_Optional_Parameter argument if present. We have
6939 -- already checked that this is only allowed for the Import case.
6941 if Present (Arg_First_Optional_Parameter) then
6942 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
6943 Error_Pragma_Arg
6944 ("first optional parameter must be formal parameter name",
6945 Arg_First_Optional_Parameter);
6946 end if;
6948 Formal := First_Formal (Ent);
6949 loop
6950 if No (Formal) then
6951 Error_Pragma_Arg
6952 ("specified formal parameter& not found",
6953 Arg_First_Optional_Parameter);
6954 end if;
6956 exit when Chars (Formal) =
6957 Chars (Arg_First_Optional_Parameter);
6959 Next_Formal (Formal);
6960 end loop;
6962 Set_First_Optional_Parameter (Ent, Formal);
6964 -- Check specified and all remaining formals have right form
6966 while Present (Formal) loop
6967 if Ekind (Formal) /= E_In_Parameter then
6968 Error_Msg_NE
6969 ("optional formal& is not of mode in!",
6970 Arg_First_Optional_Parameter, Formal);
6972 else
6973 Dval := Default_Value (Formal);
6975 if No (Dval) then
6976 Error_Msg_NE
6977 ("optional formal& does not have default value!",
6978 Arg_First_Optional_Parameter, Formal);
6980 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
6981 null;
6983 else
6984 Error_Msg_FE
6985 ("default value for optional formal& is non-static!",
6986 Arg_First_Optional_Parameter, Formal);
6987 end if;
6988 end if;
6990 Set_Is_Optional_Parameter (Formal);
6991 Next_Formal (Formal);
6992 end loop;
6993 end if;
6994 end Process_Extended_Import_Export_Subprogram_Pragma;
6996 --------------------------
6997 -- Process_Generic_List --
6998 --------------------------
7000 procedure Process_Generic_List is
7001 Arg : Node_Id;
7002 Exp : Node_Id;
7004 begin
7005 Check_No_Identifiers;
7006 Check_At_Least_N_Arguments (1);
7008 -- Check all arguments are names of generic units or instances
7010 Arg := Arg1;
7011 while Present (Arg) loop
7012 Exp := Get_Pragma_Arg (Arg);
7013 Analyze (Exp);
7015 if not Is_Entity_Name (Exp)
7016 or else
7017 (not Is_Generic_Instance (Entity (Exp))
7018 and then
7019 not Is_Generic_Unit (Entity (Exp)))
7020 then
7021 Error_Pragma_Arg
7022 ("pragma% argument must be name of generic unit/instance",
7023 Arg);
7024 end if;
7026 Next (Arg);
7027 end loop;
7028 end Process_Generic_List;
7030 ------------------------------------
7031 -- Process_Import_Predefined_Type --
7032 ------------------------------------
7034 procedure Process_Import_Predefined_Type is
7035 Loc : constant Source_Ptr := Sloc (N);
7036 Elmt : Elmt_Id;
7037 Ftyp : Node_Id := Empty;
7038 Decl : Node_Id;
7039 Def : Node_Id;
7040 Nam : Name_Id;
7042 begin
7043 String_To_Name_Buffer (Strval (Expression (Arg3)));
7044 Nam := Name_Find;
7046 Elmt := First_Elmt (Predefined_Float_Types);
7047 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
7048 Next_Elmt (Elmt);
7049 end loop;
7051 Ftyp := Node (Elmt);
7053 if Present (Ftyp) then
7055 -- Don't build a derived type declaration, because predefined C
7056 -- types have no declaration anywhere, so cannot really be named.
7057 -- Instead build a full type declaration, starting with an
7058 -- appropriate type definition is built
7060 if Is_Floating_Point_Type (Ftyp) then
7061 Def := Make_Floating_Point_Definition (Loc,
7062 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
7063 Make_Real_Range_Specification (Loc,
7064 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
7065 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
7067 -- Should never have a predefined type we cannot handle
7069 else
7070 raise Program_Error;
7071 end if;
7073 -- Build and insert a Full_Type_Declaration, which will be
7074 -- analyzed as soon as this list entry has been analyzed.
7076 Decl := Make_Full_Type_Declaration (Loc,
7077 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
7078 Type_Definition => Def);
7080 Insert_After (N, Decl);
7081 Mark_Rewrite_Insertion (Decl);
7083 else
7084 Error_Pragma_Arg ("no matching type found for pragma%",
7085 Arg2);
7086 end if;
7087 end Process_Import_Predefined_Type;
7089 ---------------------------------
7090 -- Process_Import_Or_Interface --
7091 ---------------------------------
7093 procedure Process_Import_Or_Interface is
7094 C : Convention_Id;
7095 Def_Id : Entity_Id;
7096 Hom_Id : Entity_Id;
7098 begin
7099 Process_Convention (C, Def_Id);
7100 Kill_Size_Check_Code (Def_Id);
7101 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
7103 if Ekind_In (Def_Id, E_Variable, E_Constant) then
7105 -- We do not permit Import to apply to a renaming declaration
7107 if Present (Renamed_Object (Def_Id)) then
7108 Error_Pragma_Arg
7109 ("pragma% not allowed for object renaming", Arg2);
7111 -- User initialization is not allowed for imported object, but
7112 -- the object declaration may contain a default initialization,
7113 -- that will be discarded. Note that an explicit initialization
7114 -- only counts if it comes from source, otherwise it is simply
7115 -- the code generator making an implicit initialization explicit.
7117 elsif Present (Expression (Parent (Def_Id)))
7118 and then Comes_From_Source (Expression (Parent (Def_Id)))
7119 then
7120 Error_Msg_Sloc := Sloc (Def_Id);
7121 Error_Pragma_Arg
7122 ("no initialization allowed for declaration of& #",
7123 "\imported entities cannot be initialized (RM B.1(24))",
7124 Arg2);
7126 else
7127 Set_Imported (Def_Id);
7128 Process_Interface_Name (Def_Id, Arg3, Arg4);
7130 -- Note that we do not set Is_Public here. That's because we
7131 -- only want to set it if there is no address clause, and we
7132 -- don't know that yet, so we delay that processing till
7133 -- freeze time.
7135 -- pragma Import completes deferred constants
7137 if Ekind (Def_Id) = E_Constant then
7138 Set_Has_Completion (Def_Id);
7139 end if;
7141 -- It is not possible to import a constant of an unconstrained
7142 -- array type (e.g. string) because there is no simple way to
7143 -- write a meaningful subtype for it.
7145 if Is_Array_Type (Etype (Def_Id))
7146 and then not Is_Constrained (Etype (Def_Id))
7147 then
7148 Error_Msg_NE
7149 ("imported constant& must have a constrained subtype",
7150 N, Def_Id);
7151 end if;
7152 end if;
7154 elsif Is_Subprogram (Def_Id)
7155 or else Is_Generic_Subprogram (Def_Id)
7156 then
7157 -- If the name is overloaded, pragma applies to all of the denoted
7158 -- entities in the same declarative part, unless the pragma comes
7159 -- from an aspect specification.
7161 Hom_Id := Def_Id;
7162 while Present (Hom_Id) loop
7164 Def_Id := Get_Base_Subprogram (Hom_Id);
7166 -- Ignore inherited subprograms because the pragma will apply
7167 -- to the parent operation, which is the one called.
7169 if Is_Overloadable (Def_Id)
7170 and then Present (Alias (Def_Id))
7171 then
7172 null;
7174 -- If it is not a subprogram, it must be in an outer scope and
7175 -- pragma does not apply.
7177 elsif not Is_Subprogram (Def_Id)
7178 and then not Is_Generic_Subprogram (Def_Id)
7179 then
7180 null;
7182 -- The pragma does not apply to primitives of interfaces
7184 elsif Is_Dispatching_Operation (Def_Id)
7185 and then Present (Find_Dispatching_Type (Def_Id))
7186 and then Is_Interface (Find_Dispatching_Type (Def_Id))
7187 then
7188 null;
7190 -- Verify that the homonym is in the same declarative part (not
7191 -- just the same scope). If the pragma comes from an aspect
7192 -- specification we know that it is part of the declaration.
7194 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
7195 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
7196 and then not From_Aspect_Specification (N)
7197 then
7198 exit;
7200 else
7201 Set_Imported (Def_Id);
7203 -- Reject an Import applied to an abstract subprogram
7205 if Is_Subprogram (Def_Id)
7206 and then Is_Abstract_Subprogram (Def_Id)
7207 then
7208 Error_Msg_Sloc := Sloc (Def_Id);
7209 Error_Msg_NE
7210 ("cannot import abstract subprogram& declared#",
7211 Arg2, Def_Id);
7212 end if;
7214 -- Special processing for Convention_Intrinsic
7216 if C = Convention_Intrinsic then
7218 -- Link_Name argument not allowed for intrinsic
7220 Check_No_Link_Name;
7222 Set_Is_Intrinsic_Subprogram (Def_Id);
7224 -- If no external name is present, then check that this
7225 -- is a valid intrinsic subprogram. If an external name
7226 -- is present, then this is handled by the back end.
7228 if No (Arg3) then
7229 Check_Intrinsic_Subprogram
7230 (Def_Id, Get_Pragma_Arg (Arg2));
7231 end if;
7232 end if;
7234 -- All interfaced procedures need an external symbol created
7235 -- for them since they are always referenced from another
7236 -- object file.
7238 Set_Is_Public (Def_Id);
7240 -- Verify that the subprogram does not have a completion
7241 -- through a renaming declaration. For other completions the
7242 -- pragma appears as a too late representation.
7244 declare
7245 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
7247 begin
7248 if Present (Decl)
7249 and then Nkind (Decl) = N_Subprogram_Declaration
7250 and then Present (Corresponding_Body (Decl))
7251 and then Nkind (Unit_Declaration_Node
7252 (Corresponding_Body (Decl))) =
7253 N_Subprogram_Renaming_Declaration
7254 then
7255 Error_Msg_Sloc := Sloc (Def_Id);
7256 Error_Msg_NE
7257 ("cannot import&, renaming already provided for "
7258 & "declaration #", N, Def_Id);
7259 end if;
7260 end;
7262 Set_Has_Completion (Def_Id);
7263 Process_Interface_Name (Def_Id, Arg3, Arg4);
7264 end if;
7266 if Is_Compilation_Unit (Hom_Id) then
7268 -- Its possible homonyms are not affected by the pragma.
7269 -- Such homonyms might be present in the context of other
7270 -- units being compiled.
7272 exit;
7274 elsif From_Aspect_Specification (N) then
7275 exit;
7277 else
7278 Hom_Id := Homonym (Hom_Id);
7279 end if;
7280 end loop;
7282 -- When the convention is Java or CIL, we also allow Import to
7283 -- be given for packages, generic packages, exceptions, record
7284 -- components, and access to subprograms.
7286 elsif (C = Convention_Java or else C = Convention_CIL)
7287 and then
7288 (Is_Package_Or_Generic_Package (Def_Id)
7289 or else Ekind (Def_Id) = E_Exception
7290 or else Ekind (Def_Id) = E_Access_Subprogram_Type
7291 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
7292 then
7293 Set_Imported (Def_Id);
7294 Set_Is_Public (Def_Id);
7295 Process_Interface_Name (Def_Id, Arg3, Arg4);
7297 -- Import a CPP class
7299 elsif C = Convention_CPP
7300 and then (Is_Record_Type (Def_Id)
7301 or else Ekind (Def_Id) = E_Incomplete_Type)
7302 then
7303 if Ekind (Def_Id) = E_Incomplete_Type then
7304 if Present (Full_View (Def_Id)) then
7305 Def_Id := Full_View (Def_Id);
7307 else
7308 Error_Msg_N
7309 ("cannot import 'C'P'P type before full declaration seen",
7310 Get_Pragma_Arg (Arg2));
7312 -- Although we have reported the error we decorate it as
7313 -- CPP_Class to avoid reporting spurious errors
7315 Set_Is_CPP_Class (Def_Id);
7316 return;
7317 end if;
7318 end if;
7320 -- Types treated as CPP classes must be declared limited (note:
7321 -- this used to be a warning but there is no real benefit to it
7322 -- since we did effectively intend to treat the type as limited
7323 -- anyway).
7325 if not Is_Limited_Type (Def_Id) then
7326 Error_Msg_N
7327 ("imported 'C'P'P type must be limited",
7328 Get_Pragma_Arg (Arg2));
7329 end if;
7331 if Etype (Def_Id) /= Def_Id
7332 and then not Is_CPP_Class (Root_Type (Def_Id))
7333 then
7334 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
7335 end if;
7337 Set_Is_CPP_Class (Def_Id);
7339 -- Imported CPP types must not have discriminants (because C++
7340 -- classes do not have discriminants).
7342 if Has_Discriminants (Def_Id) then
7343 Error_Msg_N
7344 ("imported 'C'P'P type cannot have discriminants",
7345 First (Discriminant_Specifications
7346 (Declaration_Node (Def_Id))));
7347 end if;
7349 -- Check that components of imported CPP types do not have default
7350 -- expressions. For private types this check is performed when the
7351 -- full view is analyzed (see Process_Full_View).
7353 if not Is_Private_Type (Def_Id) then
7354 Check_CPP_Type_Has_No_Defaults (Def_Id);
7355 end if;
7357 -- Import a CPP exception
7359 elsif C = Convention_CPP
7360 and then Ekind (Def_Id) = E_Exception
7361 then
7362 if No (Arg3) then
7363 Error_Pragma_Arg
7364 ("'External_'Name arguments is required for 'Cpp exception",
7365 Arg3);
7366 else
7367 -- As only a string is allowed, Check_Arg_Is_External_Name
7368 -- isn't called.
7369 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
7370 end if;
7372 if Present (Arg4) then
7373 Error_Pragma_Arg
7374 ("Link_Name argument not allowed for imported Cpp exception",
7375 Arg4);
7376 end if;
7378 -- Do not call Set_Interface_Name as the name of the exception
7379 -- shouldn't be modified (and in particular it shouldn't be
7380 -- the External_Name). For exceptions, the External_Name is the
7381 -- name of the RTTI structure.
7383 -- ??? Emit an error if pragma Import/Export_Exception is present
7385 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
7386 Check_No_Link_Name;
7387 Check_Arg_Count (3);
7388 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
7390 Process_Import_Predefined_Type;
7392 else
7393 Error_Pragma_Arg
7394 ("second argument of pragma% must be object, subprogram "
7395 & "or incomplete type",
7396 Arg2);
7397 end if;
7399 -- If this pragma applies to a compilation unit, then the unit, which
7400 -- is a subprogram, does not require (or allow) a body. We also do
7401 -- not need to elaborate imported procedures.
7403 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
7404 declare
7405 Cunit : constant Node_Id := Parent (Parent (N));
7406 begin
7407 Set_Body_Required (Cunit, False);
7408 end;
7409 end if;
7410 end Process_Import_Or_Interface;
7412 --------------------
7413 -- Process_Inline --
7414 --------------------
7416 procedure Process_Inline (Status : Inline_Status) is
7417 Assoc : Node_Id;
7418 Decl : Node_Id;
7419 Subp_Id : Node_Id;
7420 Subp : Entity_Id;
7421 Applies : Boolean;
7423 Effective : Boolean := False;
7424 -- Set True if inline has some effect, i.e. if there is at least one
7425 -- subprogram set as inlined as a result of the use of the pragma.
7427 procedure Make_Inline (Subp : Entity_Id);
7428 -- Subp is the defining unit name of the subprogram declaration. Set
7429 -- the flag, as well as the flag in the corresponding body, if there
7430 -- is one present.
7432 procedure Set_Inline_Flags (Subp : Entity_Id);
7433 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
7434 -- Has_Pragma_Inline_Always for the Inline_Always case.
7436 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
7437 -- Returns True if it can be determined at this stage that inlining
7438 -- is not possible, for example if the body is available and contains
7439 -- exception handlers, we prevent inlining, since otherwise we can
7440 -- get undefined symbols at link time. This function also emits a
7441 -- warning if front-end inlining is enabled and the pragma appears
7442 -- too late.
7444 -- ??? is business with link symbols still valid, or does it relate
7445 -- to front end ZCX which is being phased out ???
7447 ---------------------------
7448 -- Inlining_Not_Possible --
7449 ---------------------------
7451 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
7452 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
7453 Stats : Node_Id;
7455 begin
7456 if Nkind (Decl) = N_Subprogram_Body then
7457 Stats := Handled_Statement_Sequence (Decl);
7458 return Present (Exception_Handlers (Stats))
7459 or else Present (At_End_Proc (Stats));
7461 elsif Nkind (Decl) = N_Subprogram_Declaration
7462 and then Present (Corresponding_Body (Decl))
7463 then
7464 if Front_End_Inlining
7465 and then Analyzed (Corresponding_Body (Decl))
7466 then
7467 Error_Msg_N ("pragma appears too late, ignored??", N);
7468 return True;
7470 -- If the subprogram is a renaming as body, the body is just a
7471 -- call to the renamed subprogram, and inlining is trivially
7472 -- possible.
7474 elsif
7475 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
7476 N_Subprogram_Renaming_Declaration
7477 then
7478 return False;
7480 else
7481 Stats :=
7482 Handled_Statement_Sequence
7483 (Unit_Declaration_Node (Corresponding_Body (Decl)));
7485 return
7486 Present (Exception_Handlers (Stats))
7487 or else Present (At_End_Proc (Stats));
7488 end if;
7490 else
7491 -- If body is not available, assume the best, the check is
7492 -- performed again when compiling enclosing package bodies.
7494 return False;
7495 end if;
7496 end Inlining_Not_Possible;
7498 -----------------
7499 -- Make_Inline --
7500 -----------------
7502 procedure Make_Inline (Subp : Entity_Id) is
7503 Kind : constant Entity_Kind := Ekind (Subp);
7504 Inner_Subp : Entity_Id := Subp;
7506 begin
7507 -- Ignore if bad type, avoid cascaded error
7509 if Etype (Subp) = Any_Type then
7510 Applies := True;
7511 return;
7513 -- Ignore if all inlining is suppressed
7515 elsif Suppress_All_Inlining then
7516 Applies := True;
7517 return;
7519 -- If inlining is not possible, for now do not treat as an error
7521 elsif Status /= Suppressed
7522 and then Inlining_Not_Possible (Subp)
7523 then
7524 Applies := True;
7525 return;
7527 -- Here we have a candidate for inlining, but we must exclude
7528 -- derived operations. Otherwise we would end up trying to inline
7529 -- a phantom declaration, and the result would be to drag in a
7530 -- body which has no direct inlining associated with it. That
7531 -- would not only be inefficient but would also result in the
7532 -- backend doing cross-unit inlining in cases where it was
7533 -- definitely inappropriate to do so.
7535 -- However, a simple Comes_From_Source test is insufficient, since
7536 -- we do want to allow inlining of generic instances which also do
7537 -- not come from source. We also need to recognize specs generated
7538 -- by the front-end for bodies that carry the pragma. Finally,
7539 -- predefined operators do not come from source but are not
7540 -- inlineable either.
7542 elsif Is_Generic_Instance (Subp)
7543 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
7544 then
7545 null;
7547 elsif not Comes_From_Source (Subp)
7548 and then Scope (Subp) /= Standard_Standard
7549 then
7550 Applies := True;
7551 return;
7552 end if;
7554 -- The referenced entity must either be the enclosing entity, or
7555 -- an entity declared within the current open scope.
7557 if Present (Scope (Subp))
7558 and then Scope (Subp) /= Current_Scope
7559 and then Subp /= Current_Scope
7560 then
7561 Error_Pragma_Arg
7562 ("argument of% must be entity in current scope", Assoc);
7563 return;
7564 end if;
7566 -- Processing for procedure, operator or function. If subprogram
7567 -- is aliased (as for an instance) indicate that the renamed
7568 -- entity (if declared in the same unit) is inlined.
7570 if Is_Subprogram (Subp) then
7571 Inner_Subp := Ultimate_Alias (Inner_Subp);
7573 if In_Same_Source_Unit (Subp, Inner_Subp) then
7574 Set_Inline_Flags (Inner_Subp);
7576 Decl := Parent (Parent (Inner_Subp));
7578 if Nkind (Decl) = N_Subprogram_Declaration
7579 and then Present (Corresponding_Body (Decl))
7580 then
7581 Set_Inline_Flags (Corresponding_Body (Decl));
7583 elsif Is_Generic_Instance (Subp) then
7585 -- Indicate that the body needs to be created for
7586 -- inlining subsequent calls. The instantiation node
7587 -- follows the declaration of the wrapper package
7588 -- created for it.
7590 if Scope (Subp) /= Standard_Standard
7591 and then
7592 Need_Subprogram_Instance_Body
7593 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
7594 Subp)
7595 then
7596 null;
7597 end if;
7599 -- Inline is a program unit pragma (RM 10.1.5) and cannot
7600 -- appear in a formal part to apply to a formal subprogram.
7601 -- Do not apply check within an instance or a formal package
7602 -- the test will have been applied to the original generic.
7604 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
7605 and then List_Containing (Decl) = List_Containing (N)
7606 and then not In_Instance
7607 then
7608 Error_Msg_N
7609 ("Inline cannot apply to a formal subprogram", N);
7611 -- If Subp is a renaming, it is the renamed entity that
7612 -- will appear in any call, and be inlined. However, for
7613 -- ASIS uses it is convenient to indicate that the renaming
7614 -- itself is an inlined subprogram, so that some gnatcheck
7615 -- rules can be applied in the absence of expansion.
7617 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
7618 Set_Inline_Flags (Subp);
7619 end if;
7620 end if;
7622 Applies := True;
7624 -- For a generic subprogram set flag as well, for use at the point
7625 -- of instantiation, to determine whether the body should be
7626 -- generated.
7628 elsif Is_Generic_Subprogram (Subp) then
7629 Set_Inline_Flags (Subp);
7630 Applies := True;
7632 -- Literals are by definition inlined
7634 elsif Kind = E_Enumeration_Literal then
7635 null;
7637 -- Anything else is an error
7639 else
7640 Error_Pragma_Arg
7641 ("expect subprogram name for pragma%", Assoc);
7642 end if;
7643 end Make_Inline;
7645 ----------------------
7646 -- Set_Inline_Flags --
7647 ----------------------
7649 procedure Set_Inline_Flags (Subp : Entity_Id) is
7650 begin
7651 -- First set the Has_Pragma_XXX flags and issue the appropriate
7652 -- errors and warnings for suspicious combinations.
7654 if Prag_Id = Pragma_No_Inline then
7655 if Has_Pragma_Inline_Always (Subp) then
7656 Error_Msg_N
7657 ("Inline_Always and No_Inline are mutually exclusive", N);
7658 elsif Has_Pragma_Inline (Subp) then
7659 Error_Msg_NE
7660 ("Inline and No_Inline both specified for& ??",
7661 N, Entity (Subp_Id));
7662 end if;
7664 Set_Has_Pragma_No_Inline (Subp);
7665 else
7666 if Prag_Id = Pragma_Inline_Always then
7667 if Has_Pragma_No_Inline (Subp) then
7668 Error_Msg_N
7669 ("Inline_Always and No_Inline are mutually exclusive",
7671 end if;
7673 Set_Has_Pragma_Inline_Always (Subp);
7674 else
7675 if Has_Pragma_No_Inline (Subp) then
7676 Error_Msg_NE
7677 ("Inline and No_Inline both specified for& ??",
7678 N, Entity (Subp_Id));
7679 end if;
7680 end if;
7682 if not Has_Pragma_Inline (Subp) then
7683 Set_Has_Pragma_Inline (Subp);
7684 Effective := True;
7685 end if;
7686 end if;
7688 -- Then adjust the Is_Inlined flag. It can never be set if the
7689 -- subprogram is subject to pragma No_Inline.
7691 case Status is
7692 when Suppressed =>
7693 Set_Is_Inlined (Subp, False);
7694 when Disabled =>
7695 null;
7696 when Enabled =>
7697 if not Has_Pragma_No_Inline (Subp) then
7698 Set_Is_Inlined (Subp, True);
7699 end if;
7700 end case;
7701 end Set_Inline_Flags;
7703 -- Start of processing for Process_Inline
7705 begin
7706 Check_No_Identifiers;
7707 Check_At_Least_N_Arguments (1);
7709 if Status = Enabled then
7710 Inline_Processing_Required := True;
7711 end if;
7713 Assoc := Arg1;
7714 while Present (Assoc) loop
7715 Subp_Id := Get_Pragma_Arg (Assoc);
7716 Analyze (Subp_Id);
7717 Applies := False;
7719 if Is_Entity_Name (Subp_Id) then
7720 Subp := Entity (Subp_Id);
7722 if Subp = Any_Id then
7724 -- If previous error, avoid cascaded errors
7726 Check_Error_Detected;
7727 Applies := True;
7728 Effective := True;
7730 else
7731 Make_Inline (Subp);
7733 -- For the pragma case, climb homonym chain. This is
7734 -- what implements allowing the pragma in the renaming
7735 -- case, with the result applying to the ancestors, and
7736 -- also allows Inline to apply to all previous homonyms.
7738 if not From_Aspect_Specification (N) then
7739 while Present (Homonym (Subp))
7740 and then Scope (Homonym (Subp)) = Current_Scope
7741 loop
7742 Make_Inline (Homonym (Subp));
7743 Subp := Homonym (Subp);
7744 end loop;
7745 end if;
7746 end if;
7747 end if;
7749 if not Applies then
7750 Error_Pragma_Arg
7751 ("inappropriate argument for pragma%", Assoc);
7753 elsif not Effective
7754 and then Warn_On_Redundant_Constructs
7755 and then not (Status = Suppressed or else Suppress_All_Inlining)
7756 then
7757 if Inlining_Not_Possible (Subp) then
7758 Error_Msg_NE
7759 ("pragma Inline for& is ignored?r?",
7760 N, Entity (Subp_Id));
7761 else
7762 Error_Msg_NE
7763 ("pragma Inline for& is redundant?r?",
7764 N, Entity (Subp_Id));
7765 end if;
7766 end if;
7768 Next (Assoc);
7769 end loop;
7770 end Process_Inline;
7772 ----------------------------
7773 -- Process_Interface_Name --
7774 ----------------------------
7776 procedure Process_Interface_Name
7777 (Subprogram_Def : Entity_Id;
7778 Ext_Arg : Node_Id;
7779 Link_Arg : Node_Id)
7781 Ext_Nam : Node_Id;
7782 Link_Nam : Node_Id;
7783 String_Val : String_Id;
7785 procedure Check_Form_Of_Interface_Name
7786 (SN : Node_Id;
7787 Ext_Name_Case : Boolean);
7788 -- SN is a string literal node for an interface name. This routine
7789 -- performs some minimal checks that the name is reasonable. In
7790 -- particular that no spaces or other obviously incorrect characters
7791 -- appear. This is only a warning, since any characters are allowed.
7792 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
7794 ----------------------------------
7795 -- Check_Form_Of_Interface_Name --
7796 ----------------------------------
7798 procedure Check_Form_Of_Interface_Name
7799 (SN : Node_Id;
7800 Ext_Name_Case : Boolean)
7802 S : constant String_Id := Strval (Expr_Value_S (SN));
7803 SL : constant Nat := String_Length (S);
7804 C : Char_Code;
7806 begin
7807 if SL = 0 then
7808 Error_Msg_N ("interface name cannot be null string", SN);
7809 end if;
7811 for J in 1 .. SL loop
7812 C := Get_String_Char (S, J);
7814 -- Look for dubious character and issue unconditional warning.
7815 -- Definitely dubious if not in character range.
7817 if not In_Character_Range (C)
7819 -- For all cases except CLI target,
7820 -- commas, spaces and slashes are dubious (in CLI, we use
7821 -- commas and backslashes in external names to specify
7822 -- assembly version and public key, while slashes and spaces
7823 -- can be used in names to mark nested classes and
7824 -- valuetypes).
7826 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
7827 and then (Get_Character (C) = ','
7828 or else
7829 Get_Character (C) = '\'))
7830 or else (VM_Target /= CLI_Target
7831 and then (Get_Character (C) = ' '
7832 or else
7833 Get_Character (C) = '/'))
7834 then
7835 Error_Msg
7836 ("??interface name contains illegal character",
7837 Sloc (SN) + Source_Ptr (J));
7838 end if;
7839 end loop;
7840 end Check_Form_Of_Interface_Name;
7842 -- Start of processing for Process_Interface_Name
7844 begin
7845 if No (Link_Arg) then
7846 if No (Ext_Arg) then
7847 if VM_Target = CLI_Target
7848 and then Ekind (Subprogram_Def) = E_Package
7849 and then Nkind (Parent (Subprogram_Def)) =
7850 N_Package_Specification
7851 and then Present (Generic_Parent (Parent (Subprogram_Def)))
7852 then
7853 Set_Interface_Name
7854 (Subprogram_Def,
7855 Interface_Name
7856 (Generic_Parent (Parent (Subprogram_Def))));
7857 end if;
7859 return;
7861 elsif Chars (Ext_Arg) = Name_Link_Name then
7862 Ext_Nam := Empty;
7863 Link_Nam := Expression (Ext_Arg);
7865 else
7866 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
7867 Ext_Nam := Expression (Ext_Arg);
7868 Link_Nam := Empty;
7869 end if;
7871 else
7872 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
7873 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
7874 Ext_Nam := Expression (Ext_Arg);
7875 Link_Nam := Expression (Link_Arg);
7876 end if;
7878 -- Check expressions for external name and link name are static
7880 if Present (Ext_Nam) then
7881 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
7882 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
7884 -- Verify that external name is not the name of a local entity,
7885 -- which would hide the imported one and could lead to run-time
7886 -- surprises. The problem can only arise for entities declared in
7887 -- a package body (otherwise the external name is fully qualified
7888 -- and will not conflict).
7890 declare
7891 Nam : Name_Id;
7892 E : Entity_Id;
7893 Par : Node_Id;
7895 begin
7896 if Prag_Id = Pragma_Import then
7897 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
7898 Nam := Name_Find;
7899 E := Entity_Id (Get_Name_Table_Info (Nam));
7901 if Nam /= Chars (Subprogram_Def)
7902 and then Present (E)
7903 and then not Is_Overloadable (E)
7904 and then Is_Immediately_Visible (E)
7905 and then not Is_Imported (E)
7906 and then Ekind (Scope (E)) = E_Package
7907 then
7908 Par := Parent (E);
7909 while Present (Par) loop
7910 if Nkind (Par) = N_Package_Body then
7911 Error_Msg_Sloc := Sloc (E);
7912 Error_Msg_NE
7913 ("imported entity is hidden by & declared#",
7914 Ext_Arg, E);
7915 exit;
7916 end if;
7918 Par := Parent (Par);
7919 end loop;
7920 end if;
7921 end if;
7922 end;
7923 end if;
7925 if Present (Link_Nam) then
7926 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
7927 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
7928 end if;
7930 -- If there is no link name, just set the external name
7932 if No (Link_Nam) then
7933 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
7935 -- For the Link_Name case, the given literal is preceded by an
7936 -- asterisk, which indicates to GCC that the given name should be
7937 -- taken literally, and in particular that no prepending of
7938 -- underlines should occur, even in systems where this is the
7939 -- normal default.
7941 else
7942 Start_String;
7944 if VM_Target = No_VM then
7945 Store_String_Char (Get_Char_Code ('*'));
7946 end if;
7948 String_Val := Strval (Expr_Value_S (Link_Nam));
7949 Store_String_Chars (String_Val);
7950 Link_Nam :=
7951 Make_String_Literal (Sloc (Link_Nam),
7952 Strval => End_String);
7953 end if;
7955 -- Set the interface name. If the entity is a generic instance, use
7956 -- its alias, which is the callable entity.
7958 if Is_Generic_Instance (Subprogram_Def) then
7959 Set_Encoded_Interface_Name
7960 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
7961 else
7962 Set_Encoded_Interface_Name
7963 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
7964 end if;
7966 -- We allow duplicated export names in CIL/Java, as they are always
7967 -- enclosed in a namespace that differentiates them, and overloaded
7968 -- entities are supported by the VM.
7970 if Convention (Subprogram_Def) /= Convention_CIL
7971 and then
7972 Convention (Subprogram_Def) /= Convention_Java
7973 then
7974 Check_Duplicated_Export_Name (Link_Nam);
7975 end if;
7976 end Process_Interface_Name;
7978 -----------------------------------------
7979 -- Process_Interrupt_Or_Attach_Handler --
7980 -----------------------------------------
7982 procedure Process_Interrupt_Or_Attach_Handler is
7983 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
7984 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
7985 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
7987 begin
7988 Set_Is_Interrupt_Handler (Handler_Proc);
7990 -- If the pragma is not associated with a handler procedure within a
7991 -- protected type, then it must be for a nonprotected procedure for
7992 -- the AAMP target, in which case we don't associate a representation
7993 -- item with the procedure's scope.
7995 if Ekind (Proc_Scope) = E_Protected_Type then
7996 if Prag_Id = Pragma_Interrupt_Handler
7997 or else
7998 Prag_Id = Pragma_Attach_Handler
7999 then
8000 Record_Rep_Item (Proc_Scope, N);
8001 end if;
8002 end if;
8003 end Process_Interrupt_Or_Attach_Handler;
8005 --------------------------------------------------
8006 -- Process_Restrictions_Or_Restriction_Warnings --
8007 --------------------------------------------------
8009 -- Note: some of the simple identifier cases were handled in par-prag,
8010 -- but it is harmless (and more straightforward) to simply handle all
8011 -- cases here, even if it means we repeat a bit of work in some cases.
8013 procedure Process_Restrictions_Or_Restriction_Warnings
8014 (Warn : Boolean)
8016 Arg : Node_Id;
8017 R_Id : Restriction_Id;
8018 Id : Name_Id;
8019 Expr : Node_Id;
8020 Val : Uint;
8022 begin
8023 -- Ignore all Restrictions pragmas in CodePeer mode
8025 if CodePeer_Mode then
8026 return;
8027 end if;
8029 Check_Ada_83_Warning;
8030 Check_At_Least_N_Arguments (1);
8031 Check_Valid_Configuration_Pragma;
8033 Arg := Arg1;
8034 while Present (Arg) loop
8035 Id := Chars (Arg);
8036 Expr := Get_Pragma_Arg (Arg);
8038 -- Case of no restriction identifier present
8040 if Id = No_Name then
8041 if Nkind (Expr) /= N_Identifier then
8042 Error_Pragma_Arg
8043 ("invalid form for restriction", Arg);
8044 end if;
8046 R_Id :=
8047 Get_Restriction_Id
8048 (Process_Restriction_Synonyms (Expr));
8050 if R_Id not in All_Boolean_Restrictions then
8051 Error_Msg_Name_1 := Pname;
8052 Error_Msg_N
8053 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
8055 -- Check for possible misspelling
8057 for J in Restriction_Id loop
8058 declare
8059 Rnm : constant String := Restriction_Id'Image (J);
8061 begin
8062 Name_Buffer (1 .. Rnm'Length) := Rnm;
8063 Name_Len := Rnm'Length;
8064 Set_Casing (All_Lower_Case);
8066 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
8067 Set_Casing
8068 (Identifier_Casing (Current_Source_File));
8069 Error_Msg_String (1 .. Rnm'Length) :=
8070 Name_Buffer (1 .. Name_Len);
8071 Error_Msg_Strlen := Rnm'Length;
8072 Error_Msg_N -- CODEFIX
8073 ("\possible misspelling of ""~""",
8074 Get_Pragma_Arg (Arg));
8075 exit;
8076 end if;
8077 end;
8078 end loop;
8080 raise Pragma_Exit;
8081 end if;
8083 if Implementation_Restriction (R_Id) then
8084 Check_Restriction (No_Implementation_Restrictions, Arg);
8085 end if;
8087 -- Special processing for No_Elaboration_Code restriction
8089 if R_Id = No_Elaboration_Code then
8091 -- Restriction is only recognized within a configuration
8092 -- pragma file, or within a unit of the main extended
8093 -- program. Note: the test for Main_Unit is needed to
8094 -- properly include the case of configuration pragma files.
8096 if not (Current_Sem_Unit = Main_Unit
8097 or else In_Extended_Main_Source_Unit (N))
8098 then
8099 return;
8101 -- Don't allow in a subunit unless already specified in
8102 -- body or spec.
8104 elsif Nkind (Parent (N)) = N_Compilation_Unit
8105 and then Nkind (Unit (Parent (N))) = N_Subunit
8106 and then not Restriction_Active (No_Elaboration_Code)
8107 then
8108 Error_Msg_N
8109 ("invalid specification of ""No_Elaboration_Code""",
8111 Error_Msg_N
8112 ("\restriction cannot be specified in a subunit", N);
8113 Error_Msg_N
8114 ("\unless also specified in body or spec", N);
8115 return;
8117 -- If we have a No_Elaboration_Code pragma that we
8118 -- accept, then it needs to be added to the configuration
8119 -- restrcition set so that we get proper application to
8120 -- other units in the main extended source as required.
8122 else
8123 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
8124 end if;
8125 end if;
8127 -- If this is a warning, then set the warning unless we already
8128 -- have a real restriction active (we never want a warning to
8129 -- override a real restriction).
8131 if Warn then
8132 if not Restriction_Active (R_Id) then
8133 Set_Restriction (R_Id, N);
8134 Restriction_Warnings (R_Id) := True;
8135 end if;
8137 -- If real restriction case, then set it and make sure that the
8138 -- restriction warning flag is off, since a real restriction
8139 -- always overrides a warning.
8141 else
8142 Set_Restriction (R_Id, N);
8143 Restriction_Warnings (R_Id) := False;
8144 end if;
8146 -- Check for obsolescent restrictions in Ada 2005 mode
8148 if not Warn
8149 and then Ada_Version >= Ada_2005
8150 and then (R_Id = No_Asynchronous_Control
8151 or else
8152 R_Id = No_Unchecked_Deallocation
8153 or else
8154 R_Id = No_Unchecked_Conversion)
8155 then
8156 Check_Restriction (No_Obsolescent_Features, N);
8157 end if;
8159 -- A very special case that must be processed here: pragma
8160 -- Restrictions (No_Exceptions) turns off all run-time
8161 -- checking. This is a bit dubious in terms of the formal
8162 -- language definition, but it is what is intended by RM
8163 -- H.4(12). Restriction_Warnings never affects generated code
8164 -- so this is done only in the real restriction case.
8166 -- Atomic_Synchronization is not a real check, so it is not
8167 -- affected by this processing).
8169 if R_Id = No_Exceptions and then not Warn then
8170 for J in Scope_Suppress.Suppress'Range loop
8171 if J /= Atomic_Synchronization then
8172 Scope_Suppress.Suppress (J) := True;
8173 end if;
8174 end loop;
8175 end if;
8177 -- Case of No_Dependence => unit-name. Note that the parser
8178 -- already made the necessary entry in the No_Dependence table.
8180 elsif Id = Name_No_Dependence then
8181 if not OK_No_Dependence_Unit_Name (Expr) then
8182 raise Pragma_Exit;
8183 end if;
8185 -- Case of No_Specification_Of_Aspect => Identifier.
8187 elsif Id = Name_No_Specification_Of_Aspect then
8188 declare
8189 A_Id : Aspect_Id;
8191 begin
8192 if Nkind (Expr) /= N_Identifier then
8193 A_Id := No_Aspect;
8194 else
8195 A_Id := Get_Aspect_Id (Chars (Expr));
8196 end if;
8198 if A_Id = No_Aspect then
8199 Error_Pragma_Arg ("invalid restriction name", Arg);
8200 else
8201 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
8202 end if;
8203 end;
8205 elsif Id = Name_No_Use_Of_Attribute then
8206 if Nkind (Expr) /= N_Identifier
8207 or else not Is_Attribute_Name (Chars (Expr))
8208 then
8209 Error_Msg_N ("unknown attribute name?", Expr);
8211 else
8212 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
8213 end if;
8215 elsif Id = Name_No_Use_Of_Pragma then
8216 if Nkind (Expr) /= N_Identifier
8217 or else not Is_Pragma_Name (Chars (Expr))
8218 then
8219 Error_Msg_N ("unknown pragma name?", Expr);
8221 else
8222 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
8223 end if;
8225 -- All other cases of restriction identifier present
8227 else
8228 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
8229 Analyze_And_Resolve (Expr, Any_Integer);
8231 if R_Id not in All_Parameter_Restrictions then
8232 Error_Pragma_Arg
8233 ("invalid restriction parameter identifier", Arg);
8235 elsif not Is_OK_Static_Expression (Expr) then
8236 Flag_Non_Static_Expr
8237 ("value must be static expression!", Expr);
8238 raise Pragma_Exit;
8240 elsif not Is_Integer_Type (Etype (Expr))
8241 or else Expr_Value (Expr) < 0
8242 then
8243 Error_Pragma_Arg
8244 ("value must be non-negative integer", Arg);
8245 end if;
8247 -- Restriction pragma is active
8249 Val := Expr_Value (Expr);
8251 if not UI_Is_In_Int_Range (Val) then
8252 Error_Pragma_Arg
8253 ("pragma ignored, value too large??", Arg);
8254 end if;
8256 -- Warning case. If the real restriction is active, then we
8257 -- ignore the request, since warning never overrides a real
8258 -- restriction. Otherwise we set the proper warning. Note that
8259 -- this circuit sets the warning again if it is already set,
8260 -- which is what we want, since the constant may have changed.
8262 if Warn then
8263 if not Restriction_Active (R_Id) then
8264 Set_Restriction
8265 (R_Id, N, Integer (UI_To_Int (Val)));
8266 Restriction_Warnings (R_Id) := True;
8267 end if;
8269 -- Real restriction case, set restriction and make sure warning
8270 -- flag is off since real restriction always overrides warning.
8272 else
8273 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
8274 Restriction_Warnings (R_Id) := False;
8275 end if;
8276 end if;
8278 Next (Arg);
8279 end loop;
8280 end Process_Restrictions_Or_Restriction_Warnings;
8282 ---------------------------------
8283 -- Process_Suppress_Unsuppress --
8284 ---------------------------------
8286 -- Note: this procedure makes entries in the check suppress data
8287 -- structures managed by Sem. See spec of package Sem for full
8288 -- details on how we handle recording of check suppression.
8290 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
8291 C : Check_Id;
8292 E_Id : Node_Id;
8293 E : Entity_Id;
8295 In_Package_Spec : constant Boolean :=
8296 Is_Package_Or_Generic_Package (Current_Scope)
8297 and then not In_Package_Body (Current_Scope);
8299 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
8300 -- Used to suppress a single check on the given entity
8302 --------------------------------
8303 -- Suppress_Unsuppress_Echeck --
8304 --------------------------------
8306 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
8307 begin
8308 -- Check for error of trying to set atomic synchronization for
8309 -- a non-atomic variable.
8311 if C = Atomic_Synchronization
8312 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
8313 then
8314 Error_Msg_N
8315 ("pragma & requires atomic type or variable",
8316 Pragma_Identifier (Original_Node (N)));
8317 end if;
8319 Set_Checks_May_Be_Suppressed (E);
8321 if In_Package_Spec then
8322 Push_Global_Suppress_Stack_Entry
8323 (Entity => E,
8324 Check => C,
8325 Suppress => Suppress_Case);
8326 else
8327 Push_Local_Suppress_Stack_Entry
8328 (Entity => E,
8329 Check => C,
8330 Suppress => Suppress_Case);
8331 end if;
8333 -- If this is a first subtype, and the base type is distinct,
8334 -- then also set the suppress flags on the base type.
8336 if Is_First_Subtype (E) and then Etype (E) /= E then
8337 Suppress_Unsuppress_Echeck (Etype (E), C);
8338 end if;
8339 end Suppress_Unsuppress_Echeck;
8341 -- Start of processing for Process_Suppress_Unsuppress
8343 begin
8344 -- Ignore pragma Suppress/Unsuppress in CodePeer and SPARK modes on
8345 -- user code: we want to generate checks for analysis purposes, as
8346 -- set respectively by -gnatC and -gnatd.F
8348 if (CodePeer_Mode or SPARK_Mode) and then Comes_From_Source (N) then
8349 return;
8350 end if;
8352 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
8353 -- declarative part or a package spec (RM 11.5(5)).
8355 if not Is_Configuration_Pragma then
8356 Check_Is_In_Decl_Part_Or_Package_Spec;
8357 end if;
8359 Check_At_Least_N_Arguments (1);
8360 Check_At_Most_N_Arguments (2);
8361 Check_No_Identifier (Arg1);
8362 Check_Arg_Is_Identifier (Arg1);
8364 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
8366 if C = No_Check_Id then
8367 Error_Pragma_Arg
8368 ("argument of pragma% is not valid check name", Arg1);
8369 end if;
8371 if Arg_Count = 1 then
8373 -- Make an entry in the local scope suppress table. This is the
8374 -- table that directly shows the current value of the scope
8375 -- suppress check for any check id value.
8377 if C = All_Checks then
8379 -- For All_Checks, we set all specific predefined checks with
8380 -- the exception of Elaboration_Check, which is handled
8381 -- specially because of not wanting All_Checks to have the
8382 -- effect of deactivating static elaboration order processing.
8383 -- Atomic_Synchronization is also not affected, since this is
8384 -- not a real check.
8386 for J in Scope_Suppress.Suppress'Range loop
8387 if J /= Elaboration_Check
8388 and then
8389 J /= Atomic_Synchronization
8390 then
8391 Scope_Suppress.Suppress (J) := Suppress_Case;
8392 end if;
8393 end loop;
8395 -- If not All_Checks, and predefined check, then set appropriate
8396 -- scope entry. Note that we will set Elaboration_Check if this
8397 -- is explicitly specified. Atomic_Synchronization is allowed
8398 -- only if internally generated and entity is atomic.
8400 elsif C in Predefined_Check_Id
8401 and then (not Comes_From_Source (N)
8402 or else C /= Atomic_Synchronization)
8403 then
8404 Scope_Suppress.Suppress (C) := Suppress_Case;
8405 end if;
8407 -- Also make an entry in the Local_Entity_Suppress table
8409 Push_Local_Suppress_Stack_Entry
8410 (Entity => Empty,
8411 Check => C,
8412 Suppress => Suppress_Case);
8414 -- Case of two arguments present, where the check is suppressed for
8415 -- a specified entity (given as the second argument of the pragma)
8417 else
8418 -- This is obsolescent in Ada 2005 mode
8420 if Ada_Version >= Ada_2005 then
8421 Check_Restriction (No_Obsolescent_Features, Arg2);
8422 end if;
8424 Check_Optional_Identifier (Arg2, Name_On);
8425 E_Id := Get_Pragma_Arg (Arg2);
8426 Analyze (E_Id);
8428 if not Is_Entity_Name (E_Id) then
8429 Error_Pragma_Arg
8430 ("second argument of pragma% must be entity name", Arg2);
8431 end if;
8433 E := Entity (E_Id);
8435 if E = Any_Id then
8436 return;
8437 end if;
8439 -- Enforce RM 11.5(7) which requires that for a pragma that
8440 -- appears within a package spec, the named entity must be
8441 -- within the package spec. We allow the package name itself
8442 -- to be mentioned since that makes sense, although it is not
8443 -- strictly allowed by 11.5(7).
8445 if In_Package_Spec
8446 and then E /= Current_Scope
8447 and then Scope (E) /= Current_Scope
8448 then
8449 Error_Pragma_Arg
8450 ("entity in pragma% is not in package spec (RM 11.5(7))",
8451 Arg2);
8452 end if;
8454 -- Loop through homonyms. As noted below, in the case of a package
8455 -- spec, only homonyms within the package spec are considered.
8457 loop
8458 Suppress_Unsuppress_Echeck (E, C);
8460 if Is_Generic_Instance (E)
8461 and then Is_Subprogram (E)
8462 and then Present (Alias (E))
8463 then
8464 Suppress_Unsuppress_Echeck (Alias (E), C);
8465 end if;
8467 -- Move to next homonym if not aspect spec case
8469 exit when From_Aspect_Specification (N);
8470 E := Homonym (E);
8471 exit when No (E);
8473 -- If we are within a package specification, the pragma only
8474 -- applies to homonyms in the same scope.
8476 exit when In_Package_Spec
8477 and then Scope (E) /= Current_Scope;
8478 end loop;
8479 end if;
8480 end Process_Suppress_Unsuppress;
8482 ------------------
8483 -- Set_Exported --
8484 ------------------
8486 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
8487 begin
8488 if Is_Imported (E) then
8489 Error_Pragma_Arg
8490 ("cannot export entity& that was previously imported", Arg);
8492 elsif Present (Address_Clause (E))
8493 and then not Relaxed_RM_Semantics
8494 then
8495 Error_Pragma_Arg
8496 ("cannot export entity& that has an address clause", Arg);
8497 end if;
8499 Set_Is_Exported (E);
8501 -- Generate a reference for entity explicitly, because the
8502 -- identifier may be overloaded and name resolution will not
8503 -- generate one.
8505 Generate_Reference (E, Arg);
8507 -- Deal with exporting non-library level entity
8509 if not Is_Library_Level_Entity (E) then
8511 -- Not allowed at all for subprograms
8513 if Is_Subprogram (E) then
8514 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
8516 -- Otherwise set public and statically allocated
8518 else
8519 Set_Is_Public (E);
8520 Set_Is_Statically_Allocated (E);
8522 -- Warn if the corresponding W flag is set and the pragma comes
8523 -- from source. The latter may not be true e.g. on VMS where we
8524 -- expand export pragmas for exception codes associated with
8525 -- imported or exported exceptions. We do not want to generate
8526 -- a warning for something that the user did not write.
8528 if Warn_On_Export_Import
8529 and then Comes_From_Source (Arg)
8530 then
8531 Error_Msg_NE
8532 ("?x?& has been made static as a result of Export",
8533 Arg, E);
8534 Error_Msg_N
8535 ("\?x?this usage is non-standard and non-portable",
8536 Arg);
8537 end if;
8538 end if;
8539 end if;
8541 if Warn_On_Export_Import and then Is_Type (E) then
8542 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
8543 end if;
8545 if Warn_On_Export_Import and Inside_A_Generic then
8546 Error_Msg_NE
8547 ("all instances of& will have the same external name?x?",
8548 Arg, E);
8549 end if;
8550 end Set_Exported;
8552 ----------------------------------------------
8553 -- Set_Extended_Import_Export_External_Name --
8554 ----------------------------------------------
8556 procedure Set_Extended_Import_Export_External_Name
8557 (Internal_Ent : Entity_Id;
8558 Arg_External : Node_Id)
8560 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
8561 New_Name : Node_Id;
8563 begin
8564 if No (Arg_External) then
8565 return;
8566 end if;
8568 Check_Arg_Is_External_Name (Arg_External);
8570 if Nkind (Arg_External) = N_String_Literal then
8571 if String_Length (Strval (Arg_External)) = 0 then
8572 return;
8573 else
8574 New_Name := Adjust_External_Name_Case (Arg_External);
8575 end if;
8577 elsif Nkind (Arg_External) = N_Identifier then
8578 New_Name := Get_Default_External_Name (Arg_External);
8580 -- Check_Arg_Is_External_Name should let through only identifiers and
8581 -- string literals or static string expressions (which are folded to
8582 -- string literals).
8584 else
8585 raise Program_Error;
8586 end if;
8588 -- If we already have an external name set (by a prior normal Import
8589 -- or Export pragma), then the external names must match
8591 if Present (Interface_Name (Internal_Ent)) then
8592 Check_Matching_Internal_Names : declare
8593 S1 : constant String_Id := Strval (Old_Name);
8594 S2 : constant String_Id := Strval (New_Name);
8596 procedure Mismatch;
8597 pragma No_Return (Mismatch);
8598 -- Called if names do not match
8600 --------------
8601 -- Mismatch --
8602 --------------
8604 procedure Mismatch is
8605 begin
8606 Error_Msg_Sloc := Sloc (Old_Name);
8607 Error_Pragma_Arg
8608 ("external name does not match that given #",
8609 Arg_External);
8610 end Mismatch;
8612 -- Start of processing for Check_Matching_Internal_Names
8614 begin
8615 if String_Length (S1) /= String_Length (S2) then
8616 Mismatch;
8618 else
8619 for J in 1 .. String_Length (S1) loop
8620 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
8621 Mismatch;
8622 end if;
8623 end loop;
8624 end if;
8625 end Check_Matching_Internal_Names;
8627 -- Otherwise set the given name
8629 else
8630 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
8631 Check_Duplicated_Export_Name (New_Name);
8632 end if;
8633 end Set_Extended_Import_Export_External_Name;
8635 ------------------
8636 -- Set_Imported --
8637 ------------------
8639 procedure Set_Imported (E : Entity_Id) is
8640 begin
8641 -- Error message if already imported or exported
8643 if Is_Exported (E) or else Is_Imported (E) then
8645 -- Error if being set Exported twice
8647 if Is_Exported (E) then
8648 Error_Msg_NE ("entity& was previously exported", N, E);
8650 -- Ignore error in CodePeer mode where we treat all imported
8651 -- subprograms as unknown.
8653 elsif CodePeer_Mode then
8654 goto OK;
8656 -- OK if Import/Interface case
8658 elsif Import_Interface_Present (N) then
8659 goto OK;
8661 -- Error if being set Imported twice
8663 else
8664 Error_Msg_NE ("entity& was previously imported", N, E);
8665 end if;
8667 Error_Msg_Name_1 := Pname;
8668 Error_Msg_N
8669 ("\(pragma% applies to all previous entities)", N);
8671 Error_Msg_Sloc := Sloc (E);
8672 Error_Msg_NE ("\import not allowed for& declared#", N, E);
8674 -- Here if not previously imported or exported, OK to import
8676 else
8677 Set_Is_Imported (E);
8679 -- If the entity is an object that is not at the library level,
8680 -- then it is statically allocated. We do not worry about objects
8681 -- with address clauses in this context since they are not really
8682 -- imported in the linker sense.
8684 if Is_Object (E)
8685 and then not Is_Library_Level_Entity (E)
8686 and then No (Address_Clause (E))
8687 then
8688 Set_Is_Statically_Allocated (E);
8689 end if;
8690 end if;
8692 <<OK>> null;
8693 end Set_Imported;
8695 -------------------------
8696 -- Set_Mechanism_Value --
8697 -------------------------
8699 -- Note: the mechanism name has not been analyzed (and cannot indeed be
8700 -- analyzed, since it is semantic nonsense), so we get it in the exact
8701 -- form created by the parser.
8703 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
8704 Class : Node_Id;
8705 Param : Node_Id;
8706 Mech_Name_Id : Name_Id;
8708 procedure Bad_Class;
8709 pragma No_Return (Bad_Class);
8710 -- Signal bad descriptor class name
8712 procedure Bad_Mechanism;
8713 pragma No_Return (Bad_Mechanism);
8714 -- Signal bad mechanism name
8716 ---------------
8717 -- Bad_Class --
8718 ---------------
8720 procedure Bad_Class is
8721 begin
8722 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
8723 end Bad_Class;
8725 -------------------------
8726 -- Bad_Mechanism_Value --
8727 -------------------------
8729 procedure Bad_Mechanism is
8730 begin
8731 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
8732 end Bad_Mechanism;
8734 -- Start of processing for Set_Mechanism_Value
8736 begin
8737 if Mechanism (Ent) /= Default_Mechanism then
8738 Error_Msg_NE
8739 ("mechanism for & has already been set", Mech_Name, Ent);
8740 end if;
8742 -- MECHANISM_NAME ::= value | reference | descriptor |
8743 -- short_descriptor
8745 if Nkind (Mech_Name) = N_Identifier then
8746 if Chars (Mech_Name) = Name_Value then
8747 Set_Mechanism (Ent, By_Copy);
8748 return;
8750 elsif Chars (Mech_Name) = Name_Reference then
8751 Set_Mechanism (Ent, By_Reference);
8752 return;
8754 elsif Chars (Mech_Name) = Name_Descriptor then
8755 Check_VMS (Mech_Name);
8757 -- Descriptor => Short_Descriptor if pragma was given
8759 if Short_Descriptors then
8760 Set_Mechanism (Ent, By_Short_Descriptor);
8761 else
8762 Set_Mechanism (Ent, By_Descriptor);
8763 end if;
8765 return;
8767 elsif Chars (Mech_Name) = Name_Short_Descriptor then
8768 Check_VMS (Mech_Name);
8769 Set_Mechanism (Ent, By_Short_Descriptor);
8770 return;
8772 elsif Chars (Mech_Name) = Name_Copy then
8773 Error_Pragma_Arg
8774 ("bad mechanism name, Value assumed", Mech_Name);
8776 else
8777 Bad_Mechanism;
8778 end if;
8780 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
8781 -- short_descriptor (CLASS_NAME)
8782 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8784 -- Note: this form is parsed as an indexed component
8786 elsif Nkind (Mech_Name) = N_Indexed_Component then
8787 Class := First (Expressions (Mech_Name));
8789 if Nkind (Prefix (Mech_Name)) /= N_Identifier
8790 or else
8791 not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
8792 Name_Short_Descriptor)
8793 or else Present (Next (Class))
8794 then
8795 Bad_Mechanism;
8796 else
8797 Mech_Name_Id := Chars (Prefix (Mech_Name));
8799 -- Change Descriptor => Short_Descriptor if pragma was given
8801 if Mech_Name_Id = Name_Descriptor
8802 and then Short_Descriptors
8803 then
8804 Mech_Name_Id := Name_Short_Descriptor;
8805 end if;
8806 end if;
8808 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
8809 -- short_descriptor (Class => CLASS_NAME)
8810 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8812 -- Note: this form is parsed as a function call
8814 elsif Nkind (Mech_Name) = N_Function_Call then
8815 Param := First (Parameter_Associations (Mech_Name));
8817 if Nkind (Name (Mech_Name)) /= N_Identifier
8818 or else
8819 not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
8820 Name_Short_Descriptor)
8821 or else Present (Next (Param))
8822 or else No (Selector_Name (Param))
8823 or else Chars (Selector_Name (Param)) /= Name_Class
8824 then
8825 Bad_Mechanism;
8826 else
8827 Class := Explicit_Actual_Parameter (Param);
8828 Mech_Name_Id := Chars (Name (Mech_Name));
8829 end if;
8831 else
8832 Bad_Mechanism;
8833 end if;
8835 -- Fall through here with Class set to descriptor class name
8837 Check_VMS (Mech_Name);
8839 if Nkind (Class) /= N_Identifier then
8840 Bad_Class;
8842 elsif Mech_Name_Id = Name_Descriptor
8843 and then Chars (Class) = Name_UBS
8844 then
8845 Set_Mechanism (Ent, By_Descriptor_UBS);
8847 elsif Mech_Name_Id = Name_Descriptor
8848 and then Chars (Class) = Name_UBSB
8849 then
8850 Set_Mechanism (Ent, By_Descriptor_UBSB);
8852 elsif Mech_Name_Id = Name_Descriptor
8853 and then Chars (Class) = Name_UBA
8854 then
8855 Set_Mechanism (Ent, By_Descriptor_UBA);
8857 elsif Mech_Name_Id = Name_Descriptor
8858 and then Chars (Class) = Name_S
8859 then
8860 Set_Mechanism (Ent, By_Descriptor_S);
8862 elsif Mech_Name_Id = Name_Descriptor
8863 and then Chars (Class) = Name_SB
8864 then
8865 Set_Mechanism (Ent, By_Descriptor_SB);
8867 elsif Mech_Name_Id = Name_Descriptor
8868 and then Chars (Class) = Name_A
8869 then
8870 Set_Mechanism (Ent, By_Descriptor_A);
8872 elsif Mech_Name_Id = Name_Descriptor
8873 and then Chars (Class) = Name_NCA
8874 then
8875 Set_Mechanism (Ent, By_Descriptor_NCA);
8877 elsif Mech_Name_Id = Name_Short_Descriptor
8878 and then Chars (Class) = Name_UBS
8879 then
8880 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
8882 elsif Mech_Name_Id = Name_Short_Descriptor
8883 and then Chars (Class) = Name_UBSB
8884 then
8885 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
8887 elsif Mech_Name_Id = Name_Short_Descriptor
8888 and then Chars (Class) = Name_UBA
8889 then
8890 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
8892 elsif Mech_Name_Id = Name_Short_Descriptor
8893 and then Chars (Class) = Name_S
8894 then
8895 Set_Mechanism (Ent, By_Short_Descriptor_S);
8897 elsif Mech_Name_Id = Name_Short_Descriptor
8898 and then Chars (Class) = Name_SB
8899 then
8900 Set_Mechanism (Ent, By_Short_Descriptor_SB);
8902 elsif Mech_Name_Id = Name_Short_Descriptor
8903 and then Chars (Class) = Name_A
8904 then
8905 Set_Mechanism (Ent, By_Short_Descriptor_A);
8907 elsif Mech_Name_Id = Name_Short_Descriptor
8908 and then Chars (Class) = Name_NCA
8909 then
8910 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
8912 else
8913 Bad_Class;
8914 end if;
8915 end Set_Mechanism_Value;
8917 --------------------------
8918 -- Set_Rational_Profile --
8919 --------------------------
8921 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
8922 -- and extension to the semantics of renaming declarations.
8924 procedure Set_Rational_Profile is
8925 begin
8926 Implicit_Packing := True;
8927 Overriding_Renamings := True;
8928 Use_VADS_Size := True;
8929 end Set_Rational_Profile;
8931 ---------------------------
8932 -- Set_Ravenscar_Profile --
8933 ---------------------------
8935 -- The tasks to be done here are
8937 -- Set required policies
8939 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
8940 -- pragma Locking_Policy (Ceiling_Locking)
8942 -- Set Detect_Blocking mode
8944 -- Set required restrictions (see System.Rident for detailed list)
8946 -- Set the No_Dependence rules
8947 -- No_Dependence => Ada.Asynchronous_Task_Control
8948 -- No_Dependence => Ada.Calendar
8949 -- No_Dependence => Ada.Execution_Time.Group_Budget
8950 -- No_Dependence => Ada.Execution_Time.Timers
8951 -- No_Dependence => Ada.Task_Attributes
8952 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
8954 procedure Set_Ravenscar_Profile (N : Node_Id) is
8955 Prefix_Entity : Entity_Id;
8956 Selector_Entity : Entity_Id;
8957 Prefix_Node : Node_Id;
8958 Node : Node_Id;
8960 begin
8961 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
8963 if Task_Dispatching_Policy /= ' '
8964 and then Task_Dispatching_Policy /= 'F'
8965 then
8966 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
8967 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
8969 -- Set the FIFO_Within_Priorities policy, but always preserve
8970 -- System_Location since we like the error message with the run time
8971 -- name.
8973 else
8974 Task_Dispatching_Policy := 'F';
8976 if Task_Dispatching_Policy_Sloc /= System_Location then
8977 Task_Dispatching_Policy_Sloc := Loc;
8978 end if;
8979 end if;
8981 -- pragma Locking_Policy (Ceiling_Locking)
8983 if Locking_Policy /= ' '
8984 and then Locking_Policy /= 'C'
8985 then
8986 Error_Msg_Sloc := Locking_Policy_Sloc;
8987 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
8989 -- Set the Ceiling_Locking policy, but preserve System_Location since
8990 -- we like the error message with the run time name.
8992 else
8993 Locking_Policy := 'C';
8995 if Locking_Policy_Sloc /= System_Location then
8996 Locking_Policy_Sloc := Loc;
8997 end if;
8998 end if;
9000 -- pragma Detect_Blocking
9002 Detect_Blocking := True;
9004 -- Set the corresponding restrictions
9006 Set_Profile_Restrictions
9007 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
9009 -- Set the No_Dependence restrictions
9011 -- The following No_Dependence restrictions:
9012 -- No_Dependence => Ada.Asynchronous_Task_Control
9013 -- No_Dependence => Ada.Calendar
9014 -- No_Dependence => Ada.Task_Attributes
9015 -- are already set by previous call to Set_Profile_Restrictions.
9017 -- Set the following restrictions which were added to Ada 2005:
9018 -- No_Dependence => Ada.Execution_Time.Group_Budget
9019 -- No_Dependence => Ada.Execution_Time.Timers
9021 if Ada_Version >= Ada_2005 then
9022 Name_Buffer (1 .. 3) := "ada";
9023 Name_Len := 3;
9025 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9027 Name_Buffer (1 .. 14) := "execution_time";
9028 Name_Len := 14;
9030 Selector_Entity := Make_Identifier (Loc, Name_Find);
9032 Prefix_Node :=
9033 Make_Selected_Component
9034 (Sloc => Loc,
9035 Prefix => Prefix_Entity,
9036 Selector_Name => Selector_Entity);
9038 Name_Buffer (1 .. 13) := "group_budgets";
9039 Name_Len := 13;
9041 Selector_Entity := Make_Identifier (Loc, Name_Find);
9043 Node :=
9044 Make_Selected_Component
9045 (Sloc => Loc,
9046 Prefix => Prefix_Node,
9047 Selector_Name => Selector_Entity);
9049 Set_Restriction_No_Dependence
9050 (Unit => Node,
9051 Warn => Treat_Restrictions_As_Warnings,
9052 Profile => Ravenscar);
9054 Name_Buffer (1 .. 6) := "timers";
9055 Name_Len := 6;
9057 Selector_Entity := Make_Identifier (Loc, Name_Find);
9059 Node :=
9060 Make_Selected_Component
9061 (Sloc => Loc,
9062 Prefix => Prefix_Node,
9063 Selector_Name => Selector_Entity);
9065 Set_Restriction_No_Dependence
9066 (Unit => Node,
9067 Warn => Treat_Restrictions_As_Warnings,
9068 Profile => Ravenscar);
9069 end if;
9071 -- Set the following restrictions which was added to Ada 2012 (see
9072 -- AI-0171):
9073 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9075 if Ada_Version >= Ada_2012 then
9076 Name_Buffer (1 .. 6) := "system";
9077 Name_Len := 6;
9079 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9081 Name_Buffer (1 .. 15) := "multiprocessors";
9082 Name_Len := 15;
9084 Selector_Entity := Make_Identifier (Loc, Name_Find);
9086 Prefix_Node :=
9087 Make_Selected_Component
9088 (Sloc => Loc,
9089 Prefix => Prefix_Entity,
9090 Selector_Name => Selector_Entity);
9092 Name_Buffer (1 .. 19) := "dispatching_domains";
9093 Name_Len := 19;
9095 Selector_Entity := Make_Identifier (Loc, Name_Find);
9097 Node :=
9098 Make_Selected_Component
9099 (Sloc => Loc,
9100 Prefix => Prefix_Node,
9101 Selector_Name => Selector_Entity);
9103 Set_Restriction_No_Dependence
9104 (Unit => Node,
9105 Warn => Treat_Restrictions_As_Warnings,
9106 Profile => Ravenscar);
9107 end if;
9108 end Set_Ravenscar_Profile;
9110 ----------------
9111 -- S14_Pragma --
9112 ----------------
9114 procedure S14_Pragma is
9115 begin
9116 if not Formal_Extensions then
9117 Error_Pragma ("pragma% requires the use of debug switch -gnatd.V");
9118 end if;
9119 end S14_Pragma;
9121 -- Start of processing for Analyze_Pragma
9123 begin
9124 -- The following code is a defense against recursion. Not clear that
9125 -- this can happen legitimately, but perhaps some error situations
9126 -- can cause it, and we did see this recursion during testing.
9128 if Analyzed (N) then
9129 return;
9130 else
9131 Set_Analyzed (N, True);
9132 end if;
9134 -- Deal with unrecognized pragma
9136 Pname := Pragma_Name (N);
9138 if not Is_Pragma_Name (Pname) then
9139 if Warn_On_Unrecognized_Pragma then
9140 Error_Msg_Name_1 := Pname;
9141 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
9143 for PN in First_Pragma_Name .. Last_Pragma_Name loop
9144 if Is_Bad_Spelling_Of (Pname, PN) then
9145 Error_Msg_Name_1 := PN;
9146 Error_Msg_N -- CODEFIX
9147 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
9148 exit;
9149 end if;
9150 end loop;
9151 end if;
9153 return;
9154 end if;
9156 -- Here to start processing for recognized pragma
9158 Prag_Id := Get_Pragma_Id (Pname);
9159 Pname := Original_Aspect_Name (N);
9161 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9162 -- is already set, indicating that we have already checked the policy
9163 -- at the right point. This happens for example in the case of a pragma
9164 -- that is derived from an Aspect.
9166 if Is_Ignored (N) or else Is_Checked (N) then
9167 null;
9169 -- For a pragma that is a rewriting of another pragma, copy the
9170 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9172 elsif Is_Rewrite_Substitution (N)
9173 and then Nkind (Original_Node (N)) = N_Pragma
9174 and then Original_Node (N) /= N
9175 then
9176 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
9177 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
9179 -- Otherwise query the applicable policy at this point
9181 else
9182 Check_Applicable_Policy (N);
9184 -- If pragma is disabled, rewrite as NULL and skip analysis
9186 if Is_Disabled (N) then
9187 Rewrite (N, Make_Null_Statement (Loc));
9188 Analyze (N);
9189 raise Pragma_Exit;
9190 end if;
9191 end if;
9193 -- Preset arguments
9195 Arg_Count := 0;
9196 Arg1 := Empty;
9197 Arg2 := Empty;
9198 Arg3 := Empty;
9199 Arg4 := Empty;
9201 if Present (Pragma_Argument_Associations (N)) then
9202 Arg_Count := List_Length (Pragma_Argument_Associations (N));
9203 Arg1 := First (Pragma_Argument_Associations (N));
9205 if Present (Arg1) then
9206 Arg2 := Next (Arg1);
9208 if Present (Arg2) then
9209 Arg3 := Next (Arg2);
9211 if Present (Arg3) then
9212 Arg4 := Next (Arg3);
9213 end if;
9214 end if;
9215 end if;
9216 end if;
9218 Check_Restriction_No_Use_Of_Pragma (N);
9220 -- An enumeration type defines the pragmas that are supported by the
9221 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9222 -- into the corresponding enumeration value for the following case.
9224 case Prag_Id is
9226 -----------------
9227 -- Abort_Defer --
9228 -----------------
9230 -- pragma Abort_Defer;
9232 when Pragma_Abort_Defer =>
9233 GNAT_Pragma;
9234 Check_Arg_Count (0);
9236 -- The only required semantic processing is to check the
9237 -- placement. This pragma must appear at the start of the
9238 -- statement sequence of a handled sequence of statements.
9240 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
9241 or else N /= First (Statements (Parent (N)))
9242 then
9243 Pragma_Misplaced;
9244 end if;
9246 --------------------
9247 -- Abstract_State --
9248 --------------------
9250 -- pragma Abstract_State (ABSTRACT_STATE_LIST)
9252 -- ABSTRACT_STATE_LIST ::=
9253 -- null
9254 -- | STATE_NAME_WITH_OPTIONS
9255 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
9257 -- STATE_NAME_WITH_OPTIONS ::=
9258 -- state_NAME
9259 -- | (state_NAME with OPTION_LIST)
9261 -- OPTION_LIST ::= OPTION {, OPTION}
9263 -- OPTION ::= SIMPLE_OPTION | NAME_VALUE_OPTION
9265 -- SIMPLE_OPTION ::=
9266 -- External | Non_Volatile | Input_Only | Output_Only
9268 -- NAME_VALUE_OPTION ::= Part_Of => abstract_state_NAME
9270 when Pragma_Abstract_State => Abstract_State : declare
9271 Pack_Id : Entity_Id;
9273 -- Flags used to verify the consistency of states
9275 Non_Null_Seen : Boolean := False;
9276 Null_Seen : Boolean := False;
9278 procedure Analyze_Abstract_State (State : Node_Id);
9279 -- Verify the legality of a single state declaration. Create and
9280 -- decorate a state abstraction entity and introduce it into the
9281 -- visibility chain.
9283 ----------------------------
9284 -- Analyze_Abstract_State --
9285 ----------------------------
9287 procedure Analyze_Abstract_State (State : Node_Id) is
9288 procedure Check_Duplicate_Option
9289 (Opt : Node_Id;
9290 Status : in out Boolean);
9291 -- Flag Status denotes whether a particular option has been
9292 -- seen while processing a state. This routine verifies that
9293 -- Opt is not a duplicate property and sets the flag Status.
9295 ----------------------------
9296 -- Check_Duplicate_Option --
9297 ----------------------------
9299 procedure Check_Duplicate_Option
9300 (Opt : Node_Id;
9301 Status : in out Boolean)
9303 begin
9304 if Status then
9305 Error_Msg_N ("duplicate state option", Opt);
9306 end if;
9308 Status := True;
9309 end Check_Duplicate_Option;
9311 -- Local variables
9313 Errors : constant Nat := Serious_Errors_Detected;
9314 Loc : constant Source_Ptr := Sloc (State);
9315 Assoc : Node_Id;
9316 Id : Entity_Id;
9317 Is_Null : Boolean := False;
9318 Name : Name_Id;
9319 Opt : Node_Id;
9320 Par_State : Node_Id;
9322 -- Flags used to verify the consistency of options
9324 External_Seen : Boolean := False;
9325 Input_Seen : Boolean := False;
9326 Non_Volatile_Seen : Boolean := False;
9327 Output_Seen : Boolean := False;
9328 Part_Of_Seen : Boolean := False;
9330 -- Start of processing for Analyze_Abstract_State
9332 begin
9333 -- A package with a null abstract state is not allowed to
9334 -- declare additional states.
9336 if Null_Seen then
9337 Error_Msg_NE
9338 ("package & has null abstract state", State, Pack_Id);
9340 -- Null states appear as internally generated entities
9342 elsif Nkind (State) = N_Null then
9343 Name := New_Internal_Name ('S');
9344 Is_Null := True;
9345 Null_Seen := True;
9347 -- Catch a case where a null state appears in a list of
9348 -- non-null states.
9350 if Non_Null_Seen then
9351 Error_Msg_NE
9352 ("package & has non-null abstract state",
9353 State, Pack_Id);
9354 end if;
9356 -- Simple state declaration
9358 elsif Nkind (State) = N_Identifier then
9359 Name := Chars (State);
9360 Non_Null_Seen := True;
9362 -- State declaration with various options. This construct
9363 -- appears as an extension aggregate in the tree.
9365 elsif Nkind (State) = N_Extension_Aggregate then
9366 if Nkind (Ancestor_Part (State)) = N_Identifier then
9367 Name := Chars (Ancestor_Part (State));
9368 Non_Null_Seen := True;
9369 else
9370 Error_Msg_N
9371 ("state name must be an identifier",
9372 Ancestor_Part (State));
9373 end if;
9375 -- Process options External, Input_Only, Output_Only and
9376 -- Volatile. Ensure that none of them appear more than once.
9378 Opt := First (Expressions (State));
9379 while Present (Opt) loop
9380 if Nkind (Opt) = N_Identifier then
9381 if Chars (Opt) = Name_External then
9382 Check_Duplicate_Option (Opt, External_Seen);
9383 elsif Chars (Opt) = Name_Input_Only then
9384 Check_Duplicate_Option (Opt, Input_Seen);
9385 elsif Chars (Opt) = Name_Output_Only then
9386 Check_Duplicate_Option (Opt, Output_Seen);
9387 elsif Chars (Opt) = Name_Non_Volatile then
9388 Check_Duplicate_Option (Opt, Non_Volatile_Seen);
9390 -- Ensure that the abstract state component of option
9391 -- Part_Of has not been omitted.
9393 elsif Chars (Opt) = Name_Part_Of then
9394 Error_Msg_N
9395 ("option Part_Of requires an abstract state",
9396 Opt);
9397 else
9398 Error_Msg_N ("invalid state option", Opt);
9399 end if;
9400 else
9401 Error_Msg_N ("invalid state option", Opt);
9402 end if;
9404 Next (Opt);
9405 end loop;
9407 -- External may appear on its own or with exactly one option
9408 -- Input_Only or Output_Only, but not both.
9410 if External_Seen
9411 and then Input_Seen
9412 and then Output_Seen
9413 then
9414 Error_Msg_N
9415 ("option External requires exactly one option "
9416 & "Input_Only or Output_Only", State);
9417 end if;
9419 -- Either Input_Only or Output_Only require External
9421 if (Input_Seen or Output_Seen)
9422 and then not External_Seen
9423 then
9424 Error_Msg_N
9425 ("options Input_Only and Output_Only require option "
9426 & "External", State);
9427 end if;
9429 -- Option Part_Of appears as a component association
9431 Assoc := First (Component_Associations (State));
9432 while Present (Assoc) loop
9433 Opt := First (Choices (Assoc));
9434 while Present (Opt) loop
9435 if Nkind (Opt) = N_Identifier
9436 and then Chars (Opt) = Name_Part_Of
9437 then
9438 Check_Duplicate_Option (Opt, Part_Of_Seen);
9439 else
9440 Error_Msg_N ("invalid state option", Opt);
9441 end if;
9443 Next (Opt);
9444 end loop;
9446 -- Part_Of must denote a parent state. Ensure that the
9447 -- tree is not malformed by checking the expression of
9448 -- the component association.
9450 Par_State := Expression (Assoc);
9451 pragma Assert (Present (Par_State));
9453 Analyze (Par_State);
9455 -- Part_Of specified a legal state, this automatically
9456 -- makes the state a constituent.
9458 if Is_Entity_Name (Par_State)
9459 and then Present (Entity (Par_State))
9460 and then Ekind (Entity (Par_State)) = E_Abstract_State
9461 then
9462 null;
9463 else
9464 Error_Msg_N
9465 ("option Part_Of must denote an abstract state",
9466 Par_State);
9467 end if;
9469 Next (Assoc);
9470 end loop;
9472 -- Any other attempt to declare a state is erroneous
9474 else
9475 Error_Msg_N ("malformed abstract state declaration", State);
9476 end if;
9478 -- Do not generate a state abstraction entity if it was not
9479 -- properly declared.
9481 if Serious_Errors_Detected > Errors then
9482 return;
9483 end if;
9485 -- The generated state abstraction reuses the same characters
9486 -- from the original state declaration. Decorate the entity.
9488 Id := Make_Defining_Identifier (Loc, New_External_Name (Name));
9489 Set_Comes_From_Source (Id, not Is_Null);
9490 Set_Parent (Id, State);
9491 Set_Ekind (Id, E_Abstract_State);
9492 Set_Etype (Id, Standard_Void_Type);
9493 Set_Refined_State (Id, Empty);
9494 Set_Refinement_Constituents (Id, New_Elmt_List);
9496 -- Every non-null state must be nameable and resolvable the
9497 -- same way a constant is.
9499 if not Is_Null then
9500 Push_Scope (Pack_Id);
9501 Enter_Name (Id);
9502 Pop_Scope;
9503 end if;
9505 -- Verify whether the state introduces an illegal hidden state
9506 -- within a package subject to a null abstract state.
9508 if Formal_Extensions then
9509 Check_No_Hidden_State (Id);
9510 end if;
9512 -- Associate the state with its related package
9514 if No (Abstract_States (Pack_Id)) then
9515 Set_Abstract_States (Pack_Id, New_Elmt_List);
9516 end if;
9518 Append_Elmt (Id, Abstract_States (Pack_Id));
9519 end Analyze_Abstract_State;
9521 -- Local variables
9523 Context : constant Node_Id := Parent (Parent (N));
9524 State : Node_Id;
9526 -- Start of processing for Abstract_State
9528 begin
9529 GNAT_Pragma;
9530 S14_Pragma;
9531 Check_Arg_Count (1);
9533 -- Ensure the proper placement of the pragma. Abstract states must
9534 -- be associated with a package declaration.
9536 if not Nkind_In (Context, N_Generic_Package_Declaration,
9537 N_Package_Declaration)
9538 then
9539 Pragma_Misplaced;
9540 return;
9541 end if;
9543 Pack_Id := Defining_Entity (Context);
9544 Add_Contract_Item (N, Pack_Id);
9546 -- Verify the declaration order of pragmas Abstract_State and
9547 -- Initializes.
9549 Check_Declaration_Order
9550 (First => N,
9551 Second => Get_Pragma (Pack_Id, Pragma_Initializes));
9553 State := Expression (Arg1);
9555 -- Multiple abstract states appear as an aggregate
9557 if Nkind (State) = N_Aggregate then
9558 State := First (Expressions (State));
9559 while Present (State) loop
9560 Analyze_Abstract_State (State);
9562 Next (State);
9563 end loop;
9565 -- Various forms of a single abstract state. Note that these may
9566 -- include malformed state declarations.
9568 else
9569 Analyze_Abstract_State (State);
9570 end if;
9571 end Abstract_State;
9573 ------------
9574 -- Ada_83 --
9575 ------------
9577 -- pragma Ada_83;
9579 -- Note: this pragma also has some specific processing in Par.Prag
9580 -- because we want to set the Ada version mode during parsing.
9582 when Pragma_Ada_83 =>
9583 GNAT_Pragma;
9584 Check_Arg_Count (0);
9586 -- We really should check unconditionally for proper configuration
9587 -- pragma placement, since we really don't want mixed Ada modes
9588 -- within a single unit, and the GNAT reference manual has always
9589 -- said this was a configuration pragma, but we did not check and
9590 -- are hesitant to add the check now.
9592 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
9593 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
9594 -- or Ada 2012 mode.
9596 if Ada_Version >= Ada_2005 then
9597 Check_Valid_Configuration_Pragma;
9598 end if;
9600 -- Now set Ada 83 mode
9602 Ada_Version := Ada_83;
9603 Ada_Version_Explicit := Ada_83;
9604 Ada_Version_Pragma := N;
9606 ------------
9607 -- Ada_95 --
9608 ------------
9610 -- pragma Ada_95;
9612 -- Note: this pragma also has some specific processing in Par.Prag
9613 -- because we want to set the Ada 83 version mode during parsing.
9615 when Pragma_Ada_95 =>
9616 GNAT_Pragma;
9617 Check_Arg_Count (0);
9619 -- We really should check unconditionally for proper configuration
9620 -- pragma placement, since we really don't want mixed Ada modes
9621 -- within a single unit, and the GNAT reference manual has always
9622 -- said this was a configuration pragma, but we did not check and
9623 -- are hesitant to add the check now.
9625 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
9626 -- or Ada 95, so we must check if we are in Ada 2005 mode.
9628 if Ada_Version >= Ada_2005 then
9629 Check_Valid_Configuration_Pragma;
9630 end if;
9632 -- Now set Ada 95 mode
9634 Ada_Version := Ada_95;
9635 Ada_Version_Explicit := Ada_95;
9636 Ada_Version_Pragma := N;
9638 ---------------------
9639 -- Ada_05/Ada_2005 --
9640 ---------------------
9642 -- pragma Ada_05;
9643 -- pragma Ada_05 (LOCAL_NAME);
9645 -- pragma Ada_2005;
9646 -- pragma Ada_2005 (LOCAL_NAME):
9648 -- Note: these pragmas also have some specific processing in Par.Prag
9649 -- because we want to set the Ada 2005 version mode during parsing.
9651 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
9652 E_Id : Node_Id;
9654 begin
9655 GNAT_Pragma;
9657 if Arg_Count = 1 then
9658 Check_Arg_Is_Local_Name (Arg1);
9659 E_Id := Get_Pragma_Arg (Arg1);
9661 if Etype (E_Id) = Any_Type then
9662 return;
9663 end if;
9665 Set_Is_Ada_2005_Only (Entity (E_Id));
9666 Record_Rep_Item (Entity (E_Id), N);
9668 else
9669 Check_Arg_Count (0);
9671 -- For Ada_2005 we unconditionally enforce the documented
9672 -- configuration pragma placement, since we do not want to
9673 -- tolerate mixed modes in a unit involving Ada 2005. That
9674 -- would cause real difficulties for those cases where there
9675 -- are incompatibilities between Ada 95 and Ada 2005.
9677 Check_Valid_Configuration_Pragma;
9679 -- Now set appropriate Ada mode
9681 Ada_Version := Ada_2005;
9682 Ada_Version_Explicit := Ada_2005;
9683 Ada_Version_Pragma := N;
9684 end if;
9685 end;
9687 ---------------------
9688 -- Ada_12/Ada_2012 --
9689 ---------------------
9691 -- pragma Ada_12;
9692 -- pragma Ada_12 (LOCAL_NAME);
9694 -- pragma Ada_2012;
9695 -- pragma Ada_2012 (LOCAL_NAME):
9697 -- Note: these pragmas also have some specific processing in Par.Prag
9698 -- because we want to set the Ada 2012 version mode during parsing.
9700 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
9701 E_Id : Node_Id;
9703 begin
9704 GNAT_Pragma;
9706 if Arg_Count = 1 then
9707 Check_Arg_Is_Local_Name (Arg1);
9708 E_Id := Get_Pragma_Arg (Arg1);
9710 if Etype (E_Id) = Any_Type then
9711 return;
9712 end if;
9714 Set_Is_Ada_2012_Only (Entity (E_Id));
9715 Record_Rep_Item (Entity (E_Id), N);
9717 else
9718 Check_Arg_Count (0);
9720 -- For Ada_2012 we unconditionally enforce the documented
9721 -- configuration pragma placement, since we do not want to
9722 -- tolerate mixed modes in a unit involving Ada 2012. That
9723 -- would cause real difficulties for those cases where there
9724 -- are incompatibilities between Ada 95 and Ada 2012. We could
9725 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
9727 Check_Valid_Configuration_Pragma;
9729 -- Now set appropriate Ada mode
9731 Ada_Version := Ada_2012;
9732 Ada_Version_Explicit := Ada_2012;
9733 Ada_Version_Pragma := N;
9734 end if;
9735 end;
9737 ----------------------
9738 -- All_Calls_Remote --
9739 ----------------------
9741 -- pragma All_Calls_Remote [(library_package_NAME)];
9743 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
9744 Lib_Entity : Entity_Id;
9746 begin
9747 Check_Ada_83_Warning;
9748 Check_Valid_Library_Unit_Pragma;
9750 if Nkind (N) = N_Null_Statement then
9751 return;
9752 end if;
9754 Lib_Entity := Find_Lib_Unit_Name;
9756 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
9758 if Present (Lib_Entity)
9759 and then not Debug_Flag_U
9760 then
9761 if not Is_Remote_Call_Interface (Lib_Entity) then
9762 Error_Pragma ("pragma% only apply to rci unit");
9764 -- Set flag for entity of the library unit
9766 else
9767 Set_Has_All_Calls_Remote (Lib_Entity);
9768 end if;
9770 end if;
9771 end All_Calls_Remote;
9773 --------------
9774 -- Annotate --
9775 --------------
9777 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
9778 -- ARG ::= NAME | EXPRESSION
9780 -- The first two arguments are by convention intended to refer to an
9781 -- external tool and a tool-specific function. These arguments are
9782 -- not analyzed.
9784 when Pragma_Annotate => Annotate : declare
9785 Arg : Node_Id;
9786 Exp : Node_Id;
9788 begin
9789 GNAT_Pragma;
9790 Check_At_Least_N_Arguments (1);
9791 Check_Arg_Is_Identifier (Arg1);
9792 Check_No_Identifiers;
9793 Store_Note (N);
9795 -- Second parameter is optional, it is never analyzed
9797 if No (Arg2) then
9798 null;
9800 -- Here if we have a second parameter
9802 else
9803 -- Second parameter must be identifier
9805 Check_Arg_Is_Identifier (Arg2);
9807 -- Process remaining parameters if any
9809 Arg := Next (Arg2);
9810 while Present (Arg) loop
9811 Exp := Get_Pragma_Arg (Arg);
9812 Analyze (Exp);
9814 if Is_Entity_Name (Exp) then
9815 null;
9817 -- For string literals, we assume Standard_String as the
9818 -- type, unless the string contains wide or wide_wide
9819 -- characters.
9821 elsif Nkind (Exp) = N_String_Literal then
9822 if Has_Wide_Wide_Character (Exp) then
9823 Resolve (Exp, Standard_Wide_Wide_String);
9824 elsif Has_Wide_Character (Exp) then
9825 Resolve (Exp, Standard_Wide_String);
9826 else
9827 Resolve (Exp, Standard_String);
9828 end if;
9830 elsif Is_Overloaded (Exp) then
9831 Error_Pragma_Arg
9832 ("ambiguous argument for pragma%", Exp);
9834 else
9835 Resolve (Exp);
9836 end if;
9838 Next (Arg);
9839 end loop;
9840 end if;
9841 end Annotate;
9843 -------------------------------------------------
9844 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
9845 -------------------------------------------------
9847 -- pragma Assert
9848 -- ( [Check => ] Boolean_EXPRESSION
9849 -- [, [Message =>] Static_String_EXPRESSION]);
9851 -- pragma Assert_And_Cut
9852 -- ( [Check => ] Boolean_EXPRESSION
9853 -- [, [Message =>] Static_String_EXPRESSION]);
9855 -- pragma Assume
9856 -- ( [Check => ] Boolean_EXPRESSION
9857 -- [, [Message =>] Static_String_EXPRESSION]);
9859 -- pragma Loop_Invariant
9860 -- ( [Check => ] Boolean_EXPRESSION
9861 -- [, [Message =>] Static_String_EXPRESSION]);
9863 when Pragma_Assert |
9864 Pragma_Assert_And_Cut |
9865 Pragma_Assume |
9866 Pragma_Loop_Invariant =>
9867 Assert : declare
9868 Expr : Node_Id;
9869 Newa : List_Id;
9871 begin
9872 -- Assert is an Ada 2005 RM-defined pragma
9874 if Prag_Id = Pragma_Assert then
9875 Ada_2005_Pragma;
9877 -- The remaining ones are GNAT pragmas
9879 else
9880 GNAT_Pragma;
9881 end if;
9883 Check_At_Least_N_Arguments (1);
9884 Check_At_Most_N_Arguments (2);
9885 Check_Arg_Order ((Name_Check, Name_Message));
9886 Check_Optional_Identifier (Arg1, Name_Check);
9888 -- Special processing for Loop_Invariant
9890 if Prag_Id = Pragma_Loop_Invariant then
9892 -- Check restricted placement, must be within a loop
9894 Check_Loop_Pragma_Placement;
9896 -- Do preanalyze to deal with embedded Loop_Entry attribute
9898 Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean);
9899 end if;
9901 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
9902 -- a corresponding Check pragma:
9904 -- pragma Check (name, condition [, msg]);
9906 -- Where name is the identifier matching the pragma name. So
9907 -- rewrite pragma in this manner, transfer the message argument
9908 -- if present, and analyze the result
9910 -- Note: When dealing with a semantically analyzed tree, the
9911 -- information that a Check node N corresponds to a source Assert,
9912 -- Assume, or Assert_And_Cut pragma can be retrieved from the
9913 -- pragma kind of Original_Node(N).
9915 Expr := Get_Pragma_Arg (Arg1);
9916 Newa := New_List (
9917 Make_Pragma_Argument_Association (Loc,
9918 Expression => Make_Identifier (Loc, Pname)),
9919 Make_Pragma_Argument_Association (Sloc (Expr),
9920 Expression => Expr));
9922 if Arg_Count > 1 then
9923 Check_Optional_Identifier (Arg2, Name_Message);
9924 Append_To (Newa, New_Copy_Tree (Arg2));
9925 end if;
9927 -- Rewrite as Check pragma
9929 Rewrite (N,
9930 Make_Pragma (Loc,
9931 Chars => Name_Check,
9932 Pragma_Argument_Associations => Newa));
9933 Analyze (N);
9934 end Assert;
9936 ----------------------
9937 -- Assertion_Policy --
9938 ----------------------
9940 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
9942 -- The following form is Ada 2012 only, but we allow it in all modes
9944 -- Pragma Assertion_Policy (
9945 -- ASSERTION_KIND => POLICY_IDENTIFIER
9946 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
9948 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
9950 -- RM_ASSERTION_KIND ::= Assert |
9951 -- Static_Predicate |
9952 -- Dynamic_Predicate |
9953 -- Pre |
9954 -- Pre'Class |
9955 -- Post |
9956 -- Post'Class |
9957 -- Type_Invariant |
9958 -- Type_Invariant'Class
9960 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
9961 -- Assume |
9962 -- Contract_Cases |
9963 -- Debug |
9964 -- Initial_Condition |
9965 -- Loop_Invariant |
9966 -- Loop_Variant |
9967 -- Postcondition |
9968 -- Precondition |
9969 -- Predicate |
9970 -- Refined_Post |
9971 -- Statement_Assertions
9973 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
9974 -- ID_ASSERTION_KIND list contains implementation-defined additions
9975 -- recognized by GNAT. The effect is to control the behavior of
9976 -- identically named aspects and pragmas, depending on the specified
9977 -- policy identifier:
9979 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
9981 -- Note: Check and Ignore are language-defined. Disable is a GNAT
9982 -- implementation defined addition that results in totally ignoring
9983 -- the corresponding assertion. If Disable is specified, then the
9984 -- argument of the assertion is not even analyzed. This is useful
9985 -- when the aspect/pragma argument references entities in a with'ed
9986 -- package that is replaced by a dummy package in the final build.
9988 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
9989 -- and Type_Invariant'Class were recognized by the parser and
9990 -- transformed into references to the special internal identifiers
9991 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
9992 -- processing is required here.
9994 when Pragma_Assertion_Policy => Assertion_Policy : declare
9995 LocP : Source_Ptr;
9996 Policy : Node_Id;
9997 Arg : Node_Id;
9998 Kind : Name_Id;
10000 begin
10001 Ada_2005_Pragma;
10003 -- This can always appear as a configuration pragma
10005 if Is_Configuration_Pragma then
10006 null;
10008 -- It can also appear in a declarative part or package spec in Ada
10009 -- 2012 mode. We allow this in other modes, but in that case we
10010 -- consider that we have an Ada 2012 pragma on our hands.
10012 else
10013 Check_Is_In_Decl_Part_Or_Package_Spec;
10014 Ada_2012_Pragma;
10015 end if;
10017 -- One argument case with no identifier (first form above)
10019 if Arg_Count = 1
10020 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
10021 or else Chars (Arg1) = No_Name)
10022 then
10023 Check_Arg_Is_One_Of
10024 (Arg1, Name_Check, Name_Disable, Name_Ignore);
10026 -- Treat one argument Assertion_Policy as equivalent to:
10028 -- pragma Check_Policy (Assertion, policy)
10030 -- So rewrite pragma in that manner and link on to the chain
10031 -- of Check_Policy pragmas, marking the pragma as analyzed.
10033 Policy := Get_Pragma_Arg (Arg1);
10035 Rewrite (N,
10036 Make_Pragma (Loc,
10037 Chars => Name_Check_Policy,
10038 Pragma_Argument_Associations => New_List (
10039 Make_Pragma_Argument_Association (Loc,
10040 Expression => Make_Identifier (Loc, Name_Assertion)),
10042 Make_Pragma_Argument_Association (Loc,
10043 Expression =>
10044 Make_Identifier (Sloc (Policy), Chars (Policy))))));
10045 Analyze (N);
10047 -- Here if we have two or more arguments
10049 else
10050 Check_At_Least_N_Arguments (1);
10051 Ada_2012_Pragma;
10053 -- Loop through arguments
10055 Arg := Arg1;
10056 while Present (Arg) loop
10057 LocP := Sloc (Arg);
10059 -- Kind must be specified
10061 if Nkind (Arg) /= N_Pragma_Argument_Association
10062 or else Chars (Arg) = No_Name
10063 then
10064 Error_Pragma_Arg
10065 ("missing assertion kind for pragma%", Arg);
10066 end if;
10068 -- Check Kind and Policy have allowed forms
10070 Kind := Chars (Arg);
10072 if not Is_Valid_Assertion_Kind (Kind) then
10073 Error_Pragma_Arg
10074 ("invalid assertion kind for pragma%", Arg);
10075 end if;
10077 Check_Arg_Is_One_Of
10078 (Arg, Name_Check, Name_Disable, Name_Ignore);
10080 -- We rewrite the Assertion_Policy pragma as a series of
10081 -- Check_Policy pragmas:
10083 -- Check_Policy (Kind, Policy);
10085 Insert_Action (N,
10086 Make_Pragma (LocP,
10087 Chars => Name_Check_Policy,
10088 Pragma_Argument_Associations => New_List (
10089 Make_Pragma_Argument_Association (LocP,
10090 Expression => Make_Identifier (LocP, Kind)),
10091 Make_Pragma_Argument_Association (LocP,
10092 Expression => Get_Pragma_Arg (Arg)))));
10094 Arg := Next (Arg);
10095 end loop;
10097 -- Rewrite the Assertion_Policy pragma as null since we have
10098 -- now inserted all the equivalent Check pragmas.
10100 Rewrite (N, Make_Null_Statement (Loc));
10101 Analyze (N);
10102 end if;
10103 end Assertion_Policy;
10105 ------------------------------
10106 -- Assume_No_Invalid_Values --
10107 ------------------------------
10109 -- pragma Assume_No_Invalid_Values (On | Off);
10111 when Pragma_Assume_No_Invalid_Values =>
10112 GNAT_Pragma;
10113 Check_Valid_Configuration_Pragma;
10114 Check_Arg_Count (1);
10115 Check_No_Identifiers;
10116 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
10118 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
10119 Assume_No_Invalid_Values := True;
10120 else
10121 Assume_No_Invalid_Values := False;
10122 end if;
10124 --------------------------
10125 -- Attribute_Definition --
10126 --------------------------
10128 -- pragma Attribute_Definition
10129 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
10130 -- [Entity =>] LOCAL_NAME,
10131 -- [Expression =>] EXPRESSION | NAME);
10133 when Pragma_Attribute_Definition => Attribute_Definition : declare
10134 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
10135 Aname : Name_Id;
10137 begin
10138 GNAT_Pragma;
10139 Check_Arg_Count (3);
10140 Check_Optional_Identifier (Arg1, "attribute");
10141 Check_Optional_Identifier (Arg2, "entity");
10142 Check_Optional_Identifier (Arg3, "expression");
10144 if Nkind (Attribute_Designator) /= N_Identifier then
10145 Error_Msg_N ("attribute name expected", Attribute_Designator);
10146 return;
10147 end if;
10149 Check_Arg_Is_Local_Name (Arg2);
10151 -- If the attribute is not recognized, then issue a warning (not
10152 -- an error), and ignore the pragma.
10154 Aname := Chars (Attribute_Designator);
10156 if not Is_Attribute_Name (Aname) then
10157 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
10158 return;
10159 end if;
10161 -- Otherwise, rewrite the pragma as an attribute definition clause
10163 Rewrite (N,
10164 Make_Attribute_Definition_Clause (Loc,
10165 Name => Get_Pragma_Arg (Arg2),
10166 Chars => Aname,
10167 Expression => Get_Pragma_Arg (Arg3)));
10168 Analyze (N);
10169 end Attribute_Definition;
10171 ---------------
10172 -- AST_Entry --
10173 ---------------
10175 -- pragma AST_Entry (entry_IDENTIFIER);
10177 when Pragma_AST_Entry => AST_Entry : declare
10178 Ent : Node_Id;
10180 begin
10181 GNAT_Pragma;
10182 Check_VMS (N);
10183 Check_Arg_Count (1);
10184 Check_No_Identifiers;
10185 Check_Arg_Is_Local_Name (Arg1);
10186 Ent := Entity (Get_Pragma_Arg (Arg1));
10188 -- Note: the implementation of the AST_Entry pragma could handle
10189 -- the entry family case fine, but for now we are consistent with
10190 -- the DEC rules, and do not allow the pragma, which of course
10191 -- has the effect of also forbidding the attribute.
10193 if Ekind (Ent) /= E_Entry then
10194 Error_Pragma_Arg
10195 ("pragma% argument must be simple entry name", Arg1);
10197 elsif Is_AST_Entry (Ent) then
10198 Error_Pragma_Arg
10199 ("duplicate % pragma for entry", Arg1);
10201 elsif Has_Homonym (Ent) then
10202 Error_Pragma_Arg
10203 ("pragma% argument cannot specify overloaded entry", Arg1);
10205 else
10206 declare
10207 FF : constant Entity_Id := First_Formal (Ent);
10209 begin
10210 if Present (FF) then
10211 if Present (Next_Formal (FF)) then
10212 Error_Pragma_Arg
10213 ("entry for pragma% can have only one argument",
10214 Arg1);
10216 elsif Parameter_Mode (FF) /= E_In_Parameter then
10217 Error_Pragma_Arg
10218 ("entry parameter for pragma% must have mode IN",
10219 Arg1);
10220 end if;
10221 end if;
10222 end;
10224 Set_Is_AST_Entry (Ent);
10225 end if;
10226 end AST_Entry;
10228 ------------------
10229 -- Asynchronous --
10230 ------------------
10232 -- pragma Asynchronous (LOCAL_NAME);
10234 when Pragma_Asynchronous => Asynchronous : declare
10235 Nm : Entity_Id;
10236 C_Ent : Entity_Id;
10237 L : List_Id;
10238 S : Node_Id;
10239 N : Node_Id;
10240 Formal : Entity_Id;
10242 procedure Process_Async_Pragma;
10243 -- Common processing for procedure and access-to-procedure case
10245 --------------------------
10246 -- Process_Async_Pragma --
10247 --------------------------
10249 procedure Process_Async_Pragma is
10250 begin
10251 if No (L) then
10252 Set_Is_Asynchronous (Nm);
10253 return;
10254 end if;
10256 -- The formals should be of mode IN (RM E.4.1(6))
10258 S := First (L);
10259 while Present (S) loop
10260 Formal := Defining_Identifier (S);
10262 if Nkind (Formal) = N_Defining_Identifier
10263 and then Ekind (Formal) /= E_In_Parameter
10264 then
10265 Error_Pragma_Arg
10266 ("pragma% procedure can only have IN parameter",
10267 Arg1);
10268 end if;
10270 Next (S);
10271 end loop;
10273 Set_Is_Asynchronous (Nm);
10274 end Process_Async_Pragma;
10276 -- Start of processing for pragma Asynchronous
10278 begin
10279 Check_Ada_83_Warning;
10280 Check_No_Identifiers;
10281 Check_Arg_Count (1);
10282 Check_Arg_Is_Local_Name (Arg1);
10284 if Debug_Flag_U then
10285 return;
10286 end if;
10288 C_Ent := Cunit_Entity (Current_Sem_Unit);
10289 Analyze (Get_Pragma_Arg (Arg1));
10290 Nm := Entity (Get_Pragma_Arg (Arg1));
10292 if not Is_Remote_Call_Interface (C_Ent)
10293 and then not Is_Remote_Types (C_Ent)
10294 then
10295 -- This pragma should only appear in an RCI or Remote Types
10296 -- unit (RM E.4.1(4)).
10298 Error_Pragma
10299 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
10300 end if;
10302 if Ekind (Nm) = E_Procedure
10303 and then Nkind (Parent (Nm)) = N_Procedure_Specification
10304 then
10305 if not Is_Remote_Call_Interface (Nm) then
10306 Error_Pragma_Arg
10307 ("pragma% cannot be applied on non-remote procedure",
10308 Arg1);
10309 end if;
10311 L := Parameter_Specifications (Parent (Nm));
10312 Process_Async_Pragma;
10313 return;
10315 elsif Ekind (Nm) = E_Function then
10316 Error_Pragma_Arg
10317 ("pragma% cannot be applied to function", Arg1);
10319 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
10320 if Is_Record_Type (Nm) then
10322 -- A record type that is the Equivalent_Type for a remote
10323 -- access-to-subprogram type.
10325 N := Declaration_Node (Corresponding_Remote_Type (Nm));
10327 else
10328 -- A non-expanded RAS type (distribution is not enabled)
10330 N := Declaration_Node (Nm);
10331 end if;
10333 if Nkind (N) = N_Full_Type_Declaration
10334 and then Nkind (Type_Definition (N)) =
10335 N_Access_Procedure_Definition
10336 then
10337 L := Parameter_Specifications (Type_Definition (N));
10338 Process_Async_Pragma;
10340 if Is_Asynchronous (Nm)
10341 and then Expander_Active
10342 and then Get_PCS_Name /= Name_No_DSA
10343 then
10344 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
10345 end if;
10347 else
10348 Error_Pragma_Arg
10349 ("pragma% cannot reference access-to-function type",
10350 Arg1);
10351 end if;
10353 -- Only other possibility is Access-to-class-wide type
10355 elsif Is_Access_Type (Nm)
10356 and then Is_Class_Wide_Type (Designated_Type (Nm))
10357 then
10358 Check_First_Subtype (Arg1);
10359 Set_Is_Asynchronous (Nm);
10360 if Expander_Active then
10361 RACW_Type_Is_Asynchronous (Nm);
10362 end if;
10364 else
10365 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
10366 end if;
10367 end Asynchronous;
10369 ------------
10370 -- Atomic --
10371 ------------
10373 -- pragma Atomic (LOCAL_NAME);
10375 when Pragma_Atomic =>
10376 Process_Atomic_Shared_Volatile;
10378 -----------------------
10379 -- Atomic_Components --
10380 -----------------------
10382 -- pragma Atomic_Components (array_LOCAL_NAME);
10384 -- This processing is shared by Volatile_Components
10386 when Pragma_Atomic_Components |
10387 Pragma_Volatile_Components =>
10389 Atomic_Components : declare
10390 E_Id : Node_Id;
10391 E : Entity_Id;
10392 D : Node_Id;
10393 K : Node_Kind;
10395 begin
10396 Check_Ada_83_Warning;
10397 Check_No_Identifiers;
10398 Check_Arg_Count (1);
10399 Check_Arg_Is_Local_Name (Arg1);
10400 E_Id := Get_Pragma_Arg (Arg1);
10402 if Etype (E_Id) = Any_Type then
10403 return;
10404 end if;
10406 E := Entity (E_Id);
10408 Check_Duplicate_Pragma (E);
10410 if Rep_Item_Too_Early (E, N)
10411 or else
10412 Rep_Item_Too_Late (E, N)
10413 then
10414 return;
10415 end if;
10417 D := Declaration_Node (E);
10418 K := Nkind (D);
10420 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
10421 or else
10422 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
10423 and then Nkind (D) = N_Object_Declaration
10424 and then Nkind (Object_Definition (D)) =
10425 N_Constrained_Array_Definition)
10426 then
10427 -- The flag is set on the object, or on the base type
10429 if Nkind (D) /= N_Object_Declaration then
10430 E := Base_Type (E);
10431 end if;
10433 Set_Has_Volatile_Components (E);
10435 if Prag_Id = Pragma_Atomic_Components then
10436 Set_Has_Atomic_Components (E);
10437 end if;
10439 else
10440 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
10441 end if;
10442 end Atomic_Components;
10444 --------------------
10445 -- Attach_Handler --
10446 --------------------
10448 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
10450 when Pragma_Attach_Handler =>
10451 Check_Ada_83_Warning;
10452 Check_No_Identifiers;
10453 Check_Arg_Count (2);
10455 if No_Run_Time_Mode then
10456 Error_Msg_CRT ("Attach_Handler pragma", N);
10457 else
10458 Check_Interrupt_Or_Attach_Handler;
10460 -- The expression that designates the attribute may depend on a
10461 -- discriminant, and is therefore a per-object expression, to
10462 -- be expanded in the init proc. If expansion is enabled, then
10463 -- perform semantic checks on a copy only.
10465 if Expander_Active then
10466 declare
10467 Temp : constant Node_Id :=
10468 New_Copy_Tree (Get_Pragma_Arg (Arg2));
10469 begin
10470 Set_Parent (Temp, N);
10471 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
10472 end;
10474 else
10475 Analyze (Get_Pragma_Arg (Arg2));
10476 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
10477 end if;
10479 Process_Interrupt_Or_Attach_Handler;
10480 end if;
10482 --------------------
10483 -- C_Pass_By_Copy --
10484 --------------------
10486 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
10488 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
10489 Arg : Node_Id;
10490 Val : Uint;
10492 begin
10493 GNAT_Pragma;
10494 Check_Valid_Configuration_Pragma;
10495 Check_Arg_Count (1);
10496 Check_Optional_Identifier (Arg1, "max_size");
10498 Arg := Get_Pragma_Arg (Arg1);
10499 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
10501 Val := Expr_Value (Arg);
10503 if Val <= 0 then
10504 Error_Pragma_Arg
10505 ("maximum size for pragma% must be positive", Arg1);
10507 elsif UI_Is_In_Int_Range (Val) then
10508 Default_C_Record_Mechanism := UI_To_Int (Val);
10510 -- If a giant value is given, Int'Last will do well enough.
10511 -- If sometime someone complains that a record larger than
10512 -- two gigabytes is not copied, we will worry about it then!
10514 else
10515 Default_C_Record_Mechanism := Mechanism_Type'Last;
10516 end if;
10517 end C_Pass_By_Copy;
10519 -----------
10520 -- Check --
10521 -----------
10523 -- pragma Check ([Name =>] CHECK_KIND,
10524 -- [Check =>] Boolean_EXPRESSION
10525 -- [,[Message =>] String_EXPRESSION]);
10527 -- CHECK_KIND ::= IDENTIFIER |
10528 -- Pre'Class |
10529 -- Post'Class |
10530 -- Invariant'Class |
10531 -- Type_Invariant'Class
10533 -- The identifiers Assertions and Statement_Assertions are not
10534 -- allowed, since they have special meaning for Check_Policy.
10536 when Pragma_Check => Check : declare
10537 Expr : Node_Id;
10538 Eloc : Source_Ptr;
10539 Cname : Name_Id;
10540 Str : Node_Id;
10542 begin
10543 GNAT_Pragma;
10544 Check_At_Least_N_Arguments (2);
10545 Check_At_Most_N_Arguments (3);
10546 Check_Optional_Identifier (Arg1, Name_Name);
10547 Check_Optional_Identifier (Arg2, Name_Check);
10549 if Arg_Count = 3 then
10550 Check_Optional_Identifier (Arg3, Name_Message);
10551 Str := Get_Pragma_Arg (Arg3);
10552 end if;
10554 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
10555 Check_Arg_Is_Identifier (Arg1);
10556 Cname := Chars (Get_Pragma_Arg (Arg1));
10558 -- Check forbidden name Assertions or Statement_Assertions
10560 case Cname is
10561 when Name_Assertions =>
10562 Error_Pragma_Arg
10563 ("""Assertions"" is not allowed as a check kind "
10564 & "for pragma%", Arg1);
10566 when Name_Statement_Assertions =>
10567 Error_Pragma_Arg
10568 ("""Statement_Assertions"" is not allowed as a check kind "
10569 & "for pragma%", Arg1);
10571 when others =>
10572 null;
10573 end case;
10575 -- Check applicable policy. We skip this if Checked/Ignored status
10576 -- is already set (e.g. in the casse of a pragma from an aspect).
10578 if Is_Checked (N) or else Is_Ignored (N) then
10579 null;
10581 -- For a non-source pragma that is a rewriting of another pragma,
10582 -- copy the Is_Checked/Ignored status from the rewritten pragma.
10584 elsif Is_Rewrite_Substitution (N)
10585 and then Nkind (Original_Node (N)) = N_Pragma
10586 and then Original_Node (N) /= N
10587 then
10588 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10589 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10591 -- Otherwise query the applicable policy at this point
10593 else
10594 case Check_Kind (Cname) is
10595 when Name_Ignore =>
10596 Set_Is_Ignored (N, True);
10597 Set_Is_Checked (N, False);
10599 when Name_Check =>
10600 Set_Is_Ignored (N, False);
10601 Set_Is_Checked (N, True);
10603 -- For disable, rewrite pragma as null statement and skip
10604 -- rest of the analysis of the pragma.
10606 when Name_Disable =>
10607 Rewrite (N, Make_Null_Statement (Loc));
10608 Analyze (N);
10609 raise Pragma_Exit;
10611 -- No other possibilities
10613 when others =>
10614 raise Program_Error;
10615 end case;
10616 end if;
10618 -- If check kind was not Disable, then continue pragma analysis
10620 Expr := Get_Pragma_Arg (Arg2);
10622 -- Deal with SCO generation
10624 case Cname is
10625 when Name_Predicate |
10626 Name_Invariant =>
10628 -- Nothing to do: since checks occur in client units,
10629 -- the SCO for the aspect in the declaration unit is
10630 -- conservatively always enabled.
10632 null;
10634 when others =>
10636 if Is_Checked (N) and then not Split_PPC (N) then
10638 -- Mark aspect/pragma SCO as enabled
10640 Set_SCO_Pragma_Enabled (Loc);
10641 end if;
10642 end case;
10644 -- Deal with analyzing the string argument.
10646 if Arg_Count = 3 then
10648 -- If checks are not on we don't want any expansion (since
10649 -- such expansion would not get properly deleted) but
10650 -- we do want to analyze (to get proper references).
10651 -- The Preanalyze_And_Resolve routine does just what we want
10653 if Is_Ignored (N) then
10654 Preanalyze_And_Resolve (Str, Standard_String);
10656 -- Otherwise we need a proper analysis and expansion
10658 else
10659 Analyze_And_Resolve (Str, Standard_String);
10660 end if;
10661 end if;
10663 -- Now you might think we could just do the same with the Boolean
10664 -- expression if checks are off (and expansion is on) and then
10665 -- rewrite the check as a null statement. This would work but we
10666 -- would lose the useful warnings about an assertion being bound
10667 -- to fail even if assertions are turned off.
10669 -- So instead we wrap the boolean expression in an if statement
10670 -- that looks like:
10672 -- if False and then condition then
10673 -- null;
10674 -- end if;
10676 -- The reason we do this rewriting during semantic analysis rather
10677 -- than as part of normal expansion is that we cannot analyze and
10678 -- expand the code for the boolean expression directly, or it may
10679 -- cause insertion of actions that would escape the attempt to
10680 -- suppress the check code.
10682 -- Note that the Sloc for the if statement corresponds to the
10683 -- argument condition, not the pragma itself. The reason for
10684 -- this is that we may generate a warning if the condition is
10685 -- False at compile time, and we do not want to delete this
10686 -- warning when we delete the if statement.
10688 if Expander_Active and Is_Ignored (N) then
10689 Eloc := Sloc (Expr);
10691 Rewrite (N,
10692 Make_If_Statement (Eloc,
10693 Condition =>
10694 Make_And_Then (Eloc,
10695 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
10696 Right_Opnd => Expr),
10697 Then_Statements => New_List (
10698 Make_Null_Statement (Eloc))));
10700 In_Assertion_Expr := In_Assertion_Expr + 1;
10701 Analyze (N);
10702 In_Assertion_Expr := In_Assertion_Expr - 1;
10704 -- Check is active or expansion not active. In these cases we can
10705 -- just go ahead and analyze the boolean with no worries.
10707 else
10708 In_Assertion_Expr := In_Assertion_Expr + 1;
10709 Analyze_And_Resolve (Expr, Any_Boolean);
10710 In_Assertion_Expr := In_Assertion_Expr - 1;
10711 end if;
10712 end Check;
10714 --------------------------
10715 -- Check_Float_Overflow --
10716 --------------------------
10718 -- pragma Check_Float_Overflow;
10720 when Pragma_Check_Float_Overflow =>
10721 GNAT_Pragma;
10722 Check_Valid_Configuration_Pragma;
10723 Check_Arg_Count (0);
10724 Check_Float_Overflow := True;
10726 ----------------
10727 -- Check_Name --
10728 ----------------
10730 -- pragma Check_Name (check_IDENTIFIER);
10732 when Pragma_Check_Name =>
10733 GNAT_Pragma;
10734 Check_No_Identifiers;
10735 Check_Valid_Configuration_Pragma;
10736 Check_Arg_Count (1);
10737 Check_Arg_Is_Identifier (Arg1);
10739 declare
10740 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
10742 begin
10743 for J in Check_Names.First .. Check_Names.Last loop
10744 if Check_Names.Table (J) = Nam then
10745 return;
10746 end if;
10747 end loop;
10749 Check_Names.Append (Nam);
10750 end;
10752 ------------------
10753 -- Check_Policy --
10754 ------------------
10756 -- This is the old style syntax, which is still allowed in all modes:
10758 -- pragma Check_Policy ([Name =>] CHECK_KIND
10759 -- [Policy =>] POLICY_IDENTIFIER);
10761 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
10763 -- CHECK_KIND ::= IDENTIFIER |
10764 -- Pre'Class |
10765 -- Post'Class |
10766 -- Type_Invariant'Class |
10767 -- Invariant'Class
10769 -- This is the new style syntax, compatible with Assertion_Policy
10770 -- and also allowed in all modes.
10772 -- Pragma Check_Policy (
10773 -- CHECK_KIND => POLICY_IDENTIFIER
10774 -- {, CHECK_KIND => POLICY_IDENTIFIER});
10776 -- Note: the identifiers Name and Policy are not allowed as
10777 -- Check_Kind values. This avoids ambiguities between the old and
10778 -- new form syntax.
10780 when Pragma_Check_Policy => Check_Policy : declare
10781 Kind : Node_Id;
10783 begin
10784 GNAT_Pragma;
10785 Check_At_Least_N_Arguments (1);
10787 -- A Check_Policy pragma can appear either as a configuration
10788 -- pragma, or in a declarative part or a package spec (see RM
10789 -- 11.5(5) for rules for Suppress/Unsuppress which are also
10790 -- followed for Check_Policy).
10792 if not Is_Configuration_Pragma then
10793 Check_Is_In_Decl_Part_Or_Package_Spec;
10794 end if;
10796 -- Figure out if we have the old or new syntax. We have the
10797 -- old syntax if the first argument has no identifier, or the
10798 -- identifier is Name.
10800 if Nkind (Arg1) /= N_Pragma_Argument_Association
10801 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
10802 then
10803 -- Old syntax
10805 Check_Arg_Count (2);
10806 Check_Optional_Identifier (Arg1, Name_Name);
10807 Kind := Get_Pragma_Arg (Arg1);
10808 Rewrite_Assertion_Kind (Kind);
10809 Check_Arg_Is_Identifier (Arg1);
10811 -- Check forbidden check kind
10813 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
10814 Error_Msg_Name_2 := Chars (Kind);
10815 Error_Pragma_Arg
10816 ("pragma% does not allow% as check name", Arg1);
10817 end if;
10819 -- Check policy
10821 Check_Optional_Identifier (Arg2, Name_Policy);
10822 Check_Arg_Is_One_Of
10823 (Arg2,
10824 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
10826 -- And chain pragma on the Check_Policy_List for search
10828 Set_Next_Pragma (N, Opt.Check_Policy_List);
10829 Opt.Check_Policy_List := N;
10831 -- For the new syntax, what we do is to convert each argument to
10832 -- an old syntax equivalent. We do that because we want to chain
10833 -- old style Check_Policy pragmas for the search (we don't want
10834 -- to have to deal with multiple arguments in the search).
10836 else
10837 declare
10838 Arg : Node_Id;
10839 Argx : Node_Id;
10840 LocP : Source_Ptr;
10842 begin
10843 Arg := Arg1;
10844 while Present (Arg) loop
10845 LocP := Sloc (Arg);
10846 Argx := Get_Pragma_Arg (Arg);
10848 -- Kind must be specified
10850 if Nkind (Arg) /= N_Pragma_Argument_Association
10851 or else Chars (Arg) = No_Name
10852 then
10853 Error_Pragma_Arg
10854 ("missing assertion kind for pragma%", Arg);
10855 end if;
10857 -- Construct equivalent old form syntax Check_Policy
10858 -- pragma and insert it to get remaining checks.
10860 Insert_Action (N,
10861 Make_Pragma (LocP,
10862 Chars => Name_Check_Policy,
10863 Pragma_Argument_Associations => New_List (
10864 Make_Pragma_Argument_Association (LocP,
10865 Expression =>
10866 Make_Identifier (LocP, Chars (Arg))),
10867 Make_Pragma_Argument_Association (Sloc (Argx),
10868 Expression => Argx))));
10870 Arg := Next (Arg);
10871 end loop;
10873 -- Rewrite original Check_Policy pragma to null, since we
10874 -- have converted it into a series of old syntax pragmas.
10876 Rewrite (N, Make_Null_Statement (Loc));
10877 Analyze (N);
10878 end;
10879 end if;
10880 end Check_Policy;
10882 ---------------------
10883 -- CIL_Constructor --
10884 ---------------------
10886 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
10888 -- Processing for this pragma is shared with Java_Constructor
10890 -------------
10891 -- Comment --
10892 -------------
10894 -- pragma Comment (static_string_EXPRESSION)
10896 -- Processing for pragma Comment shares the circuitry for pragma
10897 -- Ident. The only differences are that Ident enforces a limit of 31
10898 -- characters on its argument, and also enforces limitations on
10899 -- placement for DEC compatibility. Pragma Comment shares neither of
10900 -- these restrictions.
10902 -------------------
10903 -- Common_Object --
10904 -------------------
10906 -- pragma Common_Object (
10907 -- [Internal =>] LOCAL_NAME
10908 -- [, [External =>] EXTERNAL_SYMBOL]
10909 -- [, [Size =>] EXTERNAL_SYMBOL]);
10911 -- Processing for this pragma is shared with Psect_Object
10913 ------------------------
10914 -- Compile_Time_Error --
10915 ------------------------
10917 -- pragma Compile_Time_Error
10918 -- (boolean_EXPRESSION, static_string_EXPRESSION);
10920 when Pragma_Compile_Time_Error =>
10921 GNAT_Pragma;
10922 Process_Compile_Time_Warning_Or_Error;
10924 --------------------------
10925 -- Compile_Time_Warning --
10926 --------------------------
10928 -- pragma Compile_Time_Warning
10929 -- (boolean_EXPRESSION, static_string_EXPRESSION);
10931 when Pragma_Compile_Time_Warning =>
10932 GNAT_Pragma;
10933 Process_Compile_Time_Warning_Or_Error;
10935 -------------------
10936 -- Compiler_Unit --
10937 -------------------
10939 when Pragma_Compiler_Unit =>
10940 GNAT_Pragma;
10941 Check_Arg_Count (0);
10942 Set_Is_Compiler_Unit (Get_Source_Unit (N));
10944 -----------------------------
10945 -- Complete_Representation --
10946 -----------------------------
10948 -- pragma Complete_Representation;
10950 when Pragma_Complete_Representation =>
10951 GNAT_Pragma;
10952 Check_Arg_Count (0);
10954 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
10955 Error_Pragma
10956 ("pragma & must appear within record representation clause");
10957 end if;
10959 ----------------------------
10960 -- Complex_Representation --
10961 ----------------------------
10963 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
10965 when Pragma_Complex_Representation => Complex_Representation : declare
10966 E_Id : Entity_Id;
10967 E : Entity_Id;
10968 Ent : Entity_Id;
10970 begin
10971 GNAT_Pragma;
10972 Check_Arg_Count (1);
10973 Check_Optional_Identifier (Arg1, Name_Entity);
10974 Check_Arg_Is_Local_Name (Arg1);
10975 E_Id := Get_Pragma_Arg (Arg1);
10977 if Etype (E_Id) = Any_Type then
10978 return;
10979 end if;
10981 E := Entity (E_Id);
10983 if not Is_Record_Type (E) then
10984 Error_Pragma_Arg
10985 ("argument for pragma% must be record type", Arg1);
10986 end if;
10988 Ent := First_Entity (E);
10990 if No (Ent)
10991 or else No (Next_Entity (Ent))
10992 or else Present (Next_Entity (Next_Entity (Ent)))
10993 or else not Is_Floating_Point_Type (Etype (Ent))
10994 or else Etype (Ent) /= Etype (Next_Entity (Ent))
10995 then
10996 Error_Pragma_Arg
10997 ("record for pragma% must have two fields of the same "
10998 & "floating-point type", Arg1);
11000 else
11001 Set_Has_Complex_Representation (Base_Type (E));
11003 -- We need to treat the type has having a non-standard
11004 -- representation, for back-end purposes, even though in
11005 -- general a complex will have the default representation
11006 -- of a record with two real components.
11008 Set_Has_Non_Standard_Rep (Base_Type (E));
11009 end if;
11010 end Complex_Representation;
11012 -------------------------
11013 -- Component_Alignment --
11014 -------------------------
11016 -- pragma Component_Alignment (
11017 -- [Form =>] ALIGNMENT_CHOICE
11018 -- [, [Name =>] type_LOCAL_NAME]);
11020 -- ALIGNMENT_CHOICE ::=
11021 -- Component_Size
11022 -- | Component_Size_4
11023 -- | Storage_Unit
11024 -- | Default
11026 when Pragma_Component_Alignment => Component_AlignmentP : declare
11027 Args : Args_List (1 .. 2);
11028 Names : constant Name_List (1 .. 2) := (
11029 Name_Form,
11030 Name_Name);
11032 Form : Node_Id renames Args (1);
11033 Name : Node_Id renames Args (2);
11035 Atype : Component_Alignment_Kind;
11036 Typ : Entity_Id;
11038 begin
11039 GNAT_Pragma;
11040 Gather_Associations (Names, Args);
11042 if No (Form) then
11043 Error_Pragma ("missing Form argument for pragma%");
11044 end if;
11046 Check_Arg_Is_Identifier (Form);
11048 -- Get proper alignment, note that Default = Component_Size on all
11049 -- machines we have so far, and we want to set this value rather
11050 -- than the default value to indicate that it has been explicitly
11051 -- set (and thus will not get overridden by the default component
11052 -- alignment for the current scope)
11054 if Chars (Form) = Name_Component_Size then
11055 Atype := Calign_Component_Size;
11057 elsif Chars (Form) = Name_Component_Size_4 then
11058 Atype := Calign_Component_Size_4;
11060 elsif Chars (Form) = Name_Default then
11061 Atype := Calign_Component_Size;
11063 elsif Chars (Form) = Name_Storage_Unit then
11064 Atype := Calign_Storage_Unit;
11066 else
11067 Error_Pragma_Arg
11068 ("invalid Form parameter for pragma%", Form);
11069 end if;
11071 -- Case with no name, supplied, affects scope table entry
11073 if No (Name) then
11074 Scope_Stack.Table
11075 (Scope_Stack.Last).Component_Alignment_Default := Atype;
11077 -- Case of name supplied
11079 else
11080 Check_Arg_Is_Local_Name (Name);
11081 Find_Type (Name);
11082 Typ := Entity (Name);
11084 if Typ = Any_Type
11085 or else Rep_Item_Too_Early (Typ, N)
11086 then
11087 return;
11088 else
11089 Typ := Underlying_Type (Typ);
11090 end if;
11092 if not Is_Record_Type (Typ)
11093 and then not Is_Array_Type (Typ)
11094 then
11095 Error_Pragma_Arg
11096 ("Name parameter of pragma% must identify record or "
11097 & "array type", Name);
11098 end if;
11100 -- An explicit Component_Alignment pragma overrides an
11101 -- implicit pragma Pack, but not an explicit one.
11103 if not Has_Pragma_Pack (Base_Type (Typ)) then
11104 Set_Is_Packed (Base_Type (Typ), False);
11105 Set_Component_Alignment (Base_Type (Typ), Atype);
11106 end if;
11107 end if;
11108 end Component_AlignmentP;
11110 --------------------
11111 -- Contract_Cases --
11112 --------------------
11114 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
11116 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
11118 -- CASE_GUARD ::= boolean_EXPRESSION | others
11120 -- CONSEQUENCE ::= boolean_EXPRESSION
11122 when Pragma_Contract_Cases => Contract_Cases : declare
11123 Subp_Decl : Node_Id;
11125 begin
11126 GNAT_Pragma;
11127 Check_Arg_Count (1);
11129 -- The pragma is analyzed at the end of the declarative part which
11130 -- contains the related subprogram. Reset the analyzed flag.
11132 Set_Analyzed (N, False);
11134 -- Ensure the proper placement of the pragma. Contract_Cases must
11135 -- be associated with a subprogram declaration or a body that acts
11136 -- as a spec.
11138 Subp_Decl :=
11139 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
11141 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
11142 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
11143 or else not Acts_As_Spec (Subp_Decl))
11144 then
11145 Pragma_Misplaced;
11146 return;
11147 end if;
11149 -- When the pragma appears on a subprogram body, perform the full
11150 -- analysis now.
11152 if Nkind (Subp_Decl) = N_Subprogram_Body then
11153 Analyze_Contract_Cases_In_Decl_Part (N);
11155 -- When Contract_Cases applies to a subprogram compilation unit,
11156 -- the corresponding pragma is placed after the unit's declaration
11157 -- node and needs to be analyzed immediately.
11159 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
11160 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
11161 then
11162 Analyze_Contract_Cases_In_Decl_Part (N);
11163 end if;
11165 -- Chain the pragma on the contract for further processing
11167 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
11168 end Contract_Cases;
11170 ----------------
11171 -- Controlled --
11172 ----------------
11174 -- pragma Controlled (first_subtype_LOCAL_NAME);
11176 when Pragma_Controlled => Controlled : declare
11177 Arg : Node_Id;
11179 begin
11180 Check_No_Identifiers;
11181 Check_Arg_Count (1);
11182 Check_Arg_Is_Local_Name (Arg1);
11183 Arg := Get_Pragma_Arg (Arg1);
11185 if not Is_Entity_Name (Arg)
11186 or else not Is_Access_Type (Entity (Arg))
11187 then
11188 Error_Pragma_Arg ("pragma% requires access type", Arg1);
11189 else
11190 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
11191 end if;
11192 end Controlled;
11194 ----------------
11195 -- Convention --
11196 ----------------
11198 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
11199 -- [Entity =>] LOCAL_NAME);
11201 when Pragma_Convention => Convention : declare
11202 C : Convention_Id;
11203 E : Entity_Id;
11204 pragma Warnings (Off, C);
11205 pragma Warnings (Off, E);
11206 begin
11207 Check_Arg_Order ((Name_Convention, Name_Entity));
11208 Check_Ada_83_Warning;
11209 Check_Arg_Count (2);
11210 Process_Convention (C, E);
11211 end Convention;
11213 ---------------------------
11214 -- Convention_Identifier --
11215 ---------------------------
11217 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
11218 -- [Convention =>] convention_IDENTIFIER);
11220 when Pragma_Convention_Identifier => Convention_Identifier : declare
11221 Idnam : Name_Id;
11222 Cname : Name_Id;
11224 begin
11225 GNAT_Pragma;
11226 Check_Arg_Order ((Name_Name, Name_Convention));
11227 Check_Arg_Count (2);
11228 Check_Optional_Identifier (Arg1, Name_Name);
11229 Check_Optional_Identifier (Arg2, Name_Convention);
11230 Check_Arg_Is_Identifier (Arg1);
11231 Check_Arg_Is_Identifier (Arg2);
11232 Idnam := Chars (Get_Pragma_Arg (Arg1));
11233 Cname := Chars (Get_Pragma_Arg (Arg2));
11235 if Is_Convention_Name (Cname) then
11236 Record_Convention_Identifier
11237 (Idnam, Get_Convention_Id (Cname));
11238 else
11239 Error_Pragma_Arg
11240 ("second arg for % pragma must be convention", Arg2);
11241 end if;
11242 end Convention_Identifier;
11244 ---------------
11245 -- CPP_Class --
11246 ---------------
11248 -- pragma CPP_Class ([Entity =>] local_NAME)
11250 when Pragma_CPP_Class => CPP_Class : declare
11251 begin
11252 GNAT_Pragma;
11254 if Warn_On_Obsolescent_Feature then
11255 Error_Msg_N
11256 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
11257 & "effect; replace it by pragma import?j?", N);
11258 end if;
11260 Check_Arg_Count (1);
11262 Rewrite (N,
11263 Make_Pragma (Loc,
11264 Chars => Name_Import,
11265 Pragma_Argument_Associations => New_List (
11266 Make_Pragma_Argument_Association (Loc,
11267 Expression => Make_Identifier (Loc, Name_CPP)),
11268 New_Copy (First (Pragma_Argument_Associations (N))))));
11269 Analyze (N);
11270 end CPP_Class;
11272 ---------------------
11273 -- CPP_Constructor --
11274 ---------------------
11276 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
11277 -- [, [External_Name =>] static_string_EXPRESSION ]
11278 -- [, [Link_Name =>] static_string_EXPRESSION ]);
11280 when Pragma_CPP_Constructor => CPP_Constructor : declare
11281 Elmt : Elmt_Id;
11282 Id : Entity_Id;
11283 Def_Id : Entity_Id;
11284 Tag_Typ : Entity_Id;
11286 begin
11287 GNAT_Pragma;
11288 Check_At_Least_N_Arguments (1);
11289 Check_At_Most_N_Arguments (3);
11290 Check_Optional_Identifier (Arg1, Name_Entity);
11291 Check_Arg_Is_Local_Name (Arg1);
11293 Id := Get_Pragma_Arg (Arg1);
11294 Find_Program_Unit_Name (Id);
11296 -- If we did not find the name, we are done
11298 if Etype (Id) = Any_Type then
11299 return;
11300 end if;
11302 Def_Id := Entity (Id);
11304 -- Check if already defined as constructor
11306 if Is_Constructor (Def_Id) then
11307 Error_Msg_N
11308 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
11309 return;
11310 end if;
11312 if Ekind (Def_Id) = E_Function
11313 and then (Is_CPP_Class (Etype (Def_Id))
11314 or else (Is_Class_Wide_Type (Etype (Def_Id))
11315 and then
11316 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
11317 then
11318 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
11319 Error_Msg_N
11320 ("'C'P'P constructor must be defined in the scope of "
11321 & "its returned type", Arg1);
11322 end if;
11324 if Arg_Count >= 2 then
11325 Set_Imported (Def_Id);
11326 Set_Is_Public (Def_Id);
11327 Process_Interface_Name (Def_Id, Arg2, Arg3);
11328 end if;
11330 Set_Has_Completion (Def_Id);
11331 Set_Is_Constructor (Def_Id);
11332 Set_Convention (Def_Id, Convention_CPP);
11334 -- Imported C++ constructors are not dispatching primitives
11335 -- because in C++ they don't have a dispatch table slot.
11336 -- However, in Ada the constructor has the profile of a
11337 -- function that returns a tagged type and therefore it has
11338 -- been treated as a primitive operation during semantic
11339 -- analysis. We now remove it from the list of primitive
11340 -- operations of the type.
11342 if Is_Tagged_Type (Etype (Def_Id))
11343 and then not Is_Class_Wide_Type (Etype (Def_Id))
11344 and then Is_Dispatching_Operation (Def_Id)
11345 then
11346 Tag_Typ := Etype (Def_Id);
11348 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
11349 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
11350 Next_Elmt (Elmt);
11351 end loop;
11353 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
11354 Set_Is_Dispatching_Operation (Def_Id, False);
11355 end if;
11357 -- For backward compatibility, if the constructor returns a
11358 -- class wide type, and we internally change the return type to
11359 -- the corresponding root type.
11361 if Is_Class_Wide_Type (Etype (Def_Id)) then
11362 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
11363 end if;
11364 else
11365 Error_Pragma_Arg
11366 ("pragma% requires function returning a 'C'P'P_Class type",
11367 Arg1);
11368 end if;
11369 end CPP_Constructor;
11371 -----------------
11372 -- CPP_Virtual --
11373 -----------------
11375 when Pragma_CPP_Virtual => CPP_Virtual : declare
11376 begin
11377 GNAT_Pragma;
11379 if Warn_On_Obsolescent_Feature then
11380 Error_Msg_N
11381 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
11382 & "effect?j?", N);
11383 end if;
11384 end CPP_Virtual;
11386 ----------------
11387 -- CPP_Vtable --
11388 ----------------
11390 when Pragma_CPP_Vtable => CPP_Vtable : declare
11391 begin
11392 GNAT_Pragma;
11394 if Warn_On_Obsolescent_Feature then
11395 Error_Msg_N
11396 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
11397 & "effect?j?", N);
11398 end if;
11399 end CPP_Vtable;
11401 ---------
11402 -- CPU --
11403 ---------
11405 -- pragma CPU (EXPRESSION);
11407 when Pragma_CPU => CPU : declare
11408 P : constant Node_Id := Parent (N);
11409 Arg : Node_Id;
11410 Ent : Entity_Id;
11412 begin
11413 Ada_2012_Pragma;
11414 Check_No_Identifiers;
11415 Check_Arg_Count (1);
11417 -- Subprogram case
11419 if Nkind (P) = N_Subprogram_Body then
11420 Check_In_Main_Program;
11422 Arg := Get_Pragma_Arg (Arg1);
11423 Analyze_And_Resolve (Arg, Any_Integer);
11425 Ent := Defining_Unit_Name (Specification (P));
11427 if Nkind (Ent) = N_Defining_Program_Unit_Name then
11428 Ent := Defining_Identifier (Ent);
11429 end if;
11431 -- Must be static
11433 if not Is_Static_Expression (Arg) then
11434 Flag_Non_Static_Expr
11435 ("main subprogram affinity is not static!", Arg);
11436 raise Pragma_Exit;
11438 -- If constraint error, then we already signalled an error
11440 elsif Raises_Constraint_Error (Arg) then
11441 null;
11443 -- Otherwise check in range
11445 else
11446 declare
11447 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
11448 -- This is the entity System.Multiprocessors.CPU_Range;
11450 Val : constant Uint := Expr_Value (Arg);
11452 begin
11453 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
11454 or else
11455 Val > Expr_Value (Type_High_Bound (CPU_Id))
11456 then
11457 Error_Pragma_Arg
11458 ("main subprogram CPU is out of range", Arg1);
11459 end if;
11460 end;
11461 end if;
11463 Set_Main_CPU
11464 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
11466 -- Task case
11468 elsif Nkind (P) = N_Task_Definition then
11469 Arg := Get_Pragma_Arg (Arg1);
11470 Ent := Defining_Identifier (Parent (P));
11472 -- The expression must be analyzed in the special manner
11473 -- described in "Handling of Default and Per-Object
11474 -- Expressions" in sem.ads.
11476 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
11478 -- Anything else is incorrect
11480 else
11481 Pragma_Misplaced;
11482 end if;
11484 -- Check duplicate pragma before we chain the pragma in the Rep
11485 -- Item chain of Ent.
11487 Check_Duplicate_Pragma (Ent);
11488 Record_Rep_Item (Ent, N);
11489 end CPU;
11491 -----------
11492 -- Debug --
11493 -----------
11495 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
11497 when Pragma_Debug => Debug : declare
11498 Cond : Node_Id;
11499 Call : Node_Id;
11501 begin
11502 GNAT_Pragma;
11504 -- The condition for executing the call is that the expander
11505 -- is active and that we are not ignoring this debug pragma.
11507 Cond :=
11508 New_Occurrence_Of
11509 (Boolean_Literals
11510 (Expander_Active and then not Is_Ignored (N)),
11511 Loc);
11513 if not Is_Ignored (N) then
11514 Set_SCO_Pragma_Enabled (Loc);
11515 end if;
11517 if Arg_Count = 2 then
11518 Cond :=
11519 Make_And_Then (Loc,
11520 Left_Opnd => Relocate_Node (Cond),
11521 Right_Opnd => Get_Pragma_Arg (Arg1));
11522 Call := Get_Pragma_Arg (Arg2);
11523 else
11524 Call := Get_Pragma_Arg (Arg1);
11525 end if;
11527 if Nkind_In (Call,
11528 N_Indexed_Component,
11529 N_Function_Call,
11530 N_Identifier,
11531 N_Expanded_Name,
11532 N_Selected_Component)
11533 then
11534 -- If this pragma Debug comes from source, its argument was
11535 -- parsed as a name form (which is syntactically identical).
11536 -- In a generic context a parameterless call will be left as
11537 -- an expanded name (if global) or selected_component if local.
11538 -- Change it to a procedure call statement now.
11540 Change_Name_To_Procedure_Call_Statement (Call);
11542 elsif Nkind (Call) = N_Procedure_Call_Statement then
11544 -- Already in the form of a procedure call statement: nothing
11545 -- to do (could happen in case of an internally generated
11546 -- pragma Debug).
11548 null;
11550 else
11551 -- All other cases: diagnose error
11553 Error_Msg
11554 ("argument of pragma ""Debug"" is not procedure call",
11555 Sloc (Call));
11556 return;
11557 end if;
11559 -- Rewrite into a conditional with an appropriate condition. We
11560 -- wrap the procedure call in a block so that overhead from e.g.
11561 -- use of the secondary stack does not generate execution overhead
11562 -- for suppressed conditions.
11564 -- Normally the analysis that follows will freeze the subprogram
11565 -- being called. However, if the call is to a null procedure,
11566 -- we want to freeze it before creating the block, because the
11567 -- analysis that follows may be done with expansion disabled, in
11568 -- which case the body will not be generated, leading to spurious
11569 -- errors.
11571 if Nkind (Call) = N_Procedure_Call_Statement
11572 and then Is_Entity_Name (Name (Call))
11573 then
11574 Analyze (Name (Call));
11575 Freeze_Before (N, Entity (Name (Call)));
11576 end if;
11578 Rewrite (N, Make_Implicit_If_Statement (N,
11579 Condition => Cond,
11580 Then_Statements => New_List (
11581 Make_Block_Statement (Loc,
11582 Handled_Statement_Sequence =>
11583 Make_Handled_Sequence_Of_Statements (Loc,
11584 Statements => New_List (Relocate_Node (Call)))))));
11585 Analyze (N);
11586 end Debug;
11588 ------------------
11589 -- Debug_Policy --
11590 ------------------
11592 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
11594 when Pragma_Debug_Policy =>
11595 GNAT_Pragma;
11596 Check_Arg_Count (1);
11597 Check_No_Identifiers;
11598 Check_Arg_Is_Identifier (Arg1);
11600 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
11601 -- rewrite it that way, and let the rest of the checking come
11602 -- from analyzing the rewritten pragma.
11604 Rewrite (N,
11605 Make_Pragma (Loc,
11606 Chars => Name_Check_Policy,
11607 Pragma_Argument_Associations => New_List (
11608 Make_Pragma_Argument_Association (Loc,
11609 Expression => Make_Identifier (Loc, Name_Debug)),
11611 Make_Pragma_Argument_Association (Loc,
11612 Expression => Get_Pragma_Arg (Arg1)))));
11613 Analyze (N);
11615 -------------
11616 -- Depends --
11617 -------------
11619 -- pragma Depends (DEPENDENCY_RELATION);
11621 -- DEPENDENCY_RELATION ::=
11622 -- null
11623 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
11625 -- DEPENDENCY_CLAUSE ::=
11626 -- OUTPUT_LIST =>[+] INPUT_LIST
11627 -- | NULL_DEPENDENCY_CLAUSE
11629 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
11631 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
11633 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
11635 -- OUTPUT ::= NAME | FUNCTION_RESULT
11636 -- INPUT ::= NAME
11638 -- where FUNCTION_RESULT is a function Result attribute_reference
11640 when Pragma_Depends => Depends : declare
11641 Subp_Decl : Node_Id;
11643 begin
11644 GNAT_Pragma;
11645 S14_Pragma;
11646 Check_Arg_Count (1);
11648 -- Ensure the proper placement of the pragma. Depends must be
11649 -- associated with a subprogram declaration or a body that acts
11650 -- as a spec.
11652 Subp_Decl :=
11653 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
11655 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
11656 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
11657 or else not Acts_As_Spec (Subp_Decl))
11658 then
11659 Pragma_Misplaced;
11660 return;
11661 end if;
11663 -- When the pragma appears on a subprogram body, perform the full
11664 -- analysis now.
11666 if Nkind (Subp_Decl) = N_Subprogram_Body then
11667 Analyze_Depends_In_Decl_Part (N);
11669 -- When Depends applies to a subprogram compilation unit, the
11670 -- corresponding pragma is placed after the unit's declaration
11671 -- node and needs to be analyzed immediately.
11673 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
11674 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
11675 then
11676 Analyze_Depends_In_Decl_Part (N);
11677 end if;
11679 -- Chain the pragma on the contract for further processing
11681 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
11682 end Depends;
11684 ---------------------
11685 -- Detect_Blocking --
11686 ---------------------
11688 -- pragma Detect_Blocking;
11690 when Pragma_Detect_Blocking =>
11691 Ada_2005_Pragma;
11692 Check_Arg_Count (0);
11693 Check_Valid_Configuration_Pragma;
11694 Detect_Blocking := True;
11696 --------------------------
11697 -- Default_Storage_Pool --
11698 --------------------------
11700 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
11702 when Pragma_Default_Storage_Pool =>
11703 Ada_2012_Pragma;
11704 Check_Arg_Count (1);
11706 -- Default_Storage_Pool can appear as a configuration pragma, or
11707 -- in a declarative part or a package spec.
11709 if not Is_Configuration_Pragma then
11710 Check_Is_In_Decl_Part_Or_Package_Spec;
11711 end if;
11713 -- Case of Default_Storage_Pool (null);
11715 if Nkind (Expression (Arg1)) = N_Null then
11716 Analyze (Expression (Arg1));
11718 -- This is an odd case, this is not really an expression, so
11719 -- we don't have a type for it. So just set the type to Empty.
11721 Set_Etype (Expression (Arg1), Empty);
11723 -- Case of Default_Storage_Pool (storage_pool_NAME);
11725 else
11726 -- If it's a configuration pragma, then the only allowed
11727 -- argument is "null".
11729 if Is_Configuration_Pragma then
11730 Error_Pragma_Arg ("NULL expected", Arg1);
11731 end if;
11733 -- The expected type for a non-"null" argument is
11734 -- Root_Storage_Pool'Class.
11736 Analyze_And_Resolve
11737 (Get_Pragma_Arg (Arg1),
11738 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
11739 end if;
11741 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
11742 -- for an access type will use this information to set the
11743 -- appropriate attributes of the access type.
11745 Default_Pool := Expression (Arg1);
11747 ------------------------------------
11748 -- Disable_Atomic_Synchronization --
11749 ------------------------------------
11751 -- pragma Disable_Atomic_Synchronization [(Entity)];
11753 when Pragma_Disable_Atomic_Synchronization =>
11754 GNAT_Pragma;
11755 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
11757 -------------------
11758 -- Discard_Names --
11759 -------------------
11761 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
11763 when Pragma_Discard_Names => Discard_Names : declare
11764 E : Entity_Id;
11765 E_Id : Entity_Id;
11767 begin
11768 Check_Ada_83_Warning;
11770 -- Deal with configuration pragma case
11772 if Arg_Count = 0 and then Is_Configuration_Pragma then
11773 Global_Discard_Names := True;
11774 return;
11776 -- Otherwise, check correct appropriate context
11778 else
11779 Check_Is_In_Decl_Part_Or_Package_Spec;
11781 if Arg_Count = 0 then
11783 -- If there is no parameter, then from now on this pragma
11784 -- applies to any enumeration, exception or tagged type
11785 -- defined in the current declarative part, and recursively
11786 -- to any nested scope.
11788 Set_Discard_Names (Current_Scope);
11789 return;
11791 else
11792 Check_Arg_Count (1);
11793 Check_Optional_Identifier (Arg1, Name_On);
11794 Check_Arg_Is_Local_Name (Arg1);
11796 E_Id := Get_Pragma_Arg (Arg1);
11798 if Etype (E_Id) = Any_Type then
11799 return;
11800 else
11801 E := Entity (E_Id);
11802 end if;
11804 if (Is_First_Subtype (E)
11805 and then
11806 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
11807 or else Ekind (E) = E_Exception
11808 then
11809 Set_Discard_Names (E);
11810 Record_Rep_Item (E, N);
11812 else
11813 Error_Pragma_Arg
11814 ("inappropriate entity for pragma%", Arg1);
11815 end if;
11817 end if;
11818 end if;
11819 end Discard_Names;
11821 ------------------------
11822 -- Dispatching_Domain --
11823 ------------------------
11825 -- pragma Dispatching_Domain (EXPRESSION);
11827 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
11828 P : constant Node_Id := Parent (N);
11829 Arg : Node_Id;
11830 Ent : Entity_Id;
11832 begin
11833 Ada_2012_Pragma;
11834 Check_No_Identifiers;
11835 Check_Arg_Count (1);
11837 -- This pragma is born obsolete, but not the aspect
11839 if not From_Aspect_Specification (N) then
11840 Check_Restriction
11841 (No_Obsolescent_Features, Pragma_Identifier (N));
11842 end if;
11844 if Nkind (P) = N_Task_Definition then
11845 Arg := Get_Pragma_Arg (Arg1);
11846 Ent := Defining_Identifier (Parent (P));
11848 -- The expression must be analyzed in the special manner
11849 -- described in "Handling of Default and Per-Object
11850 -- Expressions" in sem.ads.
11852 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
11854 -- Check duplicate pragma before we chain the pragma in the Rep
11855 -- Item chain of Ent.
11857 Check_Duplicate_Pragma (Ent);
11858 Record_Rep_Item (Ent, N);
11860 -- Anything else is incorrect
11862 else
11863 Pragma_Misplaced;
11864 end if;
11865 end Dispatching_Domain;
11867 ---------------
11868 -- Elaborate --
11869 ---------------
11871 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
11873 when Pragma_Elaborate => Elaborate : declare
11874 Arg : Node_Id;
11875 Citem : Node_Id;
11877 begin
11878 -- Pragma must be in context items list of a compilation unit
11880 if not Is_In_Context_Clause then
11881 Pragma_Misplaced;
11882 end if;
11884 -- Must be at least one argument
11886 if Arg_Count = 0 then
11887 Error_Pragma ("pragma% requires at least one argument");
11888 end if;
11890 -- In Ada 83 mode, there can be no items following it in the
11891 -- context list except other pragmas and implicit with clauses
11892 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
11893 -- placement rule does not apply.
11895 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
11896 Citem := Next (N);
11897 while Present (Citem) loop
11898 if Nkind (Citem) = N_Pragma
11899 or else (Nkind (Citem) = N_With_Clause
11900 and then Implicit_With (Citem))
11901 then
11902 null;
11903 else
11904 Error_Pragma
11905 ("(Ada 83) pragma% must be at end of context clause");
11906 end if;
11908 Next (Citem);
11909 end loop;
11910 end if;
11912 -- Finally, the arguments must all be units mentioned in a with
11913 -- clause in the same context clause. Note we already checked (in
11914 -- Par.Prag) that the arguments are all identifiers or selected
11915 -- components.
11917 Arg := Arg1;
11918 Outer : while Present (Arg) loop
11919 Citem := First (List_Containing (N));
11920 Inner : while Citem /= N loop
11921 if Nkind (Citem) = N_With_Clause
11922 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
11923 then
11924 Set_Elaborate_Present (Citem, True);
11925 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
11926 Generate_Reference (Entity (Name (Citem)), Citem);
11928 -- With the pragma present, elaboration calls on
11929 -- subprograms from the named unit need no further
11930 -- checks, as long as the pragma appears in the current
11931 -- compilation unit. If the pragma appears in some unit
11932 -- in the context, there might still be a need for an
11933 -- Elaborate_All_Desirable from the current compilation
11934 -- to the named unit, so we keep the check enabled.
11936 if In_Extended_Main_Source_Unit (N) then
11937 Set_Suppress_Elaboration_Warnings
11938 (Entity (Name (Citem)));
11939 end if;
11941 exit Inner;
11942 end if;
11944 Next (Citem);
11945 end loop Inner;
11947 if Citem = N then
11948 Error_Pragma_Arg
11949 ("argument of pragma% is not withed unit", Arg);
11950 end if;
11952 Next (Arg);
11953 end loop Outer;
11955 -- Give a warning if operating in static mode with -gnatwl
11956 -- (elaboration warnings enabled) switch set.
11958 if Elab_Warnings and not Dynamic_Elaboration_Checks then
11959 Error_Msg_N
11960 ("?l?use of pragma Elaborate may not be safe", N);
11961 Error_Msg_N
11962 ("?l?use pragma Elaborate_All instead if possible", N);
11963 end if;
11964 end Elaborate;
11966 -------------------
11967 -- Elaborate_All --
11968 -------------------
11970 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
11972 when Pragma_Elaborate_All => Elaborate_All : declare
11973 Arg : Node_Id;
11974 Citem : Node_Id;
11976 begin
11977 Check_Ada_83_Warning;
11979 -- Pragma must be in context items list of a compilation unit
11981 if not Is_In_Context_Clause then
11982 Pragma_Misplaced;
11983 end if;
11985 -- Must be at least one argument
11987 if Arg_Count = 0 then
11988 Error_Pragma ("pragma% requires at least one argument");
11989 end if;
11991 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
11992 -- have to appear at the end of the context clause, but may
11993 -- appear mixed in with other items, even in Ada 83 mode.
11995 -- Final check: the arguments must all be units mentioned in
11996 -- a with clause in the same context clause. Note that we
11997 -- already checked (in Par.Prag) that all the arguments are
11998 -- either identifiers or selected components.
12000 Arg := Arg1;
12001 Outr : while Present (Arg) loop
12002 Citem := First (List_Containing (N));
12003 Innr : while Citem /= N loop
12004 if Nkind (Citem) = N_With_Clause
12005 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
12006 then
12007 Set_Elaborate_All_Present (Citem, True);
12008 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
12010 -- Suppress warnings and elaboration checks on the named
12011 -- unit if the pragma is in the current compilation, as
12012 -- for pragma Elaborate.
12014 if In_Extended_Main_Source_Unit (N) then
12015 Set_Suppress_Elaboration_Warnings
12016 (Entity (Name (Citem)));
12017 end if;
12018 exit Innr;
12019 end if;
12021 Next (Citem);
12022 end loop Innr;
12024 if Citem = N then
12025 Set_Error_Posted (N);
12026 Error_Pragma_Arg
12027 ("argument of pragma% is not withed unit", Arg);
12028 end if;
12030 Next (Arg);
12031 end loop Outr;
12032 end Elaborate_All;
12034 --------------------
12035 -- Elaborate_Body --
12036 --------------------
12038 -- pragma Elaborate_Body [( library_unit_NAME )];
12040 when Pragma_Elaborate_Body => Elaborate_Body : declare
12041 Cunit_Node : Node_Id;
12042 Cunit_Ent : Entity_Id;
12044 begin
12045 Check_Ada_83_Warning;
12046 Check_Valid_Library_Unit_Pragma;
12048 if Nkind (N) = N_Null_Statement then
12049 return;
12050 end if;
12052 Cunit_Node := Cunit (Current_Sem_Unit);
12053 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12055 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
12056 N_Subprogram_Body)
12057 then
12058 Error_Pragma ("pragma% must refer to a spec, not a body");
12059 else
12060 Set_Body_Required (Cunit_Node, True);
12061 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
12063 -- If we are in dynamic elaboration mode, then we suppress
12064 -- elaboration warnings for the unit, since it is definitely
12065 -- fine NOT to do dynamic checks at the first level (and such
12066 -- checks will be suppressed because no elaboration boolean
12067 -- is created for Elaborate_Body packages).
12069 -- But in the static model of elaboration, Elaborate_Body is
12070 -- definitely NOT good enough to ensure elaboration safety on
12071 -- its own, since the body may WITH other units that are not
12072 -- safe from an elaboration point of view, so a client must
12073 -- still do an Elaborate_All on such units.
12075 -- Debug flag -gnatdD restores the old behavior of 3.13, where
12076 -- Elaborate_Body always suppressed elab warnings.
12078 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
12079 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
12080 end if;
12081 end if;
12082 end Elaborate_Body;
12084 ------------------------
12085 -- Elaboration_Checks --
12086 ------------------------
12088 -- pragma Elaboration_Checks (Static | Dynamic);
12090 when Pragma_Elaboration_Checks =>
12091 GNAT_Pragma;
12092 Check_Arg_Count (1);
12093 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
12094 Dynamic_Elaboration_Checks :=
12095 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
12097 ---------------
12098 -- Eliminate --
12099 ---------------
12101 -- pragma Eliminate (
12102 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
12103 -- [,[Entity =>] IDENTIFIER |
12104 -- SELECTED_COMPONENT |
12105 -- STRING_LITERAL]
12106 -- [, OVERLOADING_RESOLUTION]);
12108 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
12109 -- SOURCE_LOCATION
12111 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
12112 -- FUNCTION_PROFILE
12114 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
12116 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
12117 -- Result_Type => result_SUBTYPE_NAME]
12119 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
12120 -- SUBTYPE_NAME ::= STRING_LITERAL
12122 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
12123 -- SOURCE_TRACE ::= STRING_LITERAL
12125 when Pragma_Eliminate => Eliminate : declare
12126 Args : Args_List (1 .. 5);
12127 Names : constant Name_List (1 .. 5) := (
12128 Name_Unit_Name,
12129 Name_Entity,
12130 Name_Parameter_Types,
12131 Name_Result_Type,
12132 Name_Source_Location);
12134 Unit_Name : Node_Id renames Args (1);
12135 Entity : Node_Id renames Args (2);
12136 Parameter_Types : Node_Id renames Args (3);
12137 Result_Type : Node_Id renames Args (4);
12138 Source_Location : Node_Id renames Args (5);
12140 begin
12141 GNAT_Pragma;
12142 Check_Valid_Configuration_Pragma;
12143 Gather_Associations (Names, Args);
12145 if No (Unit_Name) then
12146 Error_Pragma ("missing Unit_Name argument for pragma%");
12147 end if;
12149 if No (Entity)
12150 and then (Present (Parameter_Types)
12151 or else
12152 Present (Result_Type)
12153 or else
12154 Present (Source_Location))
12155 then
12156 Error_Pragma ("missing Entity argument for pragma%");
12157 end if;
12159 if (Present (Parameter_Types)
12160 or else
12161 Present (Result_Type))
12162 and then
12163 Present (Source_Location)
12164 then
12165 Error_Pragma
12166 ("parameter profile and source location cannot be used "
12167 & "together in pragma%");
12168 end if;
12170 Process_Eliminate_Pragma
12172 Unit_Name,
12173 Entity,
12174 Parameter_Types,
12175 Result_Type,
12176 Source_Location);
12177 end Eliminate;
12179 -----------------------------------
12180 -- Enable_Atomic_Synchronization --
12181 -----------------------------------
12183 -- pragma Enable_Atomic_Synchronization [(Entity)];
12185 when Pragma_Enable_Atomic_Synchronization =>
12186 GNAT_Pragma;
12187 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
12189 ------------
12190 -- Export --
12191 ------------
12193 -- pragma Export (
12194 -- [ Convention =>] convention_IDENTIFIER,
12195 -- [ Entity =>] local_NAME
12196 -- [, [External_Name =>] static_string_EXPRESSION ]
12197 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12199 when Pragma_Export => Export : declare
12200 C : Convention_Id;
12201 Def_Id : Entity_Id;
12203 pragma Warnings (Off, C);
12205 begin
12206 Check_Ada_83_Warning;
12207 Check_Arg_Order
12208 ((Name_Convention,
12209 Name_Entity,
12210 Name_External_Name,
12211 Name_Link_Name));
12213 Check_At_Least_N_Arguments (2);
12214 Check_At_Most_N_Arguments (4);
12215 Process_Convention (C, Def_Id);
12217 if Ekind (Def_Id) /= E_Constant then
12218 Note_Possible_Modification
12219 (Get_Pragma_Arg (Arg2), Sure => False);
12220 end if;
12222 Process_Interface_Name (Def_Id, Arg3, Arg4);
12223 Set_Exported (Def_Id, Arg2);
12225 -- If the entity is a deferred constant, propagate the information
12226 -- to the full view, because gigi elaborates the full view only.
12228 if Ekind (Def_Id) = E_Constant
12229 and then Present (Full_View (Def_Id))
12230 then
12231 declare
12232 Id2 : constant Entity_Id := Full_View (Def_Id);
12233 begin
12234 Set_Is_Exported (Id2, Is_Exported (Def_Id));
12235 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
12236 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
12237 end;
12238 end if;
12239 end Export;
12241 ----------------------
12242 -- Export_Exception --
12243 ----------------------
12245 -- pragma Export_Exception (
12246 -- [Internal =>] LOCAL_NAME
12247 -- [, [External =>] EXTERNAL_SYMBOL]
12248 -- [, [Form =>] Ada | VMS]
12249 -- [, [Code =>] static_integer_EXPRESSION]);
12251 when Pragma_Export_Exception => Export_Exception : declare
12252 Args : Args_List (1 .. 4);
12253 Names : constant Name_List (1 .. 4) := (
12254 Name_Internal,
12255 Name_External,
12256 Name_Form,
12257 Name_Code);
12259 Internal : Node_Id renames Args (1);
12260 External : Node_Id renames Args (2);
12261 Form : Node_Id renames Args (3);
12262 Code : Node_Id renames Args (4);
12264 begin
12265 GNAT_Pragma;
12267 if Inside_A_Generic then
12268 Error_Pragma ("pragma% cannot be used for generic entities");
12269 end if;
12271 Gather_Associations (Names, Args);
12272 Process_Extended_Import_Export_Exception_Pragma (
12273 Arg_Internal => Internal,
12274 Arg_External => External,
12275 Arg_Form => Form,
12276 Arg_Code => Code);
12278 if not Is_VMS_Exception (Entity (Internal)) then
12279 Set_Exported (Entity (Internal), Internal);
12280 end if;
12281 end Export_Exception;
12283 ---------------------
12284 -- Export_Function --
12285 ---------------------
12287 -- pragma Export_Function (
12288 -- [Internal =>] LOCAL_NAME
12289 -- [, [External =>] EXTERNAL_SYMBOL]
12290 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12291 -- [, [Result_Type =>] TYPE_DESIGNATOR]
12292 -- [, [Mechanism =>] MECHANISM]
12293 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
12295 -- EXTERNAL_SYMBOL ::=
12296 -- IDENTIFIER
12297 -- | static_string_EXPRESSION
12299 -- PARAMETER_TYPES ::=
12300 -- null
12301 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12303 -- TYPE_DESIGNATOR ::=
12304 -- subtype_NAME
12305 -- | subtype_Name ' Access
12307 -- MECHANISM ::=
12308 -- MECHANISM_NAME
12309 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12311 -- MECHANISM_ASSOCIATION ::=
12312 -- [formal_parameter_NAME =>] MECHANISM_NAME
12314 -- MECHANISM_NAME ::=
12315 -- Value
12316 -- | Reference
12317 -- | Descriptor [([Class =>] CLASS_NAME)]
12319 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12321 when Pragma_Export_Function => Export_Function : declare
12322 Args : Args_List (1 .. 6);
12323 Names : constant Name_List (1 .. 6) := (
12324 Name_Internal,
12325 Name_External,
12326 Name_Parameter_Types,
12327 Name_Result_Type,
12328 Name_Mechanism,
12329 Name_Result_Mechanism);
12331 Internal : Node_Id renames Args (1);
12332 External : Node_Id renames Args (2);
12333 Parameter_Types : Node_Id renames Args (3);
12334 Result_Type : Node_Id renames Args (4);
12335 Mechanism : Node_Id renames Args (5);
12336 Result_Mechanism : Node_Id renames Args (6);
12338 begin
12339 GNAT_Pragma;
12340 Gather_Associations (Names, Args);
12341 Process_Extended_Import_Export_Subprogram_Pragma (
12342 Arg_Internal => Internal,
12343 Arg_External => External,
12344 Arg_Parameter_Types => Parameter_Types,
12345 Arg_Result_Type => Result_Type,
12346 Arg_Mechanism => Mechanism,
12347 Arg_Result_Mechanism => Result_Mechanism);
12348 end Export_Function;
12350 -------------------
12351 -- Export_Object --
12352 -------------------
12354 -- pragma Export_Object (
12355 -- [Internal =>] LOCAL_NAME
12356 -- [, [External =>] EXTERNAL_SYMBOL]
12357 -- [, [Size =>] EXTERNAL_SYMBOL]);
12359 -- EXTERNAL_SYMBOL ::=
12360 -- IDENTIFIER
12361 -- | static_string_EXPRESSION
12363 -- PARAMETER_TYPES ::=
12364 -- null
12365 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12367 -- TYPE_DESIGNATOR ::=
12368 -- subtype_NAME
12369 -- | subtype_Name ' Access
12371 -- MECHANISM ::=
12372 -- MECHANISM_NAME
12373 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12375 -- MECHANISM_ASSOCIATION ::=
12376 -- [formal_parameter_NAME =>] MECHANISM_NAME
12378 -- MECHANISM_NAME ::=
12379 -- Value
12380 -- | Reference
12381 -- | Descriptor [([Class =>] CLASS_NAME)]
12383 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12385 when Pragma_Export_Object => Export_Object : declare
12386 Args : Args_List (1 .. 3);
12387 Names : constant Name_List (1 .. 3) := (
12388 Name_Internal,
12389 Name_External,
12390 Name_Size);
12392 Internal : Node_Id renames Args (1);
12393 External : Node_Id renames Args (2);
12394 Size : Node_Id renames Args (3);
12396 begin
12397 GNAT_Pragma;
12398 Gather_Associations (Names, Args);
12399 Process_Extended_Import_Export_Object_Pragma (
12400 Arg_Internal => Internal,
12401 Arg_External => External,
12402 Arg_Size => Size);
12403 end Export_Object;
12405 ----------------------
12406 -- Export_Procedure --
12407 ----------------------
12409 -- pragma Export_Procedure (
12410 -- [Internal =>] LOCAL_NAME
12411 -- [, [External =>] EXTERNAL_SYMBOL]
12412 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12413 -- [, [Mechanism =>] MECHANISM]);
12415 -- EXTERNAL_SYMBOL ::=
12416 -- IDENTIFIER
12417 -- | static_string_EXPRESSION
12419 -- PARAMETER_TYPES ::=
12420 -- null
12421 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12423 -- TYPE_DESIGNATOR ::=
12424 -- subtype_NAME
12425 -- | subtype_Name ' Access
12427 -- MECHANISM ::=
12428 -- MECHANISM_NAME
12429 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12431 -- MECHANISM_ASSOCIATION ::=
12432 -- [formal_parameter_NAME =>] MECHANISM_NAME
12434 -- MECHANISM_NAME ::=
12435 -- Value
12436 -- | Reference
12437 -- | Descriptor [([Class =>] CLASS_NAME)]
12439 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12441 when Pragma_Export_Procedure => Export_Procedure : declare
12442 Args : Args_List (1 .. 4);
12443 Names : constant Name_List (1 .. 4) := (
12444 Name_Internal,
12445 Name_External,
12446 Name_Parameter_Types,
12447 Name_Mechanism);
12449 Internal : Node_Id renames Args (1);
12450 External : Node_Id renames Args (2);
12451 Parameter_Types : Node_Id renames Args (3);
12452 Mechanism : Node_Id renames Args (4);
12454 begin
12455 GNAT_Pragma;
12456 Gather_Associations (Names, Args);
12457 Process_Extended_Import_Export_Subprogram_Pragma (
12458 Arg_Internal => Internal,
12459 Arg_External => External,
12460 Arg_Parameter_Types => Parameter_Types,
12461 Arg_Mechanism => Mechanism);
12462 end Export_Procedure;
12464 ------------------
12465 -- Export_Value --
12466 ------------------
12468 -- pragma Export_Value (
12469 -- [Value =>] static_integer_EXPRESSION,
12470 -- [Link_Name =>] static_string_EXPRESSION);
12472 when Pragma_Export_Value =>
12473 GNAT_Pragma;
12474 Check_Arg_Order ((Name_Value, Name_Link_Name));
12475 Check_Arg_Count (2);
12477 Check_Optional_Identifier (Arg1, Name_Value);
12478 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
12480 Check_Optional_Identifier (Arg2, Name_Link_Name);
12481 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
12483 -----------------------------
12484 -- Export_Valued_Procedure --
12485 -----------------------------
12487 -- pragma Export_Valued_Procedure (
12488 -- [Internal =>] LOCAL_NAME
12489 -- [, [External =>] EXTERNAL_SYMBOL,]
12490 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12491 -- [, [Mechanism =>] MECHANISM]);
12493 -- EXTERNAL_SYMBOL ::=
12494 -- IDENTIFIER
12495 -- | static_string_EXPRESSION
12497 -- PARAMETER_TYPES ::=
12498 -- null
12499 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12501 -- TYPE_DESIGNATOR ::=
12502 -- subtype_NAME
12503 -- | subtype_Name ' Access
12505 -- MECHANISM ::=
12506 -- MECHANISM_NAME
12507 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12509 -- MECHANISM_ASSOCIATION ::=
12510 -- [formal_parameter_NAME =>] MECHANISM_NAME
12512 -- MECHANISM_NAME ::=
12513 -- Value
12514 -- | Reference
12515 -- | Descriptor [([Class =>] CLASS_NAME)]
12517 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12519 when Pragma_Export_Valued_Procedure =>
12520 Export_Valued_Procedure : declare
12521 Args : Args_List (1 .. 4);
12522 Names : constant Name_List (1 .. 4) := (
12523 Name_Internal,
12524 Name_External,
12525 Name_Parameter_Types,
12526 Name_Mechanism);
12528 Internal : Node_Id renames Args (1);
12529 External : Node_Id renames Args (2);
12530 Parameter_Types : Node_Id renames Args (3);
12531 Mechanism : Node_Id renames Args (4);
12533 begin
12534 GNAT_Pragma;
12535 Gather_Associations (Names, Args);
12536 Process_Extended_Import_Export_Subprogram_Pragma (
12537 Arg_Internal => Internal,
12538 Arg_External => External,
12539 Arg_Parameter_Types => Parameter_Types,
12540 Arg_Mechanism => Mechanism);
12541 end Export_Valued_Procedure;
12543 -------------------
12544 -- Extend_System --
12545 -------------------
12547 -- pragma Extend_System ([Name =>] Identifier);
12549 when Pragma_Extend_System => Extend_System : declare
12550 begin
12551 GNAT_Pragma;
12552 Check_Valid_Configuration_Pragma;
12553 Check_Arg_Count (1);
12554 Check_Optional_Identifier (Arg1, Name_Name);
12555 Check_Arg_Is_Identifier (Arg1);
12557 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12559 if Name_Len > 4
12560 and then Name_Buffer (1 .. 4) = "aux_"
12561 then
12562 if Present (System_Extend_Pragma_Arg) then
12563 if Chars (Get_Pragma_Arg (Arg1)) =
12564 Chars (Expression (System_Extend_Pragma_Arg))
12565 then
12566 null;
12567 else
12568 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
12569 Error_Pragma ("pragma% conflicts with that #");
12570 end if;
12572 else
12573 System_Extend_Pragma_Arg := Arg1;
12575 if not GNAT_Mode then
12576 System_Extend_Unit := Arg1;
12577 end if;
12578 end if;
12579 else
12580 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
12581 end if;
12582 end Extend_System;
12584 ------------------------
12585 -- Extensions_Allowed --
12586 ------------------------
12588 -- pragma Extensions_Allowed (ON | OFF);
12590 when Pragma_Extensions_Allowed =>
12591 GNAT_Pragma;
12592 Check_Arg_Count (1);
12593 Check_No_Identifiers;
12594 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12596 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12597 Extensions_Allowed := True;
12598 Ada_Version := Ada_Version_Type'Last;
12600 else
12601 Extensions_Allowed := False;
12602 Ada_Version := Ada_Version_Explicit;
12603 Ada_Version_Pragma := Empty;
12604 end if;
12606 --------------
12607 -- External --
12608 --------------
12610 -- pragma External (
12611 -- [ Convention =>] convention_IDENTIFIER,
12612 -- [ Entity =>] local_NAME
12613 -- [, [External_Name =>] static_string_EXPRESSION ]
12614 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12616 when Pragma_External => External : declare
12617 Def_Id : Entity_Id;
12619 C : Convention_Id;
12620 pragma Warnings (Off, C);
12622 begin
12623 GNAT_Pragma;
12624 Check_Arg_Order
12625 ((Name_Convention,
12626 Name_Entity,
12627 Name_External_Name,
12628 Name_Link_Name));
12629 Check_At_Least_N_Arguments (2);
12630 Check_At_Most_N_Arguments (4);
12631 Process_Convention (C, Def_Id);
12632 Note_Possible_Modification
12633 (Get_Pragma_Arg (Arg2), Sure => False);
12634 Process_Interface_Name (Def_Id, Arg3, Arg4);
12635 Set_Exported (Def_Id, Arg2);
12636 end External;
12638 --------------------------
12639 -- External_Name_Casing --
12640 --------------------------
12642 -- pragma External_Name_Casing (
12643 -- UPPERCASE | LOWERCASE
12644 -- [, AS_IS | UPPERCASE | LOWERCASE]);
12646 when Pragma_External_Name_Casing => External_Name_Casing : declare
12647 begin
12648 GNAT_Pragma;
12649 Check_No_Identifiers;
12651 if Arg_Count = 2 then
12652 Check_Arg_Is_One_Of
12653 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
12655 case Chars (Get_Pragma_Arg (Arg2)) is
12656 when Name_As_Is =>
12657 Opt.External_Name_Exp_Casing := As_Is;
12659 when Name_Uppercase =>
12660 Opt.External_Name_Exp_Casing := Uppercase;
12662 when Name_Lowercase =>
12663 Opt.External_Name_Exp_Casing := Lowercase;
12665 when others =>
12666 null;
12667 end case;
12669 else
12670 Check_Arg_Count (1);
12671 end if;
12673 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
12675 case Chars (Get_Pragma_Arg (Arg1)) is
12676 when Name_Uppercase =>
12677 Opt.External_Name_Imp_Casing := Uppercase;
12679 when Name_Lowercase =>
12680 Opt.External_Name_Imp_Casing := Lowercase;
12682 when others =>
12683 null;
12684 end case;
12685 end External_Name_Casing;
12687 ---------------
12688 -- Fast_Math --
12689 ---------------
12691 -- pragma Fast_Math;
12693 when Pragma_Fast_Math =>
12694 GNAT_Pragma;
12695 Check_No_Identifiers;
12696 Check_Valid_Configuration_Pragma;
12697 Fast_Math := True;
12699 --------------------------
12700 -- Favor_Top_Level --
12701 --------------------------
12703 -- pragma Favor_Top_Level (type_NAME);
12705 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
12706 Named_Entity : Entity_Id;
12708 begin
12709 GNAT_Pragma;
12710 Check_No_Identifiers;
12711 Check_Arg_Count (1);
12712 Check_Arg_Is_Local_Name (Arg1);
12713 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
12715 -- If it's an access-to-subprogram type (in particular, not a
12716 -- subtype), set the flag on that type.
12718 if Is_Access_Subprogram_Type (Named_Entity) then
12719 Set_Can_Use_Internal_Rep (Named_Entity, False);
12721 -- Otherwise it's an error (name denotes the wrong sort of entity)
12723 else
12724 Error_Pragma_Arg
12725 ("access-to-subprogram type expected",
12726 Get_Pragma_Arg (Arg1));
12727 end if;
12728 end Favor_Top_Level;
12730 ---------------------------
12731 -- Finalize_Storage_Only --
12732 ---------------------------
12734 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
12736 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
12737 Assoc : constant Node_Id := Arg1;
12738 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
12739 Typ : Entity_Id;
12741 begin
12742 GNAT_Pragma;
12743 Check_No_Identifiers;
12744 Check_Arg_Count (1);
12745 Check_Arg_Is_Local_Name (Arg1);
12747 Find_Type (Type_Id);
12748 Typ := Entity (Type_Id);
12750 if Typ = Any_Type
12751 or else Rep_Item_Too_Early (Typ, N)
12752 then
12753 return;
12754 else
12755 Typ := Underlying_Type (Typ);
12756 end if;
12758 if not Is_Controlled (Typ) then
12759 Error_Pragma ("pragma% must specify controlled type");
12760 end if;
12762 Check_First_Subtype (Arg1);
12764 if Finalize_Storage_Only (Typ) then
12765 Error_Pragma ("duplicate pragma%, only one allowed");
12767 elsif not Rep_Item_Too_Late (Typ, N) then
12768 Set_Finalize_Storage_Only (Base_Type (Typ), True);
12769 end if;
12770 end Finalize_Storage;
12772 --------------------------
12773 -- Float_Representation --
12774 --------------------------
12776 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
12778 -- FLOAT_REP ::= VAX_Float | IEEE_Float
12780 when Pragma_Float_Representation => Float_Representation : declare
12781 Argx : Node_Id;
12782 Digs : Nat;
12783 Ent : Entity_Id;
12785 begin
12786 GNAT_Pragma;
12788 if Arg_Count = 1 then
12789 Check_Valid_Configuration_Pragma;
12790 else
12791 Check_Arg_Count (2);
12792 Check_Optional_Identifier (Arg2, Name_Entity);
12793 Check_Arg_Is_Local_Name (Arg2);
12794 end if;
12796 Check_No_Identifier (Arg1);
12797 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
12799 if not OpenVMS_On_Target then
12800 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12801 Error_Pragma
12802 ("??pragma% ignored (applies only to Open'V'M'S)");
12803 end if;
12805 return;
12806 end if;
12808 -- One argument case
12810 if Arg_Count = 1 then
12811 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12812 if Opt.Float_Format = 'I' then
12813 Error_Pragma ("'I'E'E'E format previously specified");
12814 end if;
12816 Opt.Float_Format := 'V';
12818 else
12819 if Opt.Float_Format = 'V' then
12820 Error_Pragma ("'V'A'X format previously specified");
12821 end if;
12823 Opt.Float_Format := 'I';
12824 end if;
12826 Set_Standard_Fpt_Formats;
12828 -- Two argument case
12830 else
12831 Argx := Get_Pragma_Arg (Arg2);
12833 if not Is_Entity_Name (Argx)
12834 or else not Is_Floating_Point_Type (Entity (Argx))
12835 then
12836 Error_Pragma_Arg
12837 ("second argument of% pragma must be floating-point type",
12838 Arg2);
12839 end if;
12841 Ent := Entity (Argx);
12842 Digs := UI_To_Int (Digits_Value (Ent));
12844 -- Two arguments, VAX_Float case
12846 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12847 case Digs is
12848 when 6 => Set_F_Float (Ent);
12849 when 9 => Set_D_Float (Ent);
12850 when 15 => Set_G_Float (Ent);
12852 when others =>
12853 Error_Pragma_Arg
12854 ("wrong digits value, must be 6,9 or 15", Arg2);
12855 end case;
12857 -- Two arguments, IEEE_Float case
12859 else
12860 case Digs is
12861 when 6 => Set_IEEE_Short (Ent);
12862 when 15 => Set_IEEE_Long (Ent);
12864 when others =>
12865 Error_Pragma_Arg
12866 ("wrong digits value, must be 6 or 15", Arg2);
12867 end case;
12868 end if;
12869 end if;
12870 end Float_Representation;
12872 ------------
12873 -- Global --
12874 ------------
12876 -- pragma Global (GLOBAL_SPECIFICATION);
12878 -- GLOBAL_SPECIFICATION ::=
12879 -- null
12880 -- | GLOBAL_LIST
12881 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
12883 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
12885 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
12886 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
12887 -- GLOBAL_ITEM ::= NAME
12889 when Pragma_Global => Global : declare
12890 Subp_Decl : Node_Id;
12892 begin
12893 GNAT_Pragma;
12894 S14_Pragma;
12895 Check_Arg_Count (1);
12897 -- Ensure the proper placement of the pragma. Global must be
12898 -- associated with a subprogram declaration or a body that acts
12899 -- as a spec.
12901 Subp_Decl :=
12902 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
12904 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
12905 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
12906 or else not Acts_As_Spec (Subp_Decl))
12907 then
12908 Pragma_Misplaced;
12909 return;
12910 end if;
12912 -- When the pragma appears on a subprogram body, perform the full
12913 -- analysis now.
12915 if Nkind (Subp_Decl) = N_Subprogram_Body then
12916 Analyze_Global_In_Decl_Part (N);
12918 -- When Global applies to a subprogram compilation unit, the
12919 -- corresponding pragma is placed after the unit's declaration
12920 -- node and needs to be analyzed immediately.
12922 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
12923 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
12924 then
12925 Analyze_Global_In_Decl_Part (N);
12926 end if;
12928 -- Chain the pragma on the contract for further processing
12930 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12931 end Global;
12933 -----------
12934 -- Ident --
12935 -----------
12937 -- pragma Ident (static_string_EXPRESSION)
12939 -- Note: pragma Comment shares this processing. Pragma Comment is
12940 -- identical to Ident, except that the restriction of the argument to
12941 -- 31 characters and the placement restrictions are not enforced for
12942 -- pragma Comment.
12944 when Pragma_Ident | Pragma_Comment => Ident : declare
12945 Str : Node_Id;
12947 begin
12948 GNAT_Pragma;
12949 Check_Arg_Count (1);
12950 Check_No_Identifiers;
12951 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
12952 Store_Note (N);
12954 -- For pragma Ident, preserve DEC compatibility by requiring the
12955 -- pragma to appear in a declarative part or package spec.
12957 if Prag_Id = Pragma_Ident then
12958 Check_Is_In_Decl_Part_Or_Package_Spec;
12959 end if;
12961 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
12963 declare
12964 CS : Node_Id;
12965 GP : Node_Id;
12967 begin
12968 GP := Parent (Parent (N));
12970 if Nkind_In (GP, N_Package_Declaration,
12971 N_Generic_Package_Declaration)
12972 then
12973 GP := Parent (GP);
12974 end if;
12976 -- If we have a compilation unit, then record the ident value,
12977 -- checking for improper duplication.
12979 if Nkind (GP) = N_Compilation_Unit then
12980 CS := Ident_String (Current_Sem_Unit);
12982 if Present (CS) then
12984 -- For Ident, we do not permit multiple instances
12986 if Prag_Id = Pragma_Ident then
12987 Error_Pragma ("duplicate% pragma not permitted");
12989 -- For Comment, we concatenate the string, unless we want
12990 -- to preserve the tree structure for ASIS.
12992 elsif not ASIS_Mode then
12993 Start_String (Strval (CS));
12994 Store_String_Char (' ');
12995 Store_String_Chars (Strval (Str));
12996 Set_Strval (CS, End_String);
12997 end if;
12999 else
13000 -- In VMS, the effect of IDENT is achieved by passing
13001 -- --identification=name as a --for-linker switch.
13003 if OpenVMS_On_Target then
13004 Start_String;
13005 Store_String_Chars
13006 ("--for-linker=--identification=");
13007 String_To_Name_Buffer (Strval (Str));
13008 Store_String_Chars (Name_Buffer (1 .. Name_Len));
13010 -- Only the last processed IDENT is saved. The main
13011 -- purpose is so an IDENT associated with a main
13012 -- procedure will be used in preference to an IDENT
13013 -- associated with a with'd package.
13015 Replace_Linker_Option_String
13016 (End_String, "--for-linker=--identification=");
13017 end if;
13019 Set_Ident_String (Current_Sem_Unit, Str);
13020 end if;
13022 -- For subunits, we just ignore the Ident, since in GNAT these
13023 -- are not separate object files, and hence not separate units
13024 -- in the unit table.
13026 elsif Nkind (GP) = N_Subunit then
13027 null;
13029 -- Otherwise we have a misplaced pragma Ident, but we ignore
13030 -- this if we are in an instantiation, since it comes from
13031 -- a generic, and has no relevance to the instantiation.
13033 elsif Prag_Id = Pragma_Ident then
13034 if Instantiation_Location (Loc) = No_Location then
13035 Error_Pragma ("pragma% only allowed at outer level");
13036 end if;
13037 end if;
13038 end;
13039 end Ident;
13041 ----------------------------
13042 -- Implementation_Defined --
13043 ----------------------------
13045 -- pragma Implementation_Defined (local_NAME);
13047 -- Marks previously declared entity as implementation defined. For
13048 -- an overloaded entity, applies to the most recent homonym.
13050 -- pragma Implementation_Defined;
13052 -- The form with no arguments appears anywhere within a scope, most
13053 -- typically a package spec, and indicates that all entities that are
13054 -- defined within the package spec are Implementation_Defined.
13056 when Pragma_Implementation_Defined => Implementation_Defined : declare
13057 Ent : Entity_Id;
13059 begin
13060 GNAT_Pragma;
13061 Check_No_Identifiers;
13063 -- Form with no arguments
13065 if Arg_Count = 0 then
13066 Set_Is_Implementation_Defined (Current_Scope);
13068 -- Form with one argument
13070 else
13071 Check_Arg_Count (1);
13072 Check_Arg_Is_Local_Name (Arg1);
13073 Ent := Entity (Get_Pragma_Arg (Arg1));
13074 Set_Is_Implementation_Defined (Ent);
13075 end if;
13076 end Implementation_Defined;
13078 -----------------
13079 -- Implemented --
13080 -----------------
13082 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
13084 -- IMPLEMENTATION_KIND ::=
13085 -- By_Entry | By_Protected_Procedure | By_Any | Optional
13087 -- "By_Any" and "Optional" are treated as synonyms in order to
13088 -- support Ada 2012 aspect Synchronization.
13090 when Pragma_Implemented => Implemented : declare
13091 Proc_Id : Entity_Id;
13092 Typ : Entity_Id;
13094 begin
13095 Ada_2012_Pragma;
13096 Check_Arg_Count (2);
13097 Check_No_Identifiers;
13098 Check_Arg_Is_Identifier (Arg1);
13099 Check_Arg_Is_Local_Name (Arg1);
13100 Check_Arg_Is_One_Of (Arg2,
13101 Name_By_Any,
13102 Name_By_Entry,
13103 Name_By_Protected_Procedure,
13104 Name_Optional);
13106 -- Extract the name of the local procedure
13108 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
13110 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
13111 -- primitive procedure of a synchronized tagged type.
13113 if Ekind (Proc_Id) = E_Procedure
13114 and then Is_Primitive (Proc_Id)
13115 and then Present (First_Formal (Proc_Id))
13116 then
13117 Typ := Etype (First_Formal (Proc_Id));
13119 if Is_Tagged_Type (Typ)
13120 and then
13122 -- Check for a protected, a synchronized or a task interface
13124 ((Is_Interface (Typ)
13125 and then Is_Synchronized_Interface (Typ))
13127 -- Check for a protected type or a task type that implements
13128 -- an interface.
13130 or else
13131 (Is_Concurrent_Record_Type (Typ)
13132 and then Present (Interfaces (Typ)))
13134 -- Check for a private record extension with keyword
13135 -- "synchronized".
13137 or else
13138 (Ekind_In (Typ, E_Record_Type_With_Private,
13139 E_Record_Subtype_With_Private)
13140 and then Synchronized_Present (Parent (Typ))))
13141 then
13142 null;
13143 else
13144 Error_Pragma_Arg
13145 ("controlling formal must be of synchronized tagged type",
13146 Arg1);
13147 return;
13148 end if;
13150 -- Procedures declared inside a protected type must be accepted
13152 elsif Ekind (Proc_Id) = E_Procedure
13153 and then Is_Protected_Type (Scope (Proc_Id))
13154 then
13155 null;
13157 -- The first argument is not a primitive procedure
13159 else
13160 Error_Pragma_Arg
13161 ("pragma % must be applied to a primitive procedure", Arg1);
13162 return;
13163 end if;
13165 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
13166 -- By_Protected_Procedure to the primitive procedure of a task
13167 -- interface.
13169 if Chars (Arg2) = Name_By_Protected_Procedure
13170 and then Is_Interface (Typ)
13171 and then Is_Task_Interface (Typ)
13172 then
13173 Error_Pragma_Arg
13174 ("implementation kind By_Protected_Procedure cannot be "
13175 & "applied to a task interface primitive", Arg2);
13176 return;
13177 end if;
13179 Record_Rep_Item (Proc_Id, N);
13180 end Implemented;
13182 ----------------------
13183 -- Implicit_Packing --
13184 ----------------------
13186 -- pragma Implicit_Packing;
13188 when Pragma_Implicit_Packing =>
13189 GNAT_Pragma;
13190 Check_Arg_Count (0);
13191 Implicit_Packing := True;
13193 ------------
13194 -- Import --
13195 ------------
13197 -- pragma Import (
13198 -- [Convention =>] convention_IDENTIFIER,
13199 -- [Entity =>] local_NAME
13200 -- [, [External_Name =>] static_string_EXPRESSION ]
13201 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13203 when Pragma_Import =>
13204 Check_Ada_83_Warning;
13205 Check_Arg_Order
13206 ((Name_Convention,
13207 Name_Entity,
13208 Name_External_Name,
13209 Name_Link_Name));
13211 Check_At_Least_N_Arguments (2);
13212 Check_At_Most_N_Arguments (4);
13213 Process_Import_Or_Interface;
13215 ----------------------
13216 -- Import_Exception --
13217 ----------------------
13219 -- pragma Import_Exception (
13220 -- [Internal =>] LOCAL_NAME
13221 -- [, [External =>] EXTERNAL_SYMBOL]
13222 -- [, [Form =>] Ada | VMS]
13223 -- [, [Code =>] static_integer_EXPRESSION]);
13225 when Pragma_Import_Exception => Import_Exception : declare
13226 Args : Args_List (1 .. 4);
13227 Names : constant Name_List (1 .. 4) := (
13228 Name_Internal,
13229 Name_External,
13230 Name_Form,
13231 Name_Code);
13233 Internal : Node_Id renames Args (1);
13234 External : Node_Id renames Args (2);
13235 Form : Node_Id renames Args (3);
13236 Code : Node_Id renames Args (4);
13238 begin
13239 GNAT_Pragma;
13240 Gather_Associations (Names, Args);
13242 if Present (External) and then Present (Code) then
13243 Error_Pragma
13244 ("cannot give both External and Code options for pragma%");
13245 end if;
13247 Process_Extended_Import_Export_Exception_Pragma (
13248 Arg_Internal => Internal,
13249 Arg_External => External,
13250 Arg_Form => Form,
13251 Arg_Code => Code);
13253 if not Is_VMS_Exception (Entity (Internal)) then
13254 Set_Imported (Entity (Internal));
13255 end if;
13256 end Import_Exception;
13258 ---------------------
13259 -- Import_Function --
13260 ---------------------
13262 -- pragma Import_Function (
13263 -- [Internal =>] LOCAL_NAME,
13264 -- [, [External =>] EXTERNAL_SYMBOL]
13265 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13266 -- [, [Result_Type =>] SUBTYPE_MARK]
13267 -- [, [Mechanism =>] MECHANISM]
13268 -- [, [Result_Mechanism =>] MECHANISM_NAME]
13269 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13271 -- EXTERNAL_SYMBOL ::=
13272 -- IDENTIFIER
13273 -- | static_string_EXPRESSION
13275 -- PARAMETER_TYPES ::=
13276 -- null
13277 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13279 -- TYPE_DESIGNATOR ::=
13280 -- subtype_NAME
13281 -- | subtype_Name ' Access
13283 -- MECHANISM ::=
13284 -- MECHANISM_NAME
13285 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13287 -- MECHANISM_ASSOCIATION ::=
13288 -- [formal_parameter_NAME =>] MECHANISM_NAME
13290 -- MECHANISM_NAME ::=
13291 -- Value
13292 -- | Reference
13293 -- | Descriptor [([Class =>] CLASS_NAME)]
13295 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13297 when Pragma_Import_Function => Import_Function : declare
13298 Args : Args_List (1 .. 7);
13299 Names : constant Name_List (1 .. 7) := (
13300 Name_Internal,
13301 Name_External,
13302 Name_Parameter_Types,
13303 Name_Result_Type,
13304 Name_Mechanism,
13305 Name_Result_Mechanism,
13306 Name_First_Optional_Parameter);
13308 Internal : Node_Id renames Args (1);
13309 External : Node_Id renames Args (2);
13310 Parameter_Types : Node_Id renames Args (3);
13311 Result_Type : Node_Id renames Args (4);
13312 Mechanism : Node_Id renames Args (5);
13313 Result_Mechanism : Node_Id renames Args (6);
13314 First_Optional_Parameter : Node_Id renames Args (7);
13316 begin
13317 GNAT_Pragma;
13318 Gather_Associations (Names, Args);
13319 Process_Extended_Import_Export_Subprogram_Pragma (
13320 Arg_Internal => Internal,
13321 Arg_External => External,
13322 Arg_Parameter_Types => Parameter_Types,
13323 Arg_Result_Type => Result_Type,
13324 Arg_Mechanism => Mechanism,
13325 Arg_Result_Mechanism => Result_Mechanism,
13326 Arg_First_Optional_Parameter => First_Optional_Parameter);
13327 end Import_Function;
13329 -------------------
13330 -- Import_Object --
13331 -------------------
13333 -- pragma Import_Object (
13334 -- [Internal =>] LOCAL_NAME
13335 -- [, [External =>] EXTERNAL_SYMBOL]
13336 -- [, [Size =>] EXTERNAL_SYMBOL]);
13338 -- EXTERNAL_SYMBOL ::=
13339 -- IDENTIFIER
13340 -- | static_string_EXPRESSION
13342 when Pragma_Import_Object => Import_Object : declare
13343 Args : Args_List (1 .. 3);
13344 Names : constant Name_List (1 .. 3) := (
13345 Name_Internal,
13346 Name_External,
13347 Name_Size);
13349 Internal : Node_Id renames Args (1);
13350 External : Node_Id renames Args (2);
13351 Size : Node_Id renames Args (3);
13353 begin
13354 GNAT_Pragma;
13355 Gather_Associations (Names, Args);
13356 Process_Extended_Import_Export_Object_Pragma (
13357 Arg_Internal => Internal,
13358 Arg_External => External,
13359 Arg_Size => Size);
13360 end Import_Object;
13362 ----------------------
13363 -- Import_Procedure --
13364 ----------------------
13366 -- pragma Import_Procedure (
13367 -- [Internal =>] LOCAL_NAME
13368 -- [, [External =>] EXTERNAL_SYMBOL]
13369 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13370 -- [, [Mechanism =>] MECHANISM]
13371 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13373 -- EXTERNAL_SYMBOL ::=
13374 -- IDENTIFIER
13375 -- | static_string_EXPRESSION
13377 -- PARAMETER_TYPES ::=
13378 -- null
13379 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13381 -- TYPE_DESIGNATOR ::=
13382 -- subtype_NAME
13383 -- | subtype_Name ' Access
13385 -- MECHANISM ::=
13386 -- MECHANISM_NAME
13387 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13389 -- MECHANISM_ASSOCIATION ::=
13390 -- [formal_parameter_NAME =>] MECHANISM_NAME
13392 -- MECHANISM_NAME ::=
13393 -- Value
13394 -- | Reference
13395 -- | Descriptor [([Class =>] CLASS_NAME)]
13397 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13399 when Pragma_Import_Procedure => Import_Procedure : declare
13400 Args : Args_List (1 .. 5);
13401 Names : constant Name_List (1 .. 5) := (
13402 Name_Internal,
13403 Name_External,
13404 Name_Parameter_Types,
13405 Name_Mechanism,
13406 Name_First_Optional_Parameter);
13408 Internal : Node_Id renames Args (1);
13409 External : Node_Id renames Args (2);
13410 Parameter_Types : Node_Id renames Args (3);
13411 Mechanism : Node_Id renames Args (4);
13412 First_Optional_Parameter : Node_Id renames Args (5);
13414 begin
13415 GNAT_Pragma;
13416 Gather_Associations (Names, Args);
13417 Process_Extended_Import_Export_Subprogram_Pragma (
13418 Arg_Internal => Internal,
13419 Arg_External => External,
13420 Arg_Parameter_Types => Parameter_Types,
13421 Arg_Mechanism => Mechanism,
13422 Arg_First_Optional_Parameter => First_Optional_Parameter);
13423 end Import_Procedure;
13425 -----------------------------
13426 -- Import_Valued_Procedure --
13427 -----------------------------
13429 -- pragma Import_Valued_Procedure (
13430 -- [Internal =>] LOCAL_NAME
13431 -- [, [External =>] EXTERNAL_SYMBOL]
13432 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13433 -- [, [Mechanism =>] MECHANISM]
13434 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13436 -- EXTERNAL_SYMBOL ::=
13437 -- IDENTIFIER
13438 -- | static_string_EXPRESSION
13440 -- PARAMETER_TYPES ::=
13441 -- null
13442 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13444 -- TYPE_DESIGNATOR ::=
13445 -- subtype_NAME
13446 -- | subtype_Name ' Access
13448 -- MECHANISM ::=
13449 -- MECHANISM_NAME
13450 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13452 -- MECHANISM_ASSOCIATION ::=
13453 -- [formal_parameter_NAME =>] MECHANISM_NAME
13455 -- MECHANISM_NAME ::=
13456 -- Value
13457 -- | Reference
13458 -- | Descriptor [([Class =>] CLASS_NAME)]
13460 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13462 when Pragma_Import_Valued_Procedure =>
13463 Import_Valued_Procedure : declare
13464 Args : Args_List (1 .. 5);
13465 Names : constant Name_List (1 .. 5) := (
13466 Name_Internal,
13467 Name_External,
13468 Name_Parameter_Types,
13469 Name_Mechanism,
13470 Name_First_Optional_Parameter);
13472 Internal : Node_Id renames Args (1);
13473 External : Node_Id renames Args (2);
13474 Parameter_Types : Node_Id renames Args (3);
13475 Mechanism : Node_Id renames Args (4);
13476 First_Optional_Parameter : Node_Id renames Args (5);
13478 begin
13479 GNAT_Pragma;
13480 Gather_Associations (Names, Args);
13481 Process_Extended_Import_Export_Subprogram_Pragma (
13482 Arg_Internal => Internal,
13483 Arg_External => External,
13484 Arg_Parameter_Types => Parameter_Types,
13485 Arg_Mechanism => Mechanism,
13486 Arg_First_Optional_Parameter => First_Optional_Parameter);
13487 end Import_Valued_Procedure;
13489 -----------------
13490 -- Independent --
13491 -----------------
13493 -- pragma Independent (LOCAL_NAME);
13495 when Pragma_Independent => Independent : declare
13496 E_Id : Node_Id;
13497 E : Entity_Id;
13498 D : Node_Id;
13499 K : Node_Kind;
13501 begin
13502 Check_Ada_83_Warning;
13503 Ada_2012_Pragma;
13504 Check_No_Identifiers;
13505 Check_Arg_Count (1);
13506 Check_Arg_Is_Local_Name (Arg1);
13507 E_Id := Get_Pragma_Arg (Arg1);
13509 if Etype (E_Id) = Any_Type then
13510 return;
13511 end if;
13513 E := Entity (E_Id);
13514 D := Declaration_Node (E);
13515 K := Nkind (D);
13517 -- Check duplicate before we chain ourselves!
13519 Check_Duplicate_Pragma (E);
13521 -- Check appropriate entity
13523 if Is_Type (E) then
13524 if Rep_Item_Too_Early (E, N)
13525 or else
13526 Rep_Item_Too_Late (E, N)
13527 then
13528 return;
13529 else
13530 Check_First_Subtype (Arg1);
13531 end if;
13533 elsif K = N_Object_Declaration
13534 or else (K = N_Component_Declaration
13535 and then Original_Record_Component (E) = E)
13536 then
13537 if Rep_Item_Too_Late (E, N) then
13538 return;
13539 end if;
13541 else
13542 Error_Pragma_Arg
13543 ("inappropriate entity for pragma%", Arg1);
13544 end if;
13546 Independence_Checks.Append ((N, E));
13547 end Independent;
13549 ----------------------------
13550 -- Independent_Components --
13551 ----------------------------
13553 -- pragma Atomic_Components (array_LOCAL_NAME);
13555 -- This processing is shared by Volatile_Components
13557 when Pragma_Independent_Components => Independent_Components : declare
13558 E_Id : Node_Id;
13559 E : Entity_Id;
13560 D : Node_Id;
13561 K : Node_Kind;
13563 begin
13564 Check_Ada_83_Warning;
13565 Ada_2012_Pragma;
13566 Check_No_Identifiers;
13567 Check_Arg_Count (1);
13568 Check_Arg_Is_Local_Name (Arg1);
13569 E_Id := Get_Pragma_Arg (Arg1);
13571 if Etype (E_Id) = Any_Type then
13572 return;
13573 end if;
13575 E := Entity (E_Id);
13577 -- Check duplicate before we chain ourselves!
13579 Check_Duplicate_Pragma (E);
13581 -- Check appropriate entity
13583 if Rep_Item_Too_Early (E, N)
13584 or else
13585 Rep_Item_Too_Late (E, N)
13586 then
13587 return;
13588 end if;
13590 D := Declaration_Node (E);
13591 K := Nkind (D);
13593 if K = N_Full_Type_Declaration
13594 and then (Is_Array_Type (E) or else Is_Record_Type (E))
13595 then
13596 Independence_Checks.Append ((N, E));
13597 Set_Has_Independent_Components (Base_Type (E));
13599 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
13600 and then Nkind (D) = N_Object_Declaration
13601 and then Nkind (Object_Definition (D)) =
13602 N_Constrained_Array_Definition
13603 then
13604 Independence_Checks.Append ((N, E));
13605 Set_Has_Independent_Components (E);
13607 else
13608 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13609 end if;
13610 end Independent_Components;
13612 -----------------------
13613 -- Initial_Condition --
13614 -----------------------
13616 -- pragma Initial_Condition (boolean_EXPRESSION);
13618 when Pragma_Initial_Condition => Initial_Condition : declare
13619 Context : constant Node_Id := Parent (Parent (N));
13620 Pack_Id : Entity_Id;
13621 Stmt : Node_Id;
13623 begin
13624 GNAT_Pragma;
13625 S14_Pragma;
13626 Check_Arg_Count (1);
13628 -- Ensure the proper placement of the pragma. Initial_Condition
13629 -- must be associated with a package declaration.
13631 if not Nkind_In (Context, N_Generic_Package_Declaration,
13632 N_Package_Declaration)
13633 then
13634 Pragma_Misplaced;
13635 return;
13636 end if;
13638 Stmt := Prev (N);
13639 while Present (Stmt) loop
13641 -- Skip prior pragmas, but check for duplicates
13643 if Nkind (Stmt) = N_Pragma then
13644 if Pragma_Name (Stmt) = Pname then
13645 Error_Msg_Name_1 := Pname;
13646 Error_Msg_Sloc := Sloc (Stmt);
13647 Error_Msg_N ("pragma % duplicates pragma declared #", N);
13648 end if;
13650 -- Skip internally generated code
13652 elsif not Comes_From_Source (Stmt) then
13653 null;
13655 -- The pragma does not apply to a legal construct, issue an
13656 -- error and stop the analysis.
13658 else
13659 Pragma_Misplaced;
13660 return;
13661 end if;
13663 Stmt := Prev (Stmt);
13664 end loop;
13666 -- The pragma must be analyzed at the end of the visible
13667 -- declarations of the related package. Save the pragma for later
13668 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
13669 -- the contract of the package.
13671 Pack_Id := Defining_Entity (Context);
13672 Add_Contract_Item (N, Pack_Id);
13674 -- Verify the declaration order of pragma Initial_Condition with
13675 -- respect to pragmas Abstract_State and Initializes.
13677 Check_Declaration_Order
13678 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
13679 Second => N);
13681 Check_Declaration_Order
13682 (First => Get_Pragma (Pack_Id, Pragma_Initializes),
13683 Second => N);
13684 end Initial_Condition;
13686 ------------------------
13687 -- Initialize_Scalars --
13688 ------------------------
13690 -- pragma Initialize_Scalars;
13692 when Pragma_Initialize_Scalars =>
13693 GNAT_Pragma;
13694 Check_Arg_Count (0);
13695 Check_Valid_Configuration_Pragma;
13696 Check_Restriction (No_Initialize_Scalars, N);
13698 -- Initialize_Scalars creates false positives in CodePeer, and
13699 -- incorrect negative results in SPARK mode, so ignore this pragma
13700 -- in these modes.
13702 if not Restriction_Active (No_Initialize_Scalars)
13703 and then not (CodePeer_Mode or SPARK_Mode)
13704 then
13705 Init_Or_Norm_Scalars := True;
13706 Initialize_Scalars := True;
13707 end if;
13709 -----------------
13710 -- Initializes --
13711 -----------------
13713 -- pragma Initializes (INITIALIZATION_SPEC);
13715 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
13717 -- INITIALIZATION_LIST ::=
13718 -- INITIALIZATION_ITEM
13719 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
13721 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
13723 -- INPUT_LIST ::=
13724 -- null
13725 -- | INPUT
13726 -- | (INPUT {, INPUT})
13728 -- INPUT ::= name
13730 when Pragma_Initializes => Initializes : declare
13731 Context : constant Node_Id := Parent (Parent (N));
13732 Pack_Id : Entity_Id;
13733 Stmt : Node_Id;
13735 begin
13736 GNAT_Pragma;
13737 S14_Pragma;
13738 Check_Arg_Count (1);
13740 -- Ensure the proper placement of the pragma. Initializes must be
13741 -- associated with a package declaration.
13743 if not Nkind_In (Context, N_Generic_Package_Declaration,
13744 N_Package_Declaration)
13745 then
13746 Pragma_Misplaced;
13747 return;
13748 end if;
13750 Stmt := Prev (N);
13751 while Present (Stmt) loop
13753 -- Skip prior pragmas, but check for duplicates
13755 if Nkind (Stmt) = N_Pragma then
13756 if Pragma_Name (Stmt) = Pname then
13757 Error_Msg_Name_1 := Pname;
13758 Error_Msg_Sloc := Sloc (Stmt);
13759 Error_Msg_N ("pragma % duplicates pragma declared #", N);
13760 end if;
13762 -- Skip internally generated code
13764 elsif not Comes_From_Source (Stmt) then
13765 null;
13767 -- The pragma does not apply to a legal construct, issue an
13768 -- error and stop the analysis.
13770 else
13771 Pragma_Misplaced;
13772 return;
13773 end if;
13775 Stmt := Prev (Stmt);
13776 end loop;
13778 -- The pragma must be analyzed at the end of the visible
13779 -- declarations of the related package. Save the pragma for later
13780 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
13781 -- contract of the package.
13783 Pack_Id := Defining_Entity (Context);
13784 Add_Contract_Item (N, Pack_Id);
13786 -- Verify the declaration order of pragmas Abstract_State and
13787 -- Initializes.
13789 Check_Declaration_Order
13790 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
13791 Second => N);
13792 end Initializes;
13794 ------------
13795 -- Inline --
13796 ------------
13798 -- pragma Inline ( NAME {, NAME} );
13800 when Pragma_Inline =>
13802 -- Inline status is Enabled if inlining option is active
13804 if Inline_Active then
13805 Process_Inline (Enabled);
13806 else
13807 Process_Inline (Disabled);
13808 end if;
13810 -------------------
13811 -- Inline_Always --
13812 -------------------
13814 -- pragma Inline_Always ( NAME {, NAME} );
13816 when Pragma_Inline_Always =>
13817 GNAT_Pragma;
13819 -- Pragma always active unless in CodePeer or SPARK mode, since
13820 -- this causes walk order issues.
13822 if not (CodePeer_Mode or SPARK_Mode) then
13823 Process_Inline (Enabled);
13824 end if;
13826 --------------------
13827 -- Inline_Generic --
13828 --------------------
13830 -- pragma Inline_Generic (NAME {, NAME});
13832 when Pragma_Inline_Generic =>
13833 GNAT_Pragma;
13834 Process_Generic_List;
13836 ----------------------
13837 -- Inspection_Point --
13838 ----------------------
13840 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
13842 when Pragma_Inspection_Point => Inspection_Point : declare
13843 Arg : Node_Id;
13844 Exp : Node_Id;
13846 begin
13847 if Arg_Count > 0 then
13848 Arg := Arg1;
13849 loop
13850 Exp := Get_Pragma_Arg (Arg);
13851 Analyze (Exp);
13853 if not Is_Entity_Name (Exp)
13854 or else not Is_Object (Entity (Exp))
13855 then
13856 Error_Pragma_Arg ("object name required", Arg);
13857 end if;
13859 Next (Arg);
13860 exit when No (Arg);
13861 end loop;
13862 end if;
13863 end Inspection_Point;
13865 ---------------
13866 -- Interface --
13867 ---------------
13869 -- pragma Interface (
13870 -- [ Convention =>] convention_IDENTIFIER,
13871 -- [ Entity =>] local_NAME
13872 -- [, [External_Name =>] static_string_EXPRESSION ]
13873 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13875 when Pragma_Interface =>
13876 GNAT_Pragma;
13877 Check_Arg_Order
13878 ((Name_Convention,
13879 Name_Entity,
13880 Name_External_Name,
13881 Name_Link_Name));
13882 Check_At_Least_N_Arguments (2);
13883 Check_At_Most_N_Arguments (4);
13884 Process_Import_Or_Interface;
13886 -- In Ada 2005, the permission to use Interface (a reserved word)
13887 -- as a pragma name is considered an obsolescent feature, and this
13888 -- pragma was already obsolescent in Ada 95.
13890 if Ada_Version >= Ada_95 then
13891 Check_Restriction
13892 (No_Obsolescent_Features, Pragma_Identifier (N));
13894 if Warn_On_Obsolescent_Feature then
13895 Error_Msg_N
13896 ("pragma Interface is an obsolescent feature?j?", N);
13897 Error_Msg_N
13898 ("|use pragma Import instead?j?", N);
13899 end if;
13900 end if;
13902 --------------------
13903 -- Interface_Name --
13904 --------------------
13906 -- pragma Interface_Name (
13907 -- [ Entity =>] local_NAME
13908 -- [,[External_Name =>] static_string_EXPRESSION ]
13909 -- [,[Link_Name =>] static_string_EXPRESSION ]);
13911 when Pragma_Interface_Name => Interface_Name : declare
13912 Id : Node_Id;
13913 Def_Id : Entity_Id;
13914 Hom_Id : Entity_Id;
13915 Found : Boolean;
13917 begin
13918 GNAT_Pragma;
13919 Check_Arg_Order
13920 ((Name_Entity, Name_External_Name, Name_Link_Name));
13921 Check_At_Least_N_Arguments (2);
13922 Check_At_Most_N_Arguments (3);
13923 Id := Get_Pragma_Arg (Arg1);
13924 Analyze (Id);
13926 -- This is obsolete from Ada 95 on, but it is an implementation
13927 -- defined pragma, so we do not consider that it violates the
13928 -- restriction (No_Obsolescent_Features).
13930 if Ada_Version >= Ada_95 then
13931 if Warn_On_Obsolescent_Feature then
13932 Error_Msg_N
13933 ("pragma Interface_Name is an obsolescent feature?j?", N);
13934 Error_Msg_N
13935 ("|use pragma Import instead?j?", N);
13936 end if;
13937 end if;
13939 if not Is_Entity_Name (Id) then
13940 Error_Pragma_Arg
13941 ("first argument for pragma% must be entity name", Arg1);
13942 elsif Etype (Id) = Any_Type then
13943 return;
13944 else
13945 Def_Id := Entity (Id);
13946 end if;
13948 -- Special DEC-compatible processing for the object case, forces
13949 -- object to be imported.
13951 if Ekind (Def_Id) = E_Variable then
13952 Kill_Size_Check_Code (Def_Id);
13953 Note_Possible_Modification (Id, Sure => False);
13955 -- Initialization is not allowed for imported variable
13957 if Present (Expression (Parent (Def_Id)))
13958 and then Comes_From_Source (Expression (Parent (Def_Id)))
13959 then
13960 Error_Msg_Sloc := Sloc (Def_Id);
13961 Error_Pragma_Arg
13962 ("no initialization allowed for declaration of& #",
13963 Arg2);
13965 else
13966 -- For compatibility, support VADS usage of providing both
13967 -- pragmas Interface and Interface_Name to obtain the effect
13968 -- of a single Import pragma.
13970 if Is_Imported (Def_Id)
13971 and then Present (First_Rep_Item (Def_Id))
13972 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
13973 and then
13974 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
13975 then
13976 null;
13977 else
13978 Set_Imported (Def_Id);
13979 end if;
13981 Set_Is_Public (Def_Id);
13982 Process_Interface_Name (Def_Id, Arg2, Arg3);
13983 end if;
13985 -- Otherwise must be subprogram
13987 elsif not Is_Subprogram (Def_Id) then
13988 Error_Pragma_Arg
13989 ("argument of pragma% is not subprogram", Arg1);
13991 else
13992 Check_At_Most_N_Arguments (3);
13993 Hom_Id := Def_Id;
13994 Found := False;
13996 -- Loop through homonyms
13998 loop
13999 Def_Id := Get_Base_Subprogram (Hom_Id);
14001 if Is_Imported (Def_Id) then
14002 Process_Interface_Name (Def_Id, Arg2, Arg3);
14003 Found := True;
14004 end if;
14006 exit when From_Aspect_Specification (N);
14007 Hom_Id := Homonym (Hom_Id);
14009 exit when No (Hom_Id)
14010 or else Scope (Hom_Id) /= Current_Scope;
14011 end loop;
14013 if not Found then
14014 Error_Pragma_Arg
14015 ("argument of pragma% is not imported subprogram",
14016 Arg1);
14017 end if;
14018 end if;
14019 end Interface_Name;
14021 -----------------------
14022 -- Interrupt_Handler --
14023 -----------------------
14025 -- pragma Interrupt_Handler (handler_NAME);
14027 when Pragma_Interrupt_Handler =>
14028 Check_Ada_83_Warning;
14029 Check_Arg_Count (1);
14030 Check_No_Identifiers;
14032 if No_Run_Time_Mode then
14033 Error_Msg_CRT ("Interrupt_Handler pragma", N);
14034 else
14035 Check_Interrupt_Or_Attach_Handler;
14036 Process_Interrupt_Or_Attach_Handler;
14037 end if;
14039 ------------------------
14040 -- Interrupt_Priority --
14041 ------------------------
14043 -- pragma Interrupt_Priority [(EXPRESSION)];
14045 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
14046 P : constant Node_Id := Parent (N);
14047 Arg : Node_Id;
14048 Ent : Entity_Id;
14050 begin
14051 Check_Ada_83_Warning;
14053 if Arg_Count /= 0 then
14054 Arg := Get_Pragma_Arg (Arg1);
14055 Check_Arg_Count (1);
14056 Check_No_Identifiers;
14058 -- The expression must be analyzed in the special manner
14059 -- described in "Handling of Default and Per-Object
14060 -- Expressions" in sem.ads.
14062 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
14063 end if;
14065 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
14066 Pragma_Misplaced;
14067 return;
14069 else
14070 Ent := Defining_Identifier (Parent (P));
14072 -- Check duplicate pragma before we chain the pragma in the Rep
14073 -- Item chain of Ent.
14075 Check_Duplicate_Pragma (Ent);
14076 Record_Rep_Item (Ent, N);
14077 end if;
14078 end Interrupt_Priority;
14080 ---------------------
14081 -- Interrupt_State --
14082 ---------------------
14084 -- pragma Interrupt_State (
14085 -- [Name =>] INTERRUPT_ID,
14086 -- [State =>] INTERRUPT_STATE);
14088 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
14089 -- INTERRUPT_STATE => System | Runtime | User
14091 -- Note: if the interrupt id is given as an identifier, then it must
14092 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
14093 -- given as a static integer expression which must be in the range of
14094 -- Ada.Interrupts.Interrupt_ID.
14096 when Pragma_Interrupt_State => Interrupt_State : declare
14098 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
14099 -- This is the entity Ada.Interrupts.Interrupt_ID;
14101 State_Type : Character;
14102 -- Set to 's'/'r'/'u' for System/Runtime/User
14104 IST_Num : Pos;
14105 -- Index to entry in Interrupt_States table
14107 Int_Val : Uint;
14108 -- Value of interrupt
14110 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
14111 -- The first argument to the pragma
14113 Int_Ent : Entity_Id;
14114 -- Interrupt entity in Ada.Interrupts.Names
14116 begin
14117 GNAT_Pragma;
14118 Check_Arg_Order ((Name_Name, Name_State));
14119 Check_Arg_Count (2);
14121 Check_Optional_Identifier (Arg1, Name_Name);
14122 Check_Optional_Identifier (Arg2, Name_State);
14123 Check_Arg_Is_Identifier (Arg2);
14125 -- First argument is identifier
14127 if Nkind (Arg1X) = N_Identifier then
14129 -- Search list of names in Ada.Interrupts.Names
14131 Int_Ent := First_Entity (RTE (RE_Names));
14132 loop
14133 if No (Int_Ent) then
14134 Error_Pragma_Arg ("invalid interrupt name", Arg1);
14136 elsif Chars (Int_Ent) = Chars (Arg1X) then
14137 Int_Val := Expr_Value (Constant_Value (Int_Ent));
14138 exit;
14139 end if;
14141 Next_Entity (Int_Ent);
14142 end loop;
14144 -- First argument is not an identifier, so it must be a static
14145 -- expression of type Ada.Interrupts.Interrupt_ID.
14147 else
14148 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
14149 Int_Val := Expr_Value (Arg1X);
14151 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
14152 or else
14153 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
14154 then
14155 Error_Pragma_Arg
14156 ("value not in range of type "
14157 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
14158 end if;
14159 end if;
14161 -- Check OK state
14163 case Chars (Get_Pragma_Arg (Arg2)) is
14164 when Name_Runtime => State_Type := 'r';
14165 when Name_System => State_Type := 's';
14166 when Name_User => State_Type := 'u';
14168 when others =>
14169 Error_Pragma_Arg ("invalid interrupt state", Arg2);
14170 end case;
14172 -- Check if entry is already stored
14174 IST_Num := Interrupt_States.First;
14175 loop
14176 -- If entry not found, add it
14178 if IST_Num > Interrupt_States.Last then
14179 Interrupt_States.Append
14180 ((Interrupt_Number => UI_To_Int (Int_Val),
14181 Interrupt_State => State_Type,
14182 Pragma_Loc => Loc));
14183 exit;
14185 -- Case of entry for the same entry
14187 elsif Int_Val = Interrupt_States.Table (IST_Num).
14188 Interrupt_Number
14189 then
14190 -- If state matches, done, no need to make redundant entry
14192 exit when
14193 State_Type = Interrupt_States.Table (IST_Num).
14194 Interrupt_State;
14196 -- Otherwise if state does not match, error
14198 Error_Msg_Sloc :=
14199 Interrupt_States.Table (IST_Num).Pragma_Loc;
14200 Error_Pragma_Arg
14201 ("state conflicts with that given #", Arg2);
14202 exit;
14203 end if;
14205 IST_Num := IST_Num + 1;
14206 end loop;
14207 end Interrupt_State;
14209 ---------------
14210 -- Invariant --
14211 ---------------
14213 -- pragma Invariant
14214 -- ([Entity =>] type_LOCAL_NAME,
14215 -- [Check =>] EXPRESSION
14216 -- [,[Message =>] String_Expression]);
14218 when Pragma_Invariant => Invariant : declare
14219 Type_Id : Node_Id;
14220 Typ : Entity_Id;
14221 PDecl : Node_Id;
14223 Discard : Boolean;
14224 pragma Unreferenced (Discard);
14226 begin
14227 GNAT_Pragma;
14228 Check_At_Least_N_Arguments (2);
14229 Check_At_Most_N_Arguments (3);
14230 Check_Optional_Identifier (Arg1, Name_Entity);
14231 Check_Optional_Identifier (Arg2, Name_Check);
14233 if Arg_Count = 3 then
14234 Check_Optional_Identifier (Arg3, Name_Message);
14235 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
14236 end if;
14238 Check_Arg_Is_Local_Name (Arg1);
14240 Type_Id := Get_Pragma_Arg (Arg1);
14241 Find_Type (Type_Id);
14242 Typ := Entity (Type_Id);
14244 if Typ = Any_Type then
14245 return;
14247 -- An invariant must apply to a private type, or appear in the
14248 -- private part of a package spec and apply to a completion.
14250 elsif Ekind_In (Typ, E_Private_Type,
14251 E_Record_Type_With_Private,
14252 E_Limited_Private_Type)
14253 then
14254 null;
14256 elsif In_Private_Part (Current_Scope)
14257 and then Has_Private_Declaration (Typ)
14258 then
14259 null;
14261 elsif In_Private_Part (Current_Scope) then
14262 Error_Pragma_Arg
14263 ("pragma% only allowed for private type declared in "
14264 & "visible part", Arg1);
14266 else
14267 Error_Pragma_Arg
14268 ("pragma% only allowed for private type", Arg1);
14269 end if;
14271 -- Note that the type has at least one invariant, and also that
14272 -- it has inheritable invariants if we have Invariant'Class
14273 -- or Type_Invariant'Class. Build the corresponding invariant
14274 -- procedure declaration, so that calls to it can be generated
14275 -- before the body is built (e.g. within an expression function).
14277 PDecl := Build_Invariant_Procedure_Declaration (Typ);
14279 Insert_After (N, PDecl);
14280 Analyze (PDecl);
14282 if Class_Present (N) then
14283 Set_Has_Inheritable_Invariants (Typ);
14284 end if;
14286 -- The remaining processing is simply to link the pragma on to
14287 -- the rep item chain, for processing when the type is frozen.
14288 -- This is accomplished by a call to Rep_Item_Too_Late.
14290 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
14291 end Invariant;
14293 ----------------------
14294 -- Java_Constructor --
14295 ----------------------
14297 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
14299 -- Also handles pragma CIL_Constructor
14301 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
14302 Java_Constructor : declare
14303 Convention : Convention_Id;
14304 Def_Id : Entity_Id;
14305 Hom_Id : Entity_Id;
14306 Id : Entity_Id;
14307 This_Formal : Entity_Id;
14309 begin
14310 GNAT_Pragma;
14311 Check_Arg_Count (1);
14312 Check_Optional_Identifier (Arg1, Name_Entity);
14313 Check_Arg_Is_Local_Name (Arg1);
14315 Id := Get_Pragma_Arg (Arg1);
14316 Find_Program_Unit_Name (Id);
14318 -- If we did not find the name, we are done
14320 if Etype (Id) = Any_Type then
14321 return;
14322 end if;
14324 -- Check wrong use of pragma in wrong VM target
14326 if VM_Target = No_VM then
14327 return;
14329 elsif VM_Target = CLI_Target
14330 and then Prag_Id = Pragma_Java_Constructor
14331 then
14332 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
14334 elsif VM_Target = JVM_Target
14335 and then Prag_Id = Pragma_CIL_Constructor
14336 then
14337 Error_Pragma ("must use pragma 'Java_'Constructor");
14338 end if;
14340 case Prag_Id is
14341 when Pragma_CIL_Constructor => Convention := Convention_CIL;
14342 when Pragma_Java_Constructor => Convention := Convention_Java;
14343 when others => null;
14344 end case;
14346 Hom_Id := Entity (Id);
14348 -- Loop through homonyms
14350 loop
14351 Def_Id := Get_Base_Subprogram (Hom_Id);
14353 -- The constructor is required to be a function
14355 if Ekind (Def_Id) /= E_Function then
14356 if VM_Target = JVM_Target then
14357 Error_Pragma_Arg
14358 ("pragma% requires function returning a 'Java access "
14359 & "type", Def_Id);
14360 else
14361 Error_Pragma_Arg
14362 ("pragma% requires function returning a 'C'I'L access "
14363 & "type", Def_Id);
14364 end if;
14365 end if;
14367 -- Check arguments: For tagged type the first formal must be
14368 -- named "this" and its type must be a named access type
14369 -- designating a class-wide tagged type that has convention
14370 -- CIL/Java. The first formal must also have a null default
14371 -- value. For example:
14373 -- type Typ is tagged ...
14374 -- type Ref is access all Typ;
14375 -- pragma Convention (CIL, Typ);
14377 -- function New_Typ (This : Ref) return Ref;
14378 -- function New_Typ (This : Ref; I : Integer) return Ref;
14379 -- pragma Cil_Constructor (New_Typ);
14381 -- Reason: The first formal must NOT be a primitive of the
14382 -- tagged type.
14384 -- This rule also applies to constructors of delegates used
14385 -- to interface with standard target libraries. For example:
14387 -- type Delegate is access procedure ...
14388 -- pragma Import (CIL, Delegate, ...);
14390 -- function new_Delegate
14391 -- (This : Delegate := null; ... ) return Delegate;
14393 -- For value-types this rule does not apply.
14395 if not Is_Value_Type (Etype (Def_Id)) then
14396 if No (First_Formal (Def_Id)) then
14397 Error_Msg_Name_1 := Pname;
14398 Error_Msg_N ("% function must have parameters", Def_Id);
14399 return;
14400 end if;
14402 -- In the JRE library we have several occurrences in which
14403 -- the "this" parameter is not the first formal.
14405 This_Formal := First_Formal (Def_Id);
14407 -- In the JRE library we have several occurrences in which
14408 -- the "this" parameter is not the first formal. Search for
14409 -- it.
14411 if VM_Target = JVM_Target then
14412 while Present (This_Formal)
14413 and then Get_Name_String (Chars (This_Formal)) /= "this"
14414 loop
14415 Next_Formal (This_Formal);
14416 end loop;
14418 if No (This_Formal) then
14419 This_Formal := First_Formal (Def_Id);
14420 end if;
14421 end if;
14423 -- Warning: The first parameter should be named "this".
14424 -- We temporarily allow it because we have the following
14425 -- case in the Java runtime (file s-osinte.ads) ???
14427 -- function new_Thread
14428 -- (Self_Id : System.Address) return Thread_Id;
14429 -- pragma Java_Constructor (new_Thread);
14431 if VM_Target = JVM_Target
14432 and then Get_Name_String (Chars (First_Formal (Def_Id)))
14433 = "self_id"
14434 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
14435 then
14436 null;
14438 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
14439 Error_Msg_Name_1 := Pname;
14440 Error_Msg_N
14441 ("first formal of % function must be named `this`",
14442 Parent (This_Formal));
14444 elsif not Is_Access_Type (Etype (This_Formal)) then
14445 Error_Msg_Name_1 := Pname;
14446 Error_Msg_N
14447 ("first formal of % function must be an access type",
14448 Parameter_Type (Parent (This_Formal)));
14450 -- For delegates the type of the first formal must be a
14451 -- named access-to-subprogram type (see previous example)
14453 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
14454 and then Ekind (Etype (This_Formal))
14455 /= E_Access_Subprogram_Type
14456 then
14457 Error_Msg_Name_1 := Pname;
14458 Error_Msg_N
14459 ("first formal of % function must be a named access "
14460 & "to subprogram type",
14461 Parameter_Type (Parent (This_Formal)));
14463 -- Warning: We should reject anonymous access types because
14464 -- the constructor must not be handled as a primitive of the
14465 -- tagged type. We temporarily allow it because this profile
14466 -- is currently generated by cil2ada???
14468 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
14469 and then not Ekind_In (Etype (This_Formal),
14470 E_Access_Type,
14471 E_General_Access_Type,
14472 E_Anonymous_Access_Type)
14473 then
14474 Error_Msg_Name_1 := Pname;
14475 Error_Msg_N
14476 ("first formal of % function must be a named access "
14477 & "type", Parameter_Type (Parent (This_Formal)));
14479 elsif Atree.Convention
14480 (Designated_Type (Etype (This_Formal))) /= Convention
14481 then
14482 Error_Msg_Name_1 := Pname;
14484 if Convention = Convention_Java then
14485 Error_Msg_N
14486 ("pragma% requires convention 'Cil in designated "
14487 & "type", Parameter_Type (Parent (This_Formal)));
14488 else
14489 Error_Msg_N
14490 ("pragma% requires convention 'Java in designated "
14491 & "type", Parameter_Type (Parent (This_Formal)));
14492 end if;
14494 elsif No (Expression (Parent (This_Formal)))
14495 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
14496 then
14497 Error_Msg_Name_1 := Pname;
14498 Error_Msg_N
14499 ("pragma% requires first formal with default `null`",
14500 Parameter_Type (Parent (This_Formal)));
14501 end if;
14502 end if;
14504 -- Check result type: the constructor must be a function
14505 -- returning:
14506 -- * a value type (only allowed in the CIL compiler)
14507 -- * an access-to-subprogram type with convention Java/CIL
14508 -- * an access-type designating a type that has convention
14509 -- Java/CIL.
14511 if Is_Value_Type (Etype (Def_Id)) then
14512 null;
14514 -- Access-to-subprogram type with convention Java/CIL
14516 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
14517 if Atree.Convention (Etype (Def_Id)) /= Convention then
14518 if Convention = Convention_Java then
14519 Error_Pragma_Arg
14520 ("pragma% requires function returning a 'Java "
14521 & "access type", Arg1);
14522 else
14523 pragma Assert (Convention = Convention_CIL);
14524 Error_Pragma_Arg
14525 ("pragma% requires function returning a 'C'I'L "
14526 & "access type", Arg1);
14527 end if;
14528 end if;
14530 elsif Ekind (Etype (Def_Id)) in Access_Kind then
14531 if not Ekind_In (Etype (Def_Id), E_Access_Type,
14532 E_General_Access_Type)
14533 or else
14534 Atree.Convention
14535 (Designated_Type (Etype (Def_Id))) /= Convention
14536 then
14537 Error_Msg_Name_1 := Pname;
14539 if Convention = Convention_Java then
14540 Error_Pragma_Arg
14541 ("pragma% requires function returning a named "
14542 & "'Java access type", Arg1);
14543 else
14544 Error_Pragma_Arg
14545 ("pragma% requires function returning a named "
14546 & "'C'I'L access type", Arg1);
14547 end if;
14548 end if;
14549 end if;
14551 Set_Is_Constructor (Def_Id);
14552 Set_Convention (Def_Id, Convention);
14553 Set_Is_Imported (Def_Id);
14555 exit when From_Aspect_Specification (N);
14556 Hom_Id := Homonym (Hom_Id);
14558 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
14559 end loop;
14560 end Java_Constructor;
14562 ----------------------
14563 -- Java_Interface --
14564 ----------------------
14566 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
14568 when Pragma_Java_Interface => Java_Interface : declare
14569 Arg : Node_Id;
14570 Typ : Entity_Id;
14572 begin
14573 GNAT_Pragma;
14574 Check_Arg_Count (1);
14575 Check_Optional_Identifier (Arg1, Name_Entity);
14576 Check_Arg_Is_Local_Name (Arg1);
14578 Arg := Get_Pragma_Arg (Arg1);
14579 Analyze (Arg);
14581 if Etype (Arg) = Any_Type then
14582 return;
14583 end if;
14585 if not Is_Entity_Name (Arg)
14586 or else not Is_Type (Entity (Arg))
14587 then
14588 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
14589 end if;
14591 Typ := Underlying_Type (Entity (Arg));
14593 -- For now simply check some of the semantic constraints on the
14594 -- type. This currently leaves out some restrictions on interface
14595 -- types, namely that the parent type must be java.lang.Object.Typ
14596 -- and that all primitives of the type should be declared
14597 -- abstract. ???
14599 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
14600 Error_Pragma_Arg
14601 ("pragma% requires an abstract tagged type", Arg1);
14603 elsif not Has_Discriminants (Typ)
14604 or else Ekind (Etype (First_Discriminant (Typ)))
14605 /= E_Anonymous_Access_Type
14606 or else
14607 not Is_Class_Wide_Type
14608 (Designated_Type (Etype (First_Discriminant (Typ))))
14609 then
14610 Error_Pragma_Arg
14611 ("type must have a class-wide access discriminant", Arg1);
14612 end if;
14613 end Java_Interface;
14615 ----------------
14616 -- Keep_Names --
14617 ----------------
14619 -- pragma Keep_Names ([On => ] local_NAME);
14621 when Pragma_Keep_Names => Keep_Names : declare
14622 Arg : Node_Id;
14624 begin
14625 GNAT_Pragma;
14626 Check_Arg_Count (1);
14627 Check_Optional_Identifier (Arg1, Name_On);
14628 Check_Arg_Is_Local_Name (Arg1);
14630 Arg := Get_Pragma_Arg (Arg1);
14631 Analyze (Arg);
14633 if Etype (Arg) = Any_Type then
14634 return;
14635 end if;
14637 if not Is_Entity_Name (Arg)
14638 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
14639 then
14640 Error_Pragma_Arg
14641 ("pragma% requires a local enumeration type", Arg1);
14642 end if;
14644 Set_Discard_Names (Entity (Arg), False);
14645 end Keep_Names;
14647 -------------
14648 -- License --
14649 -------------
14651 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
14653 when Pragma_License =>
14654 GNAT_Pragma;
14655 Check_Arg_Count (1);
14656 Check_No_Identifiers;
14657 Check_Valid_Configuration_Pragma;
14658 Check_Arg_Is_Identifier (Arg1);
14660 declare
14661 Sind : constant Source_File_Index :=
14662 Source_Index (Current_Sem_Unit);
14664 begin
14665 case Chars (Get_Pragma_Arg (Arg1)) is
14666 when Name_GPL =>
14667 Set_License (Sind, GPL);
14669 when Name_Modified_GPL =>
14670 Set_License (Sind, Modified_GPL);
14672 when Name_Restricted =>
14673 Set_License (Sind, Restricted);
14675 when Name_Unrestricted =>
14676 Set_License (Sind, Unrestricted);
14678 when others =>
14679 Error_Pragma_Arg ("invalid license name", Arg1);
14680 end case;
14681 end;
14683 ---------------
14684 -- Link_With --
14685 ---------------
14687 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
14689 when Pragma_Link_With => Link_With : declare
14690 Arg : Node_Id;
14692 begin
14693 GNAT_Pragma;
14695 if Operating_Mode = Generate_Code
14696 and then In_Extended_Main_Source_Unit (N)
14697 then
14698 Check_At_Least_N_Arguments (1);
14699 Check_No_Identifiers;
14700 Check_Is_In_Decl_Part_Or_Package_Spec;
14701 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
14702 Start_String;
14704 Arg := Arg1;
14705 while Present (Arg) loop
14706 Check_Arg_Is_Static_Expression (Arg, Standard_String);
14708 -- Store argument, converting sequences of spaces to a
14709 -- single null character (this is one of the differences
14710 -- in processing between Link_With and Linker_Options).
14712 Arg_Store : declare
14713 C : constant Char_Code := Get_Char_Code (' ');
14714 S : constant String_Id :=
14715 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
14716 L : constant Nat := String_Length (S);
14717 F : Nat := 1;
14719 procedure Skip_Spaces;
14720 -- Advance F past any spaces
14722 -----------------
14723 -- Skip_Spaces --
14724 -----------------
14726 procedure Skip_Spaces is
14727 begin
14728 while F <= L and then Get_String_Char (S, F) = C loop
14729 F := F + 1;
14730 end loop;
14731 end Skip_Spaces;
14733 -- Start of processing for Arg_Store
14735 begin
14736 Skip_Spaces; -- skip leading spaces
14738 -- Loop through characters, changing any embedded
14739 -- sequence of spaces to a single null character (this
14740 -- is how Link_With/Linker_Options differ)
14742 while F <= L loop
14743 if Get_String_Char (S, F) = C then
14744 Skip_Spaces;
14745 exit when F > L;
14746 Store_String_Char (ASCII.NUL);
14748 else
14749 Store_String_Char (Get_String_Char (S, F));
14750 F := F + 1;
14751 end if;
14752 end loop;
14753 end Arg_Store;
14755 Arg := Next (Arg);
14757 if Present (Arg) then
14758 Store_String_Char (ASCII.NUL);
14759 end if;
14760 end loop;
14762 Store_Linker_Option_String (End_String);
14763 end if;
14764 end Link_With;
14766 ------------------
14767 -- Linker_Alias --
14768 ------------------
14770 -- pragma Linker_Alias (
14771 -- [Entity =>] LOCAL_NAME
14772 -- [Target =>] static_string_EXPRESSION);
14774 when Pragma_Linker_Alias =>
14775 GNAT_Pragma;
14776 Check_Arg_Order ((Name_Entity, Name_Target));
14777 Check_Arg_Count (2);
14778 Check_Optional_Identifier (Arg1, Name_Entity);
14779 Check_Optional_Identifier (Arg2, Name_Target);
14780 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14781 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
14783 -- The only processing required is to link this item on to the
14784 -- list of rep items for the given entity. This is accomplished
14785 -- by the call to Rep_Item_Too_Late (when no error is detected
14786 -- and False is returned).
14788 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
14789 return;
14790 else
14791 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
14792 end if;
14794 ------------------------
14795 -- Linker_Constructor --
14796 ------------------------
14798 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
14800 -- Code is shared with Linker_Destructor
14802 -----------------------
14803 -- Linker_Destructor --
14804 -----------------------
14806 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
14808 when Pragma_Linker_Constructor |
14809 Pragma_Linker_Destructor =>
14810 Linker_Constructor : declare
14811 Arg1_X : Node_Id;
14812 Proc : Entity_Id;
14814 begin
14815 GNAT_Pragma;
14816 Check_Arg_Count (1);
14817 Check_No_Identifiers;
14818 Check_Arg_Is_Local_Name (Arg1);
14819 Arg1_X := Get_Pragma_Arg (Arg1);
14820 Analyze (Arg1_X);
14821 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
14823 if not Is_Library_Level_Entity (Proc) then
14824 Error_Pragma_Arg
14825 ("argument for pragma% must be library level entity", Arg1);
14826 end if;
14828 -- The only processing required is to link this item on to the
14829 -- list of rep items for the given entity. This is accomplished
14830 -- by the call to Rep_Item_Too_Late (when no error is detected
14831 -- and False is returned).
14833 if Rep_Item_Too_Late (Proc, N) then
14834 return;
14835 else
14836 Set_Has_Gigi_Rep_Item (Proc);
14837 end if;
14838 end Linker_Constructor;
14840 --------------------
14841 -- Linker_Options --
14842 --------------------
14844 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
14846 when Pragma_Linker_Options => Linker_Options : declare
14847 Arg : Node_Id;
14849 begin
14850 Check_Ada_83_Warning;
14851 Check_No_Identifiers;
14852 Check_Arg_Count (1);
14853 Check_Is_In_Decl_Part_Or_Package_Spec;
14854 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
14855 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
14857 Arg := Arg2;
14858 while Present (Arg) loop
14859 Check_Arg_Is_Static_Expression (Arg, Standard_String);
14860 Store_String_Char (ASCII.NUL);
14861 Store_String_Chars
14862 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
14863 Arg := Next (Arg);
14864 end loop;
14866 if Operating_Mode = Generate_Code
14867 and then In_Extended_Main_Source_Unit (N)
14868 then
14869 Store_Linker_Option_String (End_String);
14870 end if;
14871 end Linker_Options;
14873 --------------------
14874 -- Linker_Section --
14875 --------------------
14877 -- pragma Linker_Section (
14878 -- [Entity =>] LOCAL_NAME
14879 -- [Section =>] static_string_EXPRESSION);
14881 when Pragma_Linker_Section =>
14882 GNAT_Pragma;
14883 Check_Arg_Order ((Name_Entity, Name_Section));
14884 Check_Arg_Count (2);
14885 Check_Optional_Identifier (Arg1, Name_Entity);
14886 Check_Optional_Identifier (Arg2, Name_Section);
14887 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14888 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
14890 -- This pragma applies to objects and types
14892 if not Is_Object (Entity (Get_Pragma_Arg (Arg1)))
14893 and then not Is_Type (Entity (Get_Pragma_Arg (Arg1)))
14894 then
14895 Error_Pragma_Arg
14896 ("pragma% applies only to objects and types", Arg1);
14897 end if;
14899 -- The only processing required is to link this item on to the
14900 -- list of rep items for the given entity. This is accomplished
14901 -- by the call to Rep_Item_Too_Late (when no error is detected
14902 -- and False is returned).
14904 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
14905 return;
14906 else
14907 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
14908 end if;
14910 ----------
14911 -- List --
14912 ----------
14914 -- pragma List (On | Off)
14916 -- There is nothing to do here, since we did all the processing for
14917 -- this pragma in Par.Prag (so that it works properly even in syntax
14918 -- only mode).
14920 when Pragma_List =>
14921 null;
14923 ---------------
14924 -- Lock_Free --
14925 ---------------
14927 -- pragma Lock_Free [(Boolean_EXPRESSION)];
14929 when Pragma_Lock_Free => Lock_Free : declare
14930 P : constant Node_Id := Parent (N);
14931 Arg : Node_Id;
14932 Ent : Entity_Id;
14933 Val : Boolean;
14935 begin
14936 Check_No_Identifiers;
14937 Check_At_Most_N_Arguments (1);
14939 -- Protected definition case
14941 if Nkind (P) = N_Protected_Definition then
14942 Ent := Defining_Identifier (Parent (P));
14944 -- One argument
14946 if Arg_Count = 1 then
14947 Arg := Get_Pragma_Arg (Arg1);
14948 Val := Is_True (Static_Boolean (Arg));
14950 -- No arguments (expression is considered to be True)
14952 else
14953 Val := True;
14954 end if;
14956 -- Check duplicate pragma before we chain the pragma in the Rep
14957 -- Item chain of Ent.
14959 Check_Duplicate_Pragma (Ent);
14960 Record_Rep_Item (Ent, N);
14961 Set_Uses_Lock_Free (Ent, Val);
14963 -- Anything else is incorrect placement
14965 else
14966 Pragma_Misplaced;
14967 end if;
14968 end Lock_Free;
14970 --------------------
14971 -- Locking_Policy --
14972 --------------------
14974 -- pragma Locking_Policy (policy_IDENTIFIER);
14976 when Pragma_Locking_Policy => declare
14977 subtype LP_Range is Name_Id
14978 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
14979 LP_Val : LP_Range;
14980 LP : Character;
14982 begin
14983 Check_Ada_83_Warning;
14984 Check_Arg_Count (1);
14985 Check_No_Identifiers;
14986 Check_Arg_Is_Locking_Policy (Arg1);
14987 Check_Valid_Configuration_Pragma;
14988 LP_Val := Chars (Get_Pragma_Arg (Arg1));
14990 case LP_Val is
14991 when Name_Ceiling_Locking =>
14992 LP := 'C';
14993 when Name_Inheritance_Locking =>
14994 LP := 'I';
14995 when Name_Concurrent_Readers_Locking =>
14996 LP := 'R';
14997 end case;
14999 if Locking_Policy /= ' '
15000 and then Locking_Policy /= LP
15001 then
15002 Error_Msg_Sloc := Locking_Policy_Sloc;
15003 Error_Pragma ("locking policy incompatible with policy#");
15005 -- Set new policy, but always preserve System_Location since we
15006 -- like the error message with the run time name.
15008 else
15009 Locking_Policy := LP;
15011 if Locking_Policy_Sloc /= System_Location then
15012 Locking_Policy_Sloc := Loc;
15013 end if;
15014 end if;
15015 end;
15017 ----------------
15018 -- Long_Float --
15019 ----------------
15021 -- pragma Long_Float (D_Float | G_Float);
15023 when Pragma_Long_Float => Long_Float : declare
15024 begin
15025 GNAT_Pragma;
15026 Check_Valid_Configuration_Pragma;
15027 Check_Arg_Count (1);
15028 Check_No_Identifier (Arg1);
15029 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
15031 if not OpenVMS_On_Target then
15032 Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)");
15033 end if;
15035 -- D_Float case
15037 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
15038 if Opt.Float_Format_Long = 'G' then
15039 Error_Pragma_Arg
15040 ("G_Float previously specified", Arg1);
15042 elsif Current_Sem_Unit /= Main_Unit
15043 and then Opt.Float_Format_Long /= 'D'
15044 then
15045 Error_Pragma_Arg
15046 ("main unit not compiled with pragma Long_Float (D_Float)",
15047 "\pragma% must be used consistently for whole partition",
15048 Arg1);
15050 else
15051 Opt.Float_Format_Long := 'D';
15052 end if;
15054 -- G_Float case (this is the default, does not need overriding)
15056 else
15057 if Opt.Float_Format_Long = 'D' then
15058 Error_Pragma ("D_Float previously specified");
15060 elsif Current_Sem_Unit /= Main_Unit
15061 and then Opt.Float_Format_Long /= 'G'
15062 then
15063 Error_Pragma_Arg
15064 ("main unit not compiled with pragma Long_Float (G_Float)",
15065 "\pragma% must be used consistently for whole partition",
15066 Arg1);
15068 else
15069 Opt.Float_Format_Long := 'G';
15070 end if;
15071 end if;
15073 Set_Standard_Fpt_Formats;
15074 end Long_Float;
15076 -------------------
15077 -- Loop_Optimize --
15078 -------------------
15080 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
15082 -- OPTIMIZATION_HINT ::= No_Unroll | Unroll | No_Vector | Vector
15084 when Pragma_Loop_Optimize => Loop_Optimize : declare
15085 Hint : Node_Id;
15087 begin
15088 GNAT_Pragma;
15089 Check_At_Least_N_Arguments (1);
15090 Check_No_Identifiers;
15092 Hint := First (Pragma_Argument_Associations (N));
15093 while Present (Hint) loop
15094 Check_Arg_Is_One_Of (Hint,
15095 Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector);
15096 Next (Hint);
15097 end loop;
15099 Check_Loop_Pragma_Placement;
15100 end Loop_Optimize;
15102 ------------------
15103 -- Loop_Variant --
15104 ------------------
15106 -- pragma Loop_Variant
15107 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
15109 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
15111 -- CHANGE_DIRECTION ::= Increases | Decreases
15113 when Pragma_Loop_Variant => Loop_Variant : declare
15114 Variant : Node_Id;
15116 begin
15117 GNAT_Pragma;
15118 Check_At_Least_N_Arguments (1);
15119 Check_Loop_Pragma_Placement;
15121 -- Process all increasing / decreasing expressions
15123 Variant := First (Pragma_Argument_Associations (N));
15124 while Present (Variant) loop
15125 if not Nam_In (Chars (Variant), Name_Decreases,
15126 Name_Increases)
15127 then
15128 Error_Pragma_Arg ("wrong change modifier", Variant);
15129 end if;
15131 Preanalyze_Assert_Expression
15132 (Expression (Variant), Any_Discrete);
15134 Next (Variant);
15135 end loop;
15136 end Loop_Variant;
15138 -----------------------
15139 -- Machine_Attribute --
15140 -----------------------
15142 -- pragma Machine_Attribute (
15143 -- [Entity =>] LOCAL_NAME,
15144 -- [Attribute_Name =>] static_string_EXPRESSION
15145 -- [, [Info =>] static_EXPRESSION] );
15147 when Pragma_Machine_Attribute => Machine_Attribute : declare
15148 Def_Id : Entity_Id;
15150 begin
15151 GNAT_Pragma;
15152 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
15154 if Arg_Count = 3 then
15155 Check_Optional_Identifier (Arg3, Name_Info);
15156 Check_Arg_Is_Static_Expression (Arg3);
15157 else
15158 Check_Arg_Count (2);
15159 end if;
15161 Check_Optional_Identifier (Arg1, Name_Entity);
15162 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
15163 Check_Arg_Is_Local_Name (Arg1);
15164 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
15165 Def_Id := Entity (Get_Pragma_Arg (Arg1));
15167 if Is_Access_Type (Def_Id) then
15168 Def_Id := Designated_Type (Def_Id);
15169 end if;
15171 if Rep_Item_Too_Early (Def_Id, N) then
15172 return;
15173 end if;
15175 Def_Id := Underlying_Type (Def_Id);
15177 -- The only processing required is to link this item on to the
15178 -- list of rep items for the given entity. This is accomplished
15179 -- by the call to Rep_Item_Too_Late (when no error is detected
15180 -- and False is returned).
15182 if Rep_Item_Too_Late (Def_Id, N) then
15183 return;
15184 else
15185 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
15186 end if;
15187 end Machine_Attribute;
15189 ----------
15190 -- Main --
15191 ----------
15193 -- pragma Main
15194 -- (MAIN_OPTION [, MAIN_OPTION]);
15196 -- MAIN_OPTION ::=
15197 -- [STACK_SIZE =>] static_integer_EXPRESSION
15198 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
15199 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
15201 when Pragma_Main => Main : declare
15202 Args : Args_List (1 .. 3);
15203 Names : constant Name_List (1 .. 3) := (
15204 Name_Stack_Size,
15205 Name_Task_Stack_Size_Default,
15206 Name_Time_Slicing_Enabled);
15208 Nod : Node_Id;
15210 begin
15211 GNAT_Pragma;
15212 Gather_Associations (Names, Args);
15214 for J in 1 .. 2 loop
15215 if Present (Args (J)) then
15216 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
15217 end if;
15218 end loop;
15220 if Present (Args (3)) then
15221 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
15222 end if;
15224 Nod := Next (N);
15225 while Present (Nod) loop
15226 if Nkind (Nod) = N_Pragma
15227 and then Pragma_Name (Nod) = Name_Main
15228 then
15229 Error_Msg_Name_1 := Pname;
15230 Error_Msg_N ("duplicate pragma% not permitted", Nod);
15231 end if;
15233 Next (Nod);
15234 end loop;
15235 end Main;
15237 ------------------
15238 -- Main_Storage --
15239 ------------------
15241 -- pragma Main_Storage
15242 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
15244 -- MAIN_STORAGE_OPTION ::=
15245 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
15246 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
15248 when Pragma_Main_Storage => Main_Storage : declare
15249 Args : Args_List (1 .. 2);
15250 Names : constant Name_List (1 .. 2) := (
15251 Name_Working_Storage,
15252 Name_Top_Guard);
15254 Nod : Node_Id;
15256 begin
15257 GNAT_Pragma;
15258 Gather_Associations (Names, Args);
15260 for J in 1 .. 2 loop
15261 if Present (Args (J)) then
15262 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
15263 end if;
15264 end loop;
15266 Check_In_Main_Program;
15268 Nod := Next (N);
15269 while Present (Nod) loop
15270 if Nkind (Nod) = N_Pragma
15271 and then Pragma_Name (Nod) = Name_Main_Storage
15272 then
15273 Error_Msg_Name_1 := Pname;
15274 Error_Msg_N ("duplicate pragma% not permitted", Nod);
15275 end if;
15277 Next (Nod);
15278 end loop;
15279 end Main_Storage;
15281 -----------------
15282 -- Memory_Size --
15283 -----------------
15285 -- pragma Memory_Size (NUMERIC_LITERAL)
15287 when Pragma_Memory_Size =>
15288 GNAT_Pragma;
15290 -- Memory size is simply ignored
15292 Check_No_Identifiers;
15293 Check_Arg_Count (1);
15294 Check_Arg_Is_Integer_Literal (Arg1);
15296 -------------
15297 -- No_Body --
15298 -------------
15300 -- pragma No_Body;
15302 -- The only correct use of this pragma is on its own in a file, in
15303 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
15304 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
15305 -- check for a file containing nothing but a No_Body pragma). If we
15306 -- attempt to process it during normal semantics processing, it means
15307 -- it was misplaced.
15309 when Pragma_No_Body =>
15310 GNAT_Pragma;
15311 Pragma_Misplaced;
15313 ---------------
15314 -- No_Inline --
15315 ---------------
15317 -- pragma No_Inline ( NAME {, NAME} );
15319 when Pragma_No_Inline =>
15320 GNAT_Pragma;
15321 Process_Inline (Suppressed);
15323 ---------------
15324 -- No_Return --
15325 ---------------
15327 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
15329 when Pragma_No_Return => No_Return : declare
15330 Id : Node_Id;
15331 E : Entity_Id;
15332 Found : Boolean;
15333 Arg : Node_Id;
15335 begin
15336 Ada_2005_Pragma;
15337 Check_At_Least_N_Arguments (1);
15339 -- Loop through arguments of pragma
15341 Arg := Arg1;
15342 while Present (Arg) loop
15343 Check_Arg_Is_Local_Name (Arg);
15344 Id := Get_Pragma_Arg (Arg);
15345 Analyze (Id);
15347 if not Is_Entity_Name (Id) then
15348 Error_Pragma_Arg ("entity name required", Arg);
15349 end if;
15351 if Etype (Id) = Any_Type then
15352 raise Pragma_Exit;
15353 end if;
15355 -- Loop to find matching procedures
15357 E := Entity (Id);
15358 Found := False;
15359 while Present (E)
15360 and then Scope (E) = Current_Scope
15361 loop
15362 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
15363 Set_No_Return (E);
15365 -- Set flag on any alias as well
15367 if Is_Overloadable (E) and then Present (Alias (E)) then
15368 Set_No_Return (Alias (E));
15369 end if;
15371 Found := True;
15372 end if;
15374 exit when From_Aspect_Specification (N);
15375 E := Homonym (E);
15376 end loop;
15378 if not Found then
15379 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
15380 end if;
15382 Next (Arg);
15383 end loop;
15384 end No_Return;
15386 -----------------
15387 -- No_Run_Time --
15388 -----------------
15390 -- pragma No_Run_Time;
15392 -- Note: this pragma is retained for backwards compatibility. See
15393 -- body of Rtsfind for full details on its handling.
15395 when Pragma_No_Run_Time =>
15396 GNAT_Pragma;
15397 Check_Valid_Configuration_Pragma;
15398 Check_Arg_Count (0);
15400 No_Run_Time_Mode := True;
15401 Configurable_Run_Time_Mode := True;
15403 -- Set Duration to 32 bits if word size is 32
15405 if Ttypes.System_Word_Size = 32 then
15406 Duration_32_Bits_On_Target := True;
15407 end if;
15409 -- Set appropriate restrictions
15411 Set_Restriction (No_Finalization, N);
15412 Set_Restriction (No_Exception_Handlers, N);
15413 Set_Restriction (Max_Tasks, N, 0);
15414 Set_Restriction (No_Tasking, N);
15416 ------------------------
15417 -- No_Strict_Aliasing --
15418 ------------------------
15420 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
15422 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
15423 E_Id : Entity_Id;
15425 begin
15426 GNAT_Pragma;
15427 Check_At_Most_N_Arguments (1);
15429 if Arg_Count = 0 then
15430 Check_Valid_Configuration_Pragma;
15431 Opt.No_Strict_Aliasing := True;
15433 else
15434 Check_Optional_Identifier (Arg2, Name_Entity);
15435 Check_Arg_Is_Local_Name (Arg1);
15436 E_Id := Entity (Get_Pragma_Arg (Arg1));
15438 if E_Id = Any_Type then
15439 return;
15440 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
15441 Error_Pragma_Arg ("pragma% requires access type", Arg1);
15442 end if;
15444 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
15445 end if;
15446 end No_Strict_Aliasing;
15448 -----------------------
15449 -- Normalize_Scalars --
15450 -----------------------
15452 -- pragma Normalize_Scalars;
15454 when Pragma_Normalize_Scalars =>
15455 Check_Ada_83_Warning;
15456 Check_Arg_Count (0);
15457 Check_Valid_Configuration_Pragma;
15459 -- Normalize_Scalars creates false positives in CodePeer, and
15460 -- incorrect negative results in SPARK mode, so ignore this pragma
15461 -- in these modes.
15463 if not (CodePeer_Mode or SPARK_Mode) then
15464 Normalize_Scalars := True;
15465 Init_Or_Norm_Scalars := True;
15466 end if;
15468 -----------------
15469 -- Obsolescent --
15470 -----------------
15472 -- pragma Obsolescent;
15474 -- pragma Obsolescent (
15475 -- [Message =>] static_string_EXPRESSION
15476 -- [,[Version =>] Ada_05]]);
15478 -- pragma Obsolescent (
15479 -- [Entity =>] NAME
15480 -- [,[Message =>] static_string_EXPRESSION
15481 -- [,[Version =>] Ada_05]] );
15483 when Pragma_Obsolescent => Obsolescent : declare
15484 Ename : Node_Id;
15485 Decl : Node_Id;
15487 procedure Set_Obsolescent (E : Entity_Id);
15488 -- Given an entity Ent, mark it as obsolescent if appropriate
15490 ---------------------
15491 -- Set_Obsolescent --
15492 ---------------------
15494 procedure Set_Obsolescent (E : Entity_Id) is
15495 Active : Boolean;
15496 Ent : Entity_Id;
15497 S : String_Id;
15499 begin
15500 Active := True;
15501 Ent := E;
15503 -- Entity name was given
15505 if Present (Ename) then
15507 -- If entity name matches, we are fine. Save entity in
15508 -- pragma argument, for ASIS use.
15510 if Chars (Ename) = Chars (Ent) then
15511 Set_Entity (Ename, Ent);
15512 Generate_Reference (Ent, Ename);
15514 -- If entity name does not match, only possibility is an
15515 -- enumeration literal from an enumeration type declaration.
15517 elsif Ekind (Ent) /= E_Enumeration_Type then
15518 Error_Pragma
15519 ("pragma % entity name does not match declaration");
15521 else
15522 Ent := First_Literal (E);
15523 loop
15524 if No (Ent) then
15525 Error_Pragma
15526 ("pragma % entity name does not match any "
15527 & "enumeration literal");
15529 elsif Chars (Ent) = Chars (Ename) then
15530 Set_Entity (Ename, Ent);
15531 Generate_Reference (Ent, Ename);
15532 exit;
15534 else
15535 Ent := Next_Literal (Ent);
15536 end if;
15537 end loop;
15538 end if;
15539 end if;
15541 -- Ent points to entity to be marked
15543 if Arg_Count >= 1 then
15545 -- Deal with static string argument
15547 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
15548 S := Strval (Get_Pragma_Arg (Arg1));
15550 for J in 1 .. String_Length (S) loop
15551 if not In_Character_Range (Get_String_Char (S, J)) then
15552 Error_Pragma_Arg
15553 ("pragma% argument does not allow wide characters",
15554 Arg1);
15555 end if;
15556 end loop;
15558 Obsolescent_Warnings.Append
15559 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
15561 -- Check for Ada_05 parameter
15563 if Arg_Count /= 1 then
15564 Check_Arg_Count (2);
15566 declare
15567 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
15569 begin
15570 Check_Arg_Is_Identifier (Argx);
15572 if Chars (Argx) /= Name_Ada_05 then
15573 Error_Msg_Name_2 := Name_Ada_05;
15574 Error_Pragma_Arg
15575 ("only allowed argument for pragma% is %", Argx);
15576 end if;
15578 if Ada_Version_Explicit < Ada_2005
15579 or else not Warn_On_Ada_2005_Compatibility
15580 then
15581 Active := False;
15582 end if;
15583 end;
15584 end if;
15585 end if;
15587 -- Set flag if pragma active
15589 if Active then
15590 Set_Is_Obsolescent (Ent);
15591 end if;
15593 return;
15594 end Set_Obsolescent;
15596 -- Start of processing for pragma Obsolescent
15598 begin
15599 GNAT_Pragma;
15601 Check_At_Most_N_Arguments (3);
15603 -- See if first argument specifies an entity name
15605 if Arg_Count >= 1
15606 and then
15607 (Chars (Arg1) = Name_Entity
15608 or else
15609 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
15610 N_Identifier,
15611 N_Operator_Symbol))
15612 then
15613 Ename := Get_Pragma_Arg (Arg1);
15615 -- Eliminate first argument, so we can share processing
15617 Arg1 := Arg2;
15618 Arg2 := Arg3;
15619 Arg_Count := Arg_Count - 1;
15621 -- No Entity name argument given
15623 else
15624 Ename := Empty;
15625 end if;
15627 if Arg_Count >= 1 then
15628 Check_Optional_Identifier (Arg1, Name_Message);
15630 if Arg_Count = 2 then
15631 Check_Optional_Identifier (Arg2, Name_Version);
15632 end if;
15633 end if;
15635 -- Get immediately preceding declaration
15637 Decl := Prev (N);
15638 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
15639 Prev (Decl);
15640 end loop;
15642 -- Cases where we do not follow anything other than another pragma
15644 if No (Decl) then
15646 -- First case: library level compilation unit declaration with
15647 -- the pragma immediately following the declaration.
15649 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
15650 Set_Obsolescent
15651 (Defining_Entity (Unit (Parent (Parent (N)))));
15652 return;
15654 -- Case 2: library unit placement for package
15656 else
15657 declare
15658 Ent : constant Entity_Id := Find_Lib_Unit_Name;
15659 begin
15660 if Is_Package_Or_Generic_Package (Ent) then
15661 Set_Obsolescent (Ent);
15662 return;
15663 end if;
15664 end;
15665 end if;
15667 -- Cases where we must follow a declaration
15669 else
15670 if Nkind (Decl) not in N_Declaration
15671 and then Nkind (Decl) not in N_Later_Decl_Item
15672 and then Nkind (Decl) not in N_Generic_Declaration
15673 and then Nkind (Decl) not in N_Renaming_Declaration
15674 then
15675 Error_Pragma
15676 ("pragma% misplaced, "
15677 & "must immediately follow a declaration");
15679 else
15680 Set_Obsolescent (Defining_Entity (Decl));
15681 return;
15682 end if;
15683 end if;
15684 end Obsolescent;
15686 --------------
15687 -- Optimize --
15688 --------------
15690 -- pragma Optimize (Time | Space | Off);
15692 -- The actual check for optimize is done in Gigi. Note that this
15693 -- pragma does not actually change the optimization setting, it
15694 -- simply checks that it is consistent with the pragma.
15696 when Pragma_Optimize =>
15697 Check_No_Identifiers;
15698 Check_Arg_Count (1);
15699 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
15701 ------------------------
15702 -- Optimize_Alignment --
15703 ------------------------
15705 -- pragma Optimize_Alignment (Time | Space | Off);
15707 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
15708 GNAT_Pragma;
15709 Check_No_Identifiers;
15710 Check_Arg_Count (1);
15711 Check_Valid_Configuration_Pragma;
15713 declare
15714 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
15715 begin
15716 case Nam is
15717 when Name_Time =>
15718 Opt.Optimize_Alignment := 'T';
15719 when Name_Space =>
15720 Opt.Optimize_Alignment := 'S';
15721 when Name_Off =>
15722 Opt.Optimize_Alignment := 'O';
15723 when others =>
15724 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
15725 end case;
15726 end;
15728 -- Set indication that mode is set locally. If we are in fact in a
15729 -- configuration pragma file, this setting is harmless since the
15730 -- switch will get reset anyway at the start of each unit.
15732 Optimize_Alignment_Local := True;
15733 end Optimize_Alignment;
15735 -------------
15736 -- Ordered --
15737 -------------
15739 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
15741 when Pragma_Ordered => Ordered : declare
15742 Assoc : constant Node_Id := Arg1;
15743 Type_Id : Node_Id;
15744 Typ : Entity_Id;
15746 begin
15747 GNAT_Pragma;
15748 Check_No_Identifiers;
15749 Check_Arg_Count (1);
15750 Check_Arg_Is_Local_Name (Arg1);
15752 Type_Id := Get_Pragma_Arg (Assoc);
15753 Find_Type (Type_Id);
15754 Typ := Entity (Type_Id);
15756 if Typ = Any_Type then
15757 return;
15758 else
15759 Typ := Underlying_Type (Typ);
15760 end if;
15762 if not Is_Enumeration_Type (Typ) then
15763 Error_Pragma ("pragma% must specify enumeration type");
15764 end if;
15766 Check_First_Subtype (Arg1);
15767 Set_Has_Pragma_Ordered (Base_Type (Typ));
15768 end Ordered;
15770 -------------------
15771 -- Overflow_Mode --
15772 -------------------
15774 -- pragma Overflow_Mode
15775 -- ([General => ] MODE [, [Assertions => ] MODE]);
15777 -- MODE := STRICT | MINIMIZED | ELIMINATED
15779 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
15780 -- since System.Bignums makes this assumption. This is true of nearly
15781 -- all (all?) targets.
15783 when Pragma_Overflow_Mode => Overflow_Mode : declare
15784 function Get_Overflow_Mode
15785 (Name : Name_Id;
15786 Arg : Node_Id) return Overflow_Mode_Type;
15787 -- Function to process one pragma argument, Arg. If an identifier
15788 -- is present, it must be Name. Mode type is returned if a valid
15789 -- argument exists, otherwise an error is signalled.
15791 -----------------------
15792 -- Get_Overflow_Mode --
15793 -----------------------
15795 function Get_Overflow_Mode
15796 (Name : Name_Id;
15797 Arg : Node_Id) return Overflow_Mode_Type
15799 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
15801 begin
15802 Check_Optional_Identifier (Arg, Name);
15803 Check_Arg_Is_Identifier (Argx);
15805 if Chars (Argx) = Name_Strict then
15806 return Strict;
15808 elsif Chars (Argx) = Name_Minimized then
15809 return Minimized;
15811 elsif Chars (Argx) = Name_Eliminated then
15812 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
15813 Error_Pragma_Arg
15814 ("Eliminated not implemented on this target", Argx);
15815 else
15816 return Eliminated;
15817 end if;
15819 else
15820 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
15821 end if;
15822 end Get_Overflow_Mode;
15824 -- Start of processing for Overflow_Mode
15826 begin
15827 GNAT_Pragma;
15828 Check_At_Least_N_Arguments (1);
15829 Check_At_Most_N_Arguments (2);
15831 -- Process first argument
15833 Scope_Suppress.Overflow_Mode_General :=
15834 Get_Overflow_Mode (Name_General, Arg1);
15836 -- Case of only one argument
15838 if Arg_Count = 1 then
15839 Scope_Suppress.Overflow_Mode_Assertions :=
15840 Scope_Suppress.Overflow_Mode_General;
15842 -- Case of two arguments present
15844 else
15845 Scope_Suppress.Overflow_Mode_Assertions :=
15846 Get_Overflow_Mode (Name_Assertions, Arg2);
15847 end if;
15848 end Overflow_Mode;
15850 --------------------------
15851 -- Overriding Renamings --
15852 --------------------------
15854 -- pragma Overriding_Renamings;
15856 when Pragma_Overriding_Renamings =>
15857 GNAT_Pragma;
15858 Check_Arg_Count (0);
15859 Check_Valid_Configuration_Pragma;
15860 Overriding_Renamings := True;
15862 ----------
15863 -- Pack --
15864 ----------
15866 -- pragma Pack (first_subtype_LOCAL_NAME);
15868 when Pragma_Pack => Pack : declare
15869 Assoc : constant Node_Id := Arg1;
15870 Type_Id : Node_Id;
15871 Typ : Entity_Id;
15872 Ctyp : Entity_Id;
15873 Ignore : Boolean := False;
15875 begin
15876 Check_No_Identifiers;
15877 Check_Arg_Count (1);
15878 Check_Arg_Is_Local_Name (Arg1);
15880 Type_Id := Get_Pragma_Arg (Assoc);
15881 Find_Type (Type_Id);
15882 Typ := Entity (Type_Id);
15884 if Typ = Any_Type
15885 or else Rep_Item_Too_Early (Typ, N)
15886 then
15887 return;
15888 else
15889 Typ := Underlying_Type (Typ);
15890 end if;
15892 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
15893 Error_Pragma ("pragma% must specify array or record type");
15894 end if;
15896 Check_First_Subtype (Arg1);
15897 Check_Duplicate_Pragma (Typ);
15899 -- Array type
15901 if Is_Array_Type (Typ) then
15902 Ctyp := Component_Type (Typ);
15904 -- Ignore pack that does nothing
15906 if Known_Static_Esize (Ctyp)
15907 and then Known_Static_RM_Size (Ctyp)
15908 and then Esize (Ctyp) = RM_Size (Ctyp)
15909 and then Addressable (Esize (Ctyp))
15910 then
15911 Ignore := True;
15912 end if;
15914 -- Process OK pragma Pack. Note that if there is a separate
15915 -- component clause present, the Pack will be cancelled. This
15916 -- processing is in Freeze.
15918 if not Rep_Item_Too_Late (Typ, N) then
15920 -- In the context of static code analysis, we do not need
15921 -- complex front-end expansions related to pragma Pack,
15922 -- so disable handling of pragma Pack in these cases.
15924 if CodePeer_Mode or SPARK_Mode then
15925 null;
15927 -- Don't attempt any packing for VM targets. We possibly
15928 -- could deal with some cases of array bit-packing, but we
15929 -- don't bother, since this is not a typical kind of
15930 -- representation in the VM context anyway (and would not
15931 -- for example work nicely with the debugger).
15933 elsif VM_Target /= No_VM then
15934 if not GNAT_Mode then
15935 Error_Pragma
15936 ("??pragma% ignored in this configuration");
15937 end if;
15939 -- Normal case where we do the pack action
15941 else
15942 if not Ignore then
15943 Set_Is_Packed (Base_Type (Typ));
15944 Set_Has_Non_Standard_Rep (Base_Type (Typ));
15945 end if;
15947 Set_Has_Pragma_Pack (Base_Type (Typ));
15948 end if;
15949 end if;
15951 -- For record types, the pack is always effective
15953 else pragma Assert (Is_Record_Type (Typ));
15954 if not Rep_Item_Too_Late (Typ, N) then
15956 -- Ignore pack request with warning in VM mode (skip warning
15957 -- if we are compiling GNAT run time library).
15959 if VM_Target /= No_VM then
15960 if not GNAT_Mode then
15961 Error_Pragma
15962 ("??pragma% ignored in this configuration");
15963 end if;
15965 -- Normal case of pack request active
15967 else
15968 Set_Is_Packed (Base_Type (Typ));
15969 Set_Has_Pragma_Pack (Base_Type (Typ));
15970 Set_Has_Non_Standard_Rep (Base_Type (Typ));
15971 end if;
15972 end if;
15973 end if;
15974 end Pack;
15976 ----------
15977 -- Page --
15978 ----------
15980 -- pragma Page;
15982 -- There is nothing to do here, since we did all the processing for
15983 -- this pragma in Par.Prag (so that it works properly even in syntax
15984 -- only mode).
15986 when Pragma_Page =>
15987 null;
15989 ----------------------------------
15990 -- Partition_Elaboration_Policy --
15991 ----------------------------------
15993 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
15995 when Pragma_Partition_Elaboration_Policy => declare
15996 subtype PEP_Range is Name_Id
15997 range First_Partition_Elaboration_Policy_Name
15998 .. Last_Partition_Elaboration_Policy_Name;
15999 PEP_Val : PEP_Range;
16000 PEP : Character;
16002 begin
16003 Ada_2005_Pragma;
16004 Check_Arg_Count (1);
16005 Check_No_Identifiers;
16006 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
16007 Check_Valid_Configuration_Pragma;
16008 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
16010 case PEP_Val is
16011 when Name_Concurrent =>
16012 PEP := 'C';
16013 when Name_Sequential =>
16014 PEP := 'S';
16015 end case;
16017 if Partition_Elaboration_Policy /= ' '
16018 and then Partition_Elaboration_Policy /= PEP
16019 then
16020 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
16021 Error_Pragma
16022 ("partition elaboration policy incompatible with policy#");
16024 -- Set new policy, but always preserve System_Location since we
16025 -- like the error message with the run time name.
16027 else
16028 Partition_Elaboration_Policy := PEP;
16030 if Partition_Elaboration_Policy_Sloc /= System_Location then
16031 Partition_Elaboration_Policy_Sloc := Loc;
16032 end if;
16033 end if;
16034 end;
16036 -------------
16037 -- Passive --
16038 -------------
16040 -- pragma Passive [(PASSIVE_FORM)];
16042 -- PASSIVE_FORM ::= Semaphore | No
16044 when Pragma_Passive =>
16045 GNAT_Pragma;
16047 if Nkind (Parent (N)) /= N_Task_Definition then
16048 Error_Pragma ("pragma% must be within task definition");
16049 end if;
16051 if Arg_Count /= 0 then
16052 Check_Arg_Count (1);
16053 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
16054 end if;
16056 ----------------------------------
16057 -- Preelaborable_Initialization --
16058 ----------------------------------
16060 -- pragma Preelaborable_Initialization (DIRECT_NAME);
16062 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
16063 Ent : Entity_Id;
16065 begin
16066 Ada_2005_Pragma;
16067 Check_Arg_Count (1);
16068 Check_No_Identifiers;
16069 Check_Arg_Is_Identifier (Arg1);
16070 Check_Arg_Is_Local_Name (Arg1);
16071 Check_First_Subtype (Arg1);
16072 Ent := Entity (Get_Pragma_Arg (Arg1));
16074 -- The pragma may come from an aspect on a private declaration,
16075 -- even if the freeze point at which this is analyzed in the
16076 -- private part after the full view.
16078 if Has_Private_Declaration (Ent)
16079 and then From_Aspect_Specification (N)
16080 then
16081 null;
16083 elsif Is_Private_Type (Ent)
16084 or else Is_Protected_Type (Ent)
16085 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
16086 then
16087 null;
16089 else
16090 Error_Pragma_Arg
16091 ("pragma % can only be applied to private, formal derived or "
16092 & "protected type",
16093 Arg1);
16094 end if;
16096 -- Give an error if the pragma is applied to a protected type that
16097 -- does not qualify (due to having entries, or due to components
16098 -- that do not qualify).
16100 if Is_Protected_Type (Ent)
16101 and then not Has_Preelaborable_Initialization (Ent)
16102 then
16103 Error_Msg_N
16104 ("protected type & does not have preelaborable "
16105 & "initialization", Ent);
16107 -- Otherwise mark the type as definitely having preelaborable
16108 -- initialization.
16110 else
16111 Set_Known_To_Have_Preelab_Init (Ent);
16112 end if;
16114 if Has_Pragma_Preelab_Init (Ent)
16115 and then Warn_On_Redundant_Constructs
16116 then
16117 Error_Pragma ("?r?duplicate pragma%!");
16118 else
16119 Set_Has_Pragma_Preelab_Init (Ent);
16120 end if;
16121 end Preelab_Init;
16123 --------------------
16124 -- Persistent_BSS --
16125 --------------------
16127 -- pragma Persistent_BSS [(object_NAME)];
16129 when Pragma_Persistent_BSS => Persistent_BSS : declare
16130 Decl : Node_Id;
16131 Ent : Entity_Id;
16132 Prag : Node_Id;
16134 begin
16135 GNAT_Pragma;
16136 Check_At_Most_N_Arguments (1);
16138 -- Case of application to specific object (one argument)
16140 if Arg_Count = 1 then
16141 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16143 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
16144 or else not
16145 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
16146 E_Constant)
16147 then
16148 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
16149 end if;
16151 Ent := Entity (Get_Pragma_Arg (Arg1));
16152 Decl := Parent (Ent);
16154 -- Check for duplication before inserting in list of
16155 -- representation items.
16157 Check_Duplicate_Pragma (Ent);
16159 if Rep_Item_Too_Late (Ent, N) then
16160 return;
16161 end if;
16163 if Present (Expression (Decl)) then
16164 Error_Pragma_Arg
16165 ("object for pragma% cannot have initialization", Arg1);
16166 end if;
16168 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
16169 Error_Pragma_Arg
16170 ("object type for pragma% is not potentially persistent",
16171 Arg1);
16172 end if;
16174 Prag :=
16175 Make_Linker_Section_Pragma
16176 (Ent, Sloc (N), ".persistent.bss");
16177 Insert_After (N, Prag);
16178 Analyze (Prag);
16180 -- Case of use as configuration pragma with no arguments
16182 else
16183 Check_Valid_Configuration_Pragma;
16184 Persistent_BSS_Mode := True;
16185 end if;
16186 end Persistent_BSS;
16188 -------------
16189 -- Polling --
16190 -------------
16192 -- pragma Polling (ON | OFF);
16194 when Pragma_Polling =>
16195 GNAT_Pragma;
16196 Check_Arg_Count (1);
16197 Check_No_Identifiers;
16198 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16199 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
16201 ------------------
16202 -- Post[_Class] --
16203 ------------------
16205 -- pragma Post (Boolean_EXPRESSION);
16206 -- pragma Post_Class (Boolean_EXPRESSION);
16208 when Pragma_Post | Pragma_Post_Class => Post : declare
16209 PC_Pragma : Node_Id;
16211 begin
16212 GNAT_Pragma;
16213 Check_Arg_Count (1);
16214 Check_No_Identifiers;
16215 Check_Pre_Post;
16217 -- Rewrite Post[_Class] pragma as Precondition pragma setting the
16218 -- flag Class_Present to True for the Post_Class case.
16220 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
16221 PC_Pragma := New_Copy (N);
16222 Set_Pragma_Identifier
16223 (PC_Pragma, Make_Identifier (Loc, Name_Postcondition));
16224 Rewrite (N, PC_Pragma);
16225 Set_Analyzed (N, False);
16226 Analyze (N);
16227 end Post;
16229 -------------------
16230 -- Postcondition --
16231 -------------------
16233 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
16234 -- [,[Message =>] String_EXPRESSION]);
16236 when Pragma_Postcondition => Postcondition : declare
16237 In_Body : Boolean;
16239 begin
16240 GNAT_Pragma;
16241 Check_At_Least_N_Arguments (1);
16242 Check_At_Most_N_Arguments (2);
16243 Check_Optional_Identifier (Arg1, Name_Check);
16245 -- Verify the proper placement of the pragma. The remainder of the
16246 -- processing is found in Sem_Ch6/Sem_Ch7.
16248 Check_Precondition_Postcondition (In_Body);
16250 -- When the pragma is a source construct appearing inside a body,
16251 -- preanalyze the boolean_expression to detect illegal forward
16252 -- references:
16254 -- procedure P is
16255 -- pragma Postcondition (X'Old ...);
16256 -- X : ...
16258 if Comes_From_Source (N) and then In_Body then
16259 Preanalyze_Spec_Expression (Expression (Arg1), Any_Boolean);
16260 end if;
16261 end Postcondition;
16263 -----------------
16264 -- Pre[_Class] --
16265 -----------------
16267 -- pragma Pre (Boolean_EXPRESSION);
16268 -- pragma Pre_Class (Boolean_EXPRESSION);
16270 when Pragma_Pre | Pragma_Pre_Class => Pre : declare
16271 PC_Pragma : Node_Id;
16273 begin
16274 GNAT_Pragma;
16275 Check_Arg_Count (1);
16276 Check_No_Identifiers;
16277 Check_Pre_Post;
16279 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
16280 -- flag Class_Present to True for the Pre_Class case.
16282 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
16283 PC_Pragma := New_Copy (N);
16284 Set_Pragma_Identifier
16285 (PC_Pragma, Make_Identifier (Loc, Name_Precondition));
16286 Rewrite (N, PC_Pragma);
16287 Set_Analyzed (N, False);
16288 Analyze (N);
16289 end Pre;
16291 ------------------
16292 -- Precondition --
16293 ------------------
16295 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
16296 -- [,[Message =>] String_EXPRESSION]);
16298 when Pragma_Precondition => Precondition : declare
16299 In_Body : Boolean;
16301 begin
16302 GNAT_Pragma;
16303 Check_At_Least_N_Arguments (1);
16304 Check_At_Most_N_Arguments (2);
16305 Check_Optional_Identifier (Arg1, Name_Check);
16306 Check_Precondition_Postcondition (In_Body);
16308 -- If in spec, nothing more to do. If in body, then we convert
16309 -- the pragma to an equivalent pragma Check. That works fine since
16310 -- pragma Check will analyze the condition in the proper context.
16312 -- The form of the pragma Check is either:
16314 -- pragma Check (Precondition, cond [, msg])
16315 -- or
16316 -- pragma Check (Pre, cond [, msg])
16318 -- We use the Pre form if this pragma derived from a Pre aspect.
16319 -- This is needed to make sure that the right set of Policy
16320 -- pragmas are checked.
16322 if In_Body then
16324 -- Rewrite as Check pragma
16326 Rewrite (N,
16327 Make_Pragma (Loc,
16328 Chars => Name_Check,
16329 Pragma_Argument_Associations => New_List (
16330 Make_Pragma_Argument_Association (Loc,
16331 Expression => Make_Identifier (Loc, Pname)),
16333 Make_Pragma_Argument_Association (Sloc (Arg1),
16334 Expression =>
16335 Relocate_Node (Get_Pragma_Arg (Arg1))))));
16337 if Arg_Count = 2 then
16338 Append_To (Pragma_Argument_Associations (N),
16339 Make_Pragma_Argument_Association (Sloc (Arg2),
16340 Expression =>
16341 Relocate_Node (Get_Pragma_Arg (Arg2))));
16342 end if;
16344 Analyze (N);
16345 end if;
16346 end Precondition;
16348 ---------------
16349 -- Predicate --
16350 ---------------
16352 -- pragma Predicate
16353 -- ([Entity =>] type_LOCAL_NAME,
16354 -- [Check =>] boolean_EXPRESSION);
16356 when Pragma_Predicate => Predicate : declare
16357 Type_Id : Node_Id;
16358 Typ : Entity_Id;
16360 Discard : Boolean;
16361 pragma Unreferenced (Discard);
16363 begin
16364 GNAT_Pragma;
16365 Check_Arg_Count (2);
16366 Check_Optional_Identifier (Arg1, Name_Entity);
16367 Check_Optional_Identifier (Arg2, Name_Check);
16369 Check_Arg_Is_Local_Name (Arg1);
16371 Type_Id := Get_Pragma_Arg (Arg1);
16372 Find_Type (Type_Id);
16373 Typ := Entity (Type_Id);
16375 if Typ = Any_Type then
16376 return;
16377 end if;
16379 -- The remaining processing is simply to link the pragma on to
16380 -- the rep item chain, for processing when the type is frozen.
16381 -- This is accomplished by a call to Rep_Item_Too_Late. We also
16382 -- mark the type as having predicates.
16384 Set_Has_Predicates (Typ);
16385 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16386 end Predicate;
16388 ------------------
16389 -- Preelaborate --
16390 ------------------
16392 -- pragma Preelaborate [(library_unit_NAME)];
16394 -- Set the flag Is_Preelaborated of program unit name entity
16396 when Pragma_Preelaborate => Preelaborate : declare
16397 Pa : constant Node_Id := Parent (N);
16398 Pk : constant Node_Kind := Nkind (Pa);
16399 Ent : Entity_Id;
16401 begin
16402 Check_Ada_83_Warning;
16403 Check_Valid_Library_Unit_Pragma;
16405 if Nkind (N) = N_Null_Statement then
16406 return;
16407 end if;
16409 Ent := Find_Lib_Unit_Name;
16410 Check_Duplicate_Pragma (Ent);
16412 -- This filters out pragmas inside generic parents that show up
16413 -- inside instantiations. Pragmas that come from aspects in the
16414 -- unit are not ignored.
16416 if Present (Ent) then
16417 if Pk = N_Package_Specification
16418 and then Present (Generic_Parent (Pa))
16419 and then not From_Aspect_Specification (N)
16420 then
16421 null;
16423 else
16424 if not Debug_Flag_U then
16425 Set_Is_Preelaborated (Ent);
16426 Set_Suppress_Elaboration_Warnings (Ent);
16427 end if;
16428 end if;
16429 end if;
16430 end Preelaborate;
16432 ---------------------
16433 -- Preelaborate_05 --
16434 ---------------------
16436 -- pragma Preelaborate_05 [(library_unit_NAME)];
16438 -- This pragma is useable only in GNAT_Mode, where it is used like
16439 -- pragma Preelaborate but it is only effective in Ada 2005 mode
16440 -- (otherwise it is ignored). This is used to implement AI-362 which
16441 -- recategorizes some run-time packages in Ada 2005 mode.
16443 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
16444 Ent : Entity_Id;
16446 begin
16447 GNAT_Pragma;
16448 Check_Valid_Library_Unit_Pragma;
16450 if not GNAT_Mode then
16451 Error_Pragma ("pragma% only available in GNAT mode");
16452 end if;
16454 if Nkind (N) = N_Null_Statement then
16455 return;
16456 end if;
16458 -- This is one of the few cases where we need to test the value of
16459 -- Ada_Version_Explicit rather than Ada_Version (which is always
16460 -- set to Ada_2012 in a predefined unit), we need to know the
16461 -- explicit version set to know if this pragma is active.
16463 if Ada_Version_Explicit >= Ada_2005 then
16464 Ent := Find_Lib_Unit_Name;
16465 Set_Is_Preelaborated (Ent);
16466 Set_Suppress_Elaboration_Warnings (Ent);
16467 end if;
16468 end Preelaborate_05;
16470 --------------
16471 -- Priority --
16472 --------------
16474 -- pragma Priority (EXPRESSION);
16476 when Pragma_Priority => Priority : declare
16477 P : constant Node_Id := Parent (N);
16478 Arg : Node_Id;
16479 Ent : Entity_Id;
16481 begin
16482 Check_No_Identifiers;
16483 Check_Arg_Count (1);
16485 -- Subprogram case
16487 if Nkind (P) = N_Subprogram_Body then
16488 Check_In_Main_Program;
16490 Ent := Defining_Unit_Name (Specification (P));
16492 if Nkind (Ent) = N_Defining_Program_Unit_Name then
16493 Ent := Defining_Identifier (Ent);
16494 end if;
16496 Arg := Get_Pragma_Arg (Arg1);
16497 Analyze_And_Resolve (Arg, Standard_Integer);
16499 -- Must be static
16501 if not Is_Static_Expression (Arg) then
16502 Flag_Non_Static_Expr
16503 ("main subprogram priority is not static!", Arg);
16504 raise Pragma_Exit;
16506 -- If constraint error, then we already signalled an error
16508 elsif Raises_Constraint_Error (Arg) then
16509 null;
16511 -- Otherwise check in range
16513 else
16514 declare
16515 Val : constant Uint := Expr_Value (Arg);
16517 begin
16518 if Val < 0
16519 or else Val > Expr_Value (Expression
16520 (Parent (RTE (RE_Max_Priority))))
16521 then
16522 Error_Pragma_Arg
16523 ("main subprogram priority is out of range", Arg1);
16524 end if;
16525 end;
16526 end if;
16528 Set_Main_Priority
16529 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
16531 -- Load an arbitrary entity from System.Tasking.Stages or
16532 -- System.Tasking.Restricted.Stages (depending on the
16533 -- supported profile) to make sure that one of these packages
16534 -- is implicitly with'ed, since we need to have the tasking
16535 -- run time active for the pragma Priority to have any effect.
16536 -- Previously with with'ed the package System.Tasking, but
16537 -- this package does not trigger the required initialization
16538 -- of the run-time library.
16540 declare
16541 Discard : Entity_Id;
16542 pragma Warnings (Off, Discard);
16543 begin
16544 if Restricted_Profile then
16545 Discard := RTE (RE_Activate_Restricted_Tasks);
16546 else
16547 Discard := RTE (RE_Activate_Tasks);
16548 end if;
16549 end;
16551 -- Task or Protected, must be of type Integer
16553 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
16554 Arg := Get_Pragma_Arg (Arg1);
16555 Ent := Defining_Identifier (Parent (P));
16557 -- The expression must be analyzed in the special manner
16558 -- described in "Handling of Default and Per-Object
16559 -- Expressions" in sem.ads.
16561 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
16563 if not Is_Static_Expression (Arg) then
16564 Check_Restriction (Static_Priorities, Arg);
16565 end if;
16567 -- Anything else is incorrect
16569 else
16570 Pragma_Misplaced;
16571 end if;
16573 -- Check duplicate pragma before we chain the pragma in the Rep
16574 -- Item chain of Ent.
16576 Check_Duplicate_Pragma (Ent);
16577 Record_Rep_Item (Ent, N);
16578 end Priority;
16580 -----------------------------------
16581 -- Priority_Specific_Dispatching --
16582 -----------------------------------
16584 -- pragma Priority_Specific_Dispatching (
16585 -- policy_IDENTIFIER,
16586 -- first_priority_EXPRESSION,
16587 -- last_priority_EXPRESSION);
16589 when Pragma_Priority_Specific_Dispatching =>
16590 Priority_Specific_Dispatching : declare
16591 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
16592 -- This is the entity System.Any_Priority;
16594 DP : Character;
16595 Lower_Bound : Node_Id;
16596 Upper_Bound : Node_Id;
16597 Lower_Val : Uint;
16598 Upper_Val : Uint;
16600 begin
16601 Ada_2005_Pragma;
16602 Check_Arg_Count (3);
16603 Check_No_Identifiers;
16604 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
16605 Check_Valid_Configuration_Pragma;
16606 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16607 DP := Fold_Upper (Name_Buffer (1));
16609 Lower_Bound := Get_Pragma_Arg (Arg2);
16610 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
16611 Lower_Val := Expr_Value (Lower_Bound);
16613 Upper_Bound := Get_Pragma_Arg (Arg3);
16614 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
16615 Upper_Val := Expr_Value (Upper_Bound);
16617 -- It is not allowed to use Task_Dispatching_Policy and
16618 -- Priority_Specific_Dispatching in the same partition.
16620 if Task_Dispatching_Policy /= ' ' then
16621 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
16622 Error_Pragma
16623 ("pragma% incompatible with Task_Dispatching_Policy#");
16625 -- Check lower bound in range
16627 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
16628 or else
16629 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
16630 then
16631 Error_Pragma_Arg
16632 ("first_priority is out of range", Arg2);
16634 -- Check upper bound in range
16636 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
16637 or else
16638 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
16639 then
16640 Error_Pragma_Arg
16641 ("last_priority is out of range", Arg3);
16643 -- Check that the priority range is valid
16645 elsif Lower_Val > Upper_Val then
16646 Error_Pragma
16647 ("last_priority_expression must be greater than or equal to "
16648 & "first_priority_expression");
16650 -- Store the new policy, but always preserve System_Location since
16651 -- we like the error message with the run-time name.
16653 else
16654 -- Check overlapping in the priority ranges specified in other
16655 -- Priority_Specific_Dispatching pragmas within the same
16656 -- partition. We can only check those we know about!
16658 for J in
16659 Specific_Dispatching.First .. Specific_Dispatching.Last
16660 loop
16661 if Specific_Dispatching.Table (J).First_Priority in
16662 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
16663 or else Specific_Dispatching.Table (J).Last_Priority in
16664 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
16665 then
16666 Error_Msg_Sloc :=
16667 Specific_Dispatching.Table (J).Pragma_Loc;
16668 Error_Pragma
16669 ("priority range overlaps with "
16670 & "Priority_Specific_Dispatching#");
16671 end if;
16672 end loop;
16674 -- The use of Priority_Specific_Dispatching is incompatible
16675 -- with Task_Dispatching_Policy.
16677 if Task_Dispatching_Policy /= ' ' then
16678 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
16679 Error_Pragma
16680 ("Priority_Specific_Dispatching incompatible "
16681 & "with Task_Dispatching_Policy#");
16682 end if;
16684 -- The use of Priority_Specific_Dispatching forces ceiling
16685 -- locking policy.
16687 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
16688 Error_Msg_Sloc := Locking_Policy_Sloc;
16689 Error_Pragma
16690 ("Priority_Specific_Dispatching incompatible "
16691 & "with Locking_Policy#");
16693 -- Set the Ceiling_Locking policy, but preserve System_Location
16694 -- since we like the error message with the run time name.
16696 else
16697 Locking_Policy := 'C';
16699 if Locking_Policy_Sloc /= System_Location then
16700 Locking_Policy_Sloc := Loc;
16701 end if;
16702 end if;
16704 -- Add entry in the table
16706 Specific_Dispatching.Append
16707 ((Dispatching_Policy => DP,
16708 First_Priority => UI_To_Int (Lower_Val),
16709 Last_Priority => UI_To_Int (Upper_Val),
16710 Pragma_Loc => Loc));
16711 end if;
16712 end Priority_Specific_Dispatching;
16714 -------------
16715 -- Profile --
16716 -------------
16718 -- pragma Profile (profile_IDENTIFIER);
16720 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
16722 when Pragma_Profile =>
16723 Ada_2005_Pragma;
16724 Check_Arg_Count (1);
16725 Check_Valid_Configuration_Pragma;
16726 Check_No_Identifiers;
16728 declare
16729 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
16731 begin
16732 if Chars (Argx) = Name_Ravenscar then
16733 Set_Ravenscar_Profile (N);
16735 elsif Chars (Argx) = Name_Restricted then
16736 Set_Profile_Restrictions
16737 (Restricted,
16738 N, Warn => Treat_Restrictions_As_Warnings);
16740 elsif Chars (Argx) = Name_Rational then
16741 Set_Rational_Profile;
16743 elsif Chars (Argx) = Name_No_Implementation_Extensions then
16744 Set_Profile_Restrictions
16745 (No_Implementation_Extensions,
16746 N, Warn => Treat_Restrictions_As_Warnings);
16748 else
16749 Error_Pragma_Arg ("& is not a valid profile", Argx);
16750 end if;
16751 end;
16753 ----------------------
16754 -- Profile_Warnings --
16755 ----------------------
16757 -- pragma Profile_Warnings (profile_IDENTIFIER);
16759 -- profile_IDENTIFIER => Restricted | Ravenscar
16761 when Pragma_Profile_Warnings =>
16762 GNAT_Pragma;
16763 Check_Arg_Count (1);
16764 Check_Valid_Configuration_Pragma;
16765 Check_No_Identifiers;
16767 declare
16768 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
16770 begin
16771 if Chars (Argx) = Name_Ravenscar then
16772 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
16774 elsif Chars (Argx) = Name_Restricted then
16775 Set_Profile_Restrictions (Restricted, N, Warn => True);
16777 elsif Chars (Argx) = Name_No_Implementation_Extensions then
16778 Set_Profile_Restrictions
16779 (No_Implementation_Extensions, N, Warn => True);
16781 else
16782 Error_Pragma_Arg ("& is not a valid profile", Argx);
16783 end if;
16784 end;
16786 --------------------------
16787 -- Propagate_Exceptions --
16788 --------------------------
16790 -- pragma Propagate_Exceptions;
16792 -- Note: this pragma is obsolete and has no effect
16794 when Pragma_Propagate_Exceptions =>
16795 GNAT_Pragma;
16796 Check_Arg_Count (0);
16798 if Warn_On_Obsolescent_Feature then
16799 Error_Msg_N
16800 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
16801 "and has no effect?j?", N);
16802 end if;
16804 ------------------
16805 -- Psect_Object --
16806 ------------------
16808 -- pragma Psect_Object (
16809 -- [Internal =>] LOCAL_NAME,
16810 -- [, [External =>] EXTERNAL_SYMBOL]
16811 -- [, [Size =>] EXTERNAL_SYMBOL]);
16813 when Pragma_Psect_Object | Pragma_Common_Object =>
16814 Psect_Object : declare
16815 Args : Args_List (1 .. 3);
16816 Names : constant Name_List (1 .. 3) := (
16817 Name_Internal,
16818 Name_External,
16819 Name_Size);
16821 Internal : Node_Id renames Args (1);
16822 External : Node_Id renames Args (2);
16823 Size : Node_Id renames Args (3);
16825 Def_Id : Entity_Id;
16827 procedure Check_Too_Long (Arg : Node_Id);
16828 -- Posts message if the argument is an identifier with more
16829 -- than 31 characters, or a string literal with more than
16830 -- 31 characters, and we are operating under VMS
16832 --------------------
16833 -- Check_Too_Long --
16834 --------------------
16836 procedure Check_Too_Long (Arg : Node_Id) is
16837 X : constant Node_Id := Original_Node (Arg);
16839 begin
16840 if not Nkind_In (X, N_String_Literal, N_Identifier) then
16841 Error_Pragma_Arg
16842 ("inappropriate argument for pragma %", Arg);
16843 end if;
16845 if OpenVMS_On_Target then
16846 if (Nkind (X) = N_String_Literal
16847 and then String_Length (Strval (X)) > 31)
16848 or else
16849 (Nkind (X) = N_Identifier
16850 and then Length_Of_Name (Chars (X)) > 31)
16851 then
16852 Error_Pragma_Arg
16853 ("argument for pragma % is longer than 31 characters",
16854 Arg);
16855 end if;
16856 end if;
16857 end Check_Too_Long;
16859 -- Start of processing for Common_Object/Psect_Object
16861 begin
16862 GNAT_Pragma;
16863 Gather_Associations (Names, Args);
16864 Process_Extended_Import_Export_Internal_Arg (Internal);
16866 Def_Id := Entity (Internal);
16868 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
16869 Error_Pragma_Arg
16870 ("pragma% must designate an object", Internal);
16871 end if;
16873 Check_Too_Long (Internal);
16875 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
16876 Error_Pragma_Arg
16877 ("cannot use pragma% for imported/exported object",
16878 Internal);
16879 end if;
16881 if Is_Concurrent_Type (Etype (Internal)) then
16882 Error_Pragma_Arg
16883 ("cannot specify pragma % for task/protected object",
16884 Internal);
16885 end if;
16887 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
16888 or else
16889 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
16890 then
16891 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
16892 end if;
16894 if Ekind (Def_Id) = E_Constant then
16895 Error_Pragma_Arg
16896 ("cannot specify pragma % for a constant", Internal);
16897 end if;
16899 if Is_Record_Type (Etype (Internal)) then
16900 declare
16901 Ent : Entity_Id;
16902 Decl : Entity_Id;
16904 begin
16905 Ent := First_Entity (Etype (Internal));
16906 while Present (Ent) loop
16907 Decl := Declaration_Node (Ent);
16909 if Ekind (Ent) = E_Component
16910 and then Nkind (Decl) = N_Component_Declaration
16911 and then Present (Expression (Decl))
16912 and then Warn_On_Export_Import
16913 then
16914 Error_Msg_N
16915 ("?x?object for pragma % has defaults", Internal);
16916 exit;
16918 else
16919 Next_Entity (Ent);
16920 end if;
16921 end loop;
16922 end;
16923 end if;
16925 if Present (Size) then
16926 Check_Too_Long (Size);
16927 end if;
16929 if Present (External) then
16930 Check_Arg_Is_External_Name (External);
16931 Check_Too_Long (External);
16932 end if;
16934 -- If all error tests pass, link pragma on to the rep item chain
16936 Record_Rep_Item (Def_Id, N);
16937 end Psect_Object;
16939 ----------
16940 -- Pure --
16941 ----------
16943 -- pragma Pure [(library_unit_NAME)];
16945 when Pragma_Pure => Pure : declare
16946 Ent : Entity_Id;
16948 begin
16949 Check_Ada_83_Warning;
16950 Check_Valid_Library_Unit_Pragma;
16952 if Nkind (N) = N_Null_Statement then
16953 return;
16954 end if;
16956 Ent := Find_Lib_Unit_Name;
16957 Set_Is_Pure (Ent);
16958 Set_Has_Pragma_Pure (Ent);
16959 Set_Suppress_Elaboration_Warnings (Ent);
16960 end Pure;
16962 -------------
16963 -- Pure_05 --
16964 -------------
16966 -- pragma Pure_05 [(library_unit_NAME)];
16968 -- This pragma is useable only in GNAT_Mode, where it is used like
16969 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
16970 -- it is ignored). It may be used after a pragma Preelaborate, in
16971 -- which case it overrides the effect of the pragma Preelaborate.
16972 -- This is used to implement AI-362 which recategorizes some run-time
16973 -- packages in Ada 2005 mode.
16975 when Pragma_Pure_05 => Pure_05 : declare
16976 Ent : Entity_Id;
16978 begin
16979 GNAT_Pragma;
16980 Check_Valid_Library_Unit_Pragma;
16982 if not GNAT_Mode then
16983 Error_Pragma ("pragma% only available in GNAT mode");
16984 end if;
16986 if Nkind (N) = N_Null_Statement then
16987 return;
16988 end if;
16990 -- This is one of the few cases where we need to test the value of
16991 -- Ada_Version_Explicit rather than Ada_Version (which is always
16992 -- set to Ada_2012 in a predefined unit), we need to know the
16993 -- explicit version set to know if this pragma is active.
16995 if Ada_Version_Explicit >= Ada_2005 then
16996 Ent := Find_Lib_Unit_Name;
16997 Set_Is_Preelaborated (Ent, False);
16998 Set_Is_Pure (Ent);
16999 Set_Suppress_Elaboration_Warnings (Ent);
17000 end if;
17001 end Pure_05;
17003 -------------
17004 -- Pure_12 --
17005 -------------
17007 -- pragma Pure_12 [(library_unit_NAME)];
17009 -- This pragma is useable only in GNAT_Mode, where it is used like
17010 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise
17011 -- it is ignored). It may be used after a pragma Preelaborate, in
17012 -- which case it overrides the effect of the pragma Preelaborate.
17013 -- This is used to implement AI05-0212 which recategorizes some
17014 -- run-time packages in Ada 2012 mode.
17016 when Pragma_Pure_12 => Pure_12 : declare
17017 Ent : Entity_Id;
17019 begin
17020 GNAT_Pragma;
17021 Check_Valid_Library_Unit_Pragma;
17023 if not GNAT_Mode then
17024 Error_Pragma ("pragma% only available in GNAT mode");
17025 end if;
17027 if Nkind (N) = N_Null_Statement then
17028 return;
17029 end if;
17031 -- This is one of the few cases where we need to test the value of
17032 -- Ada_Version_Explicit rather than Ada_Version (which is always
17033 -- set to Ada_2012 in a predefined unit), we need to know the
17034 -- explicit version set to know if this pragma is active.
17036 if Ada_Version_Explicit >= Ada_2012 then
17037 Ent := Find_Lib_Unit_Name;
17038 Set_Is_Preelaborated (Ent, False);
17039 Set_Is_Pure (Ent);
17040 Set_Suppress_Elaboration_Warnings (Ent);
17041 end if;
17042 end Pure_12;
17044 -------------------
17045 -- Pure_Function --
17046 -------------------
17048 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
17050 when Pragma_Pure_Function => Pure_Function : declare
17051 E_Id : Node_Id;
17052 E : Entity_Id;
17053 Def_Id : Entity_Id;
17054 Effective : Boolean := False;
17056 begin
17057 GNAT_Pragma;
17058 Check_Arg_Count (1);
17059 Check_Optional_Identifier (Arg1, Name_Entity);
17060 Check_Arg_Is_Local_Name (Arg1);
17061 E_Id := Get_Pragma_Arg (Arg1);
17063 if Error_Posted (E_Id) then
17064 return;
17065 end if;
17067 -- Loop through homonyms (overloadings) of referenced entity
17069 E := Entity (E_Id);
17071 if Present (E) then
17072 loop
17073 Def_Id := Get_Base_Subprogram (E);
17075 if not Ekind_In (Def_Id, E_Function,
17076 E_Generic_Function,
17077 E_Operator)
17078 then
17079 Error_Pragma_Arg
17080 ("pragma% requires a function name", Arg1);
17081 end if;
17083 Set_Is_Pure (Def_Id);
17085 if not Has_Pragma_Pure_Function (Def_Id) then
17086 Set_Has_Pragma_Pure_Function (Def_Id);
17087 Effective := True;
17088 end if;
17090 exit when From_Aspect_Specification (N);
17091 E := Homonym (E);
17092 exit when No (E) or else Scope (E) /= Current_Scope;
17093 end loop;
17095 if not Effective
17096 and then Warn_On_Redundant_Constructs
17097 then
17098 Error_Msg_NE
17099 ("pragma Pure_Function on& is redundant?r?",
17100 N, Entity (E_Id));
17101 end if;
17102 end if;
17103 end Pure_Function;
17105 --------------------
17106 -- Queuing_Policy --
17107 --------------------
17109 -- pragma Queuing_Policy (policy_IDENTIFIER);
17111 when Pragma_Queuing_Policy => declare
17112 QP : Character;
17114 begin
17115 Check_Ada_83_Warning;
17116 Check_Arg_Count (1);
17117 Check_No_Identifiers;
17118 Check_Arg_Is_Queuing_Policy (Arg1);
17119 Check_Valid_Configuration_Pragma;
17120 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
17121 QP := Fold_Upper (Name_Buffer (1));
17123 if Queuing_Policy /= ' '
17124 and then Queuing_Policy /= QP
17125 then
17126 Error_Msg_Sloc := Queuing_Policy_Sloc;
17127 Error_Pragma ("queuing policy incompatible with policy#");
17129 -- Set new policy, but always preserve System_Location since we
17130 -- like the error message with the run time name.
17132 else
17133 Queuing_Policy := QP;
17135 if Queuing_Policy_Sloc /= System_Location then
17136 Queuing_Policy_Sloc := Loc;
17137 end if;
17138 end if;
17139 end;
17141 --------------
17142 -- Rational --
17143 --------------
17145 -- pragma Rational, for compatibility with foreign compiler
17147 when Pragma_Rational =>
17148 Set_Rational_Profile;
17150 ------------------------------------
17151 -- Refined_Depends/Refined_Global --
17152 ------------------------------------
17154 -- pragma Refined_Depends (DEPENDENCY_RELATION);
17156 -- DEPENDENCY_RELATION ::=
17157 -- null
17158 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
17160 -- DEPENDENCY_CLAUSE ::=
17161 -- OUTPUT_LIST =>[+] INPUT_LIST
17162 -- | NULL_DEPENDENCY_CLAUSE
17164 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
17166 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
17168 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
17170 -- OUTPUT ::= NAME | FUNCTION_RESULT
17171 -- INPUT ::= NAME
17173 -- where FUNCTION_RESULT is a function Result attribute_reference
17175 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
17177 -- GLOBAL_SPECIFICATION ::=
17178 -- null
17179 -- | GLOBAL_LIST
17180 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
17182 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17184 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17185 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17186 -- GLOBAL_ITEM ::= NAME
17188 when Pragma_Refined_Depends |
17189 Pragma_Refined_Global => Refined_Depends_Global :
17190 declare
17191 Body_Id : Entity_Id;
17192 Legal : Boolean;
17193 Spec_Id : Entity_Id;
17195 begin
17196 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
17198 -- Save the pragma in the contract of the subprogram body. The
17199 -- remaining analysis is performed at the end of the enclosing
17200 -- declarations.
17202 if Legal then
17203 Add_Contract_Item (N, Body_Id);
17204 end if;
17205 end Refined_Depends_Global;
17207 ------------------
17208 -- Refined_Post --
17209 ------------------
17211 -- pragma Refined_Post (boolean_EXPRESSION);
17213 when Pragma_Refined_Post => Refined_Post : declare
17214 Body_Id : Entity_Id;
17215 Legal : Boolean;
17216 Spec_Id : Entity_Id;
17218 begin
17219 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
17221 -- Analyze the boolean expression as a "spec expression"
17223 if Legal then
17224 Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id);
17225 end if;
17226 end Refined_Post;
17228 -------------------
17229 -- Refined_State --
17230 -------------------
17232 -- pragma Refined_State (REFINEMENT_LIST);
17234 -- REFINEMENT_LIST ::=
17235 -- REFINEMENT_CLAUSE
17236 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
17238 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
17240 -- CONSTITUENT_LIST ::=
17241 -- null
17242 -- | CONSTITUENT
17243 -- | (CONSTITUENT {, CONSTITUENT})
17245 -- CONSTITUENT ::= object_NAME | state_NAME
17247 when Pragma_Refined_State => Refined_State : declare
17248 Context : constant Node_Id := Parent (N);
17249 Spec_Id : Entity_Id;
17250 Stmt : Node_Id;
17252 begin
17253 GNAT_Pragma;
17254 S14_Pragma;
17255 Check_Arg_Count (1);
17257 -- Ensure the proper placement of the pragma. Refined states must
17258 -- be associated with a package body.
17260 if Nkind (Context) /= N_Package_Body then
17261 Pragma_Misplaced;
17262 return;
17263 end if;
17265 Stmt := Prev (N);
17266 while Present (Stmt) loop
17268 -- Skip prior pragmas, but check for duplicates
17270 if Nkind (Stmt) = N_Pragma then
17271 if Pragma_Name (Stmt) = Pname then
17272 Error_Msg_Name_1 := Pname;
17273 Error_Msg_Sloc := Sloc (Stmt);
17274 Error_Msg_N ("pragma % duplicates pragma declared #", N);
17275 end if;
17277 -- Skip internally generated code
17279 elsif not Comes_From_Source (Stmt) then
17280 null;
17282 -- The pragma does not apply to a legal construct, issue an
17283 -- error and stop the analysis.
17285 else
17286 Pragma_Misplaced;
17287 return;
17288 end if;
17290 Stmt := Prev (Stmt);
17291 end loop;
17293 -- State refinement is allowed only when the corresponding package
17294 -- declaration has a non-null pragma Abstract_State.
17296 Spec_Id := Corresponding_Spec (Context);
17298 if No (Abstract_States (Spec_Id))
17299 or else Has_Null_Abstract_State (Spec_Id)
17300 then
17301 Error_Msg_NE
17302 ("useless refinement, package & does not define abstract "
17303 & "states", N, Spec_Id);
17304 return;
17305 end if;
17307 -- The pragma must be analyzed at the end of the declarations as
17308 -- it has visibility over the whole declarative region. Save the
17309 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
17310 -- adding it to the contract of the package body.
17312 Add_Contract_Item (N, Defining_Entity (Context));
17313 end Refined_State;
17315 -----------------------
17316 -- Relative_Deadline --
17317 -----------------------
17319 -- pragma Relative_Deadline (time_span_EXPRESSION);
17321 when Pragma_Relative_Deadline => Relative_Deadline : declare
17322 P : constant Node_Id := Parent (N);
17323 Arg : Node_Id;
17325 begin
17326 Ada_2005_Pragma;
17327 Check_No_Identifiers;
17328 Check_Arg_Count (1);
17330 Arg := Get_Pragma_Arg (Arg1);
17332 -- The expression must be analyzed in the special manner described
17333 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
17335 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
17337 -- Subprogram case
17339 if Nkind (P) = N_Subprogram_Body then
17340 Check_In_Main_Program;
17342 -- Only Task and subprogram cases allowed
17344 elsif Nkind (P) /= N_Task_Definition then
17345 Pragma_Misplaced;
17346 end if;
17348 -- Check duplicate pragma before we set the corresponding flag
17350 if Has_Relative_Deadline_Pragma (P) then
17351 Error_Pragma ("duplicate pragma% not allowed");
17352 end if;
17354 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
17355 -- Relative_Deadline pragma node cannot be inserted in the Rep
17356 -- Item chain of Ent since it is rewritten by the expander as a
17357 -- procedure call statement that will break the chain.
17359 Set_Has_Relative_Deadline_Pragma (P, True);
17360 end Relative_Deadline;
17362 ------------------------
17363 -- Remote_Access_Type --
17364 ------------------------
17366 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
17368 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
17369 E : Entity_Id;
17371 begin
17372 GNAT_Pragma;
17373 Check_Arg_Count (1);
17374 Check_Optional_Identifier (Arg1, Name_Entity);
17375 Check_Arg_Is_Local_Name (Arg1);
17377 E := Entity (Get_Pragma_Arg (Arg1));
17379 if Nkind (Parent (E)) = N_Formal_Type_Declaration
17380 and then Ekind (E) = E_General_Access_Type
17381 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
17382 and then Scope (Root_Type (Directly_Designated_Type (E)))
17383 = Scope (E)
17384 and then Is_Valid_Remote_Object_Type
17385 (Root_Type (Directly_Designated_Type (E)))
17386 then
17387 Set_Is_Remote_Types (E);
17389 else
17390 Error_Pragma_Arg
17391 ("pragma% applies only to formal access to classwide types",
17392 Arg1);
17393 end if;
17394 end Remote_Access_Type;
17396 ---------------------------
17397 -- Remote_Call_Interface --
17398 ---------------------------
17400 -- pragma Remote_Call_Interface [(library_unit_NAME)];
17402 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
17403 Cunit_Node : Node_Id;
17404 Cunit_Ent : Entity_Id;
17405 K : Node_Kind;
17407 begin
17408 Check_Ada_83_Warning;
17409 Check_Valid_Library_Unit_Pragma;
17411 if Nkind (N) = N_Null_Statement then
17412 return;
17413 end if;
17415 Cunit_Node := Cunit (Current_Sem_Unit);
17416 K := Nkind (Unit (Cunit_Node));
17417 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17419 if K = N_Package_Declaration
17420 or else K = N_Generic_Package_Declaration
17421 or else K = N_Subprogram_Declaration
17422 or else K = N_Generic_Subprogram_Declaration
17423 or else (K = N_Subprogram_Body
17424 and then Acts_As_Spec (Unit (Cunit_Node)))
17425 then
17426 null;
17427 else
17428 Error_Pragma (
17429 "pragma% must apply to package or subprogram declaration");
17430 end if;
17432 Set_Is_Remote_Call_Interface (Cunit_Ent);
17433 end Remote_Call_Interface;
17435 ------------------
17436 -- Remote_Types --
17437 ------------------
17439 -- pragma Remote_Types [(library_unit_NAME)];
17441 when Pragma_Remote_Types => Remote_Types : declare
17442 Cunit_Node : Node_Id;
17443 Cunit_Ent : Entity_Id;
17445 begin
17446 Check_Ada_83_Warning;
17447 Check_Valid_Library_Unit_Pragma;
17449 if Nkind (N) = N_Null_Statement then
17450 return;
17451 end if;
17453 Cunit_Node := Cunit (Current_Sem_Unit);
17454 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17456 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
17457 N_Generic_Package_Declaration)
17458 then
17459 Error_Pragma
17460 ("pragma% can only apply to a package declaration");
17461 end if;
17463 Set_Is_Remote_Types (Cunit_Ent);
17464 end Remote_Types;
17466 ---------------
17467 -- Ravenscar --
17468 ---------------
17470 -- pragma Ravenscar;
17472 when Pragma_Ravenscar =>
17473 GNAT_Pragma;
17474 Check_Arg_Count (0);
17475 Check_Valid_Configuration_Pragma;
17476 Set_Ravenscar_Profile (N);
17478 if Warn_On_Obsolescent_Feature then
17479 Error_Msg_N
17480 ("pragma Ravenscar is an obsolescent feature?j?", N);
17481 Error_Msg_N
17482 ("|use pragma Profile (Ravenscar) instead?j?", N);
17483 end if;
17485 -------------------------
17486 -- Restricted_Run_Time --
17487 -------------------------
17489 -- pragma Restricted_Run_Time;
17491 when Pragma_Restricted_Run_Time =>
17492 GNAT_Pragma;
17493 Check_Arg_Count (0);
17494 Check_Valid_Configuration_Pragma;
17495 Set_Profile_Restrictions
17496 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
17498 if Warn_On_Obsolescent_Feature then
17499 Error_Msg_N
17500 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
17502 Error_Msg_N
17503 ("|use pragma Profile (Restricted) instead?j?", N);
17504 end if;
17506 ------------------
17507 -- Restrictions --
17508 ------------------
17510 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
17512 -- RESTRICTION ::=
17513 -- restriction_IDENTIFIER
17514 -- | restriction_parameter_IDENTIFIER => EXPRESSION
17516 when Pragma_Restrictions =>
17517 Process_Restrictions_Or_Restriction_Warnings
17518 (Warn => Treat_Restrictions_As_Warnings);
17520 --------------------------
17521 -- Restriction_Warnings --
17522 --------------------------
17524 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
17526 -- RESTRICTION ::=
17527 -- restriction_IDENTIFIER
17528 -- | restriction_parameter_IDENTIFIER => EXPRESSION
17530 when Pragma_Restriction_Warnings =>
17531 GNAT_Pragma;
17532 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
17534 ----------------
17535 -- Reviewable --
17536 ----------------
17538 -- pragma Reviewable;
17540 when Pragma_Reviewable =>
17541 Check_Ada_83_Warning;
17542 Check_Arg_Count (0);
17544 -- Call dummy debugging function rv. This is done to assist front
17545 -- end debugging. By placing a Reviewable pragma in the source
17546 -- program, a breakpoint on rv catches this place in the source,
17547 -- allowing convenient stepping to the point of interest.
17551 --------------------------
17552 -- Short_Circuit_And_Or --
17553 --------------------------
17555 -- pragma Short_Circuit_And_Or;
17557 when Pragma_Short_Circuit_And_Or =>
17558 GNAT_Pragma;
17559 Check_Arg_Count (0);
17560 Check_Valid_Configuration_Pragma;
17561 Short_Circuit_And_Or := True;
17563 -------------------
17564 -- Share_Generic --
17565 -------------------
17567 -- pragma Share_Generic (GNAME {, GNAME});
17569 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
17571 when Pragma_Share_Generic =>
17572 GNAT_Pragma;
17573 Process_Generic_List;
17575 ------------
17576 -- Shared --
17577 ------------
17579 -- pragma Shared (LOCAL_NAME);
17581 when Pragma_Shared =>
17582 GNAT_Pragma;
17583 Process_Atomic_Shared_Volatile;
17585 --------------------
17586 -- Shared_Passive --
17587 --------------------
17589 -- pragma Shared_Passive [(library_unit_NAME)];
17591 -- Set the flag Is_Shared_Passive of program unit name entity
17593 when Pragma_Shared_Passive => Shared_Passive : declare
17594 Cunit_Node : Node_Id;
17595 Cunit_Ent : Entity_Id;
17597 begin
17598 Check_Ada_83_Warning;
17599 Check_Valid_Library_Unit_Pragma;
17601 if Nkind (N) = N_Null_Statement then
17602 return;
17603 end if;
17605 Cunit_Node := Cunit (Current_Sem_Unit);
17606 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17608 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
17609 N_Generic_Package_Declaration)
17610 then
17611 Error_Pragma
17612 ("pragma% can only apply to a package declaration");
17613 end if;
17615 Set_Is_Shared_Passive (Cunit_Ent);
17616 end Shared_Passive;
17618 -----------------------
17619 -- Short_Descriptors --
17620 -----------------------
17622 -- pragma Short_Descriptors;
17624 when Pragma_Short_Descriptors =>
17625 GNAT_Pragma;
17626 Check_Arg_Count (0);
17627 Check_Valid_Configuration_Pragma;
17628 Short_Descriptors := True;
17630 ------------------------------
17631 -- Simple_Storage_Pool_Type --
17632 ------------------------------
17634 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
17636 when Pragma_Simple_Storage_Pool_Type =>
17637 Simple_Storage_Pool_Type : declare
17638 Type_Id : Node_Id;
17639 Typ : Entity_Id;
17641 begin
17642 GNAT_Pragma;
17643 Check_Arg_Count (1);
17644 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17646 Type_Id := Get_Pragma_Arg (Arg1);
17647 Find_Type (Type_Id);
17648 Typ := Entity (Type_Id);
17650 if Typ = Any_Type then
17651 return;
17652 end if;
17654 -- We require the pragma to apply to a type declared in a package
17655 -- declaration, but not (immediately) within a package body.
17657 if Ekind (Current_Scope) /= E_Package
17658 or else In_Package_Body (Current_Scope)
17659 then
17660 Error_Pragma
17661 ("pragma% can only apply to type declared immediately "
17662 & "within a package declaration");
17663 end if;
17665 -- A simple storage pool type must be an immutably limited record
17666 -- or private type. If the pragma is given for a private type,
17667 -- the full type is similarly restricted (which is checked later
17668 -- in Freeze_Entity).
17670 if Is_Record_Type (Typ)
17671 and then not Is_Limited_View (Typ)
17672 then
17673 Error_Pragma
17674 ("pragma% can only apply to explicitly limited record type");
17676 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
17677 Error_Pragma
17678 ("pragma% can only apply to a private type that is limited");
17680 elsif not Is_Record_Type (Typ)
17681 and then not Is_Private_Type (Typ)
17682 then
17683 Error_Pragma
17684 ("pragma% can only apply to limited record or private type");
17685 end if;
17687 Record_Rep_Item (Typ, N);
17688 end Simple_Storage_Pool_Type;
17690 ----------------------
17691 -- Source_File_Name --
17692 ----------------------
17694 -- There are five forms for this pragma:
17696 -- pragma Source_File_Name (
17697 -- [UNIT_NAME =>] unit_NAME,
17698 -- BODY_FILE_NAME => STRING_LITERAL
17699 -- [, [INDEX =>] INTEGER_LITERAL]);
17701 -- pragma Source_File_Name (
17702 -- [UNIT_NAME =>] unit_NAME,
17703 -- SPEC_FILE_NAME => STRING_LITERAL
17704 -- [, [INDEX =>] INTEGER_LITERAL]);
17706 -- pragma Source_File_Name (
17707 -- BODY_FILE_NAME => STRING_LITERAL
17708 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17709 -- [, CASING => CASING_SPEC]);
17711 -- pragma Source_File_Name (
17712 -- SPEC_FILE_NAME => STRING_LITERAL
17713 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17714 -- [, CASING => CASING_SPEC]);
17716 -- pragma Source_File_Name (
17717 -- SUBUNIT_FILE_NAME => STRING_LITERAL
17718 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17719 -- [, CASING => CASING_SPEC]);
17721 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
17723 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
17724 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
17725 -- only be used when no project file is used, while SFNP can only be
17726 -- used when a project file is used.
17728 -- No processing here. Processing was completed during parsing, since
17729 -- we need to have file names set as early as possible. Units are
17730 -- loaded well before semantic processing starts.
17732 -- The only processing we defer to this point is the check for
17733 -- correct placement.
17735 when Pragma_Source_File_Name =>
17736 GNAT_Pragma;
17737 Check_Valid_Configuration_Pragma;
17739 ------------------------------
17740 -- Source_File_Name_Project --
17741 ------------------------------
17743 -- See Source_File_Name for syntax
17745 -- No processing here. Processing was completed during parsing, since
17746 -- we need to have file names set as early as possible. Units are
17747 -- loaded well before semantic processing starts.
17749 -- The only processing we defer to this point is the check for
17750 -- correct placement.
17752 when Pragma_Source_File_Name_Project =>
17753 GNAT_Pragma;
17754 Check_Valid_Configuration_Pragma;
17756 -- Check that a pragma Source_File_Name_Project is used only in a
17757 -- configuration pragmas file.
17759 -- Pragmas Source_File_Name_Project should only be generated by
17760 -- the Project Manager in configuration pragmas files.
17762 -- This is really an ugly test. It seems to depend on some
17763 -- accidental and undocumented property. At the very least it
17764 -- needs to be documented, but it would be better to have a
17765 -- clean way of testing if we are in a configuration file???
17767 if Present (Parent (N)) then
17768 Error_Pragma
17769 ("pragma% can only appear in a configuration pragmas file");
17770 end if;
17772 ----------------------
17773 -- Source_Reference --
17774 ----------------------
17776 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
17778 -- Nothing to do, all processing completed in Par.Prag, since we need
17779 -- the information for possible parser messages that are output.
17781 when Pragma_Source_Reference =>
17782 GNAT_Pragma;
17784 ----------------
17785 -- SPARK_Mode --
17786 ----------------
17788 -- pragma SPARK_Mode [(On | Off | Auto)];
17790 when Pragma_SPARK_Mode => SPARK_Mod : declare
17791 procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id);
17792 -- Associate a SPARK_Mode pragma with the context where it lives.
17793 -- If the context is a package spec or a body, the routine checks
17794 -- the consistency between modes of visible/private declarations
17795 -- and body declarations/statements.
17797 procedure Check_Spark_Mode_Conformance
17798 (Governing_Id : Entity_Id;
17799 New_Id : Entity_Id);
17800 -- Verify the "monotonicity" of SPARK modes between two entities.
17801 -- The order of modes is Off < Auto < On. Governing_Id establishes
17802 -- the mode of the context. New_Id attempts to redefine the known
17803 -- mode.
17805 procedure Check_Pragma_Conformance
17806 (Governing_Mode : Node_Id;
17807 New_Mode : Node_Id);
17808 -- Verify the "monotonicity" of two SPARK_Mode pragmas. The order
17809 -- of modes is Off < Auto < On. Governing_Mode is the established
17810 -- mode dictated by the context. New_Mode attempts to redefine the
17811 -- governing mode.
17813 function Get_SPARK_Mode_Name (Id : SPARK_Mode_Id) return Name_Id;
17814 -- Convert a value of type SPARK_Mode_Id into a corresponding name
17816 ------------------
17817 -- Chain_Pragma --
17818 ------------------
17820 procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id) is
17821 Existing_Prag : constant Node_Id :=
17822 SPARK_Mode_Pragmas (Context);
17823 begin
17824 -- The context does not have a prior mode defined
17826 if No (Existing_Prag) then
17827 Set_SPARK_Mode_Pragmas (Context, Prag);
17829 -- Chain the new mode on the list of SPARK_Mode pragmas. Verify
17830 -- the consistency between the existing mode and the new one.
17832 else
17833 Set_Next_Pragma (Existing_Prag, Prag);
17835 Check_Pragma_Conformance
17836 (Governing_Mode => Existing_Prag,
17837 New_Mode => Prag);
17838 end if;
17839 end Chain_Pragma;
17841 ----------------------------------
17842 -- Check_Spark_Mode_Conformance --
17843 ----------------------------------
17845 procedure Check_Spark_Mode_Conformance
17846 (Governing_Id : Entity_Id;
17847 New_Id : Entity_Id)
17849 Gov_Prag : constant Node_Id :=
17850 SPARK_Mode_Pragmas (Governing_Id);
17851 New_Prag : constant Node_Id := SPARK_Mode_Pragmas (New_Id);
17853 begin
17854 -- Nothing to do when one or both entities lack a mode
17856 if No (Gov_Prag) or else No (New_Prag) then
17857 return;
17858 end if;
17860 -- Do not compare the modes of a package spec and body when the
17861 -- spec mode appears in the private part. In this case the spec
17862 -- mode does not affect the body.
17864 if Ekind_In (Governing_Id, E_Generic_Package, E_Package)
17865 and then Ekind (New_Id) = E_Package_Body
17866 and then Is_Private_SPARK_Mode (Gov_Prag)
17867 then
17868 null;
17870 -- Test the pragmas
17872 else
17873 Check_Pragma_Conformance
17874 (Governing_Mode => Gov_Prag,
17875 New_Mode => New_Prag);
17876 end if;
17877 end Check_Spark_Mode_Conformance;
17879 ------------------------------
17880 -- Check_Pragma_Conformance --
17881 ------------------------------
17883 procedure Check_Pragma_Conformance
17884 (Governing_Mode : Node_Id;
17885 New_Mode : Node_Id)
17887 Gov_M : constant SPARK_Mode_Id :=
17888 Get_SPARK_Mode_Id (Governing_Mode);
17889 New_M : constant SPARK_Mode_Id := Get_SPARK_Mode_Id (New_Mode);
17891 begin
17892 -- The new mode is less restrictive than the established mode
17894 if Gov_M < New_M then
17895 Error_Msg_Name_1 := Get_SPARK_Mode_Name (New_M);
17896 Error_Msg_N ("cannot define 'S'P'A'R'K mode %", New_Mode);
17898 Error_Msg_Name_1 := Get_SPARK_Mode_Name (Gov_M);
17899 Error_Msg_Sloc := Sloc (Governing_Mode);
17900 Error_Msg_N
17901 ("\mode is less restrictive than mode % defined #",
17902 New_Mode);
17903 end if;
17904 end Check_Pragma_Conformance;
17906 -------------------------
17907 -- Get_SPARK_Mode_Name --
17908 -------------------------
17910 function Get_SPARK_Mode_Name (Id : SPARK_Mode_Id) return Name_Id is
17911 begin
17912 if Id = SPARK_On then
17913 return Name_On;
17914 elsif Id = SPARK_Off then
17915 return Name_Off;
17916 elsif Id = SPARK_Auto then
17917 return Name_Auto;
17919 -- Mode "None" should never be used in error message generation
17921 else
17922 raise Program_Error;
17923 end if;
17924 end Get_SPARK_Mode_Name;
17926 -- Local variables
17928 Body_Id : Entity_Id;
17929 Context : Node_Id;
17930 Mode : Name_Id;
17931 Mode_Id : SPARK_Mode_Id;
17932 Spec_Id : Entity_Id;
17933 Stmt : Node_Id;
17935 -- Start of processing for SPARK_Mode
17937 begin
17938 GNAT_Pragma;
17939 Check_No_Identifiers;
17940 Check_At_Most_N_Arguments (1);
17942 -- Check the legality of the mode
17944 if Arg_Count = 1 then
17945 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off, Name_Auto);
17946 Mode := Chars (Get_Pragma_Arg (Arg1));
17948 -- A SPARK_Mode without an argument defaults to "On"
17950 else
17951 Mode := Name_On;
17952 end if;
17954 Mode_Id := Get_SPARK_Mode_Id (Mode);
17955 Context := Parent (N);
17957 -- The pragma appears in a configuration file
17959 if No (Context) then
17960 Check_Valid_Configuration_Pragma;
17961 Global_SPARK_Mode := Mode_Id;
17963 -- When the pragma is placed before the declaration of a unit, it
17964 -- configures the whole unit.
17966 elsif Nkind (Context) = N_Compilation_Unit then
17967 Check_Valid_Configuration_Pragma;
17968 Set_SPARK_Mode_Pragma (Current_Sem_Unit, N);
17970 -- The pragma applies to a [library unit] subprogram or package
17972 else
17973 -- Mode "Auto" cannot be used in nested subprograms or packages
17975 if Mode_Id = SPARK_Auto then
17976 Error_Pragma_Arg
17977 ("mode `Auto` can only apply to the configuration variant "
17978 & "of pragma %", Arg1);
17979 end if;
17981 -- Verify the placement of the pragma with respect to package
17982 -- or subprogram declarations and detect duplicates.
17984 Stmt := Prev (N);
17985 while Present (Stmt) loop
17987 -- Skip prior pragmas, but check for duplicates
17989 if Nkind (Stmt) = N_Pragma then
17990 if Pragma_Name (Stmt) = Pname then
17991 Error_Msg_Name_1 := Pname;
17992 Error_Msg_Sloc := Sloc (Stmt);
17993 Error_Msg_N
17994 ("pragma % duplicates pragma declared #", N);
17995 end if;
17997 -- Skip internally generated code
17999 elsif not Comes_From_Source (Stmt) then
18000 null;
18002 -- The pragma applies to a package or subprogram declaration
18004 elsif Nkind_In (Stmt, N_Generic_Package_Declaration,
18005 N_Generic_Subprogram_Declaration,
18006 N_Package_Declaration,
18007 N_Subprogram_Declaration)
18008 then
18009 Spec_Id := Defining_Unit_Name (Specification (Stmt));
18010 Chain_Pragma (Spec_Id, N);
18011 return;
18013 -- The pragma does not apply to a legal construct, issue an
18014 -- error and stop the analysis.
18016 else
18017 Pragma_Misplaced;
18018 exit;
18019 end if;
18021 Stmt := Prev (Stmt);
18022 end loop;
18024 -- Handle all cases where the pragma is actually an aspect and
18025 -- applies to a library-level package spec, body or subprogram.
18027 -- function F ... with SPARK_Mode => ...;
18028 -- package P with SPARK_Mode => ...;
18029 -- package body P with SPARK_Mode => ... is
18031 -- The following circuitry simply prepares the proper context
18032 -- for the general pragma processing mechanism below.
18034 if Nkind (Context) = N_Compilation_Unit_Aux then
18035 Context := Unit (Parent (Context));
18037 if Nkind_In (Context, N_Package_Declaration,
18038 N_Subprogram_Declaration)
18039 then
18040 Context := Specification (Context);
18041 end if;
18042 end if;
18044 -- The pragma is at the top level of a package spec or appears
18045 -- as an aspect on a subprogram.
18047 -- function F ... with SPARK_Mode => ...;
18049 -- package P is
18050 -- pragma SPARK_Mode;
18052 if Nkind_In (Context, N_Function_Specification,
18053 N_Package_Specification,
18054 N_Procedure_Specification)
18055 then
18056 Spec_Id := Defining_Unit_Name (Context);
18057 Chain_Pragma (Spec_Id, N);
18059 -- The pragma is immediately within a package or subprogram
18060 -- body.
18062 -- function F ... is
18063 -- pragma SPARK_Mode;
18065 -- package body P is
18066 -- pragma SPARK_Mode;
18068 elsif Nkind_In (Context, N_Package_Body,
18069 N_Subprogram_Body)
18070 then
18071 Spec_Id := Corresponding_Spec (Context);
18073 if Nkind (Context) = N_Subprogram_Body then
18074 Context := Specification (Context);
18075 end if;
18077 Body_Id := Defining_Unit_Name (Context);
18079 Chain_Pragma (Body_Id, N);
18081 -- Verify that the SPARK modes are consistent between
18082 -- body and spec, if any.
18084 if Present (Spec_Id) then
18085 Check_Spark_Mode_Conformance (Spec_Id, Body_Id);
18086 end if;
18088 -- The pragma applies to the statements of a package body
18090 -- package body P is
18091 -- begin
18092 -- pragma SPARK_Mode;
18094 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
18095 and then Nkind (Parent (Context)) = N_Package_Body
18096 then
18097 Context := Parent (Context);
18098 Spec_Id := Corresponding_Spec (Context);
18099 Body_Id := Defining_Unit_Name (Context);
18101 Chain_Pragma (Body_Id, N);
18102 Check_Spark_Mode_Conformance (Spec_Id, Body_Id);
18104 -- The pragma does not apply to a legal construct, issue error
18106 else
18107 Pragma_Misplaced;
18108 end if;
18109 end if;
18110 end SPARK_Mod;
18112 --------------------------------
18113 -- Static_Elaboration_Desired --
18114 --------------------------------
18116 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
18118 when Pragma_Static_Elaboration_Desired =>
18119 GNAT_Pragma;
18120 Check_At_Most_N_Arguments (1);
18122 if Is_Compilation_Unit (Current_Scope)
18123 and then Ekind (Current_Scope) = E_Package
18124 then
18125 Set_Static_Elaboration_Desired (Current_Scope, True);
18126 else
18127 Error_Pragma ("pragma% must apply to a library-level package");
18128 end if;
18130 ------------------
18131 -- Storage_Size --
18132 ------------------
18134 -- pragma Storage_Size (EXPRESSION);
18136 when Pragma_Storage_Size => Storage_Size : declare
18137 P : constant Node_Id := Parent (N);
18138 Arg : Node_Id;
18140 begin
18141 Check_No_Identifiers;
18142 Check_Arg_Count (1);
18144 -- The expression must be analyzed in the special manner described
18145 -- in "Handling of Default Expressions" in sem.ads.
18147 Arg := Get_Pragma_Arg (Arg1);
18148 Preanalyze_Spec_Expression (Arg, Any_Integer);
18150 if not Is_Static_Expression (Arg) then
18151 Check_Restriction (Static_Storage_Size, Arg);
18152 end if;
18154 if Nkind (P) /= N_Task_Definition then
18155 Pragma_Misplaced;
18156 return;
18158 else
18159 if Has_Storage_Size_Pragma (P) then
18160 Error_Pragma ("duplicate pragma% not allowed");
18161 else
18162 Set_Has_Storage_Size_Pragma (P, True);
18163 end if;
18165 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
18166 end if;
18167 end Storage_Size;
18169 ------------------
18170 -- Storage_Unit --
18171 ------------------
18173 -- pragma Storage_Unit (NUMERIC_LITERAL);
18175 -- Only permitted argument is System'Storage_Unit value
18177 when Pragma_Storage_Unit =>
18178 Check_No_Identifiers;
18179 Check_Arg_Count (1);
18180 Check_Arg_Is_Integer_Literal (Arg1);
18182 if Intval (Get_Pragma_Arg (Arg1)) /=
18183 UI_From_Int (Ttypes.System_Storage_Unit)
18184 then
18185 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
18186 Error_Pragma_Arg
18187 ("the only allowed argument for pragma% is ^", Arg1);
18188 end if;
18190 --------------------
18191 -- Stream_Convert --
18192 --------------------
18194 -- pragma Stream_Convert (
18195 -- [Entity =>] type_LOCAL_NAME,
18196 -- [Read =>] function_NAME,
18197 -- [Write =>] function NAME);
18199 when Pragma_Stream_Convert => Stream_Convert : declare
18201 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
18202 -- Check that the given argument is the name of a local function
18203 -- of one argument that is not overloaded earlier in the current
18204 -- local scope. A check is also made that the argument is a
18205 -- function with one parameter.
18207 --------------------------------------
18208 -- Check_OK_Stream_Convert_Function --
18209 --------------------------------------
18211 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
18212 Ent : Entity_Id;
18214 begin
18215 Check_Arg_Is_Local_Name (Arg);
18216 Ent := Entity (Get_Pragma_Arg (Arg));
18218 if Has_Homonym (Ent) then
18219 Error_Pragma_Arg
18220 ("argument for pragma% may not be overloaded", Arg);
18221 end if;
18223 if Ekind (Ent) /= E_Function
18224 or else No (First_Formal (Ent))
18225 or else Present (Next_Formal (First_Formal (Ent)))
18226 then
18227 Error_Pragma_Arg
18228 ("argument for pragma% must be function of one argument",
18229 Arg);
18230 end if;
18231 end Check_OK_Stream_Convert_Function;
18233 -- Start of processing for Stream_Convert
18235 begin
18236 GNAT_Pragma;
18237 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
18238 Check_Arg_Count (3);
18239 Check_Optional_Identifier (Arg1, Name_Entity);
18240 Check_Optional_Identifier (Arg2, Name_Read);
18241 Check_Optional_Identifier (Arg3, Name_Write);
18242 Check_Arg_Is_Local_Name (Arg1);
18243 Check_OK_Stream_Convert_Function (Arg2);
18244 Check_OK_Stream_Convert_Function (Arg3);
18246 declare
18247 Typ : constant Entity_Id :=
18248 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
18249 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
18250 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
18252 begin
18253 Check_First_Subtype (Arg1);
18255 -- Check for too early or too late. Note that we don't enforce
18256 -- the rule about primitive operations in this case, since, as
18257 -- is the case for explicit stream attributes themselves, these
18258 -- restrictions are not appropriate. Note that the chaining of
18259 -- the pragma by Rep_Item_Too_Late is actually the critical
18260 -- processing done for this pragma.
18262 if Rep_Item_Too_Early (Typ, N)
18263 or else
18264 Rep_Item_Too_Late (Typ, N, FOnly => True)
18265 then
18266 return;
18267 end if;
18269 -- Return if previous error
18271 if Etype (Typ) = Any_Type
18272 or else
18273 Etype (Read) = Any_Type
18274 or else
18275 Etype (Write) = Any_Type
18276 then
18277 return;
18278 end if;
18280 -- Error checks
18282 if Underlying_Type (Etype (Read)) /= Typ then
18283 Error_Pragma_Arg
18284 ("incorrect return type for function&", Arg2);
18285 end if;
18287 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
18288 Error_Pragma_Arg
18289 ("incorrect parameter type for function&", Arg3);
18290 end if;
18292 if Underlying_Type (Etype (First_Formal (Read))) /=
18293 Underlying_Type (Etype (Write))
18294 then
18295 Error_Pragma_Arg
18296 ("result type of & does not match Read parameter type",
18297 Arg3);
18298 end if;
18299 end;
18300 end Stream_Convert;
18302 ------------------
18303 -- Style_Checks --
18304 ------------------
18306 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
18308 -- This is processed by the parser since some of the style checks
18309 -- take place during source scanning and parsing. This means that
18310 -- we don't need to issue error messages here.
18312 when Pragma_Style_Checks => Style_Checks : declare
18313 A : constant Node_Id := Get_Pragma_Arg (Arg1);
18314 S : String_Id;
18315 C : Char_Code;
18317 begin
18318 GNAT_Pragma;
18319 Check_No_Identifiers;
18321 -- Two argument form
18323 if Arg_Count = 2 then
18324 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18326 declare
18327 E_Id : Node_Id;
18328 E : Entity_Id;
18330 begin
18331 E_Id := Get_Pragma_Arg (Arg2);
18332 Analyze (E_Id);
18334 if not Is_Entity_Name (E_Id) then
18335 Error_Pragma_Arg
18336 ("second argument of pragma% must be entity name",
18337 Arg2);
18338 end if;
18340 E := Entity (E_Id);
18342 if not Ignore_Style_Checks_Pragmas then
18343 if E = Any_Id then
18344 return;
18345 else
18346 loop
18347 Set_Suppress_Style_Checks
18348 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
18349 exit when No (Homonym (E));
18350 E := Homonym (E);
18351 end loop;
18352 end if;
18353 end if;
18354 end;
18356 -- One argument form
18358 else
18359 Check_Arg_Count (1);
18361 if Nkind (A) = N_String_Literal then
18362 S := Strval (A);
18364 declare
18365 Slen : constant Natural := Natural (String_Length (S));
18366 Options : String (1 .. Slen);
18367 J : Natural;
18369 begin
18370 J := 1;
18371 loop
18372 C := Get_String_Char (S, Int (J));
18373 exit when not In_Character_Range (C);
18374 Options (J) := Get_Character (C);
18376 -- If at end of string, set options. As per discussion
18377 -- above, no need to check for errors, since we issued
18378 -- them in the parser.
18380 if J = Slen then
18381 if not Ignore_Style_Checks_Pragmas then
18382 Set_Style_Check_Options (Options);
18383 end if;
18385 exit;
18386 end if;
18388 J := J + 1;
18389 end loop;
18390 end;
18392 elsif Nkind (A) = N_Identifier then
18393 if Chars (A) = Name_All_Checks then
18394 if not Ignore_Style_Checks_Pragmas then
18395 if GNAT_Mode then
18396 Set_GNAT_Style_Check_Options;
18397 else
18398 Set_Default_Style_Check_Options;
18399 end if;
18400 end if;
18402 elsif Chars (A) = Name_On then
18403 if not Ignore_Style_Checks_Pragmas then
18404 Style_Check := True;
18405 end if;
18407 elsif Chars (A) = Name_Off then
18408 if not Ignore_Style_Checks_Pragmas then
18409 Style_Check := False;
18410 end if;
18411 end if;
18412 end if;
18413 end if;
18414 end Style_Checks;
18416 --------------
18417 -- Subtitle --
18418 --------------
18420 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
18422 when Pragma_Subtitle =>
18423 GNAT_Pragma;
18424 Check_Arg_Count (1);
18425 Check_Optional_Identifier (Arg1, Name_Subtitle);
18426 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
18427 Store_Note (N);
18429 --------------
18430 -- Suppress --
18431 --------------
18433 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
18435 when Pragma_Suppress =>
18436 Process_Suppress_Unsuppress (True);
18438 ------------------
18439 -- Suppress_All --
18440 ------------------
18442 -- pragma Suppress_All;
18444 -- The only check made here is that the pragma has no arguments.
18445 -- There are no placement rules, and the processing required (setting
18446 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
18447 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
18448 -- then creates and inserts a pragma Suppress (All_Checks).
18450 when Pragma_Suppress_All =>
18451 GNAT_Pragma;
18452 Check_Arg_Count (0);
18454 -------------------------
18455 -- Suppress_Debug_Info --
18456 -------------------------
18458 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
18460 when Pragma_Suppress_Debug_Info =>
18461 GNAT_Pragma;
18462 Check_Arg_Count (1);
18463 Check_Optional_Identifier (Arg1, Name_Entity);
18464 Check_Arg_Is_Local_Name (Arg1);
18465 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
18467 ----------------------------------
18468 -- Suppress_Exception_Locations --
18469 ----------------------------------
18471 -- pragma Suppress_Exception_Locations;
18473 when Pragma_Suppress_Exception_Locations =>
18474 GNAT_Pragma;
18475 Check_Arg_Count (0);
18476 Check_Valid_Configuration_Pragma;
18477 Exception_Locations_Suppressed := True;
18479 -----------------------------
18480 -- Suppress_Initialization --
18481 -----------------------------
18483 -- pragma Suppress_Initialization ([Entity =>] type_Name);
18485 when Pragma_Suppress_Initialization => Suppress_Init : declare
18486 E_Id : Node_Id;
18487 E : Entity_Id;
18489 begin
18490 GNAT_Pragma;
18491 Check_Arg_Count (1);
18492 Check_Optional_Identifier (Arg1, Name_Entity);
18493 Check_Arg_Is_Local_Name (Arg1);
18495 E_Id := Get_Pragma_Arg (Arg1);
18497 if Etype (E_Id) = Any_Type then
18498 return;
18499 end if;
18501 E := Entity (E_Id);
18503 if not Is_Type (E) then
18504 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
18505 end if;
18507 if Rep_Item_Too_Early (E, N)
18508 or else
18509 Rep_Item_Too_Late (E, N, FOnly => True)
18510 then
18511 return;
18512 end if;
18514 -- For incomplete/private type, set flag on full view
18516 if Is_Incomplete_Or_Private_Type (E) then
18517 if No (Full_View (Base_Type (E))) then
18518 Error_Pragma_Arg
18519 ("argument of pragma% cannot be an incomplete type", Arg1);
18520 else
18521 Set_Suppress_Initialization (Full_View (Base_Type (E)));
18522 end if;
18524 -- For first subtype, set flag on base type
18526 elsif Is_First_Subtype (E) then
18527 Set_Suppress_Initialization (Base_Type (E));
18529 -- For other than first subtype, set flag on subtype itself
18531 else
18532 Set_Suppress_Initialization (E);
18533 end if;
18534 end Suppress_Init;
18536 -----------------
18537 -- System_Name --
18538 -----------------
18540 -- pragma System_Name (DIRECT_NAME);
18542 -- Syntax check: one argument, which must be the identifier GNAT or
18543 -- the identifier GCC, no other identifiers are acceptable.
18545 when Pragma_System_Name =>
18546 GNAT_Pragma;
18547 Check_No_Identifiers;
18548 Check_Arg_Count (1);
18549 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
18551 -----------------------------
18552 -- Task_Dispatching_Policy --
18553 -----------------------------
18555 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
18557 when Pragma_Task_Dispatching_Policy => declare
18558 DP : Character;
18560 begin
18561 Check_Ada_83_Warning;
18562 Check_Arg_Count (1);
18563 Check_No_Identifiers;
18564 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18565 Check_Valid_Configuration_Pragma;
18566 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18567 DP := Fold_Upper (Name_Buffer (1));
18569 if Task_Dispatching_Policy /= ' '
18570 and then Task_Dispatching_Policy /= DP
18571 then
18572 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18573 Error_Pragma
18574 ("task dispatching policy incompatible with policy#");
18576 -- Set new policy, but always preserve System_Location since we
18577 -- like the error message with the run time name.
18579 else
18580 Task_Dispatching_Policy := DP;
18582 if Task_Dispatching_Policy_Sloc /= System_Location then
18583 Task_Dispatching_Policy_Sloc := Loc;
18584 end if;
18585 end if;
18586 end;
18588 ---------------
18589 -- Task_Info --
18590 ---------------
18592 -- pragma Task_Info (EXPRESSION);
18594 when Pragma_Task_Info => Task_Info : declare
18595 P : constant Node_Id := Parent (N);
18596 Ent : Entity_Id;
18598 begin
18599 GNAT_Pragma;
18601 if Nkind (P) /= N_Task_Definition then
18602 Error_Pragma ("pragma% must appear in task definition");
18603 end if;
18605 Check_No_Identifiers;
18606 Check_Arg_Count (1);
18608 Analyze_And_Resolve
18609 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
18611 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
18612 return;
18613 end if;
18615 Ent := Defining_Identifier (Parent (P));
18617 -- Check duplicate pragma before we chain the pragma in the Rep
18618 -- Item chain of Ent.
18620 if Has_Rep_Pragma
18621 (Ent, Name_Task_Info, Check_Parents => False)
18622 then
18623 Error_Pragma ("duplicate pragma% not allowed");
18624 end if;
18626 Record_Rep_Item (Ent, N);
18627 end Task_Info;
18629 ---------------
18630 -- Task_Name --
18631 ---------------
18633 -- pragma Task_Name (string_EXPRESSION);
18635 when Pragma_Task_Name => Task_Name : declare
18636 P : constant Node_Id := Parent (N);
18637 Arg : Node_Id;
18638 Ent : Entity_Id;
18640 begin
18641 Check_No_Identifiers;
18642 Check_Arg_Count (1);
18644 Arg := Get_Pragma_Arg (Arg1);
18646 -- The expression is used in the call to Create_Task, and must be
18647 -- expanded there, not in the context of the current spec. It must
18648 -- however be analyzed to capture global references, in case it
18649 -- appears in a generic context.
18651 Preanalyze_And_Resolve (Arg, Standard_String);
18653 if Nkind (P) /= N_Task_Definition then
18654 Pragma_Misplaced;
18655 end if;
18657 Ent := Defining_Identifier (Parent (P));
18659 -- Check duplicate pragma before we chain the pragma in the Rep
18660 -- Item chain of Ent.
18662 if Has_Rep_Pragma
18663 (Ent, Name_Task_Name, Check_Parents => False)
18664 then
18665 Error_Pragma ("duplicate pragma% not allowed");
18666 end if;
18668 Record_Rep_Item (Ent, N);
18669 end Task_Name;
18671 ------------------
18672 -- Task_Storage --
18673 ------------------
18675 -- pragma Task_Storage (
18676 -- [Task_Type =>] LOCAL_NAME,
18677 -- [Top_Guard =>] static_integer_EXPRESSION);
18679 when Pragma_Task_Storage => Task_Storage : declare
18680 Args : Args_List (1 .. 2);
18681 Names : constant Name_List (1 .. 2) := (
18682 Name_Task_Type,
18683 Name_Top_Guard);
18685 Task_Type : Node_Id renames Args (1);
18686 Top_Guard : Node_Id renames Args (2);
18688 Ent : Entity_Id;
18690 begin
18691 GNAT_Pragma;
18692 Gather_Associations (Names, Args);
18694 if No (Task_Type) then
18695 Error_Pragma
18696 ("missing task_type argument for pragma%");
18697 end if;
18699 Check_Arg_Is_Local_Name (Task_Type);
18701 Ent := Entity (Task_Type);
18703 if not Is_Task_Type (Ent) then
18704 Error_Pragma_Arg
18705 ("argument for pragma% must be task type", Task_Type);
18706 end if;
18708 if No (Top_Guard) then
18709 Error_Pragma_Arg
18710 ("pragma% takes two arguments", Task_Type);
18711 else
18712 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
18713 end if;
18715 Check_First_Subtype (Task_Type);
18717 if Rep_Item_Too_Late (Ent, N) then
18718 raise Pragma_Exit;
18719 end if;
18720 end Task_Storage;
18722 ---------------
18723 -- Test_Case --
18724 ---------------
18726 -- pragma Test_Case
18727 -- ([Name =>] Static_String_EXPRESSION
18728 -- ,[Mode =>] MODE_TYPE
18729 -- [, Requires => Boolean_EXPRESSION]
18730 -- [, Ensures => Boolean_EXPRESSION]);
18732 -- MODE_TYPE ::= Nominal | Robustness
18734 when Pragma_Test_Case =>
18735 GNAT_Pragma;
18736 Check_Test_Case;
18738 --------------------------
18739 -- Thread_Local_Storage --
18740 --------------------------
18742 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
18744 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
18745 Id : Node_Id;
18746 E : Entity_Id;
18748 begin
18749 GNAT_Pragma;
18750 Check_Arg_Count (1);
18751 Check_Optional_Identifier (Arg1, Name_Entity);
18752 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18754 Id := Get_Pragma_Arg (Arg1);
18755 Analyze (Id);
18757 if not Is_Entity_Name (Id)
18758 or else Ekind (Entity (Id)) /= E_Variable
18759 then
18760 Error_Pragma_Arg ("local variable name required", Arg1);
18761 end if;
18763 E := Entity (Id);
18765 if Rep_Item_Too_Early (E, N)
18766 or else Rep_Item_Too_Late (E, N)
18767 then
18768 raise Pragma_Exit;
18769 end if;
18771 Set_Has_Pragma_Thread_Local_Storage (E);
18772 Set_Has_Gigi_Rep_Item (E);
18773 end Thread_Local_Storage;
18775 ----------------
18776 -- Time_Slice --
18777 ----------------
18779 -- pragma Time_Slice (static_duration_EXPRESSION);
18781 when Pragma_Time_Slice => Time_Slice : declare
18782 Val : Ureal;
18783 Nod : Node_Id;
18785 begin
18786 GNAT_Pragma;
18787 Check_Arg_Count (1);
18788 Check_No_Identifiers;
18789 Check_In_Main_Program;
18790 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
18792 if not Error_Posted (Arg1) then
18793 Nod := Next (N);
18794 while Present (Nod) loop
18795 if Nkind (Nod) = N_Pragma
18796 and then Pragma_Name (Nod) = Name_Time_Slice
18797 then
18798 Error_Msg_Name_1 := Pname;
18799 Error_Msg_N ("duplicate pragma% not permitted", Nod);
18800 end if;
18802 Next (Nod);
18803 end loop;
18804 end if;
18806 -- Process only if in main unit
18808 if Get_Source_Unit (Loc) = Main_Unit then
18809 Opt.Time_Slice_Set := True;
18810 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
18812 if Val <= Ureal_0 then
18813 Opt.Time_Slice_Value := 0;
18815 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
18816 Opt.Time_Slice_Value := 1_000_000_000;
18818 else
18819 Opt.Time_Slice_Value :=
18820 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
18821 end if;
18822 end if;
18823 end Time_Slice;
18825 -----------
18826 -- Title --
18827 -----------
18829 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
18831 -- TITLING_OPTION ::=
18832 -- [Title =>] STRING_LITERAL
18833 -- | [Subtitle =>] STRING_LITERAL
18835 when Pragma_Title => Title : declare
18836 Args : Args_List (1 .. 2);
18837 Names : constant Name_List (1 .. 2) := (
18838 Name_Title,
18839 Name_Subtitle);
18841 begin
18842 GNAT_Pragma;
18843 Gather_Associations (Names, Args);
18844 Store_Note (N);
18846 for J in 1 .. 2 loop
18847 if Present (Args (J)) then
18848 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
18849 end if;
18850 end loop;
18851 end Title;
18853 ----------------------------
18854 -- Type_Invariant[_Class] --
18855 ----------------------------
18857 -- pragma Type_Invariant[_Class]
18858 -- ([Entity =>] type_LOCAL_NAME,
18859 -- [Check =>] EXPRESSION);
18861 when Pragma_Type_Invariant |
18862 Pragma_Type_Invariant_Class =>
18863 Type_Invariant : declare
18864 I_Pragma : Node_Id;
18866 begin
18867 Check_Arg_Count (2);
18869 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
18870 -- setting Class_Present for the Type_Invariant_Class case.
18872 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
18873 I_Pragma := New_Copy (N);
18874 Set_Pragma_Identifier
18875 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
18876 Rewrite (N, I_Pragma);
18877 Set_Analyzed (N, False);
18878 Analyze (N);
18879 end Type_Invariant;
18881 ---------------------
18882 -- Unchecked_Union --
18883 ---------------------
18885 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
18887 when Pragma_Unchecked_Union => Unchecked_Union : declare
18888 Assoc : constant Node_Id := Arg1;
18889 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
18890 Typ : Entity_Id;
18891 Tdef : Node_Id;
18892 Clist : Node_Id;
18893 Vpart : Node_Id;
18894 Comp : Node_Id;
18895 Variant : Node_Id;
18897 begin
18898 Ada_2005_Pragma;
18899 Check_No_Identifiers;
18900 Check_Arg_Count (1);
18901 Check_Arg_Is_Local_Name (Arg1);
18903 Find_Type (Type_Id);
18905 Typ := Entity (Type_Id);
18907 if Typ = Any_Type
18908 or else Rep_Item_Too_Early (Typ, N)
18909 then
18910 return;
18911 else
18912 Typ := Underlying_Type (Typ);
18913 end if;
18915 if Rep_Item_Too_Late (Typ, N) then
18916 return;
18917 end if;
18919 Check_First_Subtype (Arg1);
18921 -- Note remaining cases are references to a type in the current
18922 -- declarative part. If we find an error, we post the error on
18923 -- the relevant type declaration at an appropriate point.
18925 if not Is_Record_Type (Typ) then
18926 Error_Msg_N ("unchecked union must be record type", Typ);
18927 return;
18929 elsif Is_Tagged_Type (Typ) then
18930 Error_Msg_N ("unchecked union must not be tagged", Typ);
18931 return;
18933 elsif not Has_Discriminants (Typ) then
18934 Error_Msg_N
18935 ("unchecked union must have one discriminant", Typ);
18936 return;
18938 -- Note: in previous versions of GNAT we used to check for limited
18939 -- types and give an error, but in fact the standard does allow
18940 -- Unchecked_Union on limited types, so this check was removed.
18942 -- Similarly, GNAT used to require that all discriminants have
18943 -- default values, but this is not mandated by the RM.
18945 -- Proceed with basic error checks completed
18947 else
18948 Tdef := Type_Definition (Declaration_Node (Typ));
18949 Clist := Component_List (Tdef);
18951 -- Check presence of component list and variant part
18953 if No (Clist) or else No (Variant_Part (Clist)) then
18954 Error_Msg_N
18955 ("unchecked union must have variant part", Tdef);
18956 return;
18957 end if;
18959 -- Check components
18961 Comp := First (Component_Items (Clist));
18962 while Present (Comp) loop
18963 Check_Component (Comp, Typ);
18964 Next (Comp);
18965 end loop;
18967 -- Check variant part
18969 Vpart := Variant_Part (Clist);
18971 Variant := First (Variants (Vpart));
18972 while Present (Variant) loop
18973 Check_Variant (Variant, Typ);
18974 Next (Variant);
18975 end loop;
18976 end if;
18978 Set_Is_Unchecked_Union (Typ);
18979 Set_Convention (Typ, Convention_C);
18980 Set_Has_Unchecked_Union (Base_Type (Typ));
18981 Set_Is_Unchecked_Union (Base_Type (Typ));
18982 end Unchecked_Union;
18984 ------------------------
18985 -- Unimplemented_Unit --
18986 ------------------------
18988 -- pragma Unimplemented_Unit;
18990 -- Note: this only gives an error if we are generating code, or if
18991 -- we are in a generic library unit (where the pragma appears in the
18992 -- body, not in the spec).
18994 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
18995 Cunitent : constant Entity_Id :=
18996 Cunit_Entity (Get_Source_Unit (Loc));
18997 Ent_Kind : constant Entity_Kind :=
18998 Ekind (Cunitent);
19000 begin
19001 GNAT_Pragma;
19002 Check_Arg_Count (0);
19004 if Operating_Mode = Generate_Code
19005 or else Ent_Kind = E_Generic_Function
19006 or else Ent_Kind = E_Generic_Procedure
19007 or else Ent_Kind = E_Generic_Package
19008 then
19009 Get_Name_String (Chars (Cunitent));
19010 Set_Casing (Mixed_Case);
19011 Write_Str (Name_Buffer (1 .. Name_Len));
19012 Write_Str (" is not supported in this configuration");
19013 Write_Eol;
19014 raise Unrecoverable_Error;
19015 end if;
19016 end Unimplemented_Unit;
19018 ------------------------
19019 -- Universal_Aliasing --
19020 ------------------------
19022 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
19024 when Pragma_Universal_Aliasing => Universal_Alias : declare
19025 E_Id : Entity_Id;
19027 begin
19028 GNAT_Pragma;
19029 Check_Arg_Count (1);
19030 Check_Optional_Identifier (Arg2, Name_Entity);
19031 Check_Arg_Is_Local_Name (Arg1);
19032 E_Id := Entity (Get_Pragma_Arg (Arg1));
19034 if E_Id = Any_Type then
19035 return;
19036 elsif No (E_Id) or else not Is_Type (E_Id) then
19037 Error_Pragma_Arg ("pragma% requires type", Arg1);
19038 end if;
19040 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
19041 Record_Rep_Item (E_Id, N);
19042 end Universal_Alias;
19044 --------------------
19045 -- Universal_Data --
19046 --------------------
19048 -- pragma Universal_Data [(library_unit_NAME)];
19050 when Pragma_Universal_Data =>
19051 GNAT_Pragma;
19053 -- If this is a configuration pragma, then set the universal
19054 -- addressing option, otherwise confirm that the pragma satisfies
19055 -- the requirements of library unit pragma placement and leave it
19056 -- to the GNAAMP back end to detect the pragma (avoids transitive
19057 -- setting of the option due to withed units).
19059 if Is_Configuration_Pragma then
19060 Universal_Addressing_On_AAMP := True;
19061 else
19062 Check_Valid_Library_Unit_Pragma;
19063 end if;
19065 if not AAMP_On_Target then
19066 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
19067 end if;
19069 ----------------
19070 -- Unmodified --
19071 ----------------
19073 -- pragma Unmodified (local_Name {, local_Name});
19075 when Pragma_Unmodified => Unmodified : declare
19076 Arg_Node : Node_Id;
19077 Arg_Expr : Node_Id;
19078 Arg_Ent : Entity_Id;
19080 begin
19081 GNAT_Pragma;
19082 Check_At_Least_N_Arguments (1);
19084 -- Loop through arguments
19086 Arg_Node := Arg1;
19087 while Present (Arg_Node) loop
19088 Check_No_Identifier (Arg_Node);
19090 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
19091 -- in fact generate reference, so that the entity will have a
19092 -- reference, which will inhibit any warnings about it not
19093 -- being referenced, and also properly show up in the ali file
19094 -- as a reference. But this reference is recorded before the
19095 -- Has_Pragma_Unreferenced flag is set, so that no warning is
19096 -- generated for this reference.
19098 Check_Arg_Is_Local_Name (Arg_Node);
19099 Arg_Expr := Get_Pragma_Arg (Arg_Node);
19101 if Is_Entity_Name (Arg_Expr) then
19102 Arg_Ent := Entity (Arg_Expr);
19104 if not Is_Assignable (Arg_Ent) then
19105 Error_Pragma_Arg
19106 ("pragma% can only be applied to a variable",
19107 Arg_Expr);
19108 else
19109 Set_Has_Pragma_Unmodified (Arg_Ent);
19110 end if;
19111 end if;
19113 Next (Arg_Node);
19114 end loop;
19115 end Unmodified;
19117 ------------------
19118 -- Unreferenced --
19119 ------------------
19121 -- pragma Unreferenced (local_Name {, local_Name});
19123 -- or when used in a context clause:
19125 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
19127 when Pragma_Unreferenced => Unreferenced : declare
19128 Arg_Node : Node_Id;
19129 Arg_Expr : Node_Id;
19130 Arg_Ent : Entity_Id;
19131 Citem : Node_Id;
19133 begin
19134 GNAT_Pragma;
19135 Check_At_Least_N_Arguments (1);
19137 -- Check case of appearing within context clause
19139 if Is_In_Context_Clause then
19141 -- The arguments must all be units mentioned in a with clause
19142 -- in the same context clause. Note we already checked (in
19143 -- Par.Prag) that the arguments are either identifiers or
19144 -- selected components.
19146 Arg_Node := Arg1;
19147 while Present (Arg_Node) loop
19148 Citem := First (List_Containing (N));
19149 while Citem /= N loop
19150 if Nkind (Citem) = N_With_Clause
19151 and then
19152 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
19153 then
19154 Set_Has_Pragma_Unreferenced
19155 (Cunit_Entity
19156 (Get_Source_Unit
19157 (Library_Unit (Citem))));
19158 Set_Unit_Name
19159 (Get_Pragma_Arg (Arg_Node), Name (Citem));
19160 exit;
19161 end if;
19163 Next (Citem);
19164 end loop;
19166 if Citem = N then
19167 Error_Pragma_Arg
19168 ("argument of pragma% is not withed unit", Arg_Node);
19169 end if;
19171 Next (Arg_Node);
19172 end loop;
19174 -- Case of not in list of context items
19176 else
19177 Arg_Node := Arg1;
19178 while Present (Arg_Node) loop
19179 Check_No_Identifier (Arg_Node);
19181 -- Note: the analyze call done by Check_Arg_Is_Local_Name
19182 -- will in fact generate reference, so that the entity will
19183 -- have a reference, which will inhibit any warnings about
19184 -- it not being referenced, and also properly show up in the
19185 -- ali file as a reference. But this reference is recorded
19186 -- before the Has_Pragma_Unreferenced flag is set, so that
19187 -- no warning is generated for this reference.
19189 Check_Arg_Is_Local_Name (Arg_Node);
19190 Arg_Expr := Get_Pragma_Arg (Arg_Node);
19192 if Is_Entity_Name (Arg_Expr) then
19193 Arg_Ent := Entity (Arg_Expr);
19195 -- If the entity is overloaded, the pragma applies to the
19196 -- most recent overloading, as documented. In this case,
19197 -- name resolution does not generate a reference, so it
19198 -- must be done here explicitly.
19200 if Is_Overloaded (Arg_Expr) then
19201 Generate_Reference (Arg_Ent, N);
19202 end if;
19204 Set_Has_Pragma_Unreferenced (Arg_Ent);
19205 end if;
19207 Next (Arg_Node);
19208 end loop;
19209 end if;
19210 end Unreferenced;
19212 --------------------------
19213 -- Unreferenced_Objects --
19214 --------------------------
19216 -- pragma Unreferenced_Objects (local_Name {, local_Name});
19218 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
19219 Arg_Node : Node_Id;
19220 Arg_Expr : Node_Id;
19222 begin
19223 GNAT_Pragma;
19224 Check_At_Least_N_Arguments (1);
19226 Arg_Node := Arg1;
19227 while Present (Arg_Node) loop
19228 Check_No_Identifier (Arg_Node);
19229 Check_Arg_Is_Local_Name (Arg_Node);
19230 Arg_Expr := Get_Pragma_Arg (Arg_Node);
19232 if not Is_Entity_Name (Arg_Expr)
19233 or else not Is_Type (Entity (Arg_Expr))
19234 then
19235 Error_Pragma_Arg
19236 ("argument for pragma% must be type or subtype", Arg_Node);
19237 end if;
19239 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
19240 Next (Arg_Node);
19241 end loop;
19242 end Unreferenced_Objects;
19244 ------------------------------
19245 -- Unreserve_All_Interrupts --
19246 ------------------------------
19248 -- pragma Unreserve_All_Interrupts;
19250 when Pragma_Unreserve_All_Interrupts =>
19251 GNAT_Pragma;
19252 Check_Arg_Count (0);
19254 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
19255 Unreserve_All_Interrupts := True;
19256 end if;
19258 ----------------
19259 -- Unsuppress --
19260 ----------------
19262 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
19264 when Pragma_Unsuppress =>
19265 Ada_2005_Pragma;
19266 Process_Suppress_Unsuppress (False);
19268 -------------------
19269 -- Use_VADS_Size --
19270 -------------------
19272 -- pragma Use_VADS_Size;
19274 when Pragma_Use_VADS_Size =>
19275 GNAT_Pragma;
19276 Check_Arg_Count (0);
19277 Check_Valid_Configuration_Pragma;
19278 Use_VADS_Size := True;
19280 ---------------------
19281 -- Validity_Checks --
19282 ---------------------
19284 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
19286 when Pragma_Validity_Checks => Validity_Checks : declare
19287 A : constant Node_Id := Get_Pragma_Arg (Arg1);
19288 S : String_Id;
19289 C : Char_Code;
19291 begin
19292 GNAT_Pragma;
19293 Check_Arg_Count (1);
19294 Check_No_Identifiers;
19296 if Nkind (A) = N_String_Literal then
19297 S := Strval (A);
19299 declare
19300 Slen : constant Natural := Natural (String_Length (S));
19301 Options : String (1 .. Slen);
19302 J : Natural;
19304 begin
19305 J := 1;
19306 loop
19307 C := Get_String_Char (S, Int (J));
19308 exit when not In_Character_Range (C);
19309 Options (J) := Get_Character (C);
19311 if J = Slen then
19312 Set_Validity_Check_Options (Options);
19313 exit;
19314 else
19315 J := J + 1;
19316 end if;
19317 end loop;
19318 end;
19320 elsif Nkind (A) = N_Identifier then
19321 if Chars (A) = Name_All_Checks then
19322 Set_Validity_Check_Options ("a");
19323 elsif Chars (A) = Name_On then
19324 Validity_Checks_On := True;
19325 elsif Chars (A) = Name_Off then
19326 Validity_Checks_On := False;
19327 end if;
19328 end if;
19329 end Validity_Checks;
19331 --------------
19332 -- Volatile --
19333 --------------
19335 -- pragma Volatile (LOCAL_NAME);
19337 when Pragma_Volatile =>
19338 Process_Atomic_Shared_Volatile;
19340 -------------------------
19341 -- Volatile_Components --
19342 -------------------------
19344 -- pragma Volatile_Components (array_LOCAL_NAME);
19346 -- Volatile is handled by the same circuit as Atomic_Components
19348 --------------
19349 -- Warnings --
19350 --------------
19352 -- pragma Warnings (On | Off [,REASON]);
19353 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
19354 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
19355 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
19357 -- REASON ::= Reason => Static_String_Expression
19359 when Pragma_Warnings => Warnings : begin
19360 GNAT_Pragma;
19361 Check_At_Least_N_Arguments (1);
19363 -- See if last argument is labeled Reason. If so, make sure we
19364 -- have a static string expression, but otherwise just ignore
19365 -- the REASON argument by decreasing Num_Args by 1 (all the
19366 -- remaining tests look only at the first Num_Args arguments).
19368 declare
19369 Last_Arg : constant Node_Id :=
19370 Last (Pragma_Argument_Associations (N));
19371 begin
19372 if Nkind (Last_Arg) = N_Pragma_Argument_Association
19373 and then Chars (Last_Arg) = Name_Reason
19374 then
19375 Check_Arg_Is_Static_Expression (Last_Arg, Standard_String);
19376 Arg_Count := Arg_Count - 1;
19378 -- Not allowed in compiler units (bootstrap issues)
19380 Check_Compiler_Unit (N);
19381 end if;
19382 end;
19384 -- Now proceed with REASON taken care of and eliminated
19386 Check_No_Identifiers;
19388 -- If debug flag -gnatd.i is set, pragma is ignored
19390 if Debug_Flag_Dot_I then
19391 return;
19392 end if;
19394 -- Process various forms of the pragma
19396 declare
19397 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19399 begin
19400 -- One argument case
19402 if Arg_Count = 1 then
19404 -- On/Off one argument case was processed by parser
19406 if Nkind (Argx) = N_Identifier
19407 and then Nam_In (Chars (Argx), Name_On, Name_Off)
19408 then
19409 null;
19411 -- One argument case must be ON/OFF or static string expr
19413 elsif not Is_Static_String_Expression (Arg1) then
19414 Error_Pragma_Arg
19415 ("argument of pragma% must be On/Off or static string "
19416 & "expression", Arg1);
19418 -- One argument string expression case
19420 else
19421 declare
19422 Lit : constant Node_Id := Expr_Value_S (Argx);
19423 Str : constant String_Id := Strval (Lit);
19424 Len : constant Nat := String_Length (Str);
19425 C : Char_Code;
19426 J : Nat;
19427 OK : Boolean;
19428 Chr : Character;
19430 begin
19431 J := 1;
19432 while J <= Len loop
19433 C := Get_String_Char (Str, J);
19434 OK := In_Character_Range (C);
19436 if OK then
19437 Chr := Get_Character (C);
19439 -- Dash case: only -Wxxx is accepted
19441 if J = 1
19442 and then J < Len
19443 and then Chr = '-'
19444 then
19445 J := J + 1;
19446 C := Get_String_Char (Str, J);
19447 Chr := Get_Character (C);
19448 exit when Chr = 'W';
19449 OK := False;
19451 -- Dot case
19453 elsif J < Len and then Chr = '.' then
19454 J := J + 1;
19455 C := Get_String_Char (Str, J);
19456 Chr := Get_Character (C);
19458 if not Set_Dot_Warning_Switch (Chr) then
19459 Error_Pragma_Arg
19460 ("invalid warning switch character "
19461 & '.' & Chr, Arg1);
19462 end if;
19464 -- Non-Dot case
19466 else
19467 OK := Set_Warning_Switch (Chr);
19468 end if;
19469 end if;
19471 if not OK then
19472 Error_Pragma_Arg
19473 ("invalid warning switch character " & Chr,
19474 Arg1);
19475 end if;
19477 J := J + 1;
19478 end loop;
19479 end;
19480 end if;
19482 -- Two or more arguments (must be two)
19484 else
19485 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19486 Check_At_Most_N_Arguments (2);
19488 declare
19489 E_Id : Node_Id;
19490 E : Entity_Id;
19491 Err : Boolean;
19493 begin
19494 E_Id := Get_Pragma_Arg (Arg2);
19495 Analyze (E_Id);
19497 -- In the expansion of an inlined body, a reference to
19498 -- the formal may be wrapped in a conversion if the
19499 -- actual is a conversion. Retrieve the real entity name.
19501 if (In_Instance_Body or In_Inlined_Body)
19502 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
19503 then
19504 E_Id := Expression (E_Id);
19505 end if;
19507 -- Entity name case
19509 if Is_Entity_Name (E_Id) then
19510 E := Entity (E_Id);
19512 if E = Any_Id then
19513 return;
19514 else
19515 loop
19516 Set_Warnings_Off
19517 (E, (Chars (Get_Pragma_Arg (Arg1)) =
19518 Name_Off));
19520 -- For OFF case, make entry in warnings off
19521 -- pragma table for later processing. But we do
19522 -- not do that within an instance, since these
19523 -- warnings are about what is needed in the
19524 -- template, not an instance of it.
19526 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
19527 and then Warn_On_Warnings_Off
19528 and then not In_Instance
19529 then
19530 Warnings_Off_Pragmas.Append ((N, E));
19531 end if;
19533 if Is_Enumeration_Type (E) then
19534 declare
19535 Lit : Entity_Id;
19536 begin
19537 Lit := First_Literal (E);
19538 while Present (Lit) loop
19539 Set_Warnings_Off (Lit);
19540 Next_Literal (Lit);
19541 end loop;
19542 end;
19543 end if;
19545 exit when No (Homonym (E));
19546 E := Homonym (E);
19547 end loop;
19548 end if;
19550 -- Error if not entity or static string literal case
19552 elsif not Is_Static_String_Expression (Arg2) then
19553 Error_Pragma_Arg
19554 ("second argument of pragma% must be entity name "
19555 & "or static string expression", Arg2);
19557 -- String literal case
19559 else
19560 String_To_Name_Buffer
19561 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
19563 -- Note on configuration pragma case: If this is a
19564 -- configuration pragma, then for an OFF pragma, we
19565 -- just set Config True in the call, which is all
19566 -- that needs to be done. For the case of ON, this
19567 -- is normally an error, unless it is canceling the
19568 -- effect of a previous OFF pragma in the same file.
19569 -- In any other case, an error will be signalled (ON
19570 -- with no matching OFF).
19572 -- Note: We set Used if we are inside a generic to
19573 -- disable the test that the non-config case actually
19574 -- cancels a warning. That's because we can't be sure
19575 -- there isn't an instantiation in some other unit
19576 -- where a warning is suppressed.
19578 -- We could do a little better here by checking if the
19579 -- generic unit we are inside is public, but for now
19580 -- we don't bother with that refinement.
19582 if Chars (Argx) = Name_Off then
19583 Set_Specific_Warning_Off
19584 (Loc, Name_Buffer (1 .. Name_Len),
19585 Config => Is_Configuration_Pragma,
19586 Used => Inside_A_Generic or else In_Instance);
19588 elsif Chars (Argx) = Name_On then
19589 Set_Specific_Warning_On
19590 (Loc, Name_Buffer (1 .. Name_Len), Err);
19592 if Err then
19593 Error_Msg
19594 ("??pragma Warnings On with no matching "
19595 & "Warnings Off", Loc);
19596 end if;
19597 end if;
19598 end if;
19599 end;
19600 end if;
19601 end;
19602 end Warnings;
19604 -------------------
19605 -- Weak_External --
19606 -------------------
19608 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
19610 when Pragma_Weak_External => Weak_External : declare
19611 Ent : Entity_Id;
19613 begin
19614 GNAT_Pragma;
19615 Check_Arg_Count (1);
19616 Check_Optional_Identifier (Arg1, Name_Entity);
19617 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19618 Ent := Entity (Get_Pragma_Arg (Arg1));
19620 if Rep_Item_Too_Early (Ent, N) then
19621 return;
19622 else
19623 Ent := Underlying_Type (Ent);
19624 end if;
19626 -- The only processing required is to link this item on to the
19627 -- list of rep items for the given entity. This is accomplished
19628 -- by the call to Rep_Item_Too_Late (when no error is detected
19629 -- and False is returned).
19631 if Rep_Item_Too_Late (Ent, N) then
19632 return;
19633 else
19634 Set_Has_Gigi_Rep_Item (Ent);
19635 end if;
19636 end Weak_External;
19638 -----------------------------
19639 -- Wide_Character_Encoding --
19640 -----------------------------
19642 -- pragma Wide_Character_Encoding (IDENTIFIER);
19644 when Pragma_Wide_Character_Encoding =>
19645 GNAT_Pragma;
19647 -- Nothing to do, handled in parser. Note that we do not enforce
19648 -- configuration pragma placement, this pragma can appear at any
19649 -- place in the source, allowing mixed encodings within a single
19650 -- source program.
19652 null;
19654 --------------------
19655 -- Unknown_Pragma --
19656 --------------------
19658 -- Should be impossible, since the case of an unknown pragma is
19659 -- separately processed before the case statement is entered.
19661 when Unknown_Pragma =>
19662 raise Program_Error;
19663 end case;
19665 -- AI05-0144: detect dangerous order dependence. Disabled for now,
19666 -- until AI is formally approved.
19668 -- Check_Order_Dependence;
19670 exception
19671 when Pragma_Exit => null;
19672 end Analyze_Pragma;
19674 ---------------------------------------------
19675 -- Analyze_Pre_Post_Condition_In_Decl_Part --
19676 ---------------------------------------------
19678 procedure Analyze_Pre_Post_Condition_In_Decl_Part
19679 (Prag : Node_Id;
19680 Subp_Id : Entity_Id)
19682 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
19683 Nam : constant Name_Id := Original_Aspect_Name (Prag);
19684 Expr : Node_Id;
19686 Restore_Scope : Boolean := False;
19687 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
19689 begin
19690 -- Ensure that the subprogram and its formals are visible when analyzing
19691 -- the expression of the pragma.
19693 if not In_Open_Scopes (Subp_Id) then
19694 Restore_Scope := True;
19695 Push_Scope (Subp_Id);
19696 Install_Formals (Subp_Id);
19697 end if;
19699 -- Preanalyze the boolean expression, we treat this as a spec expression
19700 -- (i.e. similar to a default expression).
19702 Expr := Get_Pragma_Arg (Arg1);
19704 -- In ASIS mode, for a pragma generated from a source aspect, analyze
19705 -- the original aspect expression, which is shared with the generated
19706 -- pragma.
19708 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
19709 Expr := Expression (Corresponding_Aspect (Prag));
19710 end if;
19712 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
19714 -- For a class-wide condition, a reference to a controlling formal must
19715 -- be interpreted as having the class-wide type (or an access to such)
19716 -- so that the inherited condition can be properly applied to any
19717 -- overriding operation (see ARM12 6.6.1 (7)).
19719 if Class_Present (Prag) then
19720 Class_Wide_Condition : declare
19721 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
19723 ACW : Entity_Id := Empty;
19724 -- Access to T'class, created if there is a controlling formal
19725 -- that is an access parameter.
19727 function Get_ACW return Entity_Id;
19728 -- If the expression has a reference to an controlling access
19729 -- parameter, create an access to T'class for the necessary
19730 -- conversions if one does not exist.
19732 function Process (N : Node_Id) return Traverse_Result;
19733 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
19734 -- aspect for a primitive subprogram of a tagged type T, a name
19735 -- that denotes a formal parameter of type T is interpreted as
19736 -- having type T'Class. Similarly, a name that denotes a formal
19737 -- accessparameter of type access-to-T is interpreted as having
19738 -- type access-to-T'Class. This ensures the expression is well-
19739 -- defined for a primitive subprogram of a type descended from T.
19740 -- Note that this replacement is not done for selector names in
19741 -- parameter associations. These carry an entity for reference
19742 -- purposes, but semantically they are just identifiers.
19744 -------------
19745 -- Get_ACW --
19746 -------------
19748 function Get_ACW return Entity_Id is
19749 Loc : constant Source_Ptr := Sloc (Prag);
19750 Decl : Node_Id;
19752 begin
19753 if No (ACW) then
19754 Decl :=
19755 Make_Full_Type_Declaration (Loc,
19756 Defining_Identifier => Make_Temporary (Loc, 'T'),
19757 Type_Definition =>
19758 Make_Access_To_Object_Definition (Loc,
19759 Subtype_Indication =>
19760 New_Occurrence_Of (Class_Wide_Type (T), Loc),
19761 All_Present => True));
19763 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
19764 Analyze (Decl);
19765 ACW := Defining_Identifier (Decl);
19766 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
19767 end if;
19769 return ACW;
19770 end Get_ACW;
19772 -------------
19773 -- Process --
19774 -------------
19776 function Process (N : Node_Id) return Traverse_Result is
19777 Loc : constant Source_Ptr := Sloc (N);
19778 Typ : Entity_Id;
19780 begin
19781 if Is_Entity_Name (N)
19782 and then Present (Entity (N))
19783 and then Is_Formal (Entity (N))
19784 and then Nkind (Parent (N)) /= N_Type_Conversion
19785 and then
19786 (Nkind (Parent (N)) /= N_Parameter_Association
19787 or else N /= Selector_Name (Parent (N)))
19788 then
19789 if Etype (Entity (N)) = T then
19790 Typ := Class_Wide_Type (T);
19792 elsif Is_Access_Type (Etype (Entity (N)))
19793 and then Designated_Type (Etype (Entity (N))) = T
19794 then
19795 Typ := Get_ACW;
19796 else
19797 Typ := Empty;
19798 end if;
19800 if Present (Typ) then
19801 Rewrite (N,
19802 Make_Type_Conversion (Loc,
19803 Subtype_Mark =>
19804 New_Occurrence_Of (Typ, Loc),
19805 Expression => New_Occurrence_Of (Entity (N), Loc)));
19806 Set_Etype (N, Typ);
19807 end if;
19808 end if;
19810 return OK;
19811 end Process;
19813 procedure Replace_Type is new Traverse_Proc (Process);
19815 -- Start of processing for Class_Wide_Condition
19817 begin
19818 if not Present (T) then
19820 -- Pre'Class/Post'Class aspect cases
19822 if From_Aspect_Specification (Prag) then
19823 if Nam = Name_uPre then
19824 Error_Msg_Name_1 := Name_Pre;
19825 else
19826 Error_Msg_Name_1 := Name_Post;
19827 end if;
19829 Error_Msg_Name_2 := Name_Class;
19831 Error_Msg_N
19832 ("aspect `%''%` can only be specified for a primitive "
19833 & "operation of a tagged type",
19834 Corresponding_Aspect (Prag));
19836 -- Pre_Class, Post_Class pragma cases
19838 else
19839 if Nam = Name_uPre then
19840 Error_Msg_Name_1 := Name_Pre_Class;
19841 else
19842 Error_Msg_Name_1 := Name_Post_Class;
19843 end if;
19845 Error_Msg_N
19846 ("pragma% can only be specified for a primitive "
19847 & "operation of a tagged type",
19848 Corresponding_Aspect (Prag));
19849 end if;
19850 end if;
19852 Replace_Type (Get_Pragma_Arg (Arg1));
19853 end Class_Wide_Condition;
19854 end if;
19856 -- Remove the subprogram from the scope stack now that the pre-analysis
19857 -- of the precondition/postcondition is done.
19859 if Restore_Scope then
19860 End_Scope;
19861 end if;
19862 end Analyze_Pre_Post_Condition_In_Decl_Part;
19864 ------------------------------------------
19865 -- Analyze_Refined_Depends_In_Decl_Part --
19866 ------------------------------------------
19868 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
19869 Dependencies : List_Id := No_List;
19870 Depends : Node_Id;
19871 -- The corresponding Depends pragma along with its clauses
19873 Global : Node_Id := Empty;
19874 -- The corresponding Refined_Global pragma (if any)
19876 Out_Items : Elist_Id := No_Elist;
19877 -- All output items as defined in pragma Refined_Global (if any)
19879 Refinements : List_Id := No_List;
19880 -- The clauses of pragma Refined_Depends
19882 Spec_Id : Entity_Id;
19883 -- The entity of the subprogram subject to pragma Refined_Depends
19885 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
19886 -- Verify the legality of a single clause
19888 procedure Report_Extra_Clauses;
19889 -- Emit an error for each extra clause the appears in Refined_Depends
19891 -----------------------------
19892 -- Check_Dependency_Clause --
19893 -----------------------------
19895 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
19896 function Inputs_Match
19897 (Ref_Clause : Node_Id;
19898 Do_Checks : Boolean) return Boolean;
19899 -- Determine whether the inputs of clause Dep_Clause match those of
19900 -- clause Ref_Clause. If flag Do_Checks is set, the routine reports
19901 -- missed or extra input items.
19903 function Output_Constituents (State_Id : Entity_Id) return Elist_Id;
19904 -- Given a state denoted by State_Id, return a list of all output
19905 -- constituents that may be referenced within Refined_Depends. The
19906 -- contents of the list depend on whethe Refined_Global is present.
19908 procedure Report_Unused_Constituents (Constits : Elist_Id);
19909 -- Emit errors for all constituents found in list Constits
19911 ------------------
19912 -- Inputs_Match --
19913 ------------------
19915 function Inputs_Match
19916 (Ref_Clause : Node_Id;
19917 Do_Checks : Boolean) return Boolean
19919 Ref_Inputs : List_Id;
19920 -- The input list of the refinement clause
19922 function Is_Matching_Input (Dep_Input : Node_Id) return Boolean;
19923 -- Determine whether input Dep_Input matches one of the inputs of
19924 -- clause Ref_Clause.
19926 procedure Report_Extra_Inputs;
19927 -- Emit errors for all extra inputs that appear in Ref_Clause
19929 -----------------------
19930 -- Is_Matching_Input --
19931 -----------------------
19933 function Is_Matching_Input (Dep_Input : Node_Id) return Boolean is
19934 procedure Match_Error (Msg : String; N : Node_Id);
19935 -- Emit a matching error if flag Do_Checks is set
19937 -----------------
19938 -- Match_Error --
19939 -----------------
19941 procedure Match_Error (Msg : String; N : Node_Id) is
19942 begin
19943 if Do_Checks then
19944 Error_Msg_N (Msg, N);
19945 end if;
19946 end Match_Error;
19948 -- Local variables
19950 Dep_Id : Node_Id;
19951 Next_Ref_Input : Node_Id;
19952 Ref_Id : Entity_Id;
19953 Ref_Input : Node_Id;
19955 Has_Constituent : Boolean := False;
19956 -- Flag set when the refinement input list contains at least
19957 -- one constituent of the state denoted by Dep_Id.
19959 Has_Null_State : Boolean := False;
19960 -- Flag set when the dependency input is a state with a null
19961 -- refinement.
19963 Has_Refined_State : Boolean := False;
19964 -- Flag set when the dependency input is a state with visible
19965 -- refinement.
19967 -- Start of processing for Is_Matching_Input
19969 begin
19970 -- Match a null input with another null input
19972 if Nkind (Dep_Input) = N_Null then
19973 Ref_Input := First (Ref_Inputs);
19975 -- Remove the matching null from the pool of candidates
19977 if Nkind (Ref_Input) = N_Null then
19978 Remove (Ref_Input);
19979 return True;
19981 else
19982 Match_Error
19983 ("null input cannot be matched in corresponding "
19984 & "refinement clause", Dep_Input);
19985 end if;
19987 -- Remaining cases are formal parameters, variables, and states
19989 else
19990 Dep_Id := Entity_Of (Dep_Input);
19992 -- Inspect all inputs of the refinement clause and attempt
19993 -- to match against the inputs of the dependence clause.
19995 Ref_Input := First (Ref_Inputs);
19996 while Present (Ref_Input) loop
19998 -- Store the next input now because a match will remove
19999 -- it from the list.
20001 Next_Ref_Input := Next (Ref_Input);
20003 if Ekind (Dep_Id) = E_Abstract_State then
20005 -- A state with a null refinement matches either a
20006 -- null input list or nothing at all (no input):
20008 -- Refined_State => (State => null)
20010 -- No input
20012 -- Depends => (<output> => (State, Input))
20013 -- Refined_Depends => (<output> => Input) -- OK
20015 -- Null input list
20017 -- Depends => (<output> => State)
20018 -- Refined_Depends => (<output> => null) -- OK
20020 if Has_Null_Refinement (Dep_Id) then
20021 Has_Null_State := True;
20023 -- Remove the matching null from the pool of
20024 -- candidates.
20026 if Nkind (Ref_Input) = N_Null then
20027 Remove (Ref_Input);
20028 end if;
20030 return True;
20032 -- The state has a non-null refinement in which case
20033 -- remove all the matching constituents of the state:
20035 -- Refined_State => (State => (C1, C2))
20036 -- Depends => (<output> => State)
20037 -- Refined_Depends => (<output> => (C1, C2))
20039 elsif Has_Non_Null_Refinement (Dep_Id) then
20040 Has_Refined_State := True;
20042 -- Ref_Input is an entity name
20044 if Is_Entity_Name (Ref_Input) then
20045 Ref_Id := Entity_Of (Ref_Input);
20047 -- The input of the refinement clause is a valid
20048 -- constituent of the state. Remove the input
20049 -- from the pool of candidates. Note that the
20050 -- search continues because the state may be
20051 -- represented by multiple constituents.
20053 if Ekind_In (Ref_Id, E_Abstract_State,
20054 E_Variable)
20055 and then Present (Refined_State (Ref_Id))
20056 and then Refined_State (Ref_Id) = Dep_Id
20057 then
20058 Has_Constituent := True;
20059 Remove (Ref_Input);
20060 end if;
20061 end if;
20062 end if;
20064 -- Formal parameters and variables are matched on
20065 -- entities. If this is the case, remove the input from
20066 -- the candidate list.
20068 elsif Is_Entity_Name (Ref_Input)
20069 and then Entity_Of (Ref_Input) = Dep_Id
20070 then
20071 Remove (Ref_Input);
20072 return True;
20073 end if;
20075 Ref_Input := Next_Ref_Input;
20076 end loop;
20078 -- When a state with a null refinement appears as the last
20079 -- input, it matches nothing:
20081 -- Refined_State => (State => null)
20082 -- Depends => (<output> => (Input, State))
20083 -- Refined_Depends => (<output> => Input) -- OK
20085 if Ekind (Dep_Id) = E_Abstract_State
20086 and then Has_Null_Refinement (Dep_Id)
20087 and then No (Ref_Input)
20088 then
20089 Has_Null_State := True;
20090 end if;
20091 end if;
20093 -- A state with visible refinement was matched against one or
20094 -- more of its constituents.
20096 if Has_Constituent then
20097 return True;
20099 -- A state with a null refinement matched null or nothing
20101 elsif Has_Null_State then
20102 return True;
20104 -- The input of a dependence clause does not have a matching
20105 -- input in the refinement clause, emit an error.
20107 else
20108 Match_Error
20109 ("input cannot be matched in corresponding refinement "
20110 & "clause", Dep_Input);
20112 if Has_Refined_State then
20113 Match_Error
20114 ("\check the use of constituents in dependence "
20115 & "refinement", Dep_Input);
20116 end if;
20118 return False;
20119 end if;
20120 end Is_Matching_Input;
20122 -------------------------
20123 -- Report_Extra_Inputs --
20124 -------------------------
20126 procedure Report_Extra_Inputs is
20127 Input : Node_Id;
20129 begin
20130 if Present (Ref_Inputs) and then Do_Checks then
20131 Input := First (Ref_Inputs);
20132 while Present (Input) loop
20133 Error_Msg_N
20134 ("unmatched or extra input in refinement clause",
20135 Input);
20137 Next (Input);
20138 end loop;
20139 end if;
20140 end Report_Extra_Inputs;
20142 -- Local variables
20144 Dep_Inputs : constant Node_Id := Expression (Dep_Clause);
20145 Inputs : constant Node_Id := Expression (Ref_Clause);
20146 Dep_Input : Node_Id;
20147 Result : Boolean;
20149 -- Start of processing for Inputs_Match
20151 begin
20152 -- Construct a list of all refinement inputs. Note that the input
20153 -- list is copied because the algorithm modifies its contents and
20154 -- this should not be visible in Refined_Depends.
20156 if Nkind (Inputs) = N_Aggregate then
20157 Ref_Inputs := New_Copy_List (Expressions (Inputs));
20158 else
20159 Ref_Inputs := New_List (Inputs);
20160 end if;
20162 -- Depending on whether the original dependency clause mentions
20163 -- states with visible refinement, the corresponding refinement
20164 -- clause may differ greatly in structure and contents:
20166 -- State with null refinement
20168 -- Refined_State => (State => null)
20169 -- Depends => (<output> => State)
20170 -- Refined_Depends => (<output> => null)
20172 -- Depends => (<output> => (State, Input))
20173 -- Refined_Depends => (<output> => Input)
20175 -- Depends => (<output> => (Input_1, State, Input_2))
20176 -- Refined_Depends => (<output> => (Input_1, Input_2))
20178 -- State with non-null refinement
20180 -- Refined_State => (State_1 => (C1, C2))
20181 -- Depends => (<output> => State)
20182 -- Refined_Depends => (<output> => C1)
20183 -- or
20184 -- Refined_Depends => (<output> => (C1, C2))
20186 if Nkind (Dep_Inputs) = N_Aggregate then
20187 Dep_Input := First (Expressions (Dep_Inputs));
20188 while Present (Dep_Input) loop
20189 if not Is_Matching_Input (Dep_Input) then
20190 Result := False;
20191 end if;
20193 Next (Dep_Input);
20194 end loop;
20196 Result := True;
20198 -- Solitary input
20200 else
20201 Result := Is_Matching_Input (Dep_Inputs);
20202 end if;
20204 Report_Extra_Inputs;
20205 return Result;
20206 end Inputs_Match;
20208 -------------------------
20209 -- Output_Constituents --
20210 -------------------------
20212 function Output_Constituents (State_Id : Entity_Id) return Elist_Id is
20213 Item_Elmt : Elmt_Id;
20214 Item_Id : Entity_Id;
20215 Result : Elist_Id := No_Elist;
20217 begin
20218 -- The related subprogram is subject to pragma Refined_Global. All
20219 -- usable output constituents are defined in its output item list.
20221 if Present (Global) then
20222 Item_Elmt := First_Elmt (Out_Items);
20223 while Present (Item_Elmt) loop
20224 Item_Id := Node (Item_Elmt);
20226 -- The constituent is part of the refinement of the input
20227 -- state, add it to the result list.
20229 if Refined_State (Item_Id) = State_Id then
20230 Add_Item (Item_Id, Result);
20231 end if;
20233 Next_Elmt (Item_Elmt);
20234 end loop;
20236 -- When pragma Refined_Global is not present, the usable output
20237 -- constituents are all the constituents as defined in pragma
20238 -- Refined_State. Note that the elements are copied because the
20239 -- algorithm trims the list and this should not be reflected in
20240 -- the state itself.
20242 else
20243 Result := New_Copy_Elist (Refinement_Constituents (State_Id));
20244 end if;
20246 return Result;
20247 end Output_Constituents;
20249 --------------------------------
20250 -- Report_Unused_Constituents --
20251 --------------------------------
20253 procedure Report_Unused_Constituents (Constits : Elist_Id) is
20254 Constit : Entity_Id;
20255 Elmt : Elmt_Id;
20256 Posted : Boolean := False;
20258 begin
20259 if Present (Constits) then
20260 Elmt := First_Elmt (Constits);
20261 while Present (Elmt) loop
20262 Constit := Node (Elmt);
20264 -- A constituent must always refine a state
20266 pragma Assert (Present (Refined_State (Constit)));
20268 -- When a state has a visible refinement and its mode is
20269 -- Output_Only, all its constituents must be used as
20270 -- outputs.
20272 if not Posted then
20273 Posted := True;
20274 Error_Msg_NE
20275 ("output only state & must be replaced by all its "
20276 & "constituents in dependence refinement",
20277 N, Refined_State (Constit));
20278 end if;
20280 Error_Msg_NE
20281 ("\ constituent & is missing in output list", N, Constit);
20283 Next_Elmt (Elmt);
20284 end loop;
20285 end if;
20286 end Report_Unused_Constituents;
20288 -- Local variables
20290 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
20291 Dep_Id : Entity_Id;
20292 Matching_Clause : Node_Id := Empty;
20293 Next_Ref_Clause : Node_Id;
20294 Ref_Clause : Node_Id;
20295 Ref_Id : Entity_Id;
20296 Ref_Output : Node_Id;
20298 Has_Constituent : Boolean := False;
20299 -- Flag set when the refinement output list contains at least one
20300 -- constituent of the state denoted by Dep_Id.
20302 Has_Null_State : Boolean := False;
20303 -- Flag set when the output of clause Dep_Clause is a state with a
20304 -- null refinement.
20306 Has_Refined_State : Boolean := False;
20307 -- Flag set when the output of clause Dep_Clause is a state with
20308 -- visible refinement.
20310 Out_Constits : Elist_Id := No_Elist;
20311 -- This list contains the entities all output constituents of state
20312 -- Dep_Id as defined in pragma Refined_State.
20314 -- Start of processing for Check_Dependency_Clause
20316 begin
20317 -- The analysis of pragma Depends should produce normalized clauses
20318 -- with exactly one output. This is important because output items
20319 -- are unique in the whole dependence relation and can be used as
20320 -- keys.
20322 pragma Assert (No (Next (Dep_Output)));
20324 -- Inspect all clauses of Refined_Depends and attempt to match the
20325 -- output of Dep_Clause against an output from the refinement clauses
20326 -- set.
20328 Ref_Clause := First (Refinements);
20329 while Present (Ref_Clause) loop
20330 Matching_Clause := Empty;
20332 -- Store the next clause now because a match will trim the list of
20333 -- refinement clauses and this side effect should not be visible
20334 -- in pragma Refined_Depends.
20336 Next_Ref_Clause := Next (Ref_Clause);
20338 -- The analysis of pragma Refined_Depends should produce
20339 -- normalized clauses with exactly one output.
20341 Ref_Output := First (Choices (Ref_Clause));
20342 pragma Assert (No (Next (Ref_Output)));
20344 -- Two null output lists match if their inputs match
20346 if Nkind (Dep_Output) = N_Null
20347 and then Nkind (Ref_Output) = N_Null
20348 then
20349 Matching_Clause := Ref_Clause;
20350 exit;
20352 -- Two function 'Result attributes match if their inputs match.
20353 -- Note that there is no need to compare the two prefixes because
20354 -- the attributes cannot denote anything but the related function.
20356 elsif Is_Attribute_Result (Dep_Output)
20357 and then Is_Attribute_Result (Ref_Output)
20358 then
20359 Matching_Clause := Ref_Clause;
20360 exit;
20362 -- The remaining cases are formal parameters, variables and states
20364 elsif Is_Entity_Name (Dep_Output) then
20365 Dep_Id := Entity_Of (Dep_Output);
20367 if Ekind (Dep_Id) = E_Abstract_State then
20369 -- A state with a null refinement matches either a null
20370 -- output list or nothing at all (no clause):
20372 -- Refined_State => (State => null)
20374 -- No clause
20376 -- Depends => (State => null)
20377 -- Refined_Depends => null -- OK
20379 -- Null output list
20381 -- Depends => (State => <input>)
20382 -- Refined_Depends => (null => <input>) -- OK
20384 if Has_Null_Refinement (Dep_Id) then
20385 Has_Null_State := True;
20387 -- When a state with null refinement matches a null
20388 -- output, compare their inputs.
20390 if Nkind (Ref_Output) = N_Null then
20391 Matching_Clause := Ref_Clause;
20392 end if;
20394 exit;
20396 -- The state has a non-null refinement in which case the
20397 -- match is based on constituents and inputs. A state with
20398 -- multiple output constituents may match multiple clauses:
20400 -- Refined_State => (State => (C1, C2))
20401 -- Depends => (State => <input>)
20402 -- Refined_Depends => ((C1, C2) => <input>)
20404 -- When normalized, the above becomes:
20406 -- Refined_Depends => (C1 => <input>,
20407 -- C2 => <input>)
20409 elsif Has_Non_Null_Refinement (Dep_Id) then
20410 Has_Refined_State := True;
20412 -- Store the entities of all output constituents of an
20413 -- Output_Only state with visible refinement.
20415 if No (Out_Constits)
20416 and then Is_Output_Only_State (Dep_Id)
20417 then
20418 Out_Constits := Output_Constituents (Dep_Id);
20419 end if;
20421 if Is_Entity_Name (Ref_Output) then
20422 Ref_Id := Entity_Of (Ref_Output);
20424 -- The output of the refinement clause is a valid
20425 -- constituent of the state. Remove the clause from
20426 -- the pool of candidates if both input lists match.
20427 -- Note that the search continues because one clause
20428 -- may have been normalized into multiple clauses as
20429 -- per the example above.
20431 if Ekind_In (Ref_Id, E_Abstract_State, E_Variable)
20432 and then Present (Refined_State (Ref_Id))
20433 and then Refined_State (Ref_Id) = Dep_Id
20434 and then Inputs_Match
20435 (Ref_Clause, Do_Checks => False)
20436 then
20437 Has_Constituent := True;
20438 Remove (Ref_Clause);
20440 -- The matching constituent may act as an output
20441 -- for an Output_Only state. Remove the item from
20442 -- the available output constituents.
20444 Remove (Out_Constits, Ref_Id);
20445 end if;
20446 end if;
20447 end if;
20449 -- Formal parameters and variables match if their inputs match
20451 elsif Is_Entity_Name (Ref_Output)
20452 and then Entity_Of (Ref_Output) = Dep_Id
20453 then
20454 Matching_Clause := Ref_Clause;
20455 exit;
20456 end if;
20457 end if;
20459 Ref_Clause := Next_Ref_Clause;
20460 end loop;
20462 -- Handle the case where pragma Depends contains one or more clauses
20463 -- that only mention states with null refinements. In that case the
20464 -- corresponding pragma Refined_Depends may have a null relation.
20466 -- Refined_State => (State => null)
20467 -- Depends => (State => null)
20468 -- Refined_Depends => null -- OK
20470 -- Another instance of the same scenario occurs when the list of
20471 -- refinements has been depleted while processing previous clauses.
20473 if Is_Entity_Name (Dep_Output)
20474 and then (No (Refinements) or else Is_Empty_List (Refinements))
20475 then
20476 Dep_Id := Entity_Of (Dep_Output);
20478 if Ekind (Dep_Id) = E_Abstract_State
20479 and then Has_Null_Refinement (Dep_Id)
20480 then
20481 Has_Null_State := True;
20482 end if;
20483 end if;
20485 -- The above search produced a match based on unique output. Ensure
20486 -- that the inputs match as well and if they do, remove the clause
20487 -- from the pool of candidates.
20489 if Present (Matching_Clause) then
20490 if Inputs_Match (Matching_Clause, Do_Checks => True) then
20491 Remove (Matching_Clause);
20492 end if;
20494 -- A state with a visible refinement was matched against one or
20495 -- more clauses containing appropriate constituents.
20497 elsif Has_Constituent then
20498 null;
20500 -- A state with a null refinement did not warrant a clause
20502 elsif Has_Null_State then
20503 null;
20505 -- The dependence relation of pragma Refined_Depends does not contain
20506 -- a matching clause, emit an error.
20508 else
20509 Error_Msg_NE
20510 ("dependence clause of subprogram & has no matching refinement "
20511 & "in body", Ref_Clause, Spec_Id);
20513 if Has_Refined_State then
20514 Error_Msg_N
20515 ("\check the use of constituents in dependence refinement",
20516 Ref_Clause);
20517 end if;
20518 end if;
20520 -- Emit errors for all unused constituents of an Output_Only state
20521 -- with visible refinement.
20523 Report_Unused_Constituents (Out_Constits);
20524 end Check_Dependency_Clause;
20526 --------------------------
20527 -- Report_Extra_Clauses --
20528 --------------------------
20530 procedure Report_Extra_Clauses is
20531 Clause : Node_Id;
20533 begin
20534 if Present (Refinements) then
20535 Clause := First (Refinements);
20536 while Present (Clause) loop
20538 -- Do not complain about a null input refinement, since a null
20539 -- input legitimately matches anything.
20541 if Nkind (Clause) /= N_Component_Association
20542 or else Nkind (Expression (Clause)) /= N_Null
20543 then
20544 Error_Msg_N
20545 ("unmatched or extra clause in dependence refinement",
20546 Clause);
20547 end if;
20549 Next (Clause);
20550 end loop;
20551 end if;
20552 end Report_Extra_Clauses;
20554 -- Local variables
20556 Body_Decl : constant Node_Id := Parent (N);
20557 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
20558 Errors : constant Nat := Serious_Errors_Detected;
20559 Clause : Node_Id;
20560 Deps : Node_Id;
20561 Refs : Node_Id;
20563 -- The following are dummy variables that capture unused output of
20564 -- routine Collect_Global_Items.
20566 D1, D2 : Elist_Id := No_Elist;
20567 D3, D4, D5, D6 : Boolean;
20569 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
20571 begin
20572 Spec_Id := Corresponding_Spec (Body_Decl);
20573 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
20575 -- The subprogram declarations lacks pragma Depends. This renders
20576 -- Refined_Depends useless as there is nothing to refine.
20578 if No (Depends) then
20579 Error_Msg_NE
20580 ("useless refinement, subprogram & lacks dependence clauses",
20581 N, Spec_Id);
20582 return;
20583 end if;
20585 Deps := Get_Pragma_Arg (First (Pragma_Argument_Associations (Depends)));
20587 -- A null dependency relation renders the refinement useless because it
20588 -- cannot possibly mention abstract states with visible refinement. Note
20589 -- that the inverse is not true as states may be refined to null.
20591 if Nkind (Deps) = N_Null then
20592 Error_Msg_NE
20593 ("useless refinement, subprogram & does not depend on abstract "
20594 & "state with visible refinement", N, Spec_Id);
20595 return;
20596 end if;
20598 -- Multiple dependency clauses appear as component associations of an
20599 -- aggregate.
20601 pragma Assert (Nkind (Deps) = N_Aggregate);
20602 Dependencies := Component_Associations (Deps);
20604 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
20605 -- This ensures that the categorization of all refined dependency items
20606 -- is consistent with their role.
20608 Analyze_Depends_In_Decl_Part (N);
20609 Refs := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
20611 if Serious_Errors_Detected = Errors then
20613 -- The related subprogram may be subject to pragma Refined_Global. If
20614 -- this is the case, gather all output items. These are needed when
20615 -- verifying the use of constituents that apply to output states with
20616 -- visible refinement.
20618 Global := Get_Pragma (Body_Id, Pragma_Refined_Global);
20620 if Present (Global) then
20621 Collect_Global_Items
20622 (Prag => Global,
20623 In_Items => D1,
20624 In_Out_Items => D2,
20625 Out_Items => Out_Items,
20626 Has_In_State => D3,
20627 Has_In_Out_State => D4,
20628 Has_Out_State => D5,
20629 Has_Null_State => D6);
20630 end if;
20632 if Nkind (Refs) = N_Null then
20633 Refinements := No_List;
20635 -- Multiple dependency clauses appear as component associations of an
20636 -- aggregate. Note that the clauses are copied because the algorithm
20637 -- modifies them and this should not be visible in Refined_Depends.
20639 else pragma Assert (Nkind (Refs) = N_Aggregate);
20640 Refinements := New_Copy_List (Component_Associations (Refs));
20641 end if;
20643 -- Inspect all the clauses of pragma Depends looking for a matching
20644 -- clause in pragma Refined_Depends. The approach is to use the
20645 -- sole output of a clause as a key. Output items are unique in a
20646 -- dependence relation. Clause normalization also ensured that all
20647 -- clauses have exactly one output. Depending on what the key is, one
20648 -- or more refinement clauses may satisfy the dependency clause. Each
20649 -- time a dependency clause is matched, its related refinement clause
20650 -- is consumed. In the end, two things may happen:
20652 -- 1) A clause of pragma Depends was not matched in which case
20653 -- Check_Dependency_Clause reports the error.
20655 -- 2) Refined_Depends has an extra clause in which case the error
20656 -- is reported by Report_Extra_Clauses.
20658 Clause := First (Dependencies);
20659 while Present (Clause) loop
20660 Check_Dependency_Clause (Clause);
20661 Next (Clause);
20662 end loop;
20663 end if;
20665 if Serious_Errors_Detected = Errors then
20666 Report_Extra_Clauses;
20667 end if;
20668 end Analyze_Refined_Depends_In_Decl_Part;
20670 -----------------------------------------
20671 -- Analyze_Refined_Global_In_Decl_Part --
20672 -----------------------------------------
20674 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
20675 Global : Node_Id;
20676 -- The corresponding Global pragma
20678 Has_In_State : Boolean := False;
20679 Has_In_Out_State : Boolean := False;
20680 Has_Out_State : Boolean := False;
20681 -- These flags are set when the corresponding Global pragma has a state
20682 -- of mode Input, In_Out and Output respectively with a visible
20683 -- refinement.
20685 Has_Null_State : Boolean := False;
20686 -- This flag is set when the corresponding Global pragma has at least
20687 -- one state with a null refinement.
20689 In_Constits : Elist_Id := No_Elist;
20690 In_Out_Constits : Elist_Id := No_Elist;
20691 Out_Constits : Elist_Id := No_Elist;
20692 -- These lists contain the entities of all Input, In_Out and Output
20693 -- constituents that appear in Refined_Global and participate in state
20694 -- refinement.
20696 In_Items : Elist_Id := No_Elist;
20697 In_Out_Items : Elist_Id := No_Elist;
20698 Out_Items : Elist_Id := No_Elist;
20699 -- These list contain the entities of all Input, In_Out and Output items
20700 -- defined in the corresponding Global pragma.
20702 procedure Check_In_Out_States;
20703 -- Determine whether the corresponding Global pragma mentions In_Out
20704 -- states with visible refinement and if so, ensure that one of the
20705 -- following completions apply to the constituents of the state:
20706 -- 1) there is at least one constituent of mode In_Out
20707 -- 2) there is at least one Input and one Output constituent
20708 -- 3) not all constituents are present and one of them is of mode
20709 -- Output.
20710 -- This routine may remove elements from In_Constits, In_Out_Constits
20711 -- and Out_Constits.
20713 procedure Check_Input_States;
20714 -- Determine whether the corresponding Global pragma mentions Input
20715 -- states with visible refinement and if so, ensure that at least one of
20716 -- its constituents appears as an Input item in Refined_Global.
20717 -- This routine may remove elements from In_Constits, In_Out_Constits
20718 -- and Out_Constits.
20720 procedure Check_Output_States;
20721 -- Determine whether the corresponding Global pragma mentions Output
20722 -- states with visible refinement and if so, ensure that all of its
20723 -- constituents appear as Output items in Refined_Global. This routine
20724 -- may remove elements from In_Constits, In_Out_Constits and
20725 -- Out_Constits.
20727 procedure Check_Refined_Global_List
20728 (List : Node_Id;
20729 Global_Mode : Name_Id := Name_Input);
20730 -- Verify the legality of a single global list declaration. Global_Mode
20731 -- denotes the current mode in effect.
20733 function Present_Then_Remove
20734 (List : Elist_Id;
20735 Item : Entity_Id) return Boolean;
20736 -- Search List for a particular entity Item. If Item has been found,
20737 -- remove it from List. This routine is used to strip lists In_Constits,
20738 -- In_Out_Constits and Out_Constits of valid constituents.
20740 procedure Report_Extra_Constituents;
20741 -- Emit an error for each constituent found in lists In_Constits,
20742 -- In_Out_Constits and Out_Constits.
20744 -------------------------
20745 -- Check_In_Out_States --
20746 -------------------------
20748 procedure Check_In_Out_States is
20749 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20750 -- Determine whether one of the following coverage scenarios is in
20751 -- effect:
20752 -- 1) there is at least one constituent of mode In_Out
20753 -- 2) there is at least one Input and one Output constituent
20754 -- 3) not all constituents are present and one of them is of mode
20755 -- Output.
20756 -- If this is not the case, emit an error.
20758 -----------------------------
20759 -- Check_Constituent_Usage --
20760 -----------------------------
20762 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20763 Constit_Elmt : Elmt_Id;
20764 Constit_Id : Entity_Id;
20765 Has_Missing : Boolean := False;
20766 In_Out_Seen : Boolean := False;
20767 In_Seen : Boolean := False;
20768 Out_Seen : Boolean := False;
20770 begin
20771 -- Process all the constituents of the state and note their modes
20772 -- within the global refinement.
20774 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20775 while Present (Constit_Elmt) loop
20776 Constit_Id := Node (Constit_Elmt);
20778 if Present_Then_Remove (In_Constits, Constit_Id) then
20779 In_Seen := True;
20781 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
20782 In_Out_Seen := True;
20784 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
20785 Out_Seen := True;
20787 else
20788 Has_Missing := True;
20789 end if;
20791 Next_Elmt (Constit_Elmt);
20792 end loop;
20794 -- A single In_Out constituent is a valid completion
20796 if In_Out_Seen then
20797 null;
20799 -- A pair of one Input and one Output constituent is a valid
20800 -- completion.
20802 elsif In_Seen and then Out_Seen then
20803 null;
20805 -- A single Output constituent is a valid completion only when
20806 -- some of the other constituents are missing.
20808 elsif Has_Missing and then Out_Seen then
20809 null;
20811 else
20812 Error_Msg_NE
20813 ("global refinement of state & redefines the mode of its "
20814 & "constituents", N, State_Id);
20815 end if;
20816 end Check_Constituent_Usage;
20818 -- Local variables
20820 Item_Elmt : Elmt_Id;
20821 Item_Id : Entity_Id;
20823 -- Start of processing for Check_In_Out_States
20825 begin
20826 -- Inspect the In_Out items of the corresponding Global pragma
20827 -- looking for a state with a visible refinement.
20829 if Has_In_Out_State and then Present (In_Out_Items) then
20830 Item_Elmt := First_Elmt (In_Out_Items);
20831 while Present (Item_Elmt) loop
20832 Item_Id := Node (Item_Elmt);
20834 -- Ensure that one of the three coverage variants is satisfied
20836 if Ekind (Item_Id) = E_Abstract_State
20837 and then Has_Non_Null_Refinement (Item_Id)
20838 then
20839 Check_Constituent_Usage (Item_Id);
20840 end if;
20842 Next_Elmt (Item_Elmt);
20843 end loop;
20844 end if;
20845 end Check_In_Out_States;
20847 ------------------------
20848 -- Check_Input_States --
20849 ------------------------
20851 procedure Check_Input_States is
20852 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20853 -- Determine whether at least one constituent of state State_Id with
20854 -- visible refinement is used and has mode Input. Ensure that the
20855 -- remaining constituents do not have In_Out or Output modes.
20857 -----------------------------
20858 -- Check_Constituent_Usage --
20859 -----------------------------
20861 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20862 Constit_Elmt : Elmt_Id;
20863 Constit_Id : Entity_Id;
20864 In_Seen : Boolean := False;
20866 begin
20867 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20868 while Present (Constit_Elmt) loop
20869 Constit_Id := Node (Constit_Elmt);
20871 -- At least one of the constituents appears as an Input
20873 if Present_Then_Remove (In_Constits, Constit_Id) then
20874 In_Seen := True;
20876 -- The constituent appears in the global refinement, but has
20877 -- mode In_Out or Output.
20879 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
20880 or else Present_Then_Remove (Out_Constits, Constit_Id)
20881 then
20882 Error_Msg_Name_1 := Chars (State_Id);
20883 Error_Msg_NE
20884 ("constituent & of state % must have mode Input in global "
20885 & "refinement", N, Constit_Id);
20886 end if;
20888 Next_Elmt (Constit_Elmt);
20889 end loop;
20891 -- Not one of the constituents appeared as Input
20893 if not In_Seen then
20894 Error_Msg_NE
20895 ("global refinement of state & must include at least one "
20896 & "constituent of mode Input", N, State_Id);
20897 end if;
20898 end Check_Constituent_Usage;
20900 -- Local variables
20902 Item_Elmt : Elmt_Id;
20903 Item_Id : Entity_Id;
20905 -- Start of processing for Check_Input_States
20907 begin
20908 -- Inspect the Input items of the corresponding Global pragma
20909 -- looking for a state with a visible refinement.
20911 if Has_In_State and then Present (In_Items) then
20912 Item_Elmt := First_Elmt (In_Items);
20913 while Present (Item_Elmt) loop
20914 Item_Id := Node (Item_Elmt);
20916 -- Ensure that at least one of the constituents is utilized and
20917 -- is of mode Input.
20919 if Ekind (Item_Id) = E_Abstract_State
20920 and then Has_Non_Null_Refinement (Item_Id)
20921 then
20922 Check_Constituent_Usage (Item_Id);
20923 end if;
20925 Next_Elmt (Item_Elmt);
20926 end loop;
20927 end if;
20928 end Check_Input_States;
20930 -------------------------
20931 -- Check_Output_States --
20932 -------------------------
20934 procedure Check_Output_States is
20935 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20936 -- Determine whether all constituents of state State_Id with visible
20937 -- refinement are used and have mode Output. Emit an error if this is
20938 -- not the case.
20940 -----------------------------
20941 -- Check_Constituent_Usage --
20942 -----------------------------
20944 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20945 Constit_Elmt : Elmt_Id;
20946 Constit_Id : Entity_Id;
20948 begin
20949 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20950 while Present (Constit_Elmt) loop
20951 Constit_Id := Node (Constit_Elmt);
20953 if Present_Then_Remove (Out_Constits, Constit_Id) then
20954 null;
20956 else
20957 Remove (In_Constits, Constit_Id);
20958 Remove (In_Out_Constits, Constit_Id);
20960 Error_Msg_Name_1 := Chars (State_Id);
20961 Error_Msg_NE
20962 ("constituent & of state % must have mode Output in "
20963 & "global refinement", N, Constit_Id);
20964 end if;
20966 Next_Elmt (Constit_Elmt);
20967 end loop;
20968 end Check_Constituent_Usage;
20970 -- Local variables
20972 Item_Elmt : Elmt_Id;
20973 Item_Id : Entity_Id;
20975 -- Start of processing for Check_Output_States
20977 begin
20978 -- Inspect the Output items of the corresponding Global pragma
20979 -- looking for a state with a visible refinement.
20981 if Has_Out_State and then Present (Out_Items) then
20982 Item_Elmt := First_Elmt (Out_Items);
20983 while Present (Item_Elmt) loop
20984 Item_Id := Node (Item_Elmt);
20986 -- Ensure that all of the constituents are utilized and they
20987 -- have mode Output.
20989 if Ekind (Item_Id) = E_Abstract_State
20990 and then Has_Non_Null_Refinement (Item_Id)
20991 then
20992 Check_Constituent_Usage (Item_Id);
20993 end if;
20995 Next_Elmt (Item_Elmt);
20996 end loop;
20997 end if;
20998 end Check_Output_States;
21000 -------------------------------
21001 -- Check_Refined_Global_List --
21002 -------------------------------
21004 procedure Check_Refined_Global_List
21005 (List : Node_Id;
21006 Global_Mode : Name_Id := Name_Input)
21008 procedure Check_Refined_Global_Item
21009 (Item : Node_Id;
21010 Global_Mode : Name_Id);
21011 -- Verify the legality of a single global item declaration. Parameter
21012 -- Global_Mode denotes the current mode in effect.
21014 -------------------------------
21015 -- Check_Refined_Global_Item --
21016 -------------------------------
21018 procedure Check_Refined_Global_Item
21019 (Item : Node_Id;
21020 Global_Mode : Name_Id)
21022 Item_Id : constant Entity_Id := Entity_Of (Item);
21024 procedure Inconsistent_Mode_Error (Expect : Name_Id);
21025 -- Issue a common error message for all mode mismatches. Expect
21026 -- denotes the expected mode.
21028 -----------------------------
21029 -- Inconsistent_Mode_Error --
21030 -----------------------------
21032 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
21033 begin
21034 Error_Msg_NE
21035 ("global item & has inconsistent modes", Item, Item_Id);
21037 Error_Msg_Name_1 := Global_Mode;
21038 Error_Msg_N ("\ expected mode %", Item);
21040 Error_Msg_Name_1 := Expect;
21041 Error_Msg_N ("\ found mode %", Item);
21042 end Inconsistent_Mode_Error;
21044 -- Start of processing for Check_Refined_Global_Item
21046 begin
21047 -- The state or variable acts as a constituent of a state, collect
21048 -- it for the state completeness checks performed later on.
21050 if Present (Refined_State (Item_Id)) then
21051 if Global_Mode = Name_Input then
21052 Add_Item (Item_Id, In_Constits);
21054 elsif Global_Mode = Name_In_Out then
21055 Add_Item (Item_Id, In_Out_Constits);
21057 elsif Global_Mode = Name_Output then
21058 Add_Item (Item_Id, Out_Constits);
21059 end if;
21061 -- When not a constituent, ensure that both occurrences of the
21062 -- item in pragmas Global and Refined_Global match.
21064 elsif Contains (In_Items, Item_Id) then
21065 if Global_Mode /= Name_Input then
21066 Inconsistent_Mode_Error (Name_Input);
21067 end if;
21069 elsif Contains (In_Out_Items, Item_Id) then
21070 if Global_Mode /= Name_In_Out then
21071 Inconsistent_Mode_Error (Name_In_Out);
21072 end if;
21074 elsif Contains (Out_Items, Item_Id) then
21075 if Global_Mode /= Name_Output then
21076 Inconsistent_Mode_Error (Name_Output);
21077 end if;
21079 -- The item does not appear in the corresponding Global pragma, it
21080 -- must be an extra.
21082 else
21083 Error_Msg_NE ("extra global item &", Item, Item_Id);
21084 end if;
21085 end Check_Refined_Global_Item;
21087 -- Local variables
21089 Item : Node_Id;
21091 -- Start of processing for Check_Refined_Global_List
21093 begin
21094 if Nkind (List) = N_Null then
21095 null;
21097 -- Single global item declaration
21099 elsif Nkind_In (List, N_Expanded_Name,
21100 N_Identifier,
21101 N_Selected_Component)
21102 then
21103 Check_Refined_Global_Item (List, Global_Mode);
21105 -- Simple global list or moded global list declaration
21107 elsif Nkind (List) = N_Aggregate then
21109 -- The declaration of a simple global list appear as a collection
21110 -- of expressions.
21112 if Present (Expressions (List)) then
21113 Item := First (Expressions (List));
21114 while Present (Item) loop
21115 Check_Refined_Global_Item (Item, Global_Mode);
21117 Next (Item);
21118 end loop;
21120 -- The declaration of a moded global list appears as a collection
21121 -- of component associations where individual choices denote
21122 -- modes.
21124 elsif Present (Component_Associations (List)) then
21125 Item := First (Component_Associations (List));
21126 while Present (Item) loop
21127 Check_Refined_Global_List
21128 (List => Expression (Item),
21129 Global_Mode => Chars (First (Choices (Item))));
21131 Next (Item);
21132 end loop;
21134 -- Invalid tree
21136 else
21137 raise Program_Error;
21138 end if;
21140 -- Invalid list
21142 else
21143 raise Program_Error;
21144 end if;
21145 end Check_Refined_Global_List;
21147 -------------------------
21148 -- Present_Then_Remove --
21149 -------------------------
21151 function Present_Then_Remove
21152 (List : Elist_Id;
21153 Item : Entity_Id) return Boolean
21155 Elmt : Elmt_Id;
21157 begin
21158 if Present (List) then
21159 Elmt := First_Elmt (List);
21160 while Present (Elmt) loop
21161 if Node (Elmt) = Item then
21162 Remove_Elmt (List, Elmt);
21163 return True;
21164 end if;
21166 Next_Elmt (Elmt);
21167 end loop;
21168 end if;
21170 return False;
21171 end Present_Then_Remove;
21173 -------------------------------
21174 -- Report_Extra_Constituents --
21175 -------------------------------
21177 procedure Report_Extra_Constituents is
21178 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
21179 -- Emit an error for every element of List
21181 ---------------------------------------
21182 -- Report_Extra_Constituents_In_List --
21183 ---------------------------------------
21185 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
21186 Constit_Elmt : Elmt_Id;
21188 begin
21189 if Present (List) then
21190 Constit_Elmt := First_Elmt (List);
21191 while Present (Constit_Elmt) loop
21192 Error_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
21193 Next_Elmt (Constit_Elmt);
21194 end loop;
21195 end if;
21196 end Report_Extra_Constituents_In_List;
21198 -- Start of processing for Report_Extra_Constituents
21200 begin
21201 Report_Extra_Constituents_In_List (In_Constits);
21202 Report_Extra_Constituents_In_List (In_Out_Constits);
21203 Report_Extra_Constituents_In_List (Out_Constits);
21204 end Report_Extra_Constituents;
21206 -- Local variables
21208 Body_Decl : constant Node_Id := Parent (N);
21209 Errors : constant Nat := Serious_Errors_Detected;
21210 Items : constant Node_Id :=
21211 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
21212 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
21214 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
21216 begin
21217 Global := Get_Pragma (Spec_Id, Pragma_Global);
21219 -- The subprogram declaration lacks pragma Global. This renders
21220 -- Refined_Global useless as there is nothing to refine.
21222 if No (Global) then
21223 Error_Msg_NE
21224 ("useless refinement, subprogram & lacks global items", N, Spec_Id);
21225 return;
21226 end if;
21228 -- Extract all relevant items from the corresponding Global pragma
21230 Collect_Global_Items
21231 (Prag => Global,
21232 In_Items => In_Items,
21233 In_Out_Items => In_Out_Items,
21234 Out_Items => Out_Items,
21235 Has_In_State => Has_In_State,
21236 Has_In_Out_State => Has_In_Out_State,
21237 Has_Out_State => Has_Out_State,
21238 Has_Null_State => Has_Null_State);
21240 -- The corresponding Global pragma must mention at least one state with
21241 -- a visible refinement at the point Refined_Global is processed. States
21242 -- with null refinements warrant a Refined_Global pragma.
21244 if not Has_In_State
21245 and then not Has_In_Out_State
21246 and then not Has_Out_State
21247 and then not Has_Null_State
21248 then
21249 Error_Msg_NE
21250 ("useless refinement, subprogram & does not mention abstract state "
21251 & "with visible refinement", N, Spec_Id);
21252 return;
21253 end if;
21255 -- The global refinement of inputs and outputs cannot be null when the
21256 -- corresponding Global pragma contains at least one item except in the
21257 -- case where we have states with null refinements.
21259 if Nkind (Items) = N_Null
21260 and then
21261 (Present (In_Items)
21262 or else Present (In_Out_Items)
21263 or else Present (Out_Items))
21264 and then not Has_Null_State
21265 then
21266 Error_Msg_NE
21267 ("refinement cannot be null, subprogram & has global items",
21268 N, Spec_Id);
21269 return;
21270 end if;
21272 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
21273 -- This ensures that the categorization of all refined global items is
21274 -- consistent with their role.
21276 Analyze_Global_In_Decl_Part (N);
21278 -- Perform all refinement checks with respect to completeness and mode
21279 -- matching.
21281 if Serious_Errors_Detected = Errors then
21282 Check_Refined_Global_List (Items);
21283 end if;
21285 -- For Input states with visible refinement, at least one constituent
21286 -- must be used as an Input in the global refinement.
21288 if Serious_Errors_Detected = Errors then
21289 Check_Input_States;
21290 end if;
21292 -- Verify all possible completion variants for In_Out states with
21293 -- visible refinement.
21295 if Serious_Errors_Detected = Errors then
21296 Check_In_Out_States;
21297 end if;
21299 -- For Output states with visible refinement, all constituents must be
21300 -- used as Outputs in the global refinement.
21302 if Serious_Errors_Detected = Errors then
21303 Check_Output_States;
21304 end if;
21306 -- Emit errors for all constituents that belong to other states with
21307 -- visible refinement that do not appear in Global.
21309 if Serious_Errors_Detected = Errors then
21310 Report_Extra_Constituents;
21311 end if;
21312 end Analyze_Refined_Global_In_Decl_Part;
21314 ----------------------------------------
21315 -- Analyze_Refined_State_In_Decl_Part --
21316 ----------------------------------------
21318 procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is
21319 Pack_Body : constant Node_Id := Parent (N);
21320 Spec_Id : constant Entity_Id := Corresponding_Spec (Pack_Body);
21322 Abstr_States : Elist_Id := No_Elist;
21323 -- A list of all abstract states defined in the package declaration. The
21324 -- list is used to report unrefined states.
21326 Constituents_Seen : Elist_Id := No_Elist;
21327 -- A list that contains all constituents processed so far. The list is
21328 -- used to detect multiple uses of the same constituent.
21330 Hidden_States : Elist_Id := No_Elist;
21331 -- A list of all hidden states (abstract states and variables) that
21332 -- appear in the package spec and body. The list is used to report
21333 -- unused hidden states.
21335 Refined_States_Seen : Elist_Id := No_Elist;
21336 -- A list that contains all refined states processed so far. The list is
21337 -- used to detect duplicate refinements.
21339 procedure Analyze_Refinement_Clause (Clause : Node_Id);
21340 -- Perform full analysis of a single refinement clause
21342 procedure Collect_Hidden_States;
21343 -- Gather the entities of all hidden states that appear in the spec and
21344 -- body of the related package in Hidden_States.
21346 procedure Report_Unrefined_States;
21347 -- Emit errors for all abstract states that have not been refined by
21348 -- the pragma.
21350 procedure Report_Unused_Hidden_States;
21351 -- Emit errors for all hidden states of the related package that do not
21352 -- participate in a refinement.
21354 -------------------------------
21355 -- Analyze_Refinement_Clause --
21356 -------------------------------
21358 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
21359 State_Id : Entity_Id := Empty;
21360 -- The entity of the state being refined in the current clause
21362 Non_Null_Seen : Boolean := False;
21363 Null_Seen : Boolean := False;
21364 -- Flags used to detect multiple uses of null in a single clause or a
21365 -- mixture of null and non-null constituents.
21367 procedure Analyze_Constituent (Constit : Node_Id);
21368 -- Perform full analysis of a single constituent
21370 procedure Check_Matching_State
21371 (State : Node_Id;
21372 State_Id : Entity_Id);
21373 -- Determine whether state State denoted by its name State_Id appears
21374 -- in Abstr_States. Emit an error when attempting to re-refine the
21375 -- state or when the state is not defined in the package declaration.
21376 -- Otherwise remove the state from Abstr_States.
21378 -------------------------
21379 -- Analyze_Constituent --
21380 -------------------------
21382 procedure Analyze_Constituent (Constit : Node_Id) is
21383 procedure Check_Matching_Constituent (Constit_Id : Entity_Id);
21384 -- Determine whether constituent Constit denoted by its entity
21385 -- Constit_Id appears in Hidden_States. Emit an error when the
21386 -- constituent is not a valid hidden state of the related package
21387 -- or when it is used more than once. Otherwise remove the
21388 -- constituent from Hidden_States.
21390 --------------------------------
21391 -- Check_Matching_Constituent --
21392 --------------------------------
21394 procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is
21395 procedure Collect_Constituent;
21396 -- Add constituent Constit_Id to the refinements of State_Id
21398 -------------------------
21399 -- Collect_Constituent --
21400 -------------------------
21402 procedure Collect_Constituent is
21403 begin
21404 -- Add the constituent to the lis of processed items to aid
21405 -- with the detection of duplicates.
21407 Add_Item (Constit_Id, Constituents_Seen);
21409 -- Collect the constituent in the list of refinement items.
21410 -- Establish a relation between the refined state and its
21411 -- constituent.
21413 Append_Elmt (Constit_Id, Refinement_Constituents (State_Id));
21414 Set_Refined_State (Constit_Id, State_Id);
21416 -- The state has at least one legal constituent, mark the
21417 -- start of the refinement region. The region ends when the
21418 -- body declarations end (see routine Analyze_Declarations).
21420 Set_Has_Visible_Refinement (State_Id);
21421 end Collect_Constituent;
21423 -- Local variables
21425 State_Elmt : Elmt_Id;
21427 -- Start of processing for Check_Matching_Constituent
21429 begin
21430 -- Detect a duplicate use of a constituent
21432 if Contains (Constituents_Seen, Constit_Id) then
21433 Error_Msg_NE
21434 ("duplicate use of constituent &", Constit, Constit_Id);
21435 return;
21437 -- A state can act as a constituent only when it is part of
21438 -- another state. This relation is expressed by option Part_Of
21439 -- of pragma Abstract_State.
21441 elsif Ekind (Constit_Id) = E_Abstract_State then
21442 if not Is_Part_Of (Constit_Id, State_Id) then
21443 Error_Msg_Name_1 := Chars (State_Id);
21444 Error_Msg_NE
21445 ("state & is not a valid constituent of ancestor "
21446 & "state %", Constit, Constit_Id);
21447 return;
21449 -- The constituent has the proper Part_Of option, but may
21450 -- not appear in the immediate hidden state of the related
21451 -- package. This case arises when the constituent appears
21452 -- in a private child or a private sibling. Recognize these
21453 -- scenarios and collect the constituent.
21455 elsif Is_Child_Or_Sibling
21456 (Pack_1 => Scope (State_Id),
21457 Pack_2 => Scope (Constit_Id),
21458 Private_Child => True)
21459 then
21460 Collect_Constituent;
21461 return;
21462 end if;
21463 end if;
21465 -- Inspect the hidden states of the related package looking for
21466 -- a match.
21468 if Present (Hidden_States) then
21469 State_Elmt := First_Elmt (Hidden_States);
21470 while Present (State_Elmt) loop
21472 -- A valid hidden state or variable acts as a constituent
21474 if Node (State_Elmt) = Constit_Id then
21476 -- Add the constituent to the lis of processed items
21477 -- to aid with the detection of duplicates. Remove the
21478 -- constituent from Hidden_States to signal that it
21479 -- has already been matched.
21481 Add_Item (Constit_Id, Constituents_Seen);
21482 Remove_Elmt (Hidden_States, State_Elmt);
21484 Collect_Constituent;
21485 return;
21486 end if;
21488 Next_Elmt (State_Elmt);
21489 end loop;
21490 end if;
21492 -- If we get here, we are refining a state that is not hidden
21493 -- with respect to the related package.
21495 Error_Msg_Name_1 := Chars (Spec_Id);
21496 Error_Msg_NE
21497 ("cannot use & in refinement, constituent is not a hidden "
21498 & "state of package %", Constit, Constit_Id);
21499 end Check_Matching_Constituent;
21501 -- Local variables
21503 Constit_Id : Entity_Id;
21505 -- Start of processing for Analyze_Constituent
21507 begin
21508 -- Detect multiple uses of null in a single refinement clause or a
21509 -- mixture of null and non-null constituents.
21511 if Nkind (Constit) = N_Null then
21512 if Null_Seen then
21513 Error_Msg_N
21514 ("multiple null constituents not allowed", Constit);
21516 elsif Non_Null_Seen then
21517 Error_Msg_N
21518 ("cannot mix null and non-null constituents", Constit);
21520 else
21521 Null_Seen := True;
21523 -- Collect the constituent in the list of refinement items
21525 Append_Elmt (Constit, Refinement_Constituents (State_Id));
21527 -- The state has at least one legal constituent, mark the
21528 -- start of the refinement region. The region ends when the
21529 -- body declarations end (see Analyze_Declarations).
21531 Set_Has_Visible_Refinement (State_Id);
21532 end if;
21534 -- Non-null constituents
21536 else
21537 Non_Null_Seen := True;
21539 if Null_Seen then
21540 Error_Msg_N
21541 ("cannot mix null and non-null constituents", Constit);
21542 end if;
21544 Analyze (Constit);
21546 -- Ensure that the constituent denotes a valid state or a
21547 -- whole variable.
21549 if Is_Entity_Name (Constit) then
21550 Constit_Id := Entity (Constit);
21552 if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then
21553 Check_Matching_Constituent (Constit_Id);
21555 else
21556 Error_Msg_NE
21557 ("constituent & must denote a variable or state",
21558 Constit, Constit_Id);
21559 end if;
21561 -- The constituent is illegal
21563 else
21564 Error_Msg_N ("malformed constituent", Constit);
21565 end if;
21566 end if;
21567 end Analyze_Constituent;
21569 --------------------------
21570 -- Check_Matching_State --
21571 --------------------------
21573 procedure Check_Matching_State
21574 (State : Node_Id;
21575 State_Id : Entity_Id)
21577 State_Elmt : Elmt_Id;
21579 begin
21580 -- Detect a duplicate refinement of a state
21582 if Contains (Refined_States_Seen, State_Id) then
21583 Error_Msg_NE
21584 ("duplicate refinement of state &", State, State_Id);
21585 return;
21586 end if;
21588 -- Inspect the abstract states defined in the package declaration
21589 -- looking for a match.
21591 State_Elmt := First_Elmt (Abstr_States);
21592 while Present (State_Elmt) loop
21594 -- A valid abstract state is being refined in the body. Add
21595 -- the state to the list of processed refined states to aid
21596 -- with the detection of duplicate refinements. Remove the
21597 -- state from Abstr_States to signal that it has already been
21598 -- refined.
21600 if Node (State_Elmt) = State_Id then
21601 Add_Item (State_Id, Refined_States_Seen);
21602 Remove_Elmt (Abstr_States, State_Elmt);
21603 return;
21604 end if;
21606 Next_Elmt (State_Elmt);
21607 end loop;
21609 -- If we get here, we are refining a state that is not defined in
21610 -- the package declaration.
21612 Error_Msg_Name_1 := Chars (Spec_Id);
21613 Error_Msg_NE
21614 ("cannot refine state, & is not defined in package %",
21615 State, State_Id);
21616 end Check_Matching_State;
21618 -- Local declarations
21620 Constit : Node_Id;
21621 State : Node_Id;
21623 -- Start of processing for Analyze_Refinement_Clause
21625 begin
21626 -- Analyze the state name of a refinement clause
21628 State := First (Choices (Clause));
21629 while Present (State) loop
21630 if Present (State_Id) then
21631 Error_Msg_N
21632 ("refinement clause cannot cover multiple states", State);
21634 else
21635 Analyze (State);
21637 -- Ensure that the state name denotes a valid abstract state
21638 -- that is defined in the spec of the related package.
21640 if Is_Entity_Name (State) then
21641 State_Id := Entity (State);
21643 -- Catch any attempts to re-refine a state or refine a
21644 -- state that is not defined in the package declaration.
21646 if Ekind (State_Id) = E_Abstract_State then
21647 Check_Matching_State (State, State_Id);
21648 else
21649 Error_Msg_NE
21650 ("& must denote an abstract state", State, State_Id);
21651 end if;
21653 -- Enforce SPARK RM (6.1.5(4)): A global item shall not
21654 -- denote a state abstraction whose refinement is visible
21655 -- (a state abstraction cannot be named within its enclosing
21656 -- package's body other than in its refinement).
21658 if Has_Body_References (State_Id) then
21659 declare
21660 Ref : Elmt_Id;
21661 Nod : Node_Id;
21662 begin
21663 Ref := First_Elmt (Body_References (State_Id));
21664 while Present (Ref) loop
21665 Nod := Node (Ref);
21666 Error_Msg_N
21667 ("global reference to & not allowed "
21668 & "(SPARK RM 6.1.5(4))", Nod);
21669 Error_Msg_Sloc := Sloc (State);
21670 Error_Msg_N ("\refinement of & is visible#", Nod);
21671 Next_Elmt (Ref);
21672 end loop;
21673 end;
21674 end if;
21676 -- The state name is illegal
21678 else
21679 Error_Msg_N
21680 ("malformed state name in refinement clause", State);
21681 end if;
21682 end if;
21684 Next (State);
21685 end loop;
21687 -- Analyze all constituents of the refinement. Multiple constituents
21688 -- appear as an aggregate.
21690 Constit := Expression (Clause);
21692 if Nkind (Constit) = N_Aggregate then
21693 if Present (Component_Associations (Constit)) then
21694 Error_Msg_N
21695 ("constituents of refinement clause must appear in "
21696 & "positional form", Constit);
21698 else pragma Assert (Present (Expressions (Constit)));
21699 Constit := First (Expressions (Constit));
21700 while Present (Constit) loop
21701 Analyze_Constituent (Constit);
21703 Next (Constit);
21704 end loop;
21705 end if;
21707 -- Various forms of a single constituent. Note that these may include
21708 -- malformed constituents.
21710 else
21711 Analyze_Constituent (Constit);
21712 end if;
21713 end Analyze_Refinement_Clause;
21715 ---------------------------
21716 -- Collect_Hidden_States --
21717 ---------------------------
21719 procedure Collect_Hidden_States is
21720 procedure Collect_Hidden_States_In_Decls (Decls : List_Id);
21721 -- Find all hidden states that appear in declarative list Decls and
21722 -- append their entities to Result.
21724 ------------------------------------
21725 -- Collect_Hidden_States_In_Decls --
21726 ------------------------------------
21728 procedure Collect_Hidden_States_In_Decls (Decls : List_Id) is
21729 procedure Collect_Abstract_States (States : Elist_Id);
21730 -- Copy the abstract states defined in list States to list Result
21732 -----------------------------
21733 -- Collect_Abstract_States --
21734 -----------------------------
21736 procedure Collect_Abstract_States (States : Elist_Id) is
21737 State_Elmt : Elmt_Id;
21739 begin
21740 State_Elmt := First_Elmt (States);
21741 while Present (State_Elmt) loop
21742 Add_Item (Node (State_Elmt), Hidden_States);
21744 Next_Elmt (State_Elmt);
21745 end loop;
21746 end Collect_Abstract_States;
21748 -- Local variables
21750 Decl : Node_Id;
21752 -- Start of processing for Collect_Hidden_States_In_Decls
21754 begin
21755 Decl := First (Decls);
21756 while Present (Decl) loop
21758 -- Source objects (non-constants) are valid hidden states
21760 if Nkind (Decl) = N_Object_Declaration
21761 and then Ekind (Defining_Entity (Decl)) = E_Variable
21762 and then Comes_From_Source (Decl)
21763 then
21764 Add_Item (Defining_Entity (Decl), Hidden_States);
21766 -- Gather the abstract states of a package along with all
21767 -- hidden states in its visible declarations.
21769 elsif Nkind (Decl) = N_Package_Declaration then
21770 Collect_Abstract_States
21771 (Abstract_States (Defining_Entity (Decl)));
21773 Collect_Hidden_States_In_Decls
21774 (Visible_Declarations (Specification (Decl)));
21775 end if;
21777 Next (Decl);
21778 end loop;
21779 end Collect_Hidden_States_In_Decls;
21781 -- Local variables
21783 Pack_Spec : constant Node_Id := Package_Specification (Spec_Id);
21785 -- Start of processing for Collect_Hidden_States
21787 begin
21788 -- Process the private declarations of the package spec and the
21789 -- declarations of the body.
21791 Collect_Hidden_States_In_Decls (Private_Declarations (Pack_Spec));
21792 Collect_Hidden_States_In_Decls (Declarations (Pack_Body));
21793 end Collect_Hidden_States;
21795 -----------------------------
21796 -- Report_Unrefined_States --
21797 -----------------------------
21799 procedure Report_Unrefined_States is
21800 State_Elmt : Elmt_Id;
21802 begin
21803 if Present (Abstr_States) then
21804 State_Elmt := First_Elmt (Abstr_States);
21805 while Present (State_Elmt) loop
21806 Error_Msg_N
21807 ("abstract state & must be refined", Node (State_Elmt));
21809 Next_Elmt (State_Elmt);
21810 end loop;
21811 end if;
21812 end Report_Unrefined_States;
21814 ---------------------------------
21815 -- Report_Unused_Hidden_States --
21816 ---------------------------------
21818 procedure Report_Unused_Hidden_States is
21819 Posted : Boolean := False;
21820 State_Elmt : Elmt_Id;
21821 State_Id : Entity_Id;
21823 begin
21824 if Present (Hidden_States) then
21825 State_Elmt := First_Elmt (Hidden_States);
21826 while Present (State_Elmt) loop
21827 State_Id := Node (State_Elmt);
21829 -- Generate an error message of the form:
21831 -- package ... has unused hidden states
21832 -- abstract state ... defined at ...
21833 -- variable ... defined at ...
21835 if not Posted then
21836 Posted := True;
21837 Error_Msg_NE
21838 ("package & has unused hidden states", N, Spec_Id);
21839 end if;
21841 Error_Msg_Sloc := Sloc (State_Id);
21843 if Ekind (State_Id) = E_Abstract_State then
21844 Error_Msg_NE ("\ abstract state & defined #", N, State_Id);
21845 else
21846 Error_Msg_NE ("\ variable & defined #", N, State_Id);
21847 end if;
21849 Next_Elmt (State_Elmt);
21850 end loop;
21851 end if;
21852 end Report_Unused_Hidden_States;
21854 -- Local declarations
21856 Clauses : constant Node_Id :=
21857 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
21858 Clause : Node_Id;
21860 -- Start of processing for Analyze_Refined_State_In_Decl_Part
21862 begin
21863 Set_Analyzed (N);
21865 -- Initialize the various lists used during analysis
21867 Abstr_States := New_Copy_Elist (Abstract_States (Spec_Id));
21868 Collect_Hidden_States;
21870 -- Multiple state refinements appear as an aggregate
21872 if Nkind (Clauses) = N_Aggregate then
21873 if Present (Expressions (Clauses)) then
21874 Error_Msg_N
21875 ("state refinements must appear as component associations",
21876 Clauses);
21878 else pragma Assert (Present (Component_Associations (Clauses)));
21879 Clause := First (Component_Associations (Clauses));
21880 while Present (Clause) loop
21881 Analyze_Refinement_Clause (Clause);
21883 Next (Clause);
21884 end loop;
21885 end if;
21887 -- Various forms of a single state refinement. Note that these may
21888 -- include malformed refinements.
21890 else
21891 Analyze_Refinement_Clause (Clauses);
21892 end if;
21894 -- Ensure that all abstract states have been refined and all hidden
21895 -- states of the related package unilized in refinements.
21897 Report_Unrefined_States;
21898 Report_Unused_Hidden_States;
21899 end Analyze_Refined_State_In_Decl_Part;
21901 ------------------------------------
21902 -- Analyze_Test_Case_In_Decl_Part --
21903 ------------------------------------
21905 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id) is
21906 begin
21907 -- Install formals and push subprogram spec onto scope stack so that we
21908 -- can see the formals from the pragma.
21910 Push_Scope (S);
21911 Install_Formals (S);
21913 -- Preanalyze the boolean expressions, we treat these as spec
21914 -- expressions (i.e. similar to a default expression).
21916 if Pragma_Name (N) = Name_Test_Case then
21917 Preanalyze_CTC_Args
21919 Get_Requires_From_CTC_Pragma (N),
21920 Get_Ensures_From_CTC_Pragma (N));
21921 end if;
21923 -- Remove the subprogram from the scope stack now that the pre-analysis
21924 -- of the expressions in the contract case or test case is done.
21926 End_Scope;
21927 end Analyze_Test_Case_In_Decl_Part;
21929 ----------------
21930 -- Appears_In --
21931 ----------------
21933 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
21934 Elmt : Elmt_Id;
21935 Id : Entity_Id;
21937 begin
21938 if Present (List) then
21939 Elmt := First_Elmt (List);
21940 while Present (Elmt) loop
21941 if Nkind (Node (Elmt)) = N_Defining_Identifier then
21942 Id := Node (Elmt);
21943 else
21944 Id := Entity (Node (Elmt));
21945 end if;
21947 if Id = Item_Id then
21948 return True;
21949 end if;
21951 Next_Elmt (Elmt);
21952 end loop;
21953 end if;
21955 return False;
21956 end Appears_In;
21958 ----------------
21959 -- Check_Kind --
21960 ----------------
21962 function Check_Kind (Nam : Name_Id) return Name_Id is
21963 PP : Node_Id;
21965 begin
21966 -- Loop through entries in check policy list
21968 PP := Opt.Check_Policy_List;
21969 while Present (PP) loop
21970 declare
21971 PPA : constant List_Id := Pragma_Argument_Associations (PP);
21972 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
21974 begin
21975 if Nam = Pnm
21976 or else (Pnm = Name_Assertion
21977 and then Is_Valid_Assertion_Kind (Nam))
21978 or else (Pnm = Name_Statement_Assertions
21979 and then Nam_In (Nam, Name_Assert,
21980 Name_Assert_And_Cut,
21981 Name_Assume,
21982 Name_Loop_Invariant))
21983 then
21984 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
21985 when Name_On | Name_Check =>
21986 return Name_Check;
21987 when Name_Off | Name_Ignore =>
21988 return Name_Ignore;
21989 when Name_Disable =>
21990 return Name_Disable;
21991 when others =>
21992 raise Program_Error;
21993 end case;
21995 else
21996 PP := Next_Pragma (PP);
21997 end if;
21998 end;
21999 end loop;
22001 -- If there are no specific entries that matched, then we let the
22002 -- setting of assertions govern. Note that this provides the needed
22003 -- compatibility with the RM for the cases of assertion, invariant,
22004 -- precondition, predicate, and postcondition.
22006 if Assertions_Enabled then
22007 return Name_Check;
22008 else
22009 return Name_Ignore;
22010 end if;
22011 end Check_Kind;
22013 -----------------------------
22014 -- Check_Applicable_Policy --
22015 -----------------------------
22017 procedure Check_Applicable_Policy (N : Node_Id) is
22018 PP : Node_Id;
22019 Policy : Name_Id;
22021 Ename : constant Name_Id := Original_Aspect_Name (N);
22023 begin
22024 -- No effect if not valid assertion kind name
22026 if not Is_Valid_Assertion_Kind (Ename) then
22027 return;
22028 end if;
22030 -- Loop through entries in check policy list
22032 PP := Opt.Check_Policy_List;
22033 while Present (PP) loop
22034 declare
22035 PPA : constant List_Id := Pragma_Argument_Associations (PP);
22036 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
22038 begin
22039 if Ename = Pnm
22040 or else Pnm = Name_Assertion
22041 or else (Pnm = Name_Statement_Assertions
22042 and then (Ename = Name_Assert or else
22043 Ename = Name_Assert_And_Cut or else
22044 Ename = Name_Assume or else
22045 Ename = Name_Loop_Invariant))
22046 then
22047 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
22049 case Policy is
22050 when Name_Off | Name_Ignore =>
22051 Set_Is_Ignored (N, True);
22052 Set_Is_Checked (N, False);
22054 when Name_On | Name_Check =>
22055 Set_Is_Checked (N, True);
22056 Set_Is_Ignored (N, False);
22058 when Name_Disable =>
22059 Set_Is_Ignored (N, True);
22060 Set_Is_Checked (N, False);
22061 Set_Is_Disabled (N, True);
22063 -- That should be exhaustive, the null here is a defence
22064 -- against a malformed tree from previous errors.
22066 when others =>
22067 null;
22068 end case;
22070 return;
22071 end if;
22073 PP := Next_Pragma (PP);
22074 end;
22075 end loop;
22077 -- If there are no specific entries that matched, then we let the
22078 -- setting of assertions govern. Note that this provides the needed
22079 -- compatibility with the RM for the cases of assertion, invariant,
22080 -- precondition, predicate, and postcondition.
22082 if Assertions_Enabled then
22083 Set_Is_Checked (N, True);
22084 Set_Is_Ignored (N, False);
22085 else
22086 Set_Is_Checked (N, False);
22087 Set_Is_Ignored (N, True);
22088 end if;
22089 end Check_Applicable_Policy;
22091 --------------------------
22092 -- Collect_Global_Items --
22093 --------------------------
22095 procedure Collect_Global_Items
22096 (Prag : Node_Id;
22097 In_Items : in out Elist_Id;
22098 In_Out_Items : in out Elist_Id;
22099 Out_Items : in out Elist_Id;
22100 Has_In_State : out Boolean;
22101 Has_In_Out_State : out Boolean;
22102 Has_Out_State : out Boolean;
22103 Has_Null_State : out Boolean)
22105 procedure Process_Global_List
22106 (List : Node_Id;
22107 Mode : Name_Id := Name_Input);
22108 -- Collect all items housed in a global list. Formal Mode denotes the
22109 -- current mode in effect.
22111 -------------------------
22112 -- Process_Global_List --
22113 -------------------------
22115 procedure Process_Global_List
22116 (List : Node_Id;
22117 Mode : Name_Id := Name_Input)
22119 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id);
22120 -- Add a single item to the appropriate list. Formal Mode denotes the
22121 -- current mode in effect.
22123 -------------------------
22124 -- Process_Global_Item --
22125 -------------------------
22127 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id) is
22128 Item_Id : constant Entity_Id := Entity_Of (Item);
22130 begin
22131 -- Signal that the global list contains at least one abstract
22132 -- state with a visible refinement. Note that the refinement may
22133 -- be null in which case there are no constituents.
22135 if Ekind (Item_Id) = E_Abstract_State then
22136 if Has_Null_Refinement (Item_Id) then
22137 Has_Null_State := True;
22139 elsif Has_Non_Null_Refinement (Item_Id) then
22140 if Mode = Name_Input then
22141 Has_In_State := True;
22142 elsif Mode = Name_In_Out then
22143 Has_In_Out_State := True;
22144 elsif Mode = Name_Output then
22145 Has_Out_State := True;
22146 end if;
22147 end if;
22148 end if;
22150 -- Add the item to the proper list
22152 if Mode = Name_Input then
22153 Add_Item (Item_Id, In_Items);
22154 elsif Mode = Name_In_Out then
22155 Add_Item (Item_Id, In_Out_Items);
22156 elsif Mode = Name_Output then
22157 Add_Item (Item_Id, Out_Items);
22158 end if;
22159 end Process_Global_Item;
22161 -- Local variables
22163 Item : Node_Id;
22165 -- Start of processing for Process_Global_List
22167 begin
22168 if Nkind (List) = N_Null then
22169 null;
22171 -- Single global item declaration
22173 elsif Nkind_In (List, N_Expanded_Name,
22174 N_Identifier,
22175 N_Selected_Component)
22176 then
22177 Process_Global_Item (List, Mode);
22179 -- Single global list or moded global list declaration
22181 elsif Nkind (List) = N_Aggregate then
22183 -- The declaration of a simple global list appear as a collection
22184 -- of expressions.
22186 if Present (Expressions (List)) then
22187 Item := First (Expressions (List));
22188 while Present (Item) loop
22189 Process_Global_Item (Item, Mode);
22191 Next (Item);
22192 end loop;
22194 -- The declaration of a moded global list appears as a collection
22195 -- of component associations where individual choices denote mode.
22197 elsif Present (Component_Associations (List)) then
22198 Item := First (Component_Associations (List));
22199 while Present (Item) loop
22200 Process_Global_List
22201 (List => Expression (Item),
22202 Mode => Chars (First (Choices (Item))));
22204 Next (Item);
22205 end loop;
22207 -- Invalid tree
22209 else
22210 raise Program_Error;
22211 end if;
22213 -- Invalid list
22215 else
22216 raise Program_Error;
22217 end if;
22218 end Process_Global_List;
22220 -- Local variables
22222 Items : constant Node_Id :=
22223 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
22225 -- Start of processing for Collect_Global_Items
22227 begin
22228 -- Assume that no states have been encountered
22230 Has_In_State := False;
22231 Has_In_Out_State := False;
22232 Has_Out_State := False;
22233 Has_Null_State := False;
22235 Process_Global_List (Items);
22236 end Collect_Global_Items;
22238 ---------------------------------------
22239 -- Collect_Subprogram_Inputs_Outputs --
22240 ---------------------------------------
22242 procedure Collect_Subprogram_Inputs_Outputs
22243 (Subp_Id : Entity_Id;
22244 Subp_Inputs : in out Elist_Id;
22245 Subp_Outputs : in out Elist_Id;
22246 Global_Seen : out Boolean)
22248 procedure Collect_Global_List
22249 (List : Node_Id;
22250 Mode : Name_Id := Name_Input);
22251 -- Collect all relevant items from a global list
22253 -------------------------
22254 -- Collect_Global_List --
22255 -------------------------
22257 procedure Collect_Global_List
22258 (List : Node_Id;
22259 Mode : Name_Id := Name_Input)
22261 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
22262 -- Add an item to the proper subprogram input or output collection
22264 -------------------------
22265 -- Collect_Global_Item --
22266 -------------------------
22268 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
22269 begin
22270 if Nam_In (Mode, Name_In_Out, Name_Input) then
22271 Add_Item (Item, Subp_Inputs);
22272 end if;
22274 if Nam_In (Mode, Name_In_Out, Name_Output) then
22275 Add_Item (Item, Subp_Outputs);
22276 end if;
22277 end Collect_Global_Item;
22279 -- Local variables
22281 Assoc : Node_Id;
22282 Item : Node_Id;
22284 -- Start of processing for Collect_Global_List
22286 begin
22287 if Nkind (List) = N_Null then
22288 null;
22290 -- Single global item declaration
22292 elsif Nkind_In (List, N_Expanded_Name,
22293 N_Identifier,
22294 N_Selected_Component)
22295 then
22296 Collect_Global_Item (List, Mode);
22298 -- Simple global list or moded global list declaration
22300 elsif Nkind (List) = N_Aggregate then
22301 if Present (Expressions (List)) then
22302 Item := First (Expressions (List));
22303 while Present (Item) loop
22304 Collect_Global_Item (Item, Mode);
22305 Next (Item);
22306 end loop;
22308 else
22309 Assoc := First (Component_Associations (List));
22310 while Present (Assoc) loop
22311 Collect_Global_List
22312 (List => Expression (Assoc),
22313 Mode => Chars (First (Choices (Assoc))));
22314 Next (Assoc);
22315 end loop;
22316 end if;
22318 -- Invalid list
22320 else
22321 raise Program_Error;
22322 end if;
22323 end Collect_Global_List;
22325 -- Local variables
22327 Formal : Entity_Id;
22328 Global : Node_Id;
22329 List : Node_Id;
22330 Spec_Id : Entity_Id;
22332 -- Start of processing for Collect_Subprogram_Inputs_Outputs
22334 begin
22335 Global_Seen := False;
22337 -- Find the entity of the corresponding spec when processing a body
22339 if Ekind (Subp_Id) = E_Subprogram_Body then
22340 Spec_Id := Corresponding_Spec (Parent (Parent (Subp_Id)));
22341 else
22342 Spec_Id := Subp_Id;
22343 end if;
22345 -- Process all formal parameters
22347 Formal := First_Formal (Spec_Id);
22348 while Present (Formal) loop
22349 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
22350 Add_Item (Formal, Subp_Inputs);
22351 end if;
22353 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
22354 Add_Item (Formal, Subp_Outputs);
22356 -- Out parameters can act as inputs when the related type is
22357 -- tagged, unconstrained array, unconstrained record or record
22358 -- with unconstrained components.
22360 if Ekind (Formal) = E_Out_Parameter
22361 and then Is_Unconstrained_Or_Tagged_Item (Formal)
22362 then
22363 Add_Item (Formal, Subp_Inputs);
22364 end if;
22365 end if;
22367 Next_Formal (Formal);
22368 end loop;
22370 -- When processing a subprogram body, look for pragma Refined_Global as
22371 -- it provides finer granularity of inputs and outputs.
22373 if Ekind (Subp_Id) = E_Subprogram_Body then
22374 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
22376 -- Subprogram declaration case, look for pragma Global
22378 else
22379 Global := Get_Pragma (Spec_Id, Pragma_Global);
22380 end if;
22382 if Present (Global) then
22383 Global_Seen := True;
22384 List := Expression (First (Pragma_Argument_Associations (Global)));
22386 -- The pragma may not have been analyzed because of the arbitrary
22387 -- declaration order of aspects. Make sure that it is analyzed for
22388 -- the purposes of item extraction.
22390 if not Analyzed (List) then
22391 if Pragma_Name (Global) = Name_Refined_Global then
22392 Analyze_Refined_Global_In_Decl_Part (Global);
22393 else
22394 Analyze_Global_In_Decl_Part (Global);
22395 end if;
22396 end if;
22398 -- Nothing to be done for a null global list
22400 if Nkind (List) /= N_Null then
22401 Collect_Global_List (List);
22402 end if;
22403 end if;
22404 end Collect_Subprogram_Inputs_Outputs;
22406 ---------------------------------
22407 -- Delay_Config_Pragma_Analyze --
22408 ---------------------------------
22410 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
22411 begin
22412 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
22413 Name_Priority_Specific_Dispatching);
22414 end Delay_Config_Pragma_Analyze;
22416 -------------------------------------
22417 -- Find_Related_Subprogram_Or_Body --
22418 -------------------------------------
22420 function Find_Related_Subprogram_Or_Body
22421 (Prag : Node_Id;
22422 Do_Checks : Boolean := False) return Node_Id
22424 Context : constant Node_Id := Parent (Prag);
22425 Nam : constant Name_Id := Pragma_Name (Prag);
22426 Stmt : Node_Id;
22428 Look_For_Body : constant Boolean :=
22429 Nam_In (Nam, Name_Refined_Depends,
22430 Name_Refined_Global,
22431 Name_Refined_Post);
22432 -- Refinement pragmas must be associated with a subprogram body [stub]
22434 begin
22435 pragma Assert (Nkind (Prag) = N_Pragma);
22437 -- If the pragma is a byproduct of aspect expansion, return the related
22438 -- context of the original aspect.
22440 if Present (Corresponding_Aspect (Prag)) then
22441 return Parent (Corresponding_Aspect (Prag));
22442 end if;
22444 -- Otherwise the pragma is a source construct, most likely part of a
22445 -- declarative list. Skip preceding declarations while looking for a
22446 -- proper subprogram declaration.
22448 pragma Assert (Is_List_Member (Prag));
22450 Stmt := Prev (Prag);
22451 while Present (Stmt) loop
22453 -- Skip prior pragmas, but check for duplicates
22455 if Nkind (Stmt) = N_Pragma then
22456 if Do_Checks and then Pragma_Name (Stmt) = Nam then
22457 Error_Msg_Name_1 := Nam;
22458 Error_Msg_Sloc := Sloc (Stmt);
22459 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
22460 end if;
22462 -- Emit an error when a refinement pragma appears on an expression
22463 -- function without a completion.
22465 elsif Do_Checks
22466 and then Look_For_Body
22467 and then Nkind (Stmt) = N_Subprogram_Declaration
22468 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
22469 and then not Has_Completion (Defining_Entity (Stmt))
22470 then
22471 Error_Msg_Name_1 := Nam;
22472 Error_Msg_N
22473 ("pragma % cannot apply to a stand alone expression function",
22474 Prag);
22476 return Empty;
22478 -- The refinement pragma applies to a subprogram body stub
22480 elsif Look_For_Body
22481 and then Nkind (Stmt) = N_Subprogram_Body_Stub
22482 then
22483 return Stmt;
22485 -- Skip internally generated code
22487 elsif not Comes_From_Source (Stmt) then
22488 null;
22490 -- Return the current construct which is either a subprogram body,
22491 -- a subprogram declaration or is illegal.
22493 else
22494 return Stmt;
22495 end if;
22497 Prev (Stmt);
22498 end loop;
22500 -- If we fall through, then the pragma was either the first declaration
22501 -- or it was preceded by other pragmas and no source constructs.
22503 -- The pragma is associated with a library-level subprogram
22505 if Nkind (Context) = N_Compilation_Unit_Aux then
22506 return Unit (Parent (Context));
22508 -- The pragma appears inside the declarative part of a subprogram body
22510 elsif Nkind (Context) = N_Subprogram_Body then
22511 return Context;
22513 -- No candidate subprogram [body] found
22515 else
22516 return Empty;
22517 end if;
22518 end Find_Related_Subprogram_Or_Body;
22520 -------------------------
22521 -- Get_Base_Subprogram --
22522 -------------------------
22524 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
22525 Result : Entity_Id;
22527 begin
22528 -- Follow subprogram renaming chain
22530 Result := Def_Id;
22532 if Is_Subprogram (Result)
22533 and then
22534 Nkind (Parent (Declaration_Node (Result))) =
22535 N_Subprogram_Renaming_Declaration
22536 and then Present (Alias (Result))
22537 then
22538 Result := Alias (Result);
22539 end if;
22541 return Result;
22542 end Get_Base_Subprogram;
22544 -----------------------
22545 -- Get_SPARK_Mode_Id --
22546 -----------------------
22548 function Get_SPARK_Mode_Id (N : Name_Id) return SPARK_Mode_Id is
22549 begin
22550 if N = Name_On then
22551 return SPARK_On;
22552 elsif N = Name_Off then
22553 return SPARK_Off;
22554 elsif N = Name_Auto then
22555 return SPARK_Auto;
22557 -- Any other argument is erroneous
22559 else
22560 raise Program_Error;
22561 end if;
22562 end Get_SPARK_Mode_Id;
22564 -----------------------
22565 -- Get_SPARK_Mode_Id --
22566 -----------------------
22568 function Get_SPARK_Mode_Id (N : Node_Id) return SPARK_Mode_Id is
22569 Args : List_Id;
22570 Mode : Node_Id;
22572 begin
22573 pragma Assert (Nkind (N) = N_Pragma);
22574 Args := Pragma_Argument_Associations (N);
22576 -- Extract the mode from the argument list
22578 if Present (Args) then
22579 Mode := First (Pragma_Argument_Associations (N));
22580 return Get_SPARK_Mode_Id (Chars (Get_Pragma_Arg (Mode)));
22582 -- When SPARK_Mode appears without an argument, the default is ON
22584 else
22585 return SPARK_On;
22586 end if;
22587 end Get_SPARK_Mode_Id;
22589 ----------------
22590 -- Initialize --
22591 ----------------
22593 procedure Initialize is
22594 begin
22595 Externals.Init;
22596 end Initialize;
22598 -----------------------------
22599 -- Is_Config_Static_String --
22600 -----------------------------
22602 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
22604 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
22605 -- This is an internal recursive function that is just like the outer
22606 -- function except that it adds the string to the name buffer rather
22607 -- than placing the string in the name buffer.
22609 ------------------------------
22610 -- Add_Config_Static_String --
22611 ------------------------------
22613 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
22614 N : Node_Id;
22615 C : Char_Code;
22617 begin
22618 N := Arg;
22620 if Nkind (N) = N_Op_Concat then
22621 if Add_Config_Static_String (Left_Opnd (N)) then
22622 N := Right_Opnd (N);
22623 else
22624 return False;
22625 end if;
22626 end if;
22628 if Nkind (N) /= N_String_Literal then
22629 Error_Msg_N ("string literal expected for pragma argument", N);
22630 return False;
22632 else
22633 for J in 1 .. String_Length (Strval (N)) loop
22634 C := Get_String_Char (Strval (N), J);
22636 if not In_Character_Range (C) then
22637 Error_Msg
22638 ("string literal contains invalid wide character",
22639 Sloc (N) + 1 + Source_Ptr (J));
22640 return False;
22641 end if;
22643 Add_Char_To_Name_Buffer (Get_Character (C));
22644 end loop;
22645 end if;
22647 return True;
22648 end Add_Config_Static_String;
22650 -- Start of processing for Is_Config_Static_String
22652 begin
22653 Name_Len := 0;
22655 return Add_Config_Static_String (Arg);
22656 end Is_Config_Static_String;
22658 -------------------------------
22659 -- Is_Elaboration_SPARK_Mode --
22660 -------------------------------
22662 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
22663 begin
22664 pragma Assert
22665 (Nkind (N) = N_Pragma
22666 and then Pragma_Name (N) = Name_SPARK_Mode
22667 and then Is_List_Member (N));
22669 -- Pragma SPARK_Mode affects the elaboration of a package body when it
22670 -- appears in the statement part of the body.
22672 return
22673 Present (Parent (N))
22674 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
22675 and then List_Containing (N) = Statements (Parent (N))
22676 and then Present (Parent (Parent (N)))
22677 and then Nkind (Parent (Parent (N))) = N_Package_Body;
22678 end Is_Elaboration_SPARK_Mode;
22680 -----------------------------------------
22681 -- Is_Non_Significant_Pragma_Reference --
22682 -----------------------------------------
22684 -- This function makes use of the following static table which indicates
22685 -- whether appearance of some name in a given pragma is to be considered
22686 -- as a reference for the purposes of warnings about unreferenced objects.
22688 -- -1 indicates that references in any argument position are significant
22689 -- 0 indicates that appearance in any argument is not significant
22690 -- +n indicates that appearance as argument n is significant, but all
22691 -- other arguments are not significant
22692 -- 99 special processing required (e.g. for pragma Check)
22694 Sig_Flags : constant array (Pragma_Id) of Int :=
22695 (Pragma_AST_Entry => -1,
22696 Pragma_Abort_Defer => -1,
22697 Pragma_Abstract_State => -1,
22698 Pragma_Ada_83 => -1,
22699 Pragma_Ada_95 => -1,
22700 Pragma_Ada_05 => -1,
22701 Pragma_Ada_2005 => -1,
22702 Pragma_Ada_12 => -1,
22703 Pragma_Ada_2012 => -1,
22704 Pragma_All_Calls_Remote => -1,
22705 Pragma_Annotate => -1,
22706 Pragma_Assert => -1,
22707 Pragma_Assert_And_Cut => -1,
22708 Pragma_Assertion_Policy => 0,
22709 Pragma_Assume => -1,
22710 Pragma_Assume_No_Invalid_Values => 0,
22711 Pragma_Attribute_Definition => +3,
22712 Pragma_Asynchronous => -1,
22713 Pragma_Atomic => 0,
22714 Pragma_Atomic_Components => 0,
22715 Pragma_Attach_Handler => -1,
22716 Pragma_Check => 99,
22717 Pragma_Check_Float_Overflow => 0,
22718 Pragma_Check_Name => 0,
22719 Pragma_Check_Policy => 0,
22720 Pragma_CIL_Constructor => -1,
22721 Pragma_CPP_Class => 0,
22722 Pragma_CPP_Constructor => 0,
22723 Pragma_CPP_Virtual => 0,
22724 Pragma_CPP_Vtable => 0,
22725 Pragma_CPU => -1,
22726 Pragma_C_Pass_By_Copy => 0,
22727 Pragma_Comment => 0,
22728 Pragma_Common_Object => -1,
22729 Pragma_Compile_Time_Error => -1,
22730 Pragma_Compile_Time_Warning => -1,
22731 Pragma_Compiler_Unit => 0,
22732 Pragma_Complete_Representation => 0,
22733 Pragma_Complex_Representation => 0,
22734 Pragma_Component_Alignment => -1,
22735 Pragma_Contract_Cases => -1,
22736 Pragma_Controlled => 0,
22737 Pragma_Convention => 0,
22738 Pragma_Convention_Identifier => 0,
22739 Pragma_Debug => -1,
22740 Pragma_Debug_Policy => 0,
22741 Pragma_Detect_Blocking => -1,
22742 Pragma_Default_Storage_Pool => -1,
22743 Pragma_Depends => -1,
22744 Pragma_Disable_Atomic_Synchronization => -1,
22745 Pragma_Discard_Names => 0,
22746 Pragma_Dispatching_Domain => -1,
22747 Pragma_Elaborate => -1,
22748 Pragma_Elaborate_All => -1,
22749 Pragma_Elaborate_Body => -1,
22750 Pragma_Elaboration_Checks => -1,
22751 Pragma_Eliminate => -1,
22752 Pragma_Enable_Atomic_Synchronization => -1,
22753 Pragma_Export => -1,
22754 Pragma_Export_Exception => -1,
22755 Pragma_Export_Function => -1,
22756 Pragma_Export_Object => -1,
22757 Pragma_Export_Procedure => -1,
22758 Pragma_Export_Value => -1,
22759 Pragma_Export_Valued_Procedure => -1,
22760 Pragma_Extend_System => -1,
22761 Pragma_Extensions_Allowed => -1,
22762 Pragma_External => -1,
22763 Pragma_Favor_Top_Level => -1,
22764 Pragma_External_Name_Casing => -1,
22765 Pragma_Fast_Math => -1,
22766 Pragma_Finalize_Storage_Only => 0,
22767 Pragma_Float_Representation => 0,
22768 Pragma_Global => -1,
22769 Pragma_Ident => -1,
22770 Pragma_Implementation_Defined => -1,
22771 Pragma_Implemented => -1,
22772 Pragma_Implicit_Packing => 0,
22773 Pragma_Import => +2,
22774 Pragma_Import_Exception => 0,
22775 Pragma_Import_Function => 0,
22776 Pragma_Import_Object => 0,
22777 Pragma_Import_Procedure => 0,
22778 Pragma_Import_Valued_Procedure => 0,
22779 Pragma_Independent => 0,
22780 Pragma_Independent_Components => 0,
22781 Pragma_Initial_Condition => -1,
22782 Pragma_Initialize_Scalars => -1,
22783 Pragma_Initializes => -1,
22784 Pragma_Inline => 0,
22785 Pragma_Inline_Always => 0,
22786 Pragma_Inline_Generic => 0,
22787 Pragma_Inspection_Point => -1,
22788 Pragma_Interface => +2,
22789 Pragma_Interface_Name => +2,
22790 Pragma_Interrupt_Handler => -1,
22791 Pragma_Interrupt_Priority => -1,
22792 Pragma_Interrupt_State => -1,
22793 Pragma_Invariant => -1,
22794 Pragma_Java_Constructor => -1,
22795 Pragma_Java_Interface => -1,
22796 Pragma_Keep_Names => 0,
22797 Pragma_License => -1,
22798 Pragma_Link_With => -1,
22799 Pragma_Linker_Alias => -1,
22800 Pragma_Linker_Constructor => -1,
22801 Pragma_Linker_Destructor => -1,
22802 Pragma_Linker_Options => -1,
22803 Pragma_Linker_Section => -1,
22804 Pragma_List => -1,
22805 Pragma_Lock_Free => -1,
22806 Pragma_Locking_Policy => -1,
22807 Pragma_Long_Float => -1,
22808 Pragma_Loop_Invariant => -1,
22809 Pragma_Loop_Optimize => -1,
22810 Pragma_Loop_Variant => -1,
22811 Pragma_Machine_Attribute => -1,
22812 Pragma_Main => -1,
22813 Pragma_Main_Storage => -1,
22814 Pragma_Memory_Size => -1,
22815 Pragma_No_Return => 0,
22816 Pragma_No_Body => 0,
22817 Pragma_No_Inline => 0,
22818 Pragma_No_Run_Time => -1,
22819 Pragma_No_Strict_Aliasing => -1,
22820 Pragma_Normalize_Scalars => -1,
22821 Pragma_Obsolescent => 0,
22822 Pragma_Optimize => -1,
22823 Pragma_Optimize_Alignment => -1,
22824 Pragma_Overflow_Mode => 0,
22825 Pragma_Overriding_Renamings => 0,
22826 Pragma_Ordered => 0,
22827 Pragma_Pack => 0,
22828 Pragma_Page => -1,
22829 Pragma_Partition_Elaboration_Policy => -1,
22830 Pragma_Passive => -1,
22831 Pragma_Persistent_BSS => 0,
22832 Pragma_Polling => -1,
22833 Pragma_Post => -1,
22834 Pragma_Postcondition => -1,
22835 Pragma_Post_Class => -1,
22836 Pragma_Pre => -1,
22837 Pragma_Precondition => -1,
22838 Pragma_Predicate => -1,
22839 Pragma_Preelaborable_Initialization => -1,
22840 Pragma_Preelaborate => -1,
22841 Pragma_Preelaborate_05 => -1,
22842 Pragma_Pre_Class => -1,
22843 Pragma_Priority => -1,
22844 Pragma_Priority_Specific_Dispatching => -1,
22845 Pragma_Profile => 0,
22846 Pragma_Profile_Warnings => 0,
22847 Pragma_Propagate_Exceptions => -1,
22848 Pragma_Psect_Object => -1,
22849 Pragma_Pure => -1,
22850 Pragma_Pure_05 => -1,
22851 Pragma_Pure_12 => -1,
22852 Pragma_Pure_Function => -1,
22853 Pragma_Queuing_Policy => -1,
22854 Pragma_Rational => -1,
22855 Pragma_Ravenscar => -1,
22856 Pragma_Refined_Depends => -1,
22857 Pragma_Refined_Global => -1,
22858 Pragma_Refined_Post => -1,
22859 Pragma_Refined_State => -1,
22860 Pragma_Relative_Deadline => -1,
22861 Pragma_Remote_Access_Type => -1,
22862 Pragma_Remote_Call_Interface => -1,
22863 Pragma_Remote_Types => -1,
22864 Pragma_Restricted_Run_Time => -1,
22865 Pragma_Restriction_Warnings => -1,
22866 Pragma_Restrictions => -1,
22867 Pragma_Reviewable => -1,
22868 Pragma_Short_Circuit_And_Or => -1,
22869 Pragma_Share_Generic => -1,
22870 Pragma_Shared => -1,
22871 Pragma_Shared_Passive => -1,
22872 Pragma_Short_Descriptors => 0,
22873 Pragma_Simple_Storage_Pool_Type => 0,
22874 Pragma_Source_File_Name => -1,
22875 Pragma_Source_File_Name_Project => -1,
22876 Pragma_Source_Reference => -1,
22877 Pragma_SPARK_Mode => 0,
22878 Pragma_Storage_Size => -1,
22879 Pragma_Storage_Unit => -1,
22880 Pragma_Static_Elaboration_Desired => -1,
22881 Pragma_Stream_Convert => -1,
22882 Pragma_Style_Checks => -1,
22883 Pragma_Subtitle => -1,
22884 Pragma_Suppress => 0,
22885 Pragma_Suppress_Exception_Locations => 0,
22886 Pragma_Suppress_All => -1,
22887 Pragma_Suppress_Debug_Info => 0,
22888 Pragma_Suppress_Initialization => 0,
22889 Pragma_System_Name => -1,
22890 Pragma_Task_Dispatching_Policy => -1,
22891 Pragma_Task_Info => -1,
22892 Pragma_Task_Name => -1,
22893 Pragma_Task_Storage => 0,
22894 Pragma_Test_Case => -1,
22895 Pragma_Thread_Local_Storage => 0,
22896 Pragma_Time_Slice => -1,
22897 Pragma_Title => -1,
22898 Pragma_Type_Invariant => -1,
22899 Pragma_Type_Invariant_Class => -1,
22900 Pragma_Unchecked_Union => 0,
22901 Pragma_Unimplemented_Unit => -1,
22902 Pragma_Universal_Aliasing => -1,
22903 Pragma_Universal_Data => -1,
22904 Pragma_Unmodified => -1,
22905 Pragma_Unreferenced => -1,
22906 Pragma_Unreferenced_Objects => -1,
22907 Pragma_Unreserve_All_Interrupts => -1,
22908 Pragma_Unsuppress => 0,
22909 Pragma_Use_VADS_Size => -1,
22910 Pragma_Validity_Checks => -1,
22911 Pragma_Volatile => 0,
22912 Pragma_Volatile_Components => 0,
22913 Pragma_Warnings => -1,
22914 Pragma_Weak_External => -1,
22915 Pragma_Wide_Character_Encoding => 0,
22916 Unknown_Pragma => 0);
22918 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
22919 Id : Pragma_Id;
22920 P : Node_Id;
22921 C : Int;
22922 A : Node_Id;
22924 begin
22925 P := Parent (N);
22927 if Nkind (P) /= N_Pragma_Argument_Association then
22928 return False;
22930 else
22931 Id := Get_Pragma_Id (Parent (P));
22932 C := Sig_Flags (Id);
22934 case C is
22935 when -1 =>
22936 return False;
22938 when 0 =>
22939 return True;
22941 when 99 =>
22942 case Id is
22944 -- For pragma Check, the first argument is not significant,
22945 -- the second and the third (if present) arguments are
22946 -- significant.
22948 when Pragma_Check =>
22949 return
22950 P = First (Pragma_Argument_Associations (Parent (P)));
22952 when others =>
22953 raise Program_Error;
22954 end case;
22956 when others =>
22957 A := First (Pragma_Argument_Associations (Parent (P)));
22958 for J in 1 .. C - 1 loop
22959 if No (A) then
22960 return False;
22961 end if;
22963 Next (A);
22964 end loop;
22966 return A = P; -- is this wrong way round ???
22967 end case;
22968 end if;
22969 end Is_Non_Significant_Pragma_Reference;
22971 ----------------
22972 -- Is_Part_Of --
22973 ----------------
22975 function Is_Part_Of
22976 (State : Entity_Id;
22977 Ancestor : Entity_Id) return Boolean
22979 Options : constant Node_Id := Parent (State);
22980 Name : Node_Id;
22981 Option : Node_Id;
22982 Value : Node_Id;
22984 begin
22985 -- A state declaration with option Part_Of appears as an extension
22986 -- aggregate with component associations.
22988 if Nkind (Options) = N_Extension_Aggregate then
22989 Option := First (Component_Associations (Options));
22990 while Present (Option) loop
22991 Name := First (Choices (Option));
22992 Value := Expression (Option);
22994 if Chars (Name) = Name_Part_Of then
22995 return Entity (Value) = Ancestor;
22996 end if;
22998 Next (Option);
22999 end loop;
23000 end if;
23002 return False;
23003 end Is_Part_Of;
23005 ------------------------------
23006 -- Is_Pragma_String_Literal --
23007 ------------------------------
23009 -- This function returns true if the corresponding pragma argument is a
23010 -- static string expression. These are the only cases in which string
23011 -- literals can appear as pragma arguments. We also allow a string literal
23012 -- as the first argument to pragma Assert (although it will of course
23013 -- always generate a type error).
23015 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
23016 Pragn : constant Node_Id := Parent (Par);
23017 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
23018 Pname : constant Name_Id := Pragma_Name (Pragn);
23019 Argn : Natural;
23020 N : Node_Id;
23022 begin
23023 Argn := 1;
23024 N := First (Assoc);
23025 loop
23026 exit when N = Par;
23027 Argn := Argn + 1;
23028 Next (N);
23029 end loop;
23031 if Pname = Name_Assert then
23032 return True;
23034 elsif Pname = Name_Export then
23035 return Argn > 2;
23037 elsif Pname = Name_Ident then
23038 return Argn = 1;
23040 elsif Pname = Name_Import then
23041 return Argn > 2;
23043 elsif Pname = Name_Interface_Name then
23044 return Argn > 1;
23046 elsif Pname = Name_Linker_Alias then
23047 return Argn = 2;
23049 elsif Pname = Name_Linker_Section then
23050 return Argn = 2;
23052 elsif Pname = Name_Machine_Attribute then
23053 return Argn = 2;
23055 elsif Pname = Name_Source_File_Name then
23056 return True;
23058 elsif Pname = Name_Source_Reference then
23059 return Argn = 2;
23061 elsif Pname = Name_Title then
23062 return True;
23064 elsif Pname = Name_Subtitle then
23065 return True;
23067 else
23068 return False;
23069 end if;
23070 end Is_Pragma_String_Literal;
23072 ---------------------------
23073 -- Is_Private_SPARK_Mode --
23074 ---------------------------
23076 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
23077 begin
23078 pragma Assert
23079 (Nkind (N) = N_Pragma
23080 and then Pragma_Name (N) = Name_SPARK_Mode
23081 and then Is_List_Member (N));
23083 -- For pragma SPARK_Mode to be private, it has to appear in the private
23084 -- declarations of a package.
23086 return
23087 Present (Parent (N))
23088 and then Nkind (Parent (N)) = N_Package_Specification
23089 and then List_Containing (N) = Private_Declarations (Parent (N));
23090 end Is_Private_SPARK_Mode;
23092 -------------------------------------
23093 -- Is_Unconstrained_Or_Tagged_Item --
23094 -------------------------------------
23096 function Is_Unconstrained_Or_Tagged_Item
23097 (Item : Entity_Id) return Boolean
23099 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
23100 -- Determine whether record type Typ has at least one unconstrained
23101 -- component.
23103 ---------------------------------
23104 -- Has_Unconstrained_Component --
23105 ---------------------------------
23107 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
23108 Comp : Entity_Id;
23110 begin
23111 Comp := First_Component (Typ);
23112 while Present (Comp) loop
23113 if Is_Unconstrained_Or_Tagged_Item (Comp) then
23114 return True;
23115 end if;
23117 Next_Component (Comp);
23118 end loop;
23120 return False;
23121 end Has_Unconstrained_Component;
23123 -- Local variables
23125 Typ : constant Entity_Id := Etype (Item);
23127 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
23129 begin
23130 if Is_Tagged_Type (Typ) then
23131 return True;
23133 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
23134 return True;
23136 elsif Is_Record_Type (Typ) then
23137 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
23138 return True;
23139 else
23140 return Has_Unconstrained_Component (Typ);
23141 end if;
23143 else
23144 return False;
23145 end if;
23146 end Is_Unconstrained_Or_Tagged_Item;
23148 -----------------------------
23149 -- Is_Valid_Assertion_Kind --
23150 -----------------------------
23152 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
23153 begin
23154 case Nam is
23155 when
23156 -- RM defined
23158 Name_Assert |
23159 Name_Static_Predicate |
23160 Name_Dynamic_Predicate |
23161 Name_Pre |
23162 Name_uPre |
23163 Name_Post |
23164 Name_uPost |
23165 Name_Type_Invariant |
23166 Name_uType_Invariant |
23168 -- Impl defined
23170 Name_Assert_And_Cut |
23171 Name_Assume |
23172 Name_Contract_Cases |
23173 Name_Debug |
23174 Name_Initial_Condition |
23175 Name_Invariant |
23176 Name_uInvariant |
23177 Name_Loop_Invariant |
23178 Name_Loop_Variant |
23179 Name_Postcondition |
23180 Name_Precondition |
23181 Name_Predicate |
23182 Name_Refined_Post |
23183 Name_Statement_Assertions => return True;
23185 when others => return False;
23186 end case;
23187 end Is_Valid_Assertion_Kind;
23189 -----------------------------------------
23190 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
23191 -----------------------------------------
23193 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is
23194 Aspects : constant List_Id := New_List;
23195 Loc : constant Source_Ptr := Sloc (Decl);
23196 Or_Decl : constant Node_Id := Original_Node (Decl);
23198 Original_Aspects : List_Id;
23199 -- To capture global references, a copy of the created aspects must be
23200 -- inserted in the original tree.
23202 Prag : Node_Id;
23203 Prag_Arg_Ass : Node_Id;
23204 Prag_Id : Pragma_Id;
23206 begin
23207 -- Check for any PPC pragmas that appear within Decl
23209 Prag := Next (Decl);
23210 while Nkind (Prag) = N_Pragma loop
23211 Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag)));
23213 case Prag_Id is
23214 when Pragma_Postcondition | Pragma_Precondition =>
23215 Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag));
23217 -- Make an aspect from any PPC pragma
23219 Append_To (Aspects,
23220 Make_Aspect_Specification (Loc,
23221 Identifier =>
23222 Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))),
23223 Expression =>
23224 Copy_Separate_Tree (Expression (Prag_Arg_Ass))));
23226 -- Generate the analysis information in the pragma expression
23227 -- and then set the pragma node analyzed to avoid any further
23228 -- analysis.
23230 Analyze (Expression (Prag_Arg_Ass));
23231 Set_Analyzed (Prag, True);
23233 when others => null;
23234 end case;
23236 Next (Prag);
23237 end loop;
23239 -- Set all new aspects into the generic declaration node
23241 if Is_Non_Empty_List (Aspects) then
23243 -- Create the list of aspects to be inserted in the original tree
23245 Original_Aspects := Copy_Separate_List (Aspects);
23247 -- Check if Decl already has aspects
23249 -- Attach the new lists of aspects to both the generic copy and the
23250 -- original tree.
23252 if Has_Aspects (Decl) then
23253 Append_List (Aspects, Aspect_Specifications (Decl));
23254 Append_List (Original_Aspects, Aspect_Specifications (Or_Decl));
23256 else
23257 Set_Parent (Aspects, Decl);
23258 Set_Aspect_Specifications (Decl, Aspects);
23259 Set_Parent (Original_Aspects, Or_Decl);
23260 Set_Aspect_Specifications (Or_Decl, Original_Aspects);
23261 end if;
23262 end if;
23263 end Make_Aspect_For_PPC_In_Gen_Sub_Decl;
23265 -------------------------
23266 -- Preanalyze_CTC_Args --
23267 -------------------------
23269 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id) is
23270 begin
23271 -- Preanalyze the boolean expressions, we treat these as spec
23272 -- expressions (i.e. similar to a default expression).
23274 if Present (Arg_Req) then
23275 Preanalyze_Assert_Expression
23276 (Get_Pragma_Arg (Arg_Req), Standard_Boolean);
23278 -- In ASIS mode, for a pragma generated from a source aspect, also
23279 -- analyze the original aspect expression.
23281 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
23282 Preanalyze_Assert_Expression
23283 (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
23284 end if;
23285 end if;
23287 if Present (Arg_Ens) then
23288 Preanalyze_Assert_Expression
23289 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
23291 -- In ASIS mode, for a pragma generated from a source aspect, also
23292 -- analyze the original aspect expression.
23294 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
23295 Preanalyze_Assert_Expression
23296 (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
23297 end if;
23298 end if;
23299 end Preanalyze_CTC_Args;
23301 --------------------------------------
23302 -- Process_Compilation_Unit_Pragmas --
23303 --------------------------------------
23305 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
23306 begin
23307 -- A special check for pragma Suppress_All, a very strange DEC pragma,
23308 -- strange because it comes at the end of the unit. Rational has the
23309 -- same name for a pragma, but treats it as a program unit pragma, In
23310 -- GNAT we just decide to allow it anywhere at all. If it appeared then
23311 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
23312 -- node, and we insert a pragma Suppress (All_Checks) at the start of
23313 -- the context clause to ensure the correct processing.
23315 if Has_Pragma_Suppress_All (N) then
23316 Prepend_To (Context_Items (N),
23317 Make_Pragma (Sloc (N),
23318 Chars => Name_Suppress,
23319 Pragma_Argument_Associations => New_List (
23320 Make_Pragma_Argument_Association (Sloc (N),
23321 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
23322 end if;
23324 -- Nothing else to do at the current time!
23326 end Process_Compilation_Unit_Pragmas;
23328 ------------------------------------
23329 -- Record_Possible_Body_Reference --
23330 ------------------------------------
23332 procedure Record_Possible_Body_Reference
23333 (Item : Node_Id;
23334 Item_Id : Entity_Id)
23336 begin
23337 if Is_Body_Name (Unit_Name (Get_Source_Unit (Item)))
23338 and then Ekind (Item_Id) = E_Abstract_State
23339 then
23340 if not Has_Body_References (Item_Id) then
23341 Set_Has_Body_References (Item_Id, True);
23342 Set_Body_References (Item_Id, New_Elmt_List);
23343 end if;
23345 Append_Elmt (Item, Body_References (Item_Id));
23346 end if;
23347 end Record_Possible_Body_Reference;
23349 ------------------------------
23350 -- Relocate_Pragmas_To_Body --
23351 ------------------------------
23353 procedure Relocate_Pragmas_To_Body
23354 (Subp_Body : Node_Id;
23355 Target_Body : Node_Id := Empty)
23357 procedure Relocate_Pragma (Prag : Node_Id);
23358 -- Remove a single pragma from its current list and add it to the
23359 -- declarations of the proper body (either Subp_Body or Target_Body).
23361 ---------------------
23362 -- Relocate_Pragma --
23363 ---------------------
23365 procedure Relocate_Pragma (Prag : Node_Id) is
23366 Decls : List_Id;
23367 Target : Node_Id;
23369 begin
23370 -- When subprogram stubs or expression functions are involves, the
23371 -- destination declaration list belongs to the proper body.
23373 if Present (Target_Body) then
23374 Target := Target_Body;
23375 else
23376 Target := Subp_Body;
23377 end if;
23379 Decls := Declarations (Target);
23381 if No (Decls) then
23382 Decls := New_List;
23383 Set_Declarations (Target, Decls);
23384 end if;
23386 -- Unhook the pragma from its current list
23388 Remove (Prag);
23389 Prepend (Prag, Decls);
23390 end Relocate_Pragma;
23392 -- Local variables
23394 Body_Id : constant Entity_Id :=
23395 Defining_Unit_Name (Specification (Subp_Body));
23396 Next_Stmt : Node_Id;
23397 Stmt : Node_Id;
23399 -- Start of processing for Relocate_Pragmas_To_Body
23401 begin
23402 -- Do not process a body that comes from a separate unit as no construct
23403 -- can possibly follow it.
23405 if not Is_List_Member (Subp_Body) then
23406 return;
23408 -- Do not relocate pragmas that follow a stub if the stub does not have
23409 -- a proper body.
23411 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
23412 and then No (Target_Body)
23413 then
23414 return;
23416 -- Do not process internally generated routine _Postconditions
23418 elsif Ekind (Body_Id) = E_Procedure
23419 and then Chars (Body_Id) = Name_uPostconditions
23420 then
23421 return;
23422 end if;
23424 -- Look at what is following the body. We are interested in certain kind
23425 -- of pragmas (either from source or byproducts of expansion) that can
23426 -- apply to a body [stub].
23428 Stmt := Next (Subp_Body);
23429 while Present (Stmt) loop
23431 -- Preserve the following statement for iteration purposes due to a
23432 -- possible relocation of a pragma.
23434 Next_Stmt := Next (Stmt);
23436 -- Move a candidate pragma following the body to the declarations of
23437 -- the body.
23439 if Nkind (Stmt) = N_Pragma
23440 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
23441 then
23442 Relocate_Pragma (Stmt);
23444 -- Skip internally generated code
23446 elsif not Comes_From_Source (Stmt) then
23447 null;
23449 -- No candidate pragmas are available for relocation
23451 else
23452 exit;
23453 end if;
23455 Stmt := Next_Stmt;
23456 end loop;
23457 end Relocate_Pragmas_To_Body;
23459 ----------------------------
23460 -- Rewrite_Assertion_Kind --
23461 ----------------------------
23463 procedure Rewrite_Assertion_Kind (N : Node_Id) is
23464 Nam : Name_Id;
23466 begin
23467 if Nkind (N) = N_Attribute_Reference
23468 and then Attribute_Name (N) = Name_Class
23469 and then Nkind (Prefix (N)) = N_Identifier
23470 then
23471 case Chars (Prefix (N)) is
23472 when Name_Pre =>
23473 Nam := Name_uPre;
23474 when Name_Post =>
23475 Nam := Name_uPost;
23476 when Name_Type_Invariant =>
23477 Nam := Name_uType_Invariant;
23478 when Name_Invariant =>
23479 Nam := Name_uInvariant;
23480 when others =>
23481 return;
23482 end case;
23484 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
23485 end if;
23486 end Rewrite_Assertion_Kind;
23488 --------
23489 -- rv --
23490 --------
23492 procedure rv is
23493 begin
23494 null;
23495 end rv;
23497 --------------------------------
23498 -- Set_Encoded_Interface_Name --
23499 --------------------------------
23501 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
23502 Str : constant String_Id := Strval (S);
23503 Len : constant Int := String_Length (Str);
23504 CC : Char_Code;
23505 C : Character;
23506 J : Int;
23508 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
23510 procedure Encode;
23511 -- Stores encoded value of character code CC. The encoding we use an
23512 -- underscore followed by four lower case hex digits.
23514 ------------
23515 -- Encode --
23516 ------------
23518 procedure Encode is
23519 begin
23520 Store_String_Char (Get_Char_Code ('_'));
23521 Store_String_Char
23522 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
23523 Store_String_Char
23524 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
23525 Store_String_Char
23526 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
23527 Store_String_Char
23528 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
23529 end Encode;
23531 -- Start of processing for Set_Encoded_Interface_Name
23533 begin
23534 -- If first character is asterisk, this is a link name, and we leave it
23535 -- completely unmodified. We also ignore null strings (the latter case
23536 -- happens only in error cases) and no encoding should occur for Java or
23537 -- AAMP interface names.
23539 if Len = 0
23540 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
23541 or else VM_Target /= No_VM
23542 or else AAMP_On_Target
23543 then
23544 Set_Interface_Name (E, S);
23546 else
23547 J := 1;
23548 loop
23549 CC := Get_String_Char (Str, J);
23551 exit when not In_Character_Range (CC);
23553 C := Get_Character (CC);
23555 exit when C /= '_' and then C /= '$'
23556 and then C not in '0' .. '9'
23557 and then C not in 'a' .. 'z'
23558 and then C not in 'A' .. 'Z';
23560 if J = Len then
23561 Set_Interface_Name (E, S);
23562 return;
23564 else
23565 J := J + 1;
23566 end if;
23567 end loop;
23569 -- Here we need to encode. The encoding we use as follows:
23570 -- three underscores + four hex digits (lower case)
23572 Start_String;
23574 for J in 1 .. String_Length (Str) loop
23575 CC := Get_String_Char (Str, J);
23577 if not In_Character_Range (CC) then
23578 Encode;
23579 else
23580 C := Get_Character (CC);
23582 if C = '_' or else C = '$'
23583 or else C in '0' .. '9'
23584 or else C in 'a' .. 'z'
23585 or else C in 'A' .. 'Z'
23586 then
23587 Store_String_Char (CC);
23588 else
23589 Encode;
23590 end if;
23591 end if;
23592 end loop;
23594 Set_Interface_Name (E,
23595 Make_String_Literal (Sloc (S),
23596 Strval => End_String));
23597 end if;
23598 end Set_Encoded_Interface_Name;
23600 -------------------
23601 -- Set_Unit_Name --
23602 -------------------
23604 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
23605 Pref : Node_Id;
23606 Scop : Entity_Id;
23608 begin
23609 if Nkind (N) = N_Identifier
23610 and then Nkind (With_Item) = N_Identifier
23611 then
23612 Set_Entity (N, Entity (With_Item));
23614 elsif Nkind (N) = N_Selected_Component then
23615 Change_Selected_Component_To_Expanded_Name (N);
23616 Set_Entity (N, Entity (With_Item));
23617 Set_Entity (Selector_Name (N), Entity (N));
23619 Pref := Prefix (N);
23620 Scop := Scope (Entity (N));
23621 while Nkind (Pref) = N_Selected_Component loop
23622 Change_Selected_Component_To_Expanded_Name (Pref);
23623 Set_Entity (Selector_Name (Pref), Scop);
23624 Set_Entity (Pref, Scop);
23625 Pref := Prefix (Pref);
23626 Scop := Scope (Scop);
23627 end loop;
23629 Set_Entity (Pref, Scop);
23630 end if;
23631 end Set_Unit_Name;
23633 end Sem_Prag;