1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Csets
; use Csets
;
37 with Debug
; use Debug
;
38 with Einfo
; use Einfo
;
39 with Elists
; use Elists
;
40 with Errout
; use Errout
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
45 with Lib
.Writ
; use Lib
.Writ
;
46 with Lib
.Xref
; use Lib
.Xref
;
47 with Namet
.Sp
; use Namet
.Sp
;
48 with Nlists
; use Nlists
;
49 with Nmake
; use Nmake
;
50 with Output
; use Output
;
51 with Par_SCO
; use Par_SCO
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch6
; use Sem_Ch6
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Ch12
; use Sem_Ch12
;
61 with Sem_Ch13
; use Sem_Ch13
;
62 with Sem_Disp
; use Sem_Disp
;
63 with Sem_Dist
; use Sem_Dist
;
64 with Sem_Elim
; use Sem_Elim
;
65 with Sem_Eval
; use Sem_Eval
;
66 with Sem_Intr
; use Sem_Intr
;
67 with Sem_Mech
; use Sem_Mech
;
68 with Sem_Res
; use Sem_Res
;
69 with Sem_Type
; use Sem_Type
;
70 with Sem_Util
; use Sem_Util
;
71 with Sem_Warn
; use Sem_Warn
;
72 with Stand
; use Stand
;
73 with Sinfo
; use Sinfo
;
74 with Sinfo
.CN
; use Sinfo
.CN
;
75 with Sinput
; use Sinput
;
76 with Stringt
; use Stringt
;
77 with Stylesw
; use Stylesw
;
79 with Targparm
; use Targparm
;
80 with Tbuild
; use Tbuild
;
82 with Uintp
; use Uintp
;
83 with Uname
; use Uname
;
84 with Urealp
; use Urealp
;
85 with Validsw
; use Validsw
;
86 with Warnsw
; use Warnsw
;
88 package body Sem_Prag
is
90 ----------------------------------------------
91 -- Common Handling of Import-Export Pragmas --
92 ----------------------------------------------
94 -- In the following section, a number of Import_xxx and Export_xxx pragmas
95 -- are defined by GNAT. These are compatible with the DEC pragmas of the
96 -- same name, and all have the following common form and processing:
99 -- [Internal =>] LOCAL_NAME
100 -- [, [External =>] EXTERNAL_SYMBOL]
101 -- [, other optional parameters ]);
104 -- [Internal =>] LOCAL_NAME
105 -- [, [External =>] EXTERNAL_SYMBOL]
106 -- [, other optional parameters ]);
108 -- EXTERNAL_SYMBOL ::=
110 -- | static_string_EXPRESSION
112 -- The internal LOCAL_NAME designates the entity that is imported or
113 -- exported, and must refer to an entity in the current declarative
114 -- part (as required by the rules for LOCAL_NAME).
116 -- The external linker name is designated by the External parameter if
117 -- given, or the Internal parameter if not (if there is no External
118 -- parameter, the External parameter is a copy of the Internal name).
120 -- If the External parameter is given as a string, then this string is
121 -- treated as an external name (exactly as though it had been given as an
122 -- External_Name parameter for a normal Import pragma).
124 -- If the External parameter is given as an identifier (or there is no
125 -- External parameter, so that the Internal identifier is used), then
126 -- the external name is the characters of the identifier, translated
127 -- to all lower case letters.
129 -- Note: the external name specified or implied by any of these special
130 -- Import_xxx or Export_xxx pragmas override an external or link name
131 -- specified in a previous Import or Export pragma.
133 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
134 -- named notation, following the standard rules for subprogram calls, i.e.
135 -- parameters can be given in any order if named notation is used, and
136 -- positional and named notation can be mixed, subject to the rule that all
137 -- positional parameters must appear first.
139 -- Note: All these pragmas are implemented exactly following the DEC design
140 -- and implementation and are intended to be fully compatible with the use
141 -- of these pragmas in the DEC Ada compiler.
143 --------------------------------------------
144 -- Checking for Duplicated External Names --
145 --------------------------------------------
147 -- It is suspicious if two separate Export pragmas use the same external
148 -- name. The following table is used to diagnose this situation so that
149 -- an appropriate warning can be issued.
151 -- The Node_Id stored is for the N_String_Literal node created to hold
152 -- the value of the external name. The Sloc of this node is used to
153 -- cross-reference the location of the duplication.
155 package Externals
is new Table
.Table
(
156 Table_Component_Type
=> Node_Id
,
157 Table_Index_Type
=> Int
,
158 Table_Low_Bound
=> 0,
159 Table_Initial
=> 100,
160 Table_Increment
=> 100,
161 Table_Name
=> "Name_Externals");
163 -------------------------------------
164 -- Local Subprograms and Variables --
165 -------------------------------------
167 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
);
168 -- Subsidiary routine to the analysis of pragmas Depends, Global and
169 -- Refined_State. Append an entity to a list. If the list is empty, create
172 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
173 -- This routine is used for possible casing adjustment of an explicit
174 -- external name supplied as a string literal (the node N), according to
175 -- the casing requirement of Opt.External_Name_Casing. If this is set to
176 -- As_Is, then the string literal is returned unchanged, but if it is set
177 -- to Uppercase or Lowercase, then a new string literal with appropriate
178 -- casing is constructed.
180 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
181 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
182 -- whether a particular item appears in a mixed list of nodes and entities.
183 -- It is assumed that all nodes in the list have entities.
185 function Check_Kind
(Nam
: Name_Id
) return Name_Id
;
186 -- This function is used in connection with pragmas Assert, Check,
187 -- and assertion aspects and pragmas, to determine if Check pragmas
188 -- (or corresponding assertion aspects or pragmas) are currently active
189 -- as determined by the presence of -gnata on the command line (which
190 -- sets the default), and the appearance of pragmas Check_Policy and
191 -- Assertion_Policy as configuration pragmas either in a configuration
192 -- pragma file, or at the start of the current unit, or locally given
193 -- Check_Policy and Assertion_Policy pragmas that are currently active.
195 -- The value returned is one of the names Check, Ignore, Disable (On
196 -- returns Check, and Off returns Ignore).
198 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
199 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
200 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
201 -- _Post, _Invariant, or _Type_Invariant, which are special names used
202 -- in identifiers to represent these attribute references.
204 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
);
205 -- In ASIS mode we need to analyze the original expression in the aspect
206 -- specification. For Initializes, Global, and related SPARK aspects, the
207 -- expression has a sui-generis syntax which may be a list, an expression,
210 procedure Check_State_And_Constituent_Use
214 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
215 -- Global and Initializes. Determine whether a state from list States and a
216 -- corresponding constituent from list Constits (if any) appear in the same
217 -- context denoted by Context. If this is the case, emit an error.
219 procedure Collect_Global_Items
221 In_Items
: in out Elist_Id
;
222 In_Out_Items
: in out Elist_Id
;
223 Out_Items
: in out Elist_Id
;
224 Proof_In_Items
: in out Elist_Id
;
225 Has_In_State
: out Boolean;
226 Has_In_Out_State
: out Boolean;
227 Has_Out_State
: out Boolean;
228 Has_Proof_In_State
: out Boolean;
229 Has_Null_State
: out Boolean);
230 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
231 -- Prag denotes pragma [Refined_]Global. Gather all input, in out, output
232 -- and Proof_In items of Prag in lists In_Items, In_Out_Items, Out_Items
233 -- and Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
234 -- and Has_Proof_In_State are set when there is at least one abstract state
235 -- with visible refinement available in the corresponding mode. Flag
236 -- Has_Null_State is set when at least state has a null refinement.
238 function Find_Related_Subprogram_Or_Body
240 Do_Checks
: Boolean := False) return Node_Id
;
241 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
242 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
243 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
244 -- Do_Checks is set, the routine reports duplicate pragmas and detects
245 -- improper use of refinement pragmas in stand alone expression functions.
246 -- The returned value depends on the related pragma as follows:
247 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
248 -- N_Subprogram_Declaration node or if the pragma applies to a stand
249 -- alone body, the N_Subprogram_Body node or Empty if illegal.
250 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
251 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
254 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
255 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
256 -- original one, following the renaming chain) is returned. Otherwise the
257 -- entity is returned unchanged. Should be in Einfo???
259 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
260 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
261 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
264 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
265 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
266 -- Determine whether dependency clause Clause is surrounded by extra
267 -- parentheses. If this is the case, issue an error message.
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 (State_Id
: Entity_Id
;
283 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
284 -- Global. Given an abstract state denoted by State_Id and a reference Ref
285 -- to it, determine whether the reference appears in a package body that
286 -- will eventually refine the state. If this is the case, record the
287 -- reference for future checks (see Analyze_Refined_State_In_Decls).
289 procedure Resolve_State
(N
: Node_Id
);
290 -- Handle the overloading of state names by functions. When N denotes a
291 -- function, this routine finds the corresponding state and sets the entity
292 -- of N to that of the state.
294 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
295 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
296 -- then it is rewritten as an identifier with the corresponding special
297 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
298 -- Check, Check_Policy.
300 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
301 -- Place semantic information on the argument of an Elaborate/Elaborate_All
302 -- pragma. Entity name for unit and its parents is taken from item in
303 -- previous with_clause that mentions the unit.
305 Dummy
: Integer := 0;
306 pragma Volatile
(Dummy
);
307 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
310 pragma No_Inline
(ip
);
311 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
312 -- is just to help debugging the front end. If a pragma Inspection_Point
313 -- is added to a source program, then breaking on ip will get you to that
314 -- point in the program.
317 pragma No_Inline
(rv
);
318 -- This is a dummy function called by the processing for pragma Reviewable.
319 -- It is there for assisting front end debugging. By placing a Reviewable
320 -- pragma in the source program, a breakpoint on rv catches this place in
321 -- the source, allowing convenient stepping to the point of interest.
327 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
329 Append_New_Elmt
(Item
, To
=> To_List
);
332 -------------------------------
333 -- Adjust_External_Name_Case --
334 -------------------------------
336 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
340 -- Adjust case of literal if required
342 if Opt
.External_Name_Exp_Casing
= As_Is
then
346 -- Copy existing string
352 for J
in 1 .. String_Length
(Strval
(N
)) loop
353 CC
:= Get_String_Char
(Strval
(N
), J
);
355 if Opt
.External_Name_Exp_Casing
= Uppercase
356 and then CC
>= Get_Char_Code
('a')
357 and then CC
<= Get_Char_Code
('z')
359 Store_String_Char
(CC
- 32);
361 elsif Opt
.External_Name_Exp_Casing
= Lowercase
362 and then CC
>= Get_Char_Code
('A')
363 and then CC
<= Get_Char_Code
('Z')
365 Store_String_Char
(CC
+ 32);
368 Store_String_Char
(CC
);
373 Make_String_Literal
(Sloc
(N
),
374 Strval
=> End_String
);
376 end Adjust_External_Name_Case
;
378 -----------------------------------------
379 -- Analyze_Contract_Cases_In_Decl_Part --
380 -----------------------------------------
382 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
383 Others_Seen
: Boolean := False;
385 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
386 -- Verify the legality of a single contract case
388 ---------------------------
389 -- Analyze_Contract_Case --
390 ---------------------------
392 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
393 Case_Guard
: Node_Id
;
395 Extra_Guard
: Node_Id
;
398 if Nkind
(CCase
) = N_Component_Association
then
399 Case_Guard
:= First
(Choices
(CCase
));
400 Conseq
:= Expression
(CCase
);
402 -- Each contract case must have exactly one case guard
404 Extra_Guard
:= Next
(Case_Guard
);
406 if Present
(Extra_Guard
) then
408 ("contract case must have exactly one case guard",
412 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
414 if Nkind
(Case_Guard
) = N_Others_Choice
then
417 ("only one others choice allowed in contract cases",
423 elsif Others_Seen
then
425 ("others must be the last choice in contract cases", N
);
428 -- Preanalyze the case guard and consequence
430 if Nkind
(Case_Guard
) /= N_Others_Choice
then
431 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
434 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
436 -- The contract case is malformed
439 Error_Msg_N
("wrong syntax in contract case", CCase
);
441 end Analyze_Contract_Case
;
450 Restore_Scope
: Boolean := False;
451 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
453 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
458 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
459 Subp_Id
:= Defining_Entity
(Subp_Decl
);
460 All_Cases
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
462 -- Single and multiple contract cases must appear in aggregate form. If
463 -- this is not the case, then either the parser of the analysis of the
464 -- pragma failed to produce an aggregate.
466 pragma Assert
(Nkind
(All_Cases
) = N_Aggregate
);
468 if No
(Component_Associations
(All_Cases
)) then
469 Error_Msg_N
("wrong syntax for constract cases", N
);
471 -- Individual contract cases appear as component associations
474 -- Ensure that the formal parameters are visible when analyzing all
475 -- clauses. This falls out of the general rule of aspects pertaining
476 -- to subprogram declarations. Skip the installation for subprogram
477 -- bodies because the formals are already visible.
479 if not In_Open_Scopes
(Subp_Id
) then
480 Restore_Scope
:= True;
481 Push_Scope
(Subp_Id
);
482 Install_Formals
(Subp_Id
);
485 CCase
:= First
(Component_Associations
(All_Cases
));
486 while Present
(CCase
) loop
487 Analyze_Contract_Case
(CCase
);
491 if Restore_Scope
then
495 end Analyze_Contract_Cases_In_Decl_Part
;
497 ----------------------------------
498 -- Analyze_Depends_In_Decl_Part --
499 ----------------------------------
501 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
502 Loc
: constant Source_Ptr
:= Sloc
(N
);
504 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
505 -- A list containing the entities of all the inputs processed so far.
506 -- The list is populated with unique entities because the same input
507 -- may appear in multiple input lists.
509 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
510 -- A list containing the entities of all the outputs processed so far.
511 -- The list is populated with unique entities because output items are
512 -- unique in a dependence relation.
514 Constits_Seen
: Elist_Id
:= No_Elist
;
515 -- A list containing the entities of all constituents processed so far.
516 -- It aids in detecting illegal usage of a state and a corresponding
517 -- constituent in pragma [Refinde_]Depends.
519 Global_Seen
: Boolean := False;
520 -- A flag set when pragma Global has been processed
522 Null_Output_Seen
: Boolean := False;
523 -- A flag used to track the legality of a null output
525 Result_Seen
: Boolean := False;
526 -- A flag set when Subp_Id'Result is processed
529 -- The entity of the subprogram subject to pragma [Refined_]Depends
531 States_Seen
: Elist_Id
:= No_Elist
;
532 -- A list containing the entities of all states processed so far. It
533 -- helps in detecting illegal usage of a state and a corresponding
534 -- constituent in pragma [Refined_]Depends.
537 -- The entity of the subprogram [body or stub] subject to pragma
538 -- [Refined_]Depends.
540 Subp_Inputs
: Elist_Id
:= No_Elist
;
541 Subp_Outputs
: Elist_Id
:= No_Elist
;
542 -- Two lists containing the full set of inputs and output of the related
543 -- subprograms. Note that these lists contain both nodes and entities.
545 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
546 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
547 -- to the name buffer. The individual kinds are as follows:
548 -- E_Abstract_State - "state"
549 -- E_In_Parameter - "parameter"
550 -- E_In_Out_Parameter - "parameter"
551 -- E_Out_Parameter - "parameter"
552 -- E_Variable - "global"
554 procedure Analyze_Dependency_Clause
557 -- Verify the legality of a single dependency clause. Flag Is_Last
558 -- denotes whether Clause is the last clause in the relation.
560 procedure Check_Function_Return
;
561 -- Verify that Funtion'Result appears as one of the outputs
562 -- (SPARK RM 6.1.5(10)).
569 -- Ensure that an item fulfils its designated input and/or output role
570 -- as specified by pragma Global (if any) or the enclosing context. If
571 -- this is not the case, emit an error. Item and Item_Id denote the
572 -- attributes of an item. Flag Is_Input should be set when item comes
573 -- from an input list. Flag Self_Ref should be set when the item is an
574 -- output and the dependency clause has operator "+".
576 procedure Check_Usage
577 (Subp_Items
: Elist_Id
;
578 Used_Items
: Elist_Id
;
580 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
581 -- error if this is not the case.
583 procedure Normalize_Clause
(Clause
: Node_Id
);
584 -- Remove a self-dependency "+" from the input list of a clause. Split
585 -- a clause with multiple outputs into multiple clauses with a single
588 -----------------------------
589 -- Add_Item_To_Name_Buffer --
590 -----------------------------
592 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
594 if Ekind
(Item_Id
) = E_Abstract_State
then
595 Add_Str_To_Name_Buffer
("state");
597 elsif Is_Formal
(Item_Id
) then
598 Add_Str_To_Name_Buffer
("parameter");
600 elsif Ekind
(Item_Id
) = E_Variable
then
601 Add_Str_To_Name_Buffer
("global");
603 -- The routine should not be called with non-SPARK items
608 end Add_Item_To_Name_Buffer
;
610 -------------------------------
611 -- Analyze_Dependency_Clause --
612 -------------------------------
614 procedure Analyze_Dependency_Clause
618 procedure Analyze_Input_List
(Inputs
: Node_Id
);
619 -- Verify the legality of a single input list
621 procedure Analyze_Input_Output
626 Seen
: in out Elist_Id
;
627 Null_Seen
: in out Boolean;
628 Non_Null_Seen
: in out Boolean);
629 -- Verify the legality of a single input or output item. Flag
630 -- Is_Input should be set whenever Item is an input, False when it
631 -- denotes an output. Flag Self_Ref should be set when the item is an
632 -- output and the dependency clause has a "+". Flag Top_Level should
633 -- be set whenever Item appears immediately within an input or output
634 -- list. Seen is a collection of all abstract states, variables and
635 -- formals processed so far. Flag Null_Seen denotes whether a null
636 -- input or output has been encountered. Flag Non_Null_Seen denotes
637 -- whether a non-null input or output has been encountered.
639 ------------------------
640 -- Analyze_Input_List --
641 ------------------------
643 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
644 Inputs_Seen
: Elist_Id
:= No_Elist
;
645 -- A list containing the entities of all inputs that appear in the
646 -- current input list.
648 Non_Null_Input_Seen
: Boolean := False;
649 Null_Input_Seen
: Boolean := False;
650 -- Flags used to check the legality of an input list
655 -- Multiple inputs appear as an aggregate
657 if Nkind
(Inputs
) = N_Aggregate
then
658 if Present
(Component_Associations
(Inputs
)) then
660 ("nested dependency relations not allowed", Inputs
);
662 elsif Present
(Expressions
(Inputs
)) then
663 Input
:= First
(Expressions
(Inputs
));
664 while Present
(Input
) loop
671 Null_Seen
=> Null_Input_Seen
,
672 Non_Null_Seen
=> Non_Null_Input_Seen
);
677 -- Syntax error, always report
680 Error_Msg_N
("malformed input dependency list", Inputs
);
683 -- Process a solitary input
692 Null_Seen
=> Null_Input_Seen
,
693 Non_Null_Seen
=> Non_Null_Input_Seen
);
696 -- Detect an illegal dependency clause of the form
700 if Null_Output_Seen
and then Null_Input_Seen
then
702 ("null dependency clause cannot have a null input list",
705 end Analyze_Input_List
;
707 --------------------------
708 -- Analyze_Input_Output --
709 --------------------------
711 procedure Analyze_Input_Output
716 Seen
: in out Elist_Id
;
717 Null_Seen
: in out Boolean;
718 Non_Null_Seen
: in out Boolean)
720 Is_Output
: constant Boolean := not Is_Input
;
725 -- Multiple input or output items appear as an aggregate
727 if Nkind
(Item
) = N_Aggregate
then
728 if not Top_Level
then
729 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
731 elsif Present
(Component_Associations
(Item
)) then
733 ("nested dependency relations not allowed", Item
);
735 -- Recursively analyze the grouped items
737 elsif Present
(Expressions
(Item
)) then
738 Grouped
:= First
(Expressions
(Item
));
739 while Present
(Grouped
) loop
742 Is_Input
=> Is_Input
,
743 Self_Ref
=> Self_Ref
,
746 Null_Seen
=> Null_Seen
,
747 Non_Null_Seen
=> Non_Null_Seen
);
752 -- Syntax error, always report
755 Error_Msg_N
("malformed dependency list", Item
);
758 -- Process Function'Result in the context of a dependency clause
760 elsif Is_Attribute_Result
(Item
) then
761 Non_Null_Seen
:= True;
763 -- It is sufficent to analyze the prefix of 'Result in order to
764 -- establish legality of the attribute.
766 Analyze
(Prefix
(Item
));
768 -- The prefix of 'Result must denote the function for which
769 -- pragma Depends applies (SPARK RM 6.1.5(11)).
771 if not Is_Entity_Name
(Prefix
(Item
))
772 or else Ekind
(Spec_Id
) /= E_Function
773 or else Entity
(Prefix
(Item
)) /= Spec_Id
775 Error_Msg_Name_1
:= Name_Result
;
777 ("prefix of attribute % must denote the enclosing "
780 -- Function'Result is allowed to appear on the output side of a
781 -- dependency clause (SPARK RM 6.1.5(6)).
784 SPARK_Msg_N
("function result cannot act as input", Item
);
788 ("cannot mix null and non-null dependency items", Item
);
794 -- Detect multiple uses of null in a single dependency list or
795 -- throughout the whole relation. Verify the placement of a null
796 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
798 elsif Nkind
(Item
) = N_Null
then
801 ("multiple null dependency relations not allowed", Item
);
803 elsif Non_Null_Seen
then
805 ("cannot mix null and non-null dependency items", Item
);
813 ("null output list must be the last clause in a "
814 & "dependency relation", Item
);
816 -- Catch a useless dependence of the form:
821 ("useless dependence, null depends on itself", Item
);
829 Non_Null_Seen
:= True;
832 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
836 Resolve_State
(Item
);
838 -- Find the entity of the item. If this is a renaming, climb
839 -- the renaming chain to reach the root object. Renamings of
840 -- non-entire objects do not yield an entity (Empty).
842 Item_Id
:= Entity_Of
(Item
);
844 if Present
(Item_Id
) then
845 if Ekind_In
(Item_Id
, E_Abstract_State
,
851 -- Ensure that the item fulfils its role as input and/or
852 -- output as specified by pragma Global or the enclosing
855 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
857 -- Detect multiple uses of the same state, variable or
858 -- formal parameter. If this is not the case, add the
859 -- item to the list of processed relations.
861 if Contains
(Seen
, Item_Id
) then
863 ("duplicate use of item &", Item
, Item_Id
);
865 Add_Item
(Item_Id
, Seen
);
868 -- Detect illegal use of an input related to a null
869 -- output. Such input items cannot appear in other
870 -- input lists (SPARK RM 6.1.5(13)).
873 and then Null_Output_Seen
874 and then Contains
(All_Inputs_Seen
, Item_Id
)
877 ("input of a null output list cannot appear in "
878 & "multiple input lists", Item
);
881 -- Add an input or a self-referential output to the list
882 -- of all processed inputs.
884 if Is_Input
or else Self_Ref
then
885 Add_Item
(Item_Id
, All_Inputs_Seen
);
888 -- State related checks (SPARK RM 6.1.5(3))
890 if Ekind
(Item_Id
) = E_Abstract_State
then
891 if Has_Visible_Refinement
(Item_Id
) then
893 ("cannot mention state & in global refinement",
896 ("\use its constituents instead", Item
);
899 -- If the reference to the abstract state appears in
900 -- an enclosing package body that will eventually
901 -- refine the state, record the reference for future
905 Record_Possible_Body_Reference
906 (State_Id
=> Item_Id
,
911 -- When the item renames an entire object, replace the
912 -- item with a reference to the object.
914 if Present
(Renamed_Object
(Entity
(Item
))) then
916 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
920 -- Add the entity of the current item to the list of
923 if Ekind
(Item_Id
) = E_Abstract_State
then
924 Add_Item
(Item_Id
, States_Seen
);
927 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
928 and then Present
(Encapsulating_State
(Item_Id
))
930 Add_Item
(Item_Id
, Constits_Seen
);
933 -- All other input/output items are illegal
934 -- (SPARK RM 6.1.5(1)).
938 ("item must denote parameter, variable, or state",
942 -- All other input/output items are illegal
943 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
947 ("item must denote parameter, variable, or state", Item
);
950 end Analyze_Input_Output
;
958 Non_Null_Output_Seen
: Boolean := False;
959 -- Flag used to check the legality of an output list
961 -- Start of processing for Analyze_Dependency_Clause
964 Inputs
:= Expression
(Clause
);
967 -- An input list with a self-dependency appears as operator "+" where
968 -- the actuals inputs are the right operand.
970 if Nkind
(Inputs
) = N_Op_Plus
then
971 Inputs
:= Right_Opnd
(Inputs
);
975 -- Process the output_list of a dependency_clause
977 Output
:= First
(Choices
(Clause
));
978 while Present
(Output
) loop
982 Self_Ref
=> Self_Ref
,
984 Seen
=> All_Outputs_Seen
,
985 Null_Seen
=> Null_Output_Seen
,
986 Non_Null_Seen
=> Non_Null_Output_Seen
);
991 -- Process the input_list of a dependency_clause
993 Analyze_Input_List
(Inputs
);
994 end Analyze_Dependency_Clause
;
996 ---------------------------
997 -- Check_Function_Return --
998 ---------------------------
1000 procedure Check_Function_Return
is
1002 if Ekind
(Spec_Id
) = E_Function
and then not Result_Seen
then
1004 ("result of & must appear in exactly one output list",
1007 end Check_Function_Return
;
1013 procedure Check_Role
1015 Item_Id
: Entity_Id
;
1020 (Item_Is_Input
: out Boolean;
1021 Item_Is_Output
: out Boolean);
1022 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1023 -- Item_Is_Output are set depending on the role.
1025 procedure Role_Error
1026 (Item_Is_Input
: Boolean;
1027 Item_Is_Output
: Boolean);
1028 -- Emit an error message concerning the incorrect use of Item in
1029 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1030 -- denote whether the item is an input and/or an output.
1037 (Item_Is_Input
: out Boolean;
1038 Item_Is_Output
: out Boolean)
1041 Item_Is_Input
:= False;
1042 Item_Is_Output
:= False;
1044 -- Abstract state cases
1046 if Ekind
(Item_Id
) = E_Abstract_State
then
1048 -- When pragma Global is present, the mode of the state may be
1049 -- further constrained by setting a more restrictive mode.
1052 if Appears_In
(Subp_Inputs
, Item_Id
) then
1053 Item_Is_Input
:= True;
1056 if Appears_In
(Subp_Outputs
, Item_Id
) then
1057 Item_Is_Output
:= True;
1060 -- Otherwise the state has a default IN OUT mode
1063 Item_Is_Input
:= True;
1064 Item_Is_Output
:= True;
1069 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1070 Item_Is_Input
:= True;
1072 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1073 Item_Is_Input
:= True;
1074 Item_Is_Output
:= True;
1076 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1077 if Scope
(Item_Id
) = Spec_Id
then
1079 -- An OUT parameter of the related subprogram has mode IN
1080 -- if its type is unconstrained or tagged because array
1081 -- bounds, discriminants or tags can be read.
1083 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1084 Item_Is_Input
:= True;
1087 Item_Is_Output
:= True;
1089 -- An OUT parameter of an enclosing subprogram behaves as a
1090 -- read-write variable in which case the mode is IN OUT.
1093 Item_Is_Input
:= True;
1094 Item_Is_Output
:= True;
1099 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1101 -- When pragma Global is present, the mode of the variable may
1102 -- be further constrained by setting a more restrictive mode.
1106 -- A variable has mode IN when its type is unconstrained or
1107 -- tagged because array bounds, discriminants or tags can be
1110 if Appears_In
(Subp_Inputs
, Item_Id
)
1111 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1113 Item_Is_Input
:= True;
1116 if Appears_In
(Subp_Outputs
, Item_Id
) then
1117 Item_Is_Output
:= True;
1120 -- Otherwise the variable has a default IN OUT mode
1123 Item_Is_Input
:= True;
1124 Item_Is_Output
:= True;
1133 procedure Role_Error
1134 (Item_Is_Input
: Boolean;
1135 Item_Is_Output
: Boolean)
1137 Error_Msg
: Name_Id
;
1142 -- When the item is not part of the input and the output set of
1143 -- the related subprogram, then it appears as extra in pragma
1144 -- [Refined_]Depends.
1146 if not Item_Is_Input
and then not Item_Is_Output
then
1147 Add_Item_To_Name_Buffer
(Item_Id
);
1148 Add_Str_To_Name_Buffer
1149 (" & cannot appear in dependence relation");
1151 Error_Msg
:= Name_Find
;
1152 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1154 Error_Msg_Name_1
:= Chars
(Subp_Id
);
1156 ("\& is not part of the input or output set of subprogram %",
1159 -- The mode of the item and its role in pragma [Refined_]Depends
1160 -- are in conflict. Construct a detailed message explaining the
1161 -- illegality (SPARK RM 6.1.5(5-6)).
1164 if Item_Is_Input
then
1165 Add_Str_To_Name_Buffer
("read-only");
1167 Add_Str_To_Name_Buffer
("write-only");
1170 Add_Char_To_Name_Buffer
(' ');
1171 Add_Item_To_Name_Buffer
(Item_Id
);
1172 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1174 if Item_Is_Input
then
1175 Add_Str_To_Name_Buffer
("output");
1177 Add_Str_To_Name_Buffer
("input");
1180 Add_Str_To_Name_Buffer
(" in dependence relation");
1181 Error_Msg
:= Name_Find
;
1182 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1188 Item_Is_Input
: Boolean;
1189 Item_Is_Output
: Boolean;
1191 -- Start of processing for Check_Role
1194 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1199 if not Item_Is_Input
then
1200 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1203 -- Self-referential item
1206 if not Item_Is_Input
or else not Item_Is_Output
then
1207 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1212 elsif not Item_Is_Output
then
1213 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1221 procedure Check_Usage
1222 (Subp_Items
: Elist_Id
;
1223 Used_Items
: Elist_Id
;
1226 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
1227 -- Emit an error concerning the illegal usage of an item
1233 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
1234 Error_Msg
: Name_Id
;
1241 -- Unconstrained and tagged items are not part of the explicit
1242 -- input set of the related subprogram, they do not have to be
1243 -- present in a dependence relation and should not be flagged
1244 -- (SPARK RM 6.1.5(8)).
1246 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1249 Add_Item_To_Name_Buffer
(Item_Id
);
1250 Add_Str_To_Name_Buffer
1251 (" & must appear in at least one input dependence list");
1253 Error_Msg
:= Name_Find
;
1254 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1257 -- Output case (SPARK RM 6.1.5(10))
1262 Add_Item_To_Name_Buffer
(Item_Id
);
1263 Add_Str_To_Name_Buffer
1264 (" & must appear in exactly one output dependence list");
1266 Error_Msg
:= Name_Find
;
1267 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1275 Item_Id
: Entity_Id
;
1277 -- Start of processing for Check_Usage
1280 if No
(Subp_Items
) then
1284 -- Each input or output of the subprogram must appear in a dependency
1287 Elmt
:= First_Elmt
(Subp_Items
);
1288 while Present
(Elmt
) loop
1289 Item
:= Node
(Elmt
);
1291 if Nkind
(Item
) = N_Defining_Identifier
then
1294 Item_Id
:= Entity_Of
(Item
);
1297 -- The item does not appear in a dependency
1299 if Present
(Item_Id
)
1300 and then not Contains
(Used_Items
, Item_Id
)
1302 if Is_Formal
(Item_Id
) then
1303 Usage_Error
(Item
, Item_Id
);
1305 -- States and global variables are not used properly only when
1306 -- the subprogram is subject to pragma Global.
1308 elsif Global_Seen
then
1309 Usage_Error
(Item
, Item_Id
);
1317 ----------------------
1318 -- Normalize_Clause --
1319 ----------------------
1321 procedure Normalize_Clause
(Clause
: Node_Id
) is
1322 procedure Create_Or_Modify_Clause
1328 Multiple
: Boolean);
1329 -- Create a brand new clause to represent the self-reference or
1330 -- modify the input and/or output lists of an existing clause. Output
1331 -- denotes a self-referencial output. Outputs is the output list of a
1332 -- clause. Inputs is the input list of a clause. After denotes the
1333 -- clause after which the new clause is to be inserted. Flag In_Place
1334 -- should be set when normalizing the last output of an output list.
1335 -- Flag Multiple should be set when Output comes from a list with
1338 procedure Normalize_Outputs
;
1339 -- If Clause contains more than one output, split the clause into
1340 -- multiple clauses with a single output. All new clauses are added
1343 -----------------------------
1344 -- Create_Or_Modify_Clause --
1345 -----------------------------
1347 procedure Create_Or_Modify_Clause
1355 procedure Propagate_Output
1358 -- Handle the various cases of output propagation to the input
1359 -- list. Output denotes a self-referencial output item. Inputs is
1360 -- the input list of a clause.
1362 ----------------------
1363 -- Propagate_Output --
1364 ----------------------
1366 procedure Propagate_Output
1370 function In_Input_List
1372 Inputs
: List_Id
) return Boolean;
1373 -- Determine whether a particulat item appears in the input
1374 -- list of a clause.
1380 function In_Input_List
1382 Inputs
: List_Id
) return Boolean
1387 Elmt
:= First
(Inputs
);
1388 while Present
(Elmt
) loop
1389 if Entity_Of
(Elmt
) = Item
then
1401 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1404 -- Start of processing for Propagate_Output
1407 -- The clause is of the form:
1409 -- (Output =>+ null)
1411 -- Remove the null input and replace it with a copy of the
1414 -- (Output => Output)
1416 if Nkind
(Inputs
) = N_Null
then
1417 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1419 -- The clause is of the form:
1421 -- (Output =>+ (Input1, ..., InputN))
1423 -- Determine whether the output is not already mentioned in the
1424 -- input list and if not, add it to the list of inputs:
1426 -- (Output => (Output, Input1, ..., InputN))
1428 elsif Nkind
(Inputs
) = N_Aggregate
then
1429 Grouped
:= Expressions
(Inputs
);
1431 if not In_Input_List
1435 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1438 -- The clause is of the form:
1440 -- (Output =>+ Input)
1442 -- If the input does not mention the output, group the two
1445 -- (Output => (Output, Input))
1447 elsif Entity_Of
(Inputs
) /= Output_Id
then
1449 Make_Aggregate
(Loc
,
1450 Expressions
=> New_List
(
1451 New_Copy_Tree
(Output
),
1452 New_Copy_Tree
(Inputs
))));
1454 end Propagate_Output
;
1458 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1459 New_Clause
: Node_Id
;
1461 -- Start of processing for Create_Or_Modify_Clause
1464 -- A null output depending on itself does not require any
1467 if Nkind
(Output
) = N_Null
then
1470 -- A function result cannot depend on itself because it cannot
1471 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1473 elsif Is_Attribute_Result
(Output
) then
1474 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1478 -- When performing the transformation in place, simply add the
1479 -- output to the list of inputs (if not already there). This case
1480 -- arises when dealing with the last output of an output list -
1481 -- we perform the normalization in place to avoid generating a
1485 Propagate_Output
(Output
, Inputs
);
1487 -- A list with multiple outputs is slowly trimmed until only
1488 -- one element remains. When this happens, replace the
1489 -- aggregate with the element itself.
1493 Rewrite
(Outputs
, Output
);
1499 -- Unchain the output from its output list as it will appear in
1500 -- a new clause. Note that we cannot simply rewrite the output
1501 -- as null because this will violate the semantics of pragma
1506 -- Generate a new clause of the form:
1507 -- (Output => Inputs)
1510 Make_Component_Association
(Loc
,
1511 Choices
=> New_List
(Output
),
1512 Expression
=> New_Copy_Tree
(Inputs
));
1514 -- The new clause contains replicated content that has already
1515 -- been analyzed. There is not need to reanalyze it or
1516 -- renormalize it again.
1518 Set_Analyzed
(New_Clause
);
1521 (Output
=> First
(Choices
(New_Clause
)),
1522 Inputs
=> Expression
(New_Clause
));
1524 Insert_After
(After
, New_Clause
);
1526 end Create_Or_Modify_Clause
;
1528 -----------------------
1529 -- Normalize_Outputs --
1530 -----------------------
1532 procedure Normalize_Outputs
is
1533 Inputs
: constant Node_Id
:= Expression
(Clause
);
1534 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1535 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1536 Last_Output
: Node_Id
;
1537 New_Clause
: Node_Id
;
1538 Next_Output
: Node_Id
;
1542 -- Multiple outputs appear as an aggregate. Nothing to do when
1543 -- the clause has exactly one output.
1545 if Nkind
(Outputs
) = N_Aggregate
then
1546 Last_Output
:= Last
(Expressions
(Outputs
));
1548 -- Create a clause for each output. Note that each time a new
1549 -- clause is created, the original output list slowly shrinks
1550 -- until there is one item left.
1552 Output
:= First
(Expressions
(Outputs
));
1553 while Present
(Output
) loop
1554 Next_Output
:= Next
(Output
);
1556 -- Unhook the output from the original output list as it
1557 -- will be relocated to a new clause.
1561 -- Special processing for the last output. At this point
1562 -- the original aggregate has been stripped down to one
1563 -- element. Replace the aggregate by the element itself.
1565 if Output
= Last_Output
then
1566 Rewrite
(Outputs
, Output
);
1569 -- Generate a clause of the form:
1570 -- (Output => Inputs)
1573 Make_Component_Association
(Loc
,
1574 Choices
=> New_List
(Output
),
1575 Expression
=> New_Copy_Tree
(Inputs
));
1577 -- The new clause contains replicated content that has
1578 -- already been analyzed. There is not need to reanalyze
1581 Set_Analyzed
(New_Clause
);
1582 Insert_After
(Clause
, New_Clause
);
1585 Output
:= Next_Output
;
1588 end Normalize_Outputs
;
1592 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1594 Last_Output
: Node_Id
;
1595 Next_Output
: Node_Id
;
1598 -- Start of processing for Normalize_Clause
1601 -- A self-dependency appears as operator "+". Remove the "+" from the
1602 -- tree by moving the real inputs to their proper place.
1604 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1605 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1606 Inputs
:= Expression
(Clause
);
1608 -- Multiple outputs appear as an aggregate
1610 if Nkind
(Outputs
) = N_Aggregate
then
1611 Last_Output
:= Last
(Expressions
(Outputs
));
1613 Output
:= First
(Expressions
(Outputs
));
1614 while Present
(Output
) loop
1616 -- Normalization may remove an output from its list,
1617 -- preserve the subsequent output now.
1619 Next_Output
:= Next
(Output
);
1621 Create_Or_Modify_Clause
1626 In_Place
=> Output
= Last_Output
,
1629 Output
:= Next_Output
;
1635 Create_Or_Modify_Clause
1645 -- Split a clause with multiple outputs into multiple clauses with a
1649 end Normalize_Clause
;
1653 Deps
: constant Node_Id
:=
1655 (First
(Pragma_Argument_Associations
(N
)));
1658 Last_Clause
: Node_Id
;
1659 Subp_Decl
: Node_Id
;
1661 Restore_Scope
: Boolean := False;
1662 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1664 -- Start of processing for Analyze_Depends_In_Decl_Part
1669 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
1670 Subp_Id
:= Defining_Entity
(Subp_Decl
);
1672 -- The logic in this routine is used to analyze both pragma Depends and
1673 -- pragma Refined_Depends since they have the same syntax and base
1674 -- semantics. Find the entity of the corresponding spec when analyzing
1677 if Nkind
(Subp_Decl
) = N_Subprogram_Body
1678 and then Present
(Corresponding_Spec
(Subp_Decl
))
1680 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
1682 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
1683 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
1685 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
1691 -- Empty dependency list
1693 if Nkind
(Deps
) = N_Null
then
1695 -- Gather all states, variables and formal parameters that the
1696 -- subprogram may depend on. These items are obtained from the
1697 -- parameter profile or pragma [Refined_]Global (if available).
1699 Collect_Subprogram_Inputs_Outputs
1700 (Subp_Id
=> Subp_Id
,
1701 Subp_Inputs
=> Subp_Inputs
,
1702 Subp_Outputs
=> Subp_Outputs
,
1703 Global_Seen
=> Global_Seen
);
1705 -- Verify that every input or output of the subprogram appear in a
1708 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1709 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1710 Check_Function_Return
;
1712 -- Dependency clauses appear as component associations of an aggregate
1714 elsif Nkind
(Deps
) = N_Aggregate
then
1716 -- Do not attempt to perform analysis of a syntactically illegal
1717 -- clause as this will lead to misleading errors.
1719 if Has_Extra_Parentheses
(Deps
) then
1723 if Present
(Component_Associations
(Deps
)) then
1724 Last_Clause
:= Last
(Component_Associations
(Deps
));
1726 -- Gather all states, variables and formal parameters that the
1727 -- subprogram may depend on. These items are obtained from the
1728 -- parameter profile or pragma [Refined_]Global (if available).
1730 Collect_Subprogram_Inputs_Outputs
1731 (Subp_Id
=> Subp_Id
,
1732 Subp_Inputs
=> Subp_Inputs
,
1733 Subp_Outputs
=> Subp_Outputs
,
1734 Global_Seen
=> Global_Seen
);
1736 -- Ensure that the formal parameters are visible when analyzing
1737 -- all clauses. This falls out of the general rule of aspects
1738 -- pertaining to subprogram declarations. Skip the installation
1739 -- for subprogram bodies because the formals are already visible.
1741 if not In_Open_Scopes
(Spec_Id
) then
1742 Restore_Scope
:= True;
1743 Push_Scope
(Spec_Id
);
1744 Install_Formals
(Spec_Id
);
1747 Clause
:= First
(Component_Associations
(Deps
));
1748 while Present
(Clause
) loop
1749 Errors
:= Serious_Errors_Detected
;
1751 -- Normalization may create extra clauses that contain
1752 -- replicated input and output names. There is no need to
1755 if not Analyzed
(Clause
) then
1756 Set_Analyzed
(Clause
);
1758 Analyze_Dependency_Clause
1760 Is_Last
=> Clause
= Last_Clause
);
1763 -- Do not normalize a clause if errors were detected (count
1764 -- of Serious_Errors has increased) because the inputs and/or
1765 -- outputs may denote illegal items. Normalization is disabled
1766 -- in ASIS mode as it alters the tree by introducing new nodes
1767 -- similar to expansion.
1769 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1770 Normalize_Clause
(Clause
);
1776 if Restore_Scope
then
1780 -- Verify that every input or output of the subprogram appear in a
1783 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1784 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1785 Check_Function_Return
;
1787 -- The dependency list is malformed. This is a syntax error, always
1791 Error_Msg_N
("malformed dependency relation", Deps
);
1795 -- The top level dependency relation is malformed. This is a syntax
1796 -- error, always report.
1799 Error_Msg_N
("malformed dependency relation", Deps
);
1803 -- Ensure that a state and a corresponding constituent do not appear
1804 -- together in pragma [Refined_]Depends.
1806 Check_State_And_Constituent_Use
1807 (States
=> States_Seen
,
1808 Constits
=> Constits_Seen
,
1810 end Analyze_Depends_In_Decl_Part
;
1812 --------------------------------------------
1813 -- Analyze_External_Property_In_Decl_Part --
1814 --------------------------------------------
1816 procedure Analyze_External_Property_In_Decl_Part
1818 Expr_Val
: out Boolean)
1820 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1821 Obj_Id
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
1822 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Next
(Arg1
));
1825 Error_Msg_Name_1
:= Pragma_Name
(N
);
1827 -- An external property pragma must apply to an effectively volatile
1828 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1829 -- The check is performed at the end of the declarative region due to a
1830 -- possible out-of-order arrangement of pragmas:
1833 -- pragma Async_Readers (Obj);
1834 -- pragma Volatile (Obj);
1836 if not Is_Effectively_Volatile
(Obj_Id
) then
1838 ("external property % must apply to a volatile object", N
);
1841 -- Ensure that the Boolean expression (if present) is static. A missing
1842 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1846 if Present
(Expr
) then
1847 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
1849 if Is_OK_Static_Expression
(Expr
) then
1850 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1852 SPARK_Msg_N
("expression of % must be static", Expr
);
1855 end Analyze_External_Property_In_Decl_Part
;
1857 ---------------------------------
1858 -- Analyze_Global_In_Decl_Part --
1859 ---------------------------------
1861 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1862 Constits_Seen
: Elist_Id
:= No_Elist
;
1863 -- A list containing the entities of all constituents processed so far.
1864 -- It aids in detecting illegal usage of a state and a corresponding
1865 -- constituent in pragma [Refinde_]Global.
1867 Seen
: Elist_Id
:= No_Elist
;
1868 -- A list containing the entities of all the items processed so far. It
1869 -- plays a role in detecting distinct entities.
1871 Spec_Id
: Entity_Id
;
1872 -- The entity of the subprogram subject to pragma [Refined_]Global
1874 States_Seen
: Elist_Id
:= No_Elist
;
1875 -- A list containing the entities of all states processed so far. It
1876 -- helps in detecting illegal usage of a state and a corresponding
1877 -- constituent in pragma [Refined_]Global.
1879 Subp_Id
: Entity_Id
;
1880 -- The entity of the subprogram [body or stub] subject to pragma
1881 -- [Refined_]Global.
1883 In_Out_Seen
: Boolean := False;
1884 Input_Seen
: Boolean := False;
1885 Output_Seen
: Boolean := False;
1886 Proof_Seen
: Boolean := False;
1887 -- Flags used to verify the consistency of modes
1889 procedure Analyze_Global_List
1891 Global_Mode
: Name_Id
:= Name_Input
);
1892 -- Verify the legality of a single global list declaration. Global_Mode
1893 -- denotes the current mode in effect.
1895 -------------------------
1896 -- Analyze_Global_List --
1897 -------------------------
1899 procedure Analyze_Global_List
1901 Global_Mode
: Name_Id
:= Name_Input
)
1903 procedure Analyze_Global_Item
1905 Global_Mode
: Name_Id
);
1906 -- Verify the legality of a single global item declaration.
1907 -- Global_Mode denotes the current mode in effect.
1909 procedure Check_Duplicate_Mode
1911 Status
: in out Boolean);
1912 -- Flag Status denotes whether a particular mode has been seen while
1913 -- processing a global list. This routine verifies that Mode is not a
1914 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1916 procedure Check_Mode_Restriction_In_Enclosing_Context
1918 Item_Id
: Entity_Id
);
1919 -- Verify that an item of mode In_Out or Output does not appear as an
1920 -- input in the Global aspect of an enclosing subprogram. If this is
1921 -- the case, emit an error. Item and Item_Id are respectively the
1922 -- item and its entity.
1924 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1925 -- Mode denotes either In_Out or Output. Depending on the kind of the
1926 -- related subprogram, emit an error if those two modes apply to a
1927 -- function (SPARK RM 6.1.4(10)).
1929 -------------------------
1930 -- Analyze_Global_Item --
1931 -------------------------
1933 procedure Analyze_Global_Item
1935 Global_Mode
: Name_Id
)
1937 Item_Id
: Entity_Id
;
1940 -- Detect one of the following cases
1942 -- with Global => (null, Name)
1943 -- with Global => (Name_1, null, Name_2)
1944 -- with Global => (Name, null)
1946 if Nkind
(Item
) = N_Null
then
1947 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
1952 Resolve_State
(Item
);
1954 -- Find the entity of the item. If this is a renaming, climb the
1955 -- renaming chain to reach the root object. Renamings of non-
1956 -- entire objects do not yield an entity (Empty).
1958 Item_Id
:= Entity_Of
(Item
);
1960 if Present
(Item_Id
) then
1962 -- A global item may denote a formal parameter of an enclosing
1963 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1964 -- provide a better error diagnostic.
1966 if Is_Formal
(Item_Id
) then
1967 if Scope
(Item_Id
) = Spec_Id
then
1969 ("global item cannot reference parameter of subprogram",
1974 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1975 -- Do this check first to provide a better error diagnostic.
1977 elsif Ekind
(Item_Id
) = E_Constant
then
1978 SPARK_Msg_N
("global item cannot denote a constant", Item
);
1980 -- A formal object may act as a global item inside a generic
1982 elsif Is_Formal_Object
(Item_Id
) then
1985 -- The only legal references are those to abstract states and
1986 -- variables (SPARK RM 6.1.4(4)).
1988 elsif not Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
1990 ("global item must denote variable or state", Item
);
1994 -- State related checks
1996 if Ekind
(Item_Id
) = E_Abstract_State
then
1998 -- An abstract state with visible refinement cannot appear
1999 -- in pragma [Refined_]Global as its place must be taken by
2000 -- some of its constituents (SPARK RM 6.1.4(8)).
2002 if Has_Visible_Refinement
(Item_Id
) then
2004 ("cannot mention state & in global refinement",
2006 SPARK_Msg_N
("\use its constituents instead", Item
);
2009 -- If the reference to the abstract state appears in an
2010 -- enclosing package body that will eventually refine the
2011 -- state, record the reference for future checks.
2014 Record_Possible_Body_Reference
2015 (State_Id
=> Item_Id
,
2019 -- Variable related checks. These are only relevant when
2020 -- SPARK_Mode is on as they are not standard Ada legality
2023 elsif SPARK_Mode
= On
2024 and then Is_Effectively_Volatile
(Item_Id
)
2026 -- An effectively volatile object cannot appear as a global
2027 -- item of a function (SPARK RM 7.1.3(9)).
2029 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2031 ("volatile object & cannot act as global item of a "
2032 & "function", Item
, Item_Id
);
2035 -- An effectively volatile object with external property
2036 -- Effective_Reads set to True must have mode Output or
2039 elsif Effective_Reads_Enabled
(Item_Id
)
2040 and then Global_Mode
= Name_Input
2043 ("volatile object & with property Effective_Reads must "
2044 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
2050 -- When the item renames an entire object, replace the item
2051 -- with a reference to the object.
2053 if Present
(Renamed_Object
(Entity
(Item
))) then
2054 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2058 -- Some form of illegal construct masquerading as a name
2059 -- (SPARK RM 6.1.4(4)).
2062 Error_Msg_N
("global item must denote variable or state", Item
);
2066 -- Verify that an output does not appear as an input in an
2067 -- enclosing subprogram.
2069 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2070 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2073 -- The same entity might be referenced through various way.
2074 -- Check the entity of the item rather than the item itself
2075 -- (SPARK RM 6.1.4(11)).
2077 if Contains
(Seen
, Item_Id
) then
2078 SPARK_Msg_N
("duplicate global item", Item
);
2080 -- Add the entity of the current item to the list of processed
2084 Add_Item
(Item_Id
, Seen
);
2086 if Ekind
(Item_Id
) = E_Abstract_State
then
2087 Add_Item
(Item_Id
, States_Seen
);
2090 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
2091 and then Present
(Encapsulating_State
(Item_Id
))
2093 Add_Item
(Item_Id
, Constits_Seen
);
2096 end Analyze_Global_Item
;
2098 --------------------------
2099 -- Check_Duplicate_Mode --
2100 --------------------------
2102 procedure Check_Duplicate_Mode
2104 Status
: in out Boolean)
2108 SPARK_Msg_N
("duplicate global mode", Mode
);
2112 end Check_Duplicate_Mode
;
2114 -------------------------------------------------
2115 -- Check_Mode_Restriction_In_Enclosing_Context --
2116 -------------------------------------------------
2118 procedure Check_Mode_Restriction_In_Enclosing_Context
2120 Item_Id
: Entity_Id
)
2122 Context
: Entity_Id
;
2124 Inputs
: Elist_Id
:= No_Elist
;
2125 Outputs
: Elist_Id
:= No_Elist
;
2128 -- Traverse the scope stack looking for enclosing subprograms
2129 -- subject to pragma [Refined_]Global.
2131 Context
:= Scope
(Subp_Id
);
2132 while Present
(Context
) and then Context
/= Standard_Standard
loop
2133 if Is_Subprogram
(Context
)
2135 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2137 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2139 Collect_Subprogram_Inputs_Outputs
2140 (Subp_Id
=> Context
,
2141 Subp_Inputs
=> Inputs
,
2142 Subp_Outputs
=> Outputs
,
2143 Global_Seen
=> Dummy
);
2145 -- The item is classified as In_Out or Output but appears as
2146 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2148 if Appears_In
(Inputs
, Item_Id
)
2149 and then not Appears_In
(Outputs
, Item_Id
)
2152 ("global item & cannot have mode In_Out or Output",
2155 ("\item already appears as input of subprogram &",
2158 -- Stop the traversal once an error has been detected
2164 Context
:= Scope
(Context
);
2166 end Check_Mode_Restriction_In_Enclosing_Context
;
2168 ----------------------------------------
2169 -- Check_Mode_Restriction_In_Function --
2170 ----------------------------------------
2172 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2174 if Ekind
(Spec_Id
) = E_Function
then
2176 ("global mode & is not applicable to functions", Mode
);
2178 end Check_Mode_Restriction_In_Function
;
2186 -- Start of processing for Analyze_Global_List
2189 if Nkind
(List
) = N_Null
then
2190 Set_Analyzed
(List
);
2192 -- Single global item declaration
2194 elsif Nkind_In
(List
, N_Expanded_Name
,
2196 N_Selected_Component
)
2198 Analyze_Global_Item
(List
, Global_Mode
);
2200 -- Simple global list or moded global list declaration
2202 elsif Nkind
(List
) = N_Aggregate
then
2203 Set_Analyzed
(List
);
2205 -- The declaration of a simple global list appear as a collection
2208 if Present
(Expressions
(List
)) then
2209 if Present
(Component_Associations
(List
)) then
2211 ("cannot mix moded and non-moded global lists", List
);
2214 Item
:= First
(Expressions
(List
));
2215 while Present
(Item
) loop
2216 Analyze_Global_Item
(Item
, Global_Mode
);
2221 -- The declaration of a moded global list appears as a collection
2222 -- of component associations where individual choices denote
2225 elsif Present
(Component_Associations
(List
)) then
2226 if Present
(Expressions
(List
)) then
2228 ("cannot mix moded and non-moded global lists", List
);
2231 Assoc
:= First
(Component_Associations
(List
));
2232 while Present
(Assoc
) loop
2233 Mode
:= First
(Choices
(Assoc
));
2235 if Nkind
(Mode
) = N_Identifier
then
2236 if Chars
(Mode
) = Name_In_Out
then
2237 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2238 Check_Mode_Restriction_In_Function
(Mode
);
2240 elsif Chars
(Mode
) = Name_Input
then
2241 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2243 elsif Chars
(Mode
) = Name_Output
then
2244 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2245 Check_Mode_Restriction_In_Function
(Mode
);
2247 elsif Chars
(Mode
) = Name_Proof_In
then
2248 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2251 SPARK_Msg_N
("invalid mode selector", Mode
);
2255 SPARK_Msg_N
("invalid mode selector", Mode
);
2258 -- Items in a moded list appear as a collection of
2259 -- expressions. Reuse the existing machinery to analyze
2263 (List
=> Expression
(Assoc
),
2264 Global_Mode
=> Chars
(Mode
));
2272 raise Program_Error
;
2275 -- Any other attempt to declare a global item is illegal. This is a
2276 -- syntax error, always report.
2279 Error_Msg_N
("malformed global list", List
);
2281 end Analyze_Global_List
;
2285 Items
: constant Node_Id
:=
2286 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2287 Subp_Decl
: Node_Id
;
2289 Restore_Scope
: Boolean := False;
2290 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2292 -- Start of processing for Analyze_Global_In_Decl_List
2296 Check_SPARK_Aspect_For_ASIS
(N
);
2298 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
2299 Subp_Id
:= Defining_Entity
(Subp_Decl
);
2301 -- The logic in this routine is used to analyze both pragma Global and
2302 -- pragma Refined_Global since they have the same syntax and base
2303 -- semantics. Find the entity of the corresponding spec when analyzing
2306 if Nkind
(Subp_Decl
) = N_Subprogram_Body
2307 and then Present
(Corresponding_Spec
(Subp_Decl
))
2309 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
2311 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
2312 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
2314 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
2320 -- There is nothing to be done for a null global list
2322 if Nkind
(Items
) = N_Null
then
2323 Set_Analyzed
(Items
);
2325 -- Analyze the various forms of global lists and items. Note that some
2326 -- of these may be malformed in which case the analysis emits error
2330 -- Ensure that the formal parameters are visible when processing an
2331 -- item. This falls out of the general rule of aspects pertaining to
2332 -- subprogram declarations.
2334 if not In_Open_Scopes
(Spec_Id
) then
2335 Restore_Scope
:= True;
2336 Push_Scope
(Spec_Id
);
2337 Install_Formals
(Spec_Id
);
2340 Analyze_Global_List
(Items
);
2342 if Restore_Scope
then
2347 -- Ensure that a state and a corresponding constituent do not appear
2348 -- together in pragma [Refined_]Global.
2350 Check_State_And_Constituent_Use
2351 (States
=> States_Seen
,
2352 Constits
=> Constits_Seen
,
2354 end Analyze_Global_In_Decl_Part
;
2356 --------------------------------------------
2357 -- Analyze_Initial_Condition_In_Decl_Part --
2358 --------------------------------------------
2360 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2361 Expr
: constant Node_Id
:=
2362 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2367 -- The expression is preanalyzed because it has not been moved to its
2368 -- final place yet. A direct analysis may generate side effects and this
2369 -- is not desired at this point.
2371 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2372 end Analyze_Initial_Condition_In_Decl_Part
;
2374 --------------------------------------
2375 -- Analyze_Initializes_In_Decl_Part --
2376 --------------------------------------
2378 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2379 Pack_Spec
: constant Node_Id
:= Parent
(N
);
2380 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Parent
(Pack_Spec
));
2382 Constits_Seen
: Elist_Id
:= No_Elist
;
2383 -- A list containing the entities of all constituents processed so far.
2384 -- It aids in detecting illegal usage of a state and a corresponding
2385 -- constituent in pragma Initializes.
2387 Items_Seen
: Elist_Id
:= No_Elist
;
2388 -- A list of all initialization items processed so far. This list is
2389 -- used to detect duplicate items.
2391 Non_Null_Seen
: Boolean := False;
2392 Null_Seen
: Boolean := False;
2393 -- Flags used to check the legality of a null initialization list
2395 States_And_Vars
: Elist_Id
:= No_Elist
;
2396 -- A list of all abstract states and variables declared in the visible
2397 -- declarations of the related package. This list is used to detect the
2398 -- legality of initialization items.
2400 States_Seen
: Elist_Id
:= No_Elist
;
2401 -- A list containing the entities of all states processed so far. It
2402 -- helps in detecting illegal usage of a state and a corresponding
2403 -- constituent in pragma Initializes.
2405 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2406 -- Verify the legality of a single initialization item
2408 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2409 -- Verify the legality of a single initialization item followed by a
2410 -- list of input items.
2412 procedure Collect_States_And_Variables
;
2413 -- Inspect the visible declarations of the related package and gather
2414 -- the entities of all abstract states and variables in States_And_Vars.
2416 ---------------------------------
2417 -- Analyze_Initialization_Item --
2418 ---------------------------------
2420 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2421 Item_Id
: Entity_Id
;
2424 -- Null initialization list
2426 if Nkind
(Item
) = N_Null
then
2428 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2430 elsif Non_Null_Seen
then
2432 ("cannot mix null and non-null initialization items", Item
);
2437 -- Initialization item
2440 Non_Null_Seen
:= True;
2444 ("cannot mix null and non-null initialization items", Item
);
2448 Resolve_State
(Item
);
2450 if Is_Entity_Name
(Item
) then
2451 Item_Id
:= Entity_Of
(Item
);
2453 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
2455 -- The state or variable must be declared in the visible
2456 -- declarations of the package (SPARK RM 7.1.5(7)).
2458 if not Contains
(States_And_Vars
, Item_Id
) then
2459 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2461 ("initialization item & must appear in the visible "
2462 & "declarations of package %", Item
, Item_Id
);
2464 -- Detect a duplicate use of the same initialization item
2465 -- (SPARK RM 7.1.5(5)).
2467 elsif Contains
(Items_Seen
, Item_Id
) then
2468 SPARK_Msg_N
("duplicate initialization item", Item
);
2470 -- The item is legal, add it to the list of processed states
2474 Add_Item
(Item_Id
, Items_Seen
);
2476 if Ekind
(Item_Id
) = E_Abstract_State
then
2477 Add_Item
(Item_Id
, States_Seen
);
2480 if Present
(Encapsulating_State
(Item_Id
)) then
2481 Add_Item
(Item_Id
, Constits_Seen
);
2485 -- The item references something that is not a state or a
2486 -- variable (SPARK RM 7.1.5(3)).
2490 ("initialization item must denote variable or state",
2494 -- Some form of illegal construct masquerading as a name
2495 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2499 ("initialization item must denote variable or state", Item
);
2502 end Analyze_Initialization_Item
;
2504 ---------------------------------------------
2505 -- Analyze_Initialization_Item_With_Inputs --
2506 ---------------------------------------------
2508 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2509 Inputs_Seen
: Elist_Id
:= No_Elist
;
2510 -- A list of all inputs processed so far. This list is used to detect
2511 -- duplicate uses of an input.
2513 Non_Null_Seen
: Boolean := False;
2514 Null_Seen
: Boolean := False;
2515 -- Flags used to check the legality of an input list
2517 procedure Analyze_Input_Item
(Input
: Node_Id
);
2518 -- Verify the legality of a single input item
2520 ------------------------
2521 -- Analyze_Input_Item --
2522 ------------------------
2524 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2525 Input_Id
: Entity_Id
;
2530 if Nkind
(Input
) = N_Null
then
2533 ("multiple null initializations not allowed", Item
);
2535 elsif Non_Null_Seen
then
2537 ("cannot mix null and non-null initialization item", Item
);
2545 Non_Null_Seen
:= True;
2549 ("cannot mix null and non-null initialization item", Item
);
2553 Resolve_State
(Input
);
2555 if Is_Entity_Name
(Input
) then
2556 Input_Id
:= Entity_Of
(Input
);
2558 if Ekind_In
(Input_Id
, E_Abstract_State
,
2564 -- The input cannot denote states or variables declared
2565 -- within the related package.
2567 if Within_Scope
(Input_Id
, Current_Scope
) then
2568 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2570 ("input item & cannot denote a visible variable or "
2571 & "state of package % (SPARK RM 7.1.5(4))",
2574 -- Detect a duplicate use of the same input item
2575 -- (SPARK RM 7.1.5(5)).
2577 elsif Contains
(Inputs_Seen
, Input_Id
) then
2578 SPARK_Msg_N
("duplicate input item", Input
);
2580 -- Input is legal, add it to the list of processed inputs
2583 Add_Item
(Input_Id
, Inputs_Seen
);
2585 if Ekind
(Input_Id
) = E_Abstract_State
then
2586 Add_Item
(Input_Id
, States_Seen
);
2589 if Ekind_In
(Input_Id
, E_Abstract_State
, E_Variable
)
2590 and then Present
(Encapsulating_State
(Input_Id
))
2592 Add_Item
(Input_Id
, Constits_Seen
);
2596 -- The input references something that is not a state or a
2597 -- variable (SPARK RM 7.1.5(3)).
2601 ("input item must denote variable or state", Input
);
2604 -- Some form of illegal construct masquerading as a name
2605 -- (SPARK RM 7.1.5(3)).
2609 ("input item must denote variable or state", Input
);
2612 end Analyze_Input_Item
;
2616 Inputs
: constant Node_Id
:= Expression
(Item
);
2620 Name_Seen
: Boolean := False;
2621 -- A flag used to detect multiple item names
2623 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2626 -- Inspect the name of an item with inputs
2628 Elmt
:= First
(Choices
(Item
));
2629 while Present
(Elmt
) loop
2631 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2634 Analyze_Initialization_Item
(Elmt
);
2640 -- Multiple input items appear as an aggregate
2642 if Nkind
(Inputs
) = N_Aggregate
then
2643 if Present
(Expressions
(Inputs
)) then
2644 Input
:= First
(Expressions
(Inputs
));
2645 while Present
(Input
) loop
2646 Analyze_Input_Item
(Input
);
2651 if Present
(Component_Associations
(Inputs
)) then
2653 ("inputs must appear in named association form", Inputs
);
2656 -- Single input item
2659 Analyze_Input_Item
(Inputs
);
2661 end Analyze_Initialization_Item_With_Inputs
;
2663 ----------------------------------
2664 -- Collect_States_And_Variables --
2665 ----------------------------------
2667 procedure Collect_States_And_Variables
is
2671 -- Collect the abstract states defined in the package (if any)
2673 if Present
(Abstract_States
(Pack_Id
)) then
2674 States_And_Vars
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2677 -- Collect all variables the appear in the visible declarations of
2678 -- the related package.
2680 if Present
(Visible_Declarations
(Pack_Spec
)) then
2681 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2682 while Present
(Decl
) loop
2683 if Nkind
(Decl
) = N_Object_Declaration
2684 and then Ekind
(Defining_Entity
(Decl
)) = E_Variable
2685 and then Comes_From_Source
(Decl
)
2687 Add_Item
(Defining_Entity
(Decl
), States_And_Vars
);
2693 end Collect_States_And_Variables
;
2697 Inits
: constant Node_Id
:=
2698 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2701 -- Start of processing for Analyze_Initializes_In_Decl_Part
2706 Check_SPARK_Aspect_For_ASIS
(N
);
2708 -- Nothing to do when the initialization list is empty
2710 if Nkind
(Inits
) = N_Null
then
2714 -- Single and multiple initialization clauses appear as an aggregate. If
2715 -- this is not the case, then either the parser or the analysis of the
2716 -- pragma failed to produce an aggregate.
2718 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2720 -- Initialize the various lists used during analysis
2722 Collect_States_And_Variables
;
2724 if Present
(Expressions
(Inits
)) then
2725 Init
:= First
(Expressions
(Inits
));
2726 while Present
(Init
) loop
2727 Analyze_Initialization_Item
(Init
);
2732 if Present
(Component_Associations
(Inits
)) then
2733 Init
:= First
(Component_Associations
(Inits
));
2734 while Present
(Init
) loop
2735 Analyze_Initialization_Item_With_Inputs
(Init
);
2740 -- Ensure that a state and a corresponding constituent do not appear
2741 -- together in pragma Initializes.
2743 Check_State_And_Constituent_Use
2744 (States
=> States_Seen
,
2745 Constits
=> Constits_Seen
,
2747 end Analyze_Initializes_In_Decl_Part
;
2749 --------------------
2750 -- Analyze_Pragma --
2751 --------------------
2753 procedure Analyze_Pragma
(N
: Node_Id
) is
2754 Loc
: constant Source_Ptr
:= Sloc
(N
);
2755 Prag_Id
: Pragma_Id
;
2758 -- Name of the source pragma, or name of the corresponding aspect for
2759 -- pragmas which originate in a source aspect. In the latter case, the
2760 -- name may be different from the pragma name.
2762 Pragma_Exit
: exception;
2763 -- This exception is used to exit pragma processing completely. It
2764 -- is used when an error is detected, and no further processing is
2765 -- required. It is also used if an earlier error has left the tree in
2766 -- a state where the pragma should not be processed.
2769 -- Number of pragma argument associations
2775 -- First four pragma arguments (pragma argument association nodes, or
2776 -- Empty if the corresponding argument does not exist).
2778 type Name_List
is array (Natural range <>) of Name_Id
;
2779 type Args_List
is array (Natural range <>) of Node_Id
;
2780 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2782 -----------------------
2783 -- Local Subprograms --
2784 -----------------------
2786 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
2787 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2788 -- get the given string argument, and place it in Name_Buffer, adding
2789 -- leading and trailing asterisks if they are not already present. The
2790 -- caller has already checked that Arg is a static string expression.
2792 procedure Ada_2005_Pragma
;
2793 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2794 -- Ada 95 mode, these are implementation defined pragmas, so should be
2795 -- caught by the No_Implementation_Pragmas restriction.
2797 procedure Ada_2012_Pragma
;
2798 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2799 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2800 -- should be caught by the No_Implementation_Pragmas restriction.
2802 procedure Analyze_Part_Of
2803 (Item_Id
: Entity_Id
;
2806 Legal
: out Boolean);
2807 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2808 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2809 -- an abstract state, variable or package instantiation. State is the
2810 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2811 -- set when the indicator is legal.
2813 procedure Analyze_Refined_Pragma
2814 (Spec_Id
: out Entity_Id
;
2815 Body_Id
: out Entity_Id
;
2816 Legal
: out Boolean);
2817 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2818 -- Refined_Global and Refined_Post. Check the placement and related
2819 -- context of the pragma. Spec_Id is the entity of the related
2820 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2821 -- Legal is set when the pragma is properly placed.
2823 procedure Check_Ada_83_Warning
;
2824 -- Issues a warning message for the current pragma if operating in Ada
2825 -- 83 mode (used for language pragmas that are not a standard part of
2826 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2829 procedure Check_Arg_Count
(Required
: Nat
);
2830 -- Check argument count for pragma is equal to given parameter. If not,
2831 -- then issue an error message and raise Pragma_Exit.
2833 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2834 -- Arg which can either be a pragma argument association, in which case
2835 -- the check is applied to the expression of the association or an
2836 -- expression directly.
2838 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
2839 -- Check that an argument has the right form for an EXTERNAL_NAME
2840 -- parameter of an extended import/export pragma. The rule is that the
2841 -- name must be an identifier or string literal (in Ada 83 mode) or a
2842 -- static string expression (in Ada 95 mode).
2844 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
2845 -- Check the specified argument Arg to make sure that it is an
2846 -- identifier. If not give error and raise Pragma_Exit.
2848 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
2849 -- Check the specified argument Arg to make sure that it is an integer
2850 -- literal. If not give error and raise Pragma_Exit.
2852 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
2853 -- Check the specified argument Arg to make sure that it has the proper
2854 -- syntactic form for a local name and meets the semantic requirements
2855 -- for a local name. The local name is analyzed as part of the
2856 -- processing for this call. In addition, the local name is required
2857 -- to represent an entity at the library level.
2859 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
2860 -- Check the specified argument Arg to make sure that it has the proper
2861 -- syntactic form for a local name and meets the semantic requirements
2862 -- for a local name. The local name is analyzed as part of the
2863 -- processing for this call.
2865 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
2866 -- Check the specified argument Arg to make sure that it is a valid
2867 -- locking policy name. If not give error and raise Pragma_Exit.
2869 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
2870 -- Check the specified argument Arg to make sure that it is a valid
2871 -- elaboration policy name. If not give error and raise Pragma_Exit.
2873 procedure Check_Arg_Is_One_Of
2876 procedure Check_Arg_Is_One_Of
2878 N1
, N2
, N3
: Name_Id
);
2879 procedure Check_Arg_Is_One_Of
2881 N1
, N2
, N3
, N4
: Name_Id
);
2882 procedure Check_Arg_Is_One_Of
2884 N1
, N2
, N3
, N4
, N5
: Name_Id
);
2885 -- Check the specified argument Arg to make sure that it is an
2886 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2887 -- present). If not then give error and raise Pragma_Exit.
2889 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
2890 -- Check the specified argument Arg to make sure that it is a valid
2891 -- queuing policy name. If not give error and raise Pragma_Exit.
2893 procedure Check_Arg_Is_OK_Static_Expression
2895 Typ
: Entity_Id
:= Empty
);
2896 -- Check the specified argument Arg to make sure that it is a static
2897 -- expression of the given type (i.e. it will be analyzed and resolved
2898 -- using this type, which can be any valid argument to Resolve, e.g.
2899 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2900 -- Typ is left Empty, then any static expression is allowed. Includes
2901 -- checking that the argument does not raise Constraint_Error.
2903 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
2904 -- Check the specified argument Arg to make sure that it is a valid task
2905 -- dispatching policy name. If not give error and raise Pragma_Exit.
2907 procedure Check_Arg_Order
(Names
: Name_List
);
2908 -- Checks for an instance of two arguments with identifiers for the
2909 -- current pragma which are not in the sequence indicated by Names,
2910 -- and if so, generates a fatal message about bad order of arguments.
2912 procedure Check_At_Least_N_Arguments
(N
: Nat
);
2913 -- Check there are at least N arguments present
2915 procedure Check_At_Most_N_Arguments
(N
: Nat
);
2916 -- Check there are no more than N arguments present
2918 procedure Check_Component
2921 In_Variant_Part
: Boolean := False);
2922 -- Examine an Unchecked_Union component for correct use of per-object
2923 -- constrained subtypes, and for restrictions on finalizable components.
2924 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2925 -- should be set when Comp comes from a record variant.
2927 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
);
2928 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2929 -- Initial_Condition and Initializes. Determine whether pragma First
2930 -- appears before pragma Second. If this is not the case, emit an error.
2932 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
2933 -- Check if a rep item of the same name as the current pragma is already
2934 -- chained as a rep pragma to the given entity. If so give a message
2935 -- about the duplicate, and then raise Pragma_Exit so does not return.
2936 -- Note that if E is a type, then this routine avoids flagging a pragma
2937 -- which applies to a parent type from which E is derived.
2939 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
2940 -- Nam is an N_String_Literal node containing the external name set by
2941 -- an Import or Export pragma (or extended Import or Export pragma).
2942 -- This procedure checks for possible duplications if this is the export
2943 -- case, and if found, issues an appropriate error message.
2945 procedure Check_Expr_Is_OK_Static_Expression
2947 Typ
: Entity_Id
:= Empty
);
2948 -- Check the specified expression Expr to make sure that it is a static
2949 -- expression of the given type (i.e. it will be analyzed and resolved
2950 -- using this type, which can be any valid argument to Resolve, e.g.
2951 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2952 -- Typ is left Empty, then any static expression is allowed. Includes
2953 -- checking that the expression does not raise Constraint_Error.
2955 procedure Check_First_Subtype
(Arg
: Node_Id
);
2956 -- Checks that Arg, whose expression is an entity name, references a
2959 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2960 -- Checks that the given argument has an identifier, and if so, requires
2961 -- it to match the given identifier name. If there is no identifier, or
2962 -- a non-matching identifier, then an error message is given and
2963 -- Pragma_Exit is raised.
2965 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
2966 -- Checks that the given argument has an identifier, and if so, requires
2967 -- it to match one of the given identifier names. If there is no
2968 -- identifier, or a non-matching identifier, then an error message is
2969 -- given and Pragma_Exit is raised.
2971 procedure Check_In_Main_Program
;
2972 -- Common checks for pragmas that appear within a main program
2973 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2975 procedure Check_Interrupt_Or_Attach_Handler
;
2976 -- Common processing for first argument of pragma Interrupt_Handler or
2977 -- pragma Attach_Handler.
2979 procedure Check_Loop_Pragma_Placement
;
2980 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2981 -- appear immediately within a construct restricted to loops, and that
2982 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2984 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
2985 -- Check that pragma appears in a declarative part, or in a package
2986 -- specification, i.e. that it does not occur in a statement sequence
2989 procedure Check_No_Identifier
(Arg
: Node_Id
);
2990 -- Checks that the given argument does not have an identifier. If
2991 -- an identifier is present, then an error message is issued, and
2992 -- Pragma_Exit is raised.
2994 procedure Check_No_Identifiers
;
2995 -- Checks that none of the arguments to the pragma has an identifier.
2996 -- If any argument has an identifier, then an error message is issued,
2997 -- and Pragma_Exit is raised.
2999 procedure Check_No_Link_Name
;
3000 -- Checks that no link name is specified
3002 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3003 -- Checks if the given argument has an identifier, and if so, requires
3004 -- it to match the given identifier name. If there is a non-matching
3005 -- identifier, then an error message is given and Pragma_Exit is raised.
3007 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3008 -- Checks if the given argument has an identifier, and if so, requires
3009 -- it to match the given identifier name. If there is a non-matching
3010 -- identifier, then an error message is given and Pragma_Exit is raised.
3011 -- In this version of the procedure, the identifier name is given as
3012 -- a string with lower case letters.
3014 procedure Check_Pre_Post
;
3015 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
3016 -- pragmas. These are processed by transformation to equivalent
3017 -- Precondition and Postcondition pragmas, but Pre and Post need an
3018 -- additional check that they are not used in a subprogram body when
3019 -- there is a separate spec present.
3021 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
3022 -- Called to process a precondition or postcondition pragma. There are
3025 -- The pragma appears after a subprogram spec
3027 -- If the corresponding check is not enabled, the pragma is analyzed
3028 -- but otherwise ignored and control returns with In_Body set False.
3030 -- If the check is enabled, then the first step is to analyze the
3031 -- pragma, but this is skipped if the subprogram spec appears within
3032 -- a package specification (because this is the case where we delay
3033 -- analysis till the end of the spec). Then (whether or not it was
3034 -- analyzed), the pragma is chained to the subprogram in question
3035 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
3036 -- to the caller with In_Body set False.
3038 -- The pragma appears at the start of subprogram body declarations
3040 -- In this case an immediate return to the caller is made with
3041 -- In_Body set True, and the pragma is NOT analyzed.
3043 -- In all other cases, an error message for bad placement is given
3045 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3046 -- Constr is a constraint from an N_Subtype_Indication node from a
3047 -- component constraint in an Unchecked_Union type. This routine checks
3048 -- that the constraint is static as required by the restrictions for
3051 procedure Check_Test_Case
;
3052 -- Called to process a test-case pragma. It starts with checking pragma
3053 -- arguments, and the rest of the treatment is similar to the one for
3054 -- pre- and postcondition in Check_Precondition_Postcondition, except
3055 -- the placement rules for the test-case pragma are stricter. These
3056 -- pragmas may only occur after a subprogram spec declared directly
3057 -- in a package spec unit. In this case, the pragma is chained to the
3058 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
3059 -- and analysis of the pragma is delayed till the end of the spec. In
3060 -- all other cases, an error message for bad placement is given.
3062 procedure Check_Valid_Configuration_Pragma
;
3063 -- Legality checks for placement of a configuration pragma
3065 procedure Check_Valid_Library_Unit_Pragma
;
3066 -- Legality checks for library unit pragmas. A special case arises for
3067 -- pragmas in generic instances that come from copies of the original
3068 -- library unit pragmas in the generic templates. In the case of other
3069 -- than library level instantiations these can appear in contexts which
3070 -- would normally be invalid (they only apply to the original template
3071 -- and to library level instantiations), and they are simply ignored,
3072 -- which is implemented by rewriting them as null statements.
3074 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3075 -- Check an Unchecked_Union variant for lack of nested variants and
3076 -- presence of at least one component. UU_Typ is the related Unchecked_
3079 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3080 -- Subsidiary routine to the processing of pragmas Abstract_State,
3081 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3082 -- Refined_Global and Refined_State. Transform argument Arg into an
3083 -- aggregate if not one already. N_Null is never transformed.
3085 procedure Error_Pragma
(Msg
: String);
3086 pragma No_Return
(Error_Pragma
);
3087 -- Outputs error message for current pragma. The message contains a %
3088 -- that will be replaced with the pragma name, and the flag is placed
3089 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3090 -- calls Fix_Error (see spec of that procedure for details).
3092 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3093 pragma No_Return
(Error_Pragma_Arg
);
3094 -- Outputs error message for current pragma. The message may contain
3095 -- a % that will be replaced with the pragma name. The parameter Arg
3096 -- may either be a pragma argument association, in which case the flag
3097 -- is placed on the expression of this association, or an expression,
3098 -- in which case the flag is placed directly on the expression. The
3099 -- message is placed using Error_Msg_N, so the message may also contain
3100 -- an & insertion character which will reference the given Arg value.
3101 -- After placing the message, Pragma_Exit is raised. Note: this routine
3102 -- calls Fix_Error (see spec of that procedure for details).
3104 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3105 pragma No_Return
(Error_Pragma_Arg
);
3106 -- Similar to above form of Error_Pragma_Arg except that two messages
3107 -- are provided, the second is a continuation comment starting with \.
3109 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3110 pragma No_Return
(Error_Pragma_Arg_Ident
);
3111 -- Outputs error message for current pragma. The message may contain a %
3112 -- that will be replaced with the pragma name. The parameter Arg must be
3113 -- a pragma argument association with a non-empty identifier (i.e. its
3114 -- Chars field must be set), and the error message is placed on the
3115 -- identifier. The message is placed using Error_Msg_N so the message
3116 -- may also contain an & insertion character which will reference
3117 -- the identifier. After placing the message, Pragma_Exit is raised.
3118 -- Note: this routine calls Fix_Error (see spec of that procedure for
3121 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3122 pragma No_Return
(Error_Pragma_Ref
);
3123 -- Outputs error message for current pragma. The message may contain
3124 -- a % that will be replaced with the pragma name. The parameter Ref
3125 -- must be an entity whose name can be referenced by & and sloc by #.
3126 -- After placing the message, Pragma_Exit is raised. Note: this routine
3127 -- calls Fix_Error (see spec of that procedure for details).
3129 function Find_Lib_Unit_Name
return Entity_Id
;
3130 -- Used for a library unit pragma to find the entity to which the
3131 -- library unit pragma applies, returns the entity found.
3133 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3134 -- If the pragma is a compilation unit pragma, the id must denote the
3135 -- compilation unit in the same compilation, and the pragma must appear
3136 -- in the list of preceding or trailing pragmas. If it is a program
3137 -- unit pragma that is not a compilation unit pragma, then the
3138 -- identifier must be visible.
3140 function Find_Unique_Parameterless_Procedure
3142 Arg
: Node_Id
) return Entity_Id
;
3143 -- Used for a procedure pragma to find the unique parameterless
3144 -- procedure identified by Name, returns it if it exists, otherwise
3145 -- errors out and uses Arg as the pragma argument for the message.
3147 function Fix_Error
(Msg
: String) return String;
3148 -- This is called prior to issuing an error message. Msg is the normal
3149 -- error message issued in the pragma case. This routine checks for the
3150 -- case of a pragma coming from an aspect in the source, and returns a
3151 -- message suitable for the aspect case as follows:
3153 -- Each substring "pragma" is replaced by "aspect"
3155 -- If "argument of" is at the start of the error message text, it is
3156 -- replaced by "entity for".
3158 -- If "argument" is at the start of the error message text, it is
3159 -- replaced by "entity".
3161 -- So for example, "argument of pragma X must be discrete type"
3162 -- returns "entity for aspect X must be a discrete type".
3164 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3165 -- be different from the pragma name). If the current pragma results
3166 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3167 -- original pragma name.
3169 procedure Gather_Associations
3171 Args
: out Args_List
);
3172 -- This procedure is used to gather the arguments for a pragma that
3173 -- permits arbitrary ordering of parameters using the normal rules
3174 -- for named and positional parameters. The Names argument is a list
3175 -- of Name_Id values that corresponds to the allowed pragma argument
3176 -- association identifiers in order. The result returned in Args is
3177 -- a list of corresponding expressions that are the pragma arguments.
3178 -- Note that this is a list of expressions, not of pragma argument
3179 -- associations (Gather_Associations has completely checked all the
3180 -- optional identifiers when it returns). An entry in Args is Empty
3181 -- on return if the corresponding argument is not present.
3183 procedure GNAT_Pragma
;
3184 -- Called for all GNAT defined pragmas to check the relevant restriction
3185 -- (No_Implementation_Pragmas).
3187 function Is_Before_First_Decl
3188 (Pragma_Node
: Node_Id
;
3189 Decls
: List_Id
) return Boolean;
3190 -- Return True if Pragma_Node is before the first declarative item in
3191 -- Decls where Decls is the list of declarative items.
3193 function Is_Configuration_Pragma
return Boolean;
3194 -- Determines if the placement of the current pragma is appropriate
3195 -- for a configuration pragma.
3197 function Is_In_Context_Clause
return Boolean;
3198 -- Returns True if pragma appears within the context clause of a unit,
3199 -- and False for any other placement (does not generate any messages).
3201 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3202 -- Analyzes the argument, and determines if it is a static string
3203 -- expression, returns True if so, False if non-static or not String.
3204 -- A special case is that a string literal returns True in Ada 83 mode
3205 -- (which has no such thing as static string expressions).
3207 procedure Pragma_Misplaced
;
3208 pragma No_Return
(Pragma_Misplaced
);
3209 -- Issue fatal error message for misplaced pragma
3211 procedure Process_Atomic_Shared_Volatile
;
3212 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3213 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3214 -- in effect to pragma Atomic.
3216 procedure Process_Compile_Time_Warning_Or_Error
;
3217 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3219 procedure Process_Convention
3220 (C
: out Convention_Id
;
3221 Ent
: out Entity_Id
);
3222 -- Common processing for Convention, Interface, Import and Export.
3223 -- Checks first two arguments of pragma, and sets the appropriate
3224 -- convention value in the specified entity or entities. On return
3225 -- C is the convention, Ent is the referenced entity.
3227 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3228 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3229 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3231 procedure Process_Extended_Import_Export_Object_Pragma
3232 (Arg_Internal
: Node_Id
;
3233 Arg_External
: Node_Id
;
3234 Arg_Size
: Node_Id
);
3235 -- Common processing for the pragmas Import/Export_Object. The three
3236 -- arguments correspond to the three named parameters of the pragmas. An
3237 -- argument is empty if the corresponding parameter is not present in
3240 procedure Process_Extended_Import_Export_Internal_Arg
3241 (Arg_Internal
: Node_Id
:= Empty
);
3242 -- Common processing for all extended Import and Export pragmas. The
3243 -- argument is the pragma parameter for the Internal argument. If
3244 -- Arg_Internal is empty or inappropriate, an error message is posted.
3245 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3246 -- set to identify the referenced entity.
3248 procedure Process_Extended_Import_Export_Subprogram_Pragma
3249 (Arg_Internal
: Node_Id
;
3250 Arg_External
: Node_Id
;
3251 Arg_Parameter_Types
: Node_Id
;
3252 Arg_Result_Type
: Node_Id
:= Empty
;
3253 Arg_Mechanism
: Node_Id
;
3254 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3255 -- Common processing for all extended Import and Export pragmas applying
3256 -- to subprograms. The caller omits any arguments that do not apply to
3257 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3258 -- only in the Import_Function and Export_Function cases). The argument
3259 -- names correspond to the allowed pragma association identifiers.
3261 procedure Process_Generic_List
;
3262 -- Common processing for Share_Generic and Inline_Generic
3264 procedure Process_Import_Or_Interface
;
3265 -- Common processing for Import of Interface
3267 procedure Process_Import_Predefined_Type
;
3268 -- Processing for completing a type with pragma Import. This is used
3269 -- to declare types that match predefined C types, especially for cases
3270 -- without corresponding Ada predefined type.
3272 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3273 -- Inline status of a subprogram, indicated as follows:
3274 -- Suppressed: inlining is suppressed for the subprogram
3275 -- Disabled: no inlining is requested for the subprogram
3276 -- Enabled: inlining is requested/required for the subprogram
3278 procedure Process_Inline
(Status
: Inline_Status
);
3279 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3280 -- indicates the inline status specified by the pragma.
3282 procedure Process_Interface_Name
3283 (Subprogram_Def
: Entity_Id
;
3285 Link_Arg
: Node_Id
);
3286 -- Given the last two arguments of pragma Import, pragma Export, or
3287 -- pragma Interface_Name, performs validity checks and sets the
3288 -- Interface_Name field of the given subprogram entity to the
3289 -- appropriate external or link name, depending on the arguments given.
3290 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3291 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3292 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3293 -- nor Link_Arg is present, the interface name is set to the default
3294 -- from the subprogram name.
3296 procedure Process_Interrupt_Or_Attach_Handler
;
3297 -- Common processing for Interrupt and Attach_Handler pragmas
3299 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3300 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3301 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3302 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3303 -- is not set in the Restrictions case.
3305 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3306 -- Common processing for Suppress and Unsuppress. The boolean parameter
3307 -- Suppress_Case is True for the Suppress case, and False for the
3310 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3311 -- This procedure sets the Is_Exported flag for the given entity,
3312 -- checking that the entity was not previously imported. Arg is
3313 -- the argument that specified the entity. A check is also made
3314 -- for exporting inappropriate entities.
3316 procedure Set_Extended_Import_Export_External_Name
3317 (Internal_Ent
: Entity_Id
;
3318 Arg_External
: Node_Id
);
3319 -- Common processing for all extended import export pragmas. The first
3320 -- argument, Internal_Ent, is the internal entity, which has already
3321 -- been checked for validity by the caller. Arg_External is from the
3322 -- Import or Export pragma, and may be null if no External parameter
3323 -- was present. If Arg_External is present and is a non-null string
3324 -- (a null string is treated as the default), then the Interface_Name
3325 -- field of Internal_Ent is set appropriately.
3327 procedure Set_Imported
(E
: Entity_Id
);
3328 -- This procedure sets the Is_Imported flag for the given entity,
3329 -- checking that it is not previously exported or imported.
3331 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3332 -- Mech is a parameter passing mechanism (see Import_Function syntax
3333 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3334 -- has the right form, and if not issues an error message. If the
3335 -- argument has the right form then the Mechanism field of Ent is
3336 -- set appropriately.
3338 procedure Set_Rational_Profile
;
3339 -- Activate the set of configuration pragmas and permissions that make
3340 -- up the Rational profile.
3342 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3343 -- Activate the set of configuration pragmas and restrictions that make
3344 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3345 -- is used for error messages on any constructs violating the profile.
3347 ----------------------------------
3348 -- Acquire_Warning_Match_String --
3349 ----------------------------------
3351 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3353 String_To_Name_Buffer
3354 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3356 -- Add asterisk at start if not already there
3358 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3359 Name_Buffer
(2 .. Name_Len
+ 1) :=
3360 Name_Buffer
(1 .. Name_Len
);
3361 Name_Buffer
(1) := '*';
3362 Name_Len
:= Name_Len
+ 1;
3365 -- Add asterisk at end if not already there
3367 if Name_Buffer
(Name_Len
) /= '*' then
3368 Name_Len
:= Name_Len
+ 1;
3369 Name_Buffer
(Name_Len
) := '*';
3371 end Acquire_Warning_Match_String
;
3373 ---------------------
3374 -- Ada_2005_Pragma --
3375 ---------------------
3377 procedure Ada_2005_Pragma
is
3379 if Ada_Version
<= Ada_95
then
3380 Check_Restriction
(No_Implementation_Pragmas
, N
);
3382 end Ada_2005_Pragma
;
3384 ---------------------
3385 -- Ada_2012_Pragma --
3386 ---------------------
3388 procedure Ada_2012_Pragma
is
3390 if Ada_Version
<= Ada_2005
then
3391 Check_Restriction
(No_Implementation_Pragmas
, N
);
3393 end Ada_2012_Pragma
;
3395 ---------------------
3396 -- Analyze_Part_Of --
3397 ---------------------
3399 procedure Analyze_Part_Of
3400 (Item_Id
: Entity_Id
;
3403 Legal
: out Boolean)
3405 Pack_Id
: Entity_Id
;
3406 Placement
: State_Space_Kind
;
3407 Parent_Unit
: Entity_Id
;
3408 State_Id
: Entity_Id
;
3411 -- Assume that the pragma/option is illegal
3415 if Nkind_In
(State
, N_Expanded_Name
,
3417 N_Selected_Component
)
3420 Resolve_State
(State
);
3422 if Is_Entity_Name
(State
)
3423 and then Ekind
(Entity
(State
)) = E_Abstract_State
3425 State_Id
:= Entity
(State
);
3429 ("indicator Part_Of must denote an abstract state", State
);
3433 -- This is a syntax error, always report
3437 ("indicator Part_Of must denote an abstract state", State
);
3441 -- Determine where the state, variable or the package instantiation
3442 -- lives with respect to the enclosing packages or package bodies (if
3443 -- any). This placement dictates the legality of the encapsulating
3446 Find_Placement_In_State_Space
3447 (Item_Id
=> Item_Id
,
3448 Placement
=> Placement
,
3449 Pack_Id
=> Pack_Id
);
3451 -- The item appears in a non-package construct with a declarative
3452 -- part (subprogram, block, etc). As such, the item is not allowed
3453 -- to be a part of an encapsulating state because the item is not
3456 if Placement
= Not_In_Package
then
3458 ("indicator Part_Of cannot appear in this context "
3459 & "(SPARK RM 7.2.6(5))", Indic
);
3460 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3462 ("\& is not part of the hidden state of package %",
3465 -- The item appears in the visible state space of some package. In
3466 -- general this scenario does not warrant Part_Of except when the
3467 -- package is a private child unit and the encapsulating state is
3468 -- declared in a parent unit or a public descendant of that parent
3471 elsif Placement
= Visible_State_Space
then
3472 if Is_Child_Unit
(Pack_Id
)
3473 and then Is_Private_Descendant
(Pack_Id
)
3475 -- A variable or state abstraction which is part of the
3476 -- visible state of a private child unit (or one of its public
3477 -- descendants) must have its Part_Of indicator specified. The
3478 -- Part_Of indicator must denote a state abstraction declared
3479 -- by either the parent unit of the private unit or by a public
3480 -- descendant of that parent unit.
3482 -- Find nearest private ancestor (which can be the current unit
3485 Parent_Unit
:= Pack_Id
;
3486 while Present
(Parent_Unit
) loop
3487 exit when Private_Present
3488 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3489 Parent_Unit
:= Scope
(Parent_Unit
);
3492 Parent_Unit
:= Scope
(Parent_Unit
);
3494 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3496 ("indicator Part_Of must denote an abstract state of& "
3497 & "or public descendant (SPARK RM 7.2.6(3))",
3498 Indic
, Parent_Unit
);
3500 elsif Scope
(State_Id
) = Parent_Unit
3501 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3503 not Is_Private_Descendant
(Scope
(State_Id
)))
3509 ("indicator Part_Of must denote an abstract state of& "
3510 & "or public descendant (SPARK RM 7.2.6(3))",
3511 Indic
, Parent_Unit
);
3514 -- Indicator Part_Of is not needed when the related package is not
3515 -- a private child unit or a public descendant thereof.
3519 ("indicator Part_Of cannot appear in this context "
3520 & "(SPARK RM 7.2.6(5))", Indic
);
3521 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3523 ("\& is declared in the visible part of package %",
3527 -- When the item appears in the private state space of a package, the
3528 -- encapsulating state must be declared in the same package.
3530 elsif Placement
= Private_State_Space
then
3531 if Scope
(State_Id
) /= Pack_Id
then
3533 ("indicator Part_Of must designate an abstract state of "
3534 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3535 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3537 ("\& is declared in the private part of package %",
3541 -- Items declared in the body state space of a package do not need
3542 -- Part_Of indicators as the refinement has already been seen.
3546 ("indicator Part_Of cannot appear in this context "
3547 & "(SPARK RM 7.2.6(5))", Indic
);
3549 if Scope
(State_Id
) = Pack_Id
then
3550 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3552 ("\& is declared in the body of package %", Indic
, Item_Id
);
3557 end Analyze_Part_Of
;
3559 ----------------------------
3560 -- Analyze_Refined_Pragma --
3561 ----------------------------
3563 procedure Analyze_Refined_Pragma
3564 (Spec_Id
: out Entity_Id
;
3565 Body_Id
: out Entity_Id
;
3566 Legal
: out Boolean)
3568 Body_Decl
: Node_Id
;
3569 Spec_Decl
: Node_Id
;
3572 -- Assume that the pragma is illegal
3579 Check_Arg_Count
(1);
3580 Check_No_Identifiers
;
3582 if Nam_In
(Pname
, Name_Refined_Depends
,
3583 Name_Refined_Global
,
3586 Ensure_Aggregate_Form
(Arg1
);
3589 -- Verify the placement of the pragma and check for duplicates. The
3590 -- pragma must apply to a subprogram body [stub].
3592 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3594 -- Extract the entities of the spec and body
3596 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3597 Body_Id
:= Defining_Entity
(Body_Decl
);
3598 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3600 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3601 Body_Id
:= Defining_Entity
(Body_Decl
);
3602 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3609 -- The pragma must apply to the second declaration of a subprogram.
3610 -- In other words, the body [stub] cannot acts as a spec.
3612 if No
(Spec_Id
) then
3613 Error_Pragma
("pragma % cannot apply to a stand alone body");
3616 -- Catch the case where the subprogram body is a subunit and acts as
3617 -- the third declaration of the subprogram.
3619 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3620 Error_Pragma
("pragma % cannot apply to a subunit");
3624 -- The pragma can only apply to the body [stub] of a subprogram
3625 -- declared in the visible part of a package. Retrieve the context of
3626 -- the subprogram declaration.
3628 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3630 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3632 ("pragma % must apply to the body of a subprogram declared in a "
3633 & "package specification");
3637 -- If we get here, then the pragma is legal
3640 end Analyze_Refined_Pragma
;
3642 --------------------------
3643 -- Check_Ada_83_Warning --
3644 --------------------------
3646 procedure Check_Ada_83_Warning
is
3648 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3649 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3651 end Check_Ada_83_Warning
;
3653 ---------------------
3654 -- Check_Arg_Count --
3655 ---------------------
3657 procedure Check_Arg_Count
(Required
: Nat
) is
3659 if Arg_Count
/= Required
then
3660 Error_Pragma
("wrong number of arguments for pragma%");
3662 end Check_Arg_Count
;
3664 --------------------------------
3665 -- Check_Arg_Is_External_Name --
3666 --------------------------------
3668 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3669 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3672 if Nkind
(Argx
) = N_Identifier
then
3676 Analyze_And_Resolve
(Argx
, Standard_String
);
3678 if Is_OK_Static_Expression
(Argx
) then
3681 elsif Etype
(Argx
) = Any_Type
then
3684 -- An interesting special case, if we have a string literal and
3685 -- we are in Ada 83 mode, then we allow it even though it will
3686 -- not be flagged as static. This allows expected Ada 83 mode
3687 -- use of external names which are string literals, even though
3688 -- technically these are not static in Ada 83.
3690 elsif Ada_Version
= Ada_83
3691 and then Nkind
(Argx
) = N_String_Literal
3695 -- Static expression that raises Constraint_Error. This has
3696 -- already been flagged, so just exit from pragma processing.
3698 elsif Is_OK_Static_Expression
(Argx
) then
3701 -- Here we have a real error (non-static expression)
3704 Error_Msg_Name_1
:= Pname
;
3707 Msg
: constant String :=
3708 "argument for pragma% must be a identifier or "
3709 & "static string expression!";
3711 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3716 end Check_Arg_Is_External_Name
;
3718 -----------------------------
3719 -- Check_Arg_Is_Identifier --
3720 -----------------------------
3722 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3723 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3725 if Nkind
(Argx
) /= N_Identifier
then
3727 ("argument for pragma% must be identifier", Argx
);
3729 end Check_Arg_Is_Identifier
;
3731 ----------------------------------
3732 -- Check_Arg_Is_Integer_Literal --
3733 ----------------------------------
3735 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3736 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3738 if Nkind
(Argx
) /= N_Integer_Literal
then
3740 ("argument for pragma% must be integer literal", Argx
);
3742 end Check_Arg_Is_Integer_Literal
;
3744 -------------------------------------------
3745 -- Check_Arg_Is_Library_Level_Local_Name --
3746 -------------------------------------------
3750 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3751 -- | library_unit_NAME
3753 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3755 Check_Arg_Is_Local_Name
(Arg
);
3757 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3758 and then Comes_From_Source
(N
)
3761 ("argument for pragma% must be library level entity", Arg
);
3763 end Check_Arg_Is_Library_Level_Local_Name
;
3765 -----------------------------
3766 -- Check_Arg_Is_Local_Name --
3767 -----------------------------
3771 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3772 -- | library_unit_NAME
3774 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3775 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3780 if Nkind
(Argx
) not in N_Direct_Name
3781 and then (Nkind
(Argx
) /= N_Attribute_Reference
3782 or else Present
(Expressions
(Argx
))
3783 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3784 and then (not Is_Entity_Name
(Argx
)
3785 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3787 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3790 -- No further check required if not an entity name
3792 if not Is_Entity_Name
(Argx
) then
3798 Ent
: constant Entity_Id
:= Entity
(Argx
);
3799 Scop
: constant Entity_Id
:= Scope
(Ent
);
3802 -- Case of a pragma applied to a compilation unit: pragma must
3803 -- occur immediately after the program unit in the compilation.
3805 if Is_Compilation_Unit
(Ent
) then
3807 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3810 -- Case of pragma placed immediately after spec
3812 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3815 -- Case of pragma placed immediately after body
3817 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3818 and then Present
(Corresponding_Body
(Decl
))
3822 (Parent
(Unit_Declaration_Node
3823 (Corresponding_Body
(Decl
))));
3825 -- All other cases are illegal
3832 -- Special restricted placement rule from 10.2.1(11.8/2)
3834 elsif Is_Generic_Formal
(Ent
)
3835 and then Prag_Id
= Pragma_Preelaborable_Initialization
3837 OK
:= List_Containing
(N
) =
3838 Generic_Formal_Declarations
3839 (Unit_Declaration_Node
(Scop
));
3841 -- If this is an aspect applied to a subprogram body, the
3842 -- pragma is inserted in its declarative part.
3844 elsif From_Aspect_Specification
(N
)
3845 and then Ent
= Current_Scope
3847 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3851 -- If the aspect is a predicate (possibly others ???) and the
3852 -- context is a record type, this is a discriminant expression
3853 -- within a type declaration, that freezes the predicated
3856 elsif From_Aspect_Specification
(N
)
3857 and then Prag_Id
= Pragma_Predicate
3858 and then Ekind
(Current_Scope
) = E_Record_Type
3859 and then Scop
= Scope
(Current_Scope
)
3863 -- Default case, just check that the pragma occurs in the scope
3864 -- of the entity denoted by the name.
3867 OK
:= Current_Scope
= Scop
;
3872 ("pragma% argument must be in same declarative part", Arg
);
3876 end Check_Arg_Is_Local_Name
;
3878 ---------------------------------
3879 -- Check_Arg_Is_Locking_Policy --
3880 ---------------------------------
3882 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3883 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3886 Check_Arg_Is_Identifier
(Argx
);
3888 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3889 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3891 end Check_Arg_Is_Locking_Policy
;
3893 -----------------------------------------------
3894 -- Check_Arg_Is_Partition_Elaboration_Policy --
3895 -----------------------------------------------
3897 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3898 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3901 Check_Arg_Is_Identifier
(Argx
);
3903 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3905 ("& is not a valid partition elaboration policy name", Argx
);
3907 end Check_Arg_Is_Partition_Elaboration_Policy
;
3909 -------------------------
3910 -- Check_Arg_Is_One_Of --
3911 -------------------------
3913 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3914 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3917 Check_Arg_Is_Identifier
(Argx
);
3919 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3920 Error_Msg_Name_2
:= N1
;
3921 Error_Msg_Name_3
:= N2
;
3922 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3924 end Check_Arg_Is_One_Of
;
3926 procedure Check_Arg_Is_One_Of
3928 N1
, N2
, N3
: Name_Id
)
3930 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3933 Check_Arg_Is_Identifier
(Argx
);
3935 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3936 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3938 end Check_Arg_Is_One_Of
;
3940 procedure Check_Arg_Is_One_Of
3942 N1
, N2
, N3
, N4
: Name_Id
)
3944 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3947 Check_Arg_Is_Identifier
(Argx
);
3949 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3950 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3952 end Check_Arg_Is_One_Of
;
3954 procedure Check_Arg_Is_One_Of
3956 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3958 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3961 Check_Arg_Is_Identifier
(Argx
);
3963 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3964 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3966 end Check_Arg_Is_One_Of
;
3968 ---------------------------------
3969 -- Check_Arg_Is_Queuing_Policy --
3970 ---------------------------------
3972 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3973 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3976 Check_Arg_Is_Identifier
(Argx
);
3978 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3979 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3981 end Check_Arg_Is_Queuing_Policy
;
3983 ---------------------------------------
3984 -- Check_Arg_Is_OK_Static_Expression --
3985 ---------------------------------------
3987 procedure Check_Arg_Is_OK_Static_Expression
3989 Typ
: Entity_Id
:= Empty
)
3992 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
3993 end Check_Arg_Is_OK_Static_Expression
;
3995 ------------------------------------------
3996 -- Check_Arg_Is_Task_Dispatching_Policy --
3997 ------------------------------------------
3999 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4000 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4003 Check_Arg_Is_Identifier
(Argx
);
4005 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4007 ("& is not an allowed task dispatching policy name", Argx
);
4009 end Check_Arg_Is_Task_Dispatching_Policy
;
4011 ---------------------
4012 -- Check_Arg_Order --
4013 ---------------------
4015 procedure Check_Arg_Order
(Names
: Name_List
) is
4018 Highest_So_Far
: Natural := 0;
4019 -- Highest index in Names seen do far
4023 for J
in 1 .. Arg_Count
loop
4024 if Chars
(Arg
) /= No_Name
then
4025 for K
in Names
'Range loop
4026 if Chars
(Arg
) = Names
(K
) then
4027 if K
< Highest_So_Far
then
4028 Error_Msg_Name_1
:= Pname
;
4030 ("parameters out of order for pragma%", Arg
);
4031 Error_Msg_Name_1
:= Names
(K
);
4032 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4033 Error_Msg_N
("\% must appear before %", Arg
);
4037 Highest_So_Far
:= K
;
4045 end Check_Arg_Order
;
4047 --------------------------------
4048 -- Check_At_Least_N_Arguments --
4049 --------------------------------
4051 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4053 if Arg_Count
< N
then
4054 Error_Pragma
("too few arguments for pragma%");
4056 end Check_At_Least_N_Arguments
;
4058 -------------------------------
4059 -- Check_At_Most_N_Arguments --
4060 -------------------------------
4062 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4065 if Arg_Count
> N
then
4067 for J
in 1 .. N
loop
4069 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4072 end Check_At_Most_N_Arguments
;
4074 ---------------------
4075 -- Check_Component --
4076 ---------------------
4078 procedure Check_Component
4081 In_Variant_Part
: Boolean := False)
4083 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4084 Sindic
: constant Node_Id
:=
4085 Subtype_Indication
(Component_Definition
(Comp
));
4086 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4089 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4090 -- object constraint, then the component type shall be an Unchecked_
4093 if Nkind
(Sindic
) = N_Subtype_Indication
4094 and then Has_Per_Object_Constraint
(Comp_Id
)
4095 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4098 ("component subtype subject to per-object constraint "
4099 & "must be an Unchecked_Union", Comp
);
4101 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4102 -- the body of a generic unit, or within the body of any of its
4103 -- descendant library units, no part of the type of a component
4104 -- declared in a variant_part of the unchecked union type shall be of
4105 -- a formal private type or formal private extension declared within
4106 -- the formal part of the generic unit.
4108 elsif Ada_Version
>= Ada_2012
4109 and then In_Generic_Body
(UU_Typ
)
4110 and then In_Variant_Part
4111 and then Is_Private_Type
(Typ
)
4112 and then Is_Generic_Type
(Typ
)
4115 ("component of unchecked union cannot be of generic type", Comp
);
4117 elsif Needs_Finalization
(Typ
) then
4119 ("component of unchecked union cannot be controlled", Comp
);
4121 elsif Has_Task
(Typ
) then
4123 ("component of unchecked union cannot have tasks", Comp
);
4125 end Check_Component
;
4127 -----------------------------
4128 -- Check_Declaration_Order --
4129 -----------------------------
4131 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4132 procedure Check_Aspect_Specification_Order
;
4133 -- Inspect the aspect specifications of the context to determine the
4136 --------------------------------------
4137 -- Check_Aspect_Specification_Order --
4138 --------------------------------------
4140 procedure Check_Aspect_Specification_Order
is
4141 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4142 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4146 -- Both aspects must be part of the same aspect specification list
4149 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4151 -- Try to reach Second starting from First in a left to right
4152 -- traversal of the aspect specifications.
4154 Asp
:= Next
(Asp_First
);
4155 while Present
(Asp
) loop
4157 -- The order is ok, First is followed by Second
4159 if Asp
= Asp_Second
then
4166 -- If we get here, then the aspects are out of order
4168 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4169 end Check_Aspect_Specification_Order
;
4175 -- Start of processing for Check_Declaration_Order
4178 -- Cannot check the order if one of the pragmas is missing
4180 if No
(First
) or else No
(Second
) then
4184 -- Set up the error names in case the order is incorrect
4186 Error_Msg_Name_1
:= Pragma_Name
(First
);
4187 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4189 if From_Aspect_Specification
(First
) then
4191 -- Both pragmas are actually aspects, check their declaration
4192 -- order in the associated aspect specification list. Otherwise
4193 -- First is an aspect and Second a source pragma.
4195 if From_Aspect_Specification
(Second
) then
4196 Check_Aspect_Specification_Order
;
4199 -- Abstract_States is a source pragma
4202 if From_Aspect_Specification
(Second
) then
4203 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4205 -- Both pragmas are source constructs. Try to reach First from
4206 -- Second by traversing the declarations backwards.
4209 Stmt
:= Prev
(Second
);
4210 while Present
(Stmt
) loop
4212 -- The order is ok, First is followed by Second
4214 if Stmt
= First
then
4221 -- If we get here, then the pragmas are out of order
4223 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4226 end Check_Declaration_Order
;
4228 ----------------------------
4229 -- Check_Duplicate_Pragma --
4230 ----------------------------
4232 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4233 Id
: Entity_Id
:= E
;
4237 -- Nothing to do if this pragma comes from an aspect specification,
4238 -- since we could not be duplicating a pragma, and we dealt with the
4239 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4241 if From_Aspect_Specification
(N
) then
4245 -- Otherwise current pragma may duplicate previous pragma or a
4246 -- previously given aspect specification or attribute definition
4247 -- clause for the same pragma.
4249 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4253 -- If the entity is a type, then we have to make sure that the
4254 -- ostensible duplicate is not for a parent type from which this
4258 if Nkind
(P
) = N_Pragma
then
4260 Args
: constant List_Id
:=
4261 Pragma_Argument_Associations
(P
);
4264 and then Is_Entity_Name
(Expression
(First
(Args
)))
4265 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4266 and then Entity
(Expression
(First
(Args
))) /= E
4272 elsif Nkind
(P
) = N_Aspect_Specification
4273 and then Is_Type
(Entity
(P
))
4274 and then Entity
(P
) /= E
4280 -- Here we have a definite duplicate
4282 Error_Msg_Name_1
:= Pragma_Name
(N
);
4283 Error_Msg_Sloc
:= Sloc
(P
);
4285 -- For a single protected or a single task object, the error is
4286 -- issued on the original entity.
4288 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4289 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4292 if Nkind
(P
) = N_Aspect_Specification
4293 or else From_Aspect_Specification
(P
)
4295 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4297 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4302 end Check_Duplicate_Pragma
;
4304 ----------------------------------
4305 -- Check_Duplicated_Export_Name --
4306 ----------------------------------
4308 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4309 String_Val
: constant String_Id
:= Strval
(Nam
);
4312 -- We are only interested in the export case, and in the case of
4313 -- generics, it is the instance, not the template, that is the
4314 -- problem (the template will generate a warning in any case).
4316 if not Inside_A_Generic
4317 and then (Prag_Id
= Pragma_Export
4319 Prag_Id
= Pragma_Export_Procedure
4321 Prag_Id
= Pragma_Export_Valued_Procedure
4323 Prag_Id
= Pragma_Export_Function
)
4325 for J
in Externals
.First
.. Externals
.Last
loop
4326 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4327 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4328 Error_Msg_N
("external name duplicates name given#", Nam
);
4333 Externals
.Append
(Nam
);
4335 end Check_Duplicated_Export_Name
;
4337 ----------------------------------------
4338 -- Check_Expr_Is_OK_Static_Expression --
4339 ----------------------------------------
4341 procedure Check_Expr_Is_OK_Static_Expression
4343 Typ
: Entity_Id
:= Empty
)
4346 if Present
(Typ
) then
4347 Analyze_And_Resolve
(Expr
, Typ
);
4349 Analyze_And_Resolve
(Expr
);
4352 if Is_OK_Static_Expression
(Expr
) then
4355 elsif Etype
(Expr
) = Any_Type
then
4358 -- An interesting special case, if we have a string literal and we
4359 -- are in Ada 83 mode, then we allow it even though it will not be
4360 -- flagged as static. This allows the use of Ada 95 pragmas like
4361 -- Import in Ada 83 mode. They will of course be flagged with
4362 -- warnings as usual, but will not cause errors.
4364 elsif Ada_Version
= Ada_83
4365 and then Nkind
(Expr
) = N_String_Literal
4369 -- Static expression that raises Constraint_Error. This has already
4370 -- been flagged, so just exit from pragma processing.
4372 elsif Is_OK_Static_Expression
(Expr
) then
4375 -- Finally, we have a real error
4378 Error_Msg_Name_1
:= Pname
;
4379 Flag_Non_Static_Expr
4380 (Fix_Error
("argument for pragma% must be a static expression!"),
4384 end Check_Expr_Is_OK_Static_Expression
;
4386 -------------------------
4387 -- Check_First_Subtype --
4388 -------------------------
4390 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4391 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4392 Ent
: constant Entity_Id
:= Entity
(Argx
);
4395 if Is_First_Subtype
(Ent
) then
4398 elsif Is_Type
(Ent
) then
4400 ("pragma% cannot apply to subtype", Argx
);
4402 elsif Is_Object
(Ent
) then
4404 ("pragma% cannot apply to object, requires a type", Argx
);
4408 ("pragma% cannot apply to&, requires a type", Argx
);
4410 end Check_First_Subtype
;
4412 ----------------------
4413 -- Check_Identifier --
4414 ----------------------
4416 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4419 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4421 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4422 Error_Msg_Name_1
:= Pname
;
4423 Error_Msg_Name_2
:= Id
;
4424 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4428 end Check_Identifier
;
4430 --------------------------------
4431 -- Check_Identifier_Is_One_Of --
4432 --------------------------------
4434 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4437 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4439 if Chars
(Arg
) = No_Name
then
4440 Error_Msg_Name_1
:= Pname
;
4441 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4444 elsif Chars
(Arg
) /= N1
4445 and then Chars
(Arg
) /= N2
4447 Error_Msg_Name_1
:= Pname
;
4448 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4452 end Check_Identifier_Is_One_Of
;
4454 ---------------------------
4455 -- Check_In_Main_Program --
4456 ---------------------------
4458 procedure Check_In_Main_Program
is
4459 P
: constant Node_Id
:= Parent
(N
);
4462 -- Must be at in subprogram body
4464 if Nkind
(P
) /= N_Subprogram_Body
then
4465 Error_Pragma
("% pragma allowed only in subprogram");
4467 -- Otherwise warn if obviously not main program
4469 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4470 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4472 Error_Msg_Name_1
:= Pname
;
4474 ("??pragma% is only effective in main program", N
);
4476 end Check_In_Main_Program
;
4478 ---------------------------------------
4479 -- Check_Interrupt_Or_Attach_Handler --
4480 ---------------------------------------
4482 procedure Check_Interrupt_Or_Attach_Handler
is
4483 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4484 Handler_Proc
, Proc_Scope
: Entity_Id
;
4489 if Prag_Id
= Pragma_Interrupt_Handler
then
4490 Check_Restriction
(No_Dynamic_Attachment
, N
);
4493 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4494 Proc_Scope
:= Scope
(Handler_Proc
);
4496 -- On AAMP only, a pragma Interrupt_Handler is supported for
4497 -- nonprotected parameterless procedures.
4499 if not AAMP_On_Target
4500 or else Prag_Id
= Pragma_Attach_Handler
4502 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4504 ("argument of pragma% must be protected procedure", Arg1
);
4507 -- For pragma case (as opposed to access case), check placement.
4508 -- We don't need to do that for aspects, because we have the
4509 -- check that they aspect applies an appropriate procedure.
4511 if not From_Aspect_Specification
(N
)
4512 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4514 Error_Pragma
("pragma% must be in protected definition");
4518 if not Is_Library_Level_Entity
(Proc_Scope
)
4519 or else (AAMP_On_Target
4520 and then not Is_Library_Level_Entity
(Handler_Proc
))
4523 ("argument for pragma% must be library level entity", Arg1
);
4526 -- AI05-0033: A pragma cannot appear within a generic body, because
4527 -- instance can be in a nested scope. The check that protected type
4528 -- is itself a library-level declaration is done elsewhere.
4530 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4531 -- handle code prior to AI-0033. Analysis tools typically are not
4532 -- interested in this pragma in any case, so no need to worry too
4533 -- much about its placement.
4535 if Inside_A_Generic
then
4536 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4537 and then In_Package_Body
(Scope
(Current_Scope
))
4538 and then not Relaxed_RM_Semantics
4540 Error_Pragma
("pragma% cannot be used inside a generic");
4543 end Check_Interrupt_Or_Attach_Handler
;
4545 ---------------------------------
4546 -- Check_Loop_Pragma_Placement --
4547 ---------------------------------
4549 procedure Check_Loop_Pragma_Placement
is
4550 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4551 -- Verify whether the current pragma is properly grouped with other
4552 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4553 -- related loop where the pragma appears.
4555 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4556 -- Determine whether an arbitrary statement Stmt denotes pragma
4557 -- Loop_Invariant or Loop_Variant.
4559 procedure Placement_Error
(Constr
: Node_Id
);
4560 pragma No_Return
(Placement_Error
);
4561 -- Node Constr denotes the last loop restricted construct before we
4562 -- encountered an illegal relation between enclosing constructs. Emit
4563 -- an error depending on what Constr was.
4565 --------------------------------
4566 -- Check_Loop_Pragma_Grouping --
4567 --------------------------------
4569 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4570 Stop_Search
: exception;
4571 -- This exception is used to terminate the recursive descent of
4572 -- routine Check_Grouping.
4574 procedure Check_Grouping
(L
: List_Id
);
4575 -- Find the first group of pragmas in list L and if successful,
4576 -- ensure that the current pragma is part of that group. The
4577 -- routine raises Stop_Search once such a check is performed to
4578 -- halt the recursive descent.
4580 procedure Grouping_Error
(Prag
: Node_Id
);
4581 pragma No_Return
(Grouping_Error
);
4582 -- Emit an error concerning the current pragma indicating that it
4583 -- should be placed after pragma Prag.
4585 --------------------
4586 -- Check_Grouping --
4587 --------------------
4589 procedure Check_Grouping
(L
: List_Id
) is
4595 -- Inspect the list of declarations or statements looking for
4596 -- the first grouping of pragmas:
4599 -- pragma Loop_Invariant ...;
4600 -- pragma Loop_Variant ...;
4602 -- pragma Loop_Variant ...; -- current pragma
4604 -- If the current pragma is not in the grouping, then it must
4605 -- either appear in a different declarative or statement list
4606 -- or the construct at (1) is separating the pragma from the
4610 while Present
(Stmt
) loop
4612 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4613 -- inside a loop or a block housed inside a loop. Inspect
4614 -- the declarations and statements of the block as they may
4615 -- contain the first grouping.
4617 if Nkind
(Stmt
) = N_Block_Statement
then
4618 HSS
:= Handled_Statement_Sequence
(Stmt
);
4620 Check_Grouping
(Declarations
(Stmt
));
4622 if Present
(HSS
) then
4623 Check_Grouping
(Statements
(HSS
));
4626 -- First pragma of the first topmost grouping has been found
4628 elsif Is_Loop_Pragma
(Stmt
) then
4630 -- The group and the current pragma are not in the same
4631 -- declarative or statement list.
4633 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4634 Grouping_Error
(Stmt
);
4636 -- Try to reach the current pragma from the first pragma
4637 -- of the grouping while skipping other members:
4639 -- pragma Loop_Invariant ...; -- first pragma
4640 -- pragma Loop_Variant ...; -- member
4642 -- pragma Loop_Variant ...; -- current pragma
4645 while Present
(Stmt
) loop
4647 -- The current pragma is either the first pragma
4648 -- of the group or is a member of the group. Stop
4649 -- the search as the placement is legal.
4654 -- Skip group members, but keep track of the last
4655 -- pragma in the group.
4657 elsif Is_Loop_Pragma
(Stmt
) then
4660 -- A non-pragma is separating the group from the
4661 -- current pragma, the placement is illegal.
4664 Grouping_Error
(Prag
);
4670 -- If the traversal did not reach the current pragma,
4671 -- then the list must be malformed.
4673 raise Program_Error
;
4681 --------------------
4682 -- Grouping_Error --
4683 --------------------
4685 procedure Grouping_Error
(Prag
: Node_Id
) is
4687 Error_Msg_Sloc
:= Sloc
(Prag
);
4688 Error_Pragma
("pragma% must appear next to pragma#");
4691 -- Start of processing for Check_Loop_Pragma_Grouping
4694 -- Inspect the statements of the loop or nested blocks housed
4695 -- within to determine whether the current pragma is part of the
4696 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4698 Check_Grouping
(Statements
(Loop_Stmt
));
4701 when Stop_Search
=> null;
4702 end Check_Loop_Pragma_Grouping
;
4704 --------------------
4705 -- Is_Loop_Pragma --
4706 --------------------
4708 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4710 -- Inspect the original node as Loop_Invariant and Loop_Variant
4711 -- pragmas are rewritten to null when assertions are disabled.
4713 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4715 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4716 Name_Loop_Invariant
,
4723 ---------------------
4724 -- Placement_Error --
4725 ---------------------
4727 procedure Placement_Error
(Constr
: Node_Id
) is
4728 LA
: constant String := " with Loop_Entry";
4731 if Prag_Id
= Pragma_Assert
then
4732 Error_Msg_String
(1 .. LA
'Length) := LA
;
4733 Error_Msg_Strlen
:= LA
'Length;
4735 Error_Msg_Strlen
:= 0;
4738 if Nkind
(Constr
) = N_Pragma
then
4740 ("pragma %~ must appear immediately within the statements "
4744 ("block containing pragma %~ must appear immediately within "
4745 & "the statements of a loop", Constr
);
4747 end Placement_Error
;
4749 -- Local declarations
4754 -- Start of processing for Check_Loop_Pragma_Placement
4757 -- Check that pragma appears immediately within a loop statement,
4758 -- ignoring intervening block statements.
4762 while Present
(Stmt
) loop
4764 -- The pragma or previous block must appear immediately within the
4765 -- current block's declarative or statement part.
4767 if Nkind
(Stmt
) = N_Block_Statement
then
4768 if (No
(Declarations
(Stmt
))
4769 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4771 List_Containing
(Prev
) /=
4772 Statements
(Handled_Statement_Sequence
(Stmt
))
4774 Placement_Error
(Prev
);
4777 -- Keep inspecting the parents because we are now within a
4778 -- chain of nested blocks.
4782 Stmt
:= Parent
(Stmt
);
4785 -- The pragma or previous block must appear immediately within the
4786 -- statements of the loop.
4788 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4789 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4790 Placement_Error
(Prev
);
4793 -- Stop the traversal because we reached the innermost loop
4794 -- regardless of whether we encountered an error or not.
4798 -- Ignore a handled statement sequence. Note that this node may
4799 -- be related to a subprogram body in which case we will emit an
4800 -- error on the next iteration of the search.
4802 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4803 Stmt
:= Parent
(Stmt
);
4805 -- Any other statement breaks the chain from the pragma to the
4809 Placement_Error
(Prev
);
4814 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4815 -- grouped together with other such pragmas.
4817 if Is_Loop_Pragma
(N
) then
4819 -- The previous check should have located the related loop
4821 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4822 Check_Loop_Pragma_Grouping
(Stmt
);
4824 end Check_Loop_Pragma_Placement
;
4826 -------------------------------------------
4827 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4828 -------------------------------------------
4830 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4839 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4842 elsif Nkind_In
(P
, N_Package_Specification
,
4847 -- Note: the following tests seem a little peculiar, because
4848 -- they test for bodies, but if we were in the statement part
4849 -- of the body, we would already have hit the handled statement
4850 -- sequence, so the only way we get here is by being in the
4851 -- declarative part of the body.
4853 elsif Nkind_In
(P
, N_Subprogram_Body
,
4864 Error_Pragma
("pragma% is not in declarative part or package spec");
4865 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4867 -------------------------
4868 -- Check_No_Identifier --
4869 -------------------------
4871 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4873 if Nkind
(Arg
) = N_Pragma_Argument_Association
4874 and then Chars
(Arg
) /= No_Name
4876 Error_Pragma_Arg_Ident
4877 ("pragma% does not permit identifier& here", Arg
);
4879 end Check_No_Identifier
;
4881 --------------------------
4882 -- Check_No_Identifiers --
4883 --------------------------
4885 procedure Check_No_Identifiers
is
4889 for J
in 1 .. Arg_Count
loop
4890 Check_No_Identifier
(Arg_Node
);
4893 end Check_No_Identifiers
;
4895 ------------------------
4896 -- Check_No_Link_Name --
4897 ------------------------
4899 procedure Check_No_Link_Name
is
4901 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4905 if Present
(Arg4
) then
4907 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4909 end Check_No_Link_Name
;
4911 -------------------------------
4912 -- Check_Optional_Identifier --
4913 -------------------------------
4915 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4918 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4919 and then Chars
(Arg
) /= No_Name
4921 if Chars
(Arg
) /= Id
then
4922 Error_Msg_Name_1
:= Pname
;
4923 Error_Msg_Name_2
:= Id
;
4924 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4928 end Check_Optional_Identifier
;
4930 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4932 Name_Buffer
(1 .. Id
'Length) := Id
;
4933 Name_Len
:= Id
'Length;
4934 Check_Optional_Identifier
(Arg
, Name_Find
);
4935 end Check_Optional_Identifier
;
4937 --------------------
4938 -- Check_Pre_Post --
4939 --------------------
4941 procedure Check_Pre_Post
is
4946 if not Is_List_Member
(N
) then
4950 -- If we are within an inlined body, the legality of the pragma
4951 -- has been checked already.
4953 if In_Inlined_Body
then
4957 -- Search prior declarations
4960 while Present
(Prev
(P
)) loop
4963 -- If the previous node is a generic subprogram, do not go to to
4964 -- the original node, which is the unanalyzed tree: we need to
4965 -- attach the pre/postconditions to the analyzed version at this
4966 -- point. They get propagated to the original tree when analyzing
4967 -- the corresponding body.
4969 if Nkind
(P
) not in N_Generic_Declaration
then
4970 PO
:= Original_Node
(P
);
4975 -- Skip past prior pragma
4977 if Nkind
(PO
) = N_Pragma
then
4980 -- Skip stuff not coming from source
4982 elsif not Comes_From_Source
(PO
) then
4984 -- The condition may apply to a subprogram instantiation
4986 if Nkind
(PO
) = N_Subprogram_Declaration
4987 and then Present
(Generic_Parent
(Specification
(PO
)))
4991 elsif Nkind
(PO
) = N_Subprogram_Declaration
4992 and then In_Instance
4996 -- For all other cases of non source code, do nothing
5002 -- Only remaining possibility is subprogram declaration
5009 -- If we fall through loop, pragma is at start of list, so see if it
5010 -- is at the start of declarations of a subprogram body.
5014 if Nkind
(PO
) = N_Subprogram_Body
5015 and then List_Containing
(N
) = Declarations
(PO
)
5017 -- This is only allowed if there is no separate specification
5019 if Present
(Corresponding_Spec
(PO
)) then
5021 ("pragma% must apply to subprogram specification");
5028 --------------------------------------
5029 -- Check_Precondition_Postcondition --
5030 --------------------------------------
5032 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
5036 procedure Chain_PPC
(PO
: Node_Id
);
5037 -- If PO is an entry or a [generic] subprogram declaration node, then
5038 -- the precondition/postcondition applies to this subprogram and the
5039 -- processing for the pragma is completed. Otherwise the pragma is
5046 procedure Chain_PPC
(PO
: Node_Id
) is
5050 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5051 if not From_Aspect_Specification
(N
) then
5053 ("pragma% cannot be applied to abstract subprogram");
5055 elsif Class_Present
(N
) then
5060 ("aspect % requires ''Class for abstract subprogram");
5063 -- AI05-0230: The same restriction applies to null procedures. For
5064 -- compatibility with earlier uses of the Ada pragma, apply this
5065 -- rule only to aspect specifications.
5067 -- The above discrepency needs documentation. Robert is dubious
5068 -- about whether it is a good idea ???
5070 elsif Nkind
(PO
) = N_Subprogram_Declaration
5071 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
5072 and then Null_Present
(Specification
(PO
))
5073 and then From_Aspect_Specification
(N
)
5074 and then not Class_Present
(N
)
5077 ("aspect % requires ''Class for null procedure");
5079 -- Pre/postconditions are legal on a subprogram body if it is not
5080 -- a completion of a declaration. They are also legal on a stub
5081 -- with no previous declarations (this is checked when processing
5082 -- the corresponding aspects).
5084 elsif Nkind
(PO
) = N_Subprogram_Body
5085 and then Acts_As_Spec
(PO
)
5089 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
5092 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5093 N_Expression_Function
,
5094 N_Generic_Subprogram_Declaration
,
5095 N_Entry_Declaration
)
5100 -- Here if we have [generic] subprogram or entry declaration
5102 if Nkind
(PO
) = N_Entry_Declaration
then
5103 S
:= Defining_Entity
(PO
);
5105 S
:= Defining_Unit_Name
(Specification
(PO
));
5107 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5108 S
:= Defining_Identifier
(S
);
5112 -- Note: we do not analyze the pragma at this point. Instead we
5113 -- delay this analysis until the end of the declarative part in
5114 -- which the pragma appears. This implements the required delay
5115 -- in this analysis, allowing forward references. The analysis
5116 -- happens at the end of Analyze_Declarations.
5118 -- Chain spec PPC pragma to list for subprogram
5120 Add_Contract_Item
(N
, S
);
5122 -- Return indicating spec case
5128 -- Start of processing for Check_Precondition_Postcondition
5131 if not Is_List_Member
(N
) then
5135 -- Preanalyze message argument if present. Visibility in this
5136 -- argument is established at the point of pragma occurrence.
5138 if Arg_Count
= 2 then
5139 Check_Optional_Identifier
(Arg2
, Name_Message
);
5140 Preanalyze_Spec_Expression
5141 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5144 -- For a pragma PPC in the extended main source unit, record enabled
5147 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5148 Set_SCO_Pragma_Enabled
(Loc
);
5151 -- If we are within an inlined body, the legality of the pragma
5152 -- has been checked already.
5154 if In_Inlined_Body
then
5159 -- Search prior declarations
5162 while Present
(Prev
(P
)) loop
5165 -- If the previous node is a generic subprogram, do not go to to
5166 -- the original node, which is the unanalyzed tree: we need to
5167 -- attach the pre/postconditions to the analyzed version at this
5168 -- point. They get propagated to the original tree when analyzing
5169 -- the corresponding body.
5171 if Nkind
(P
) not in N_Generic_Declaration
then
5172 PO
:= Original_Node
(P
);
5177 -- Skip past prior pragma
5179 if Nkind
(PO
) = N_Pragma
then
5182 -- Skip stuff not coming from source
5184 elsif not Comes_From_Source
(PO
) then
5186 -- The condition may apply to a subprogram instantiation
5188 if Nkind
(PO
) = N_Subprogram_Declaration
5189 and then Present
(Generic_Parent
(Specification
(PO
)))
5194 elsif Nkind
(PO
) = N_Subprogram_Declaration
5195 and then In_Instance
5200 -- For all other cases of non source code, do nothing
5206 -- Only remaining possibility is subprogram declaration
5214 -- If we fall through loop, pragma is at start of list, so see if it
5215 -- is at the start of declarations of a subprogram body.
5219 if Nkind
(PO
) = N_Subprogram_Body
5220 and then List_Containing
(N
) = Declarations
(PO
)
5222 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5224 -- Analyze pragma expression for correctness and for ASIS use
5226 Preanalyze_Assert_Expression
5227 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5229 -- In ASIS mode, for a pragma generated from a source aspect,
5230 -- also analyze the original aspect expression.
5232 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5233 Preanalyze_Assert_Expression
5234 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5238 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5239 -- The copy is needed because the pragma is expanded into other
5240 -- constructs which are not acceptable in the N_Contract node.
5242 if Acts_As_Spec
(PO
) and then GNATprove_Mode
then
5244 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5247 -- Preanalyze the pragma
5249 Preanalyze_Assert_Expression
5251 (First
(Pragma_Argument_Associations
(Prag
))),
5254 -- Preanalyze the corresponding aspect (if any)
5256 if Present
(Corresponding_Aspect
(Prag
)) then
5257 Preanalyze_Assert_Expression
5258 (Expression
(Corresponding_Aspect
(Prag
)),
5262 -- Chain the copy on the contract of the body
5265 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5272 -- See if it is in the pragmas after a library level subprogram
5274 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5276 -- In GNATprove mode, analyze pragma expression for correctness,
5277 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5278 -- no later point at which the aspect will be analyzed.
5280 if GNATprove_Mode
or ASIS_Mode
then
5281 Analyze_Pre_Post_Condition_In_Decl_Part
5282 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5285 Chain_PPC
(Unit
(Parent
(PO
)));
5289 -- If we fall through, pragma was misplaced
5292 end Check_Precondition_Postcondition
;
5294 -----------------------------
5295 -- Check_Static_Constraint --
5296 -----------------------------
5298 -- Note: for convenience in writing this procedure, in addition to
5299 -- the officially (i.e. by spec) allowed argument which is always a
5300 -- constraint, it also allows ranges and discriminant associations.
5301 -- Above is not clear ???
5303 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5305 procedure Require_Static
(E
: Node_Id
);
5306 -- Require given expression to be static expression
5308 --------------------
5309 -- Require_Static --
5310 --------------------
5312 procedure Require_Static
(E
: Node_Id
) is
5314 if not Is_OK_Static_Expression
(E
) then
5315 Flag_Non_Static_Expr
5316 ("non-static constraint not allowed in Unchecked_Union!", E
);
5321 -- Start of processing for Check_Static_Constraint
5324 case Nkind
(Constr
) is
5325 when N_Discriminant_Association
=>
5326 Require_Static
(Expression
(Constr
));
5329 Require_Static
(Low_Bound
(Constr
));
5330 Require_Static
(High_Bound
(Constr
));
5332 when N_Attribute_Reference
=>
5333 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5334 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5336 when N_Range_Constraint
=>
5337 Check_Static_Constraint
(Range_Expression
(Constr
));
5339 when N_Index_Or_Discriminant_Constraint
=>
5343 IDC
:= First
(Constraints
(Constr
));
5344 while Present
(IDC
) loop
5345 Check_Static_Constraint
(IDC
);
5353 end Check_Static_Constraint
;
5355 ---------------------
5356 -- Check_Test_Case --
5357 ---------------------
5359 procedure Check_Test_Case
is
5363 procedure Chain_CTC
(PO
: Node_Id
);
5364 -- If PO is a [generic] subprogram declaration node, then the
5365 -- test-case applies to this subprogram and the processing for
5366 -- the pragma is completed. Otherwise the pragma is misplaced.
5372 procedure Chain_CTC
(PO
: Node_Id
) is
5373 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5378 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5380 ("pragma% cannot be applied to abstract subprogram");
5382 elsif Nkind
(PO
) = N_Entry_Declaration
then
5383 Error_Pragma
("pragma% cannot be applied to entry");
5385 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5386 N_Generic_Subprogram_Declaration
)
5391 -- Here if we have [generic] subprogram declaration
5393 S
:= Defining_Unit_Name
(Specification
(PO
));
5395 -- Note: we do not analyze the pragma at this point. Instead we
5396 -- delay this analysis until the end of the declarative part in
5397 -- which the pragma appears. This implements the required delay
5398 -- in this analysis, allowing forward references. The analysis
5399 -- happens at the end of Analyze_Declarations.
5401 -- There should not be another test-case with the same name
5402 -- associated to this subprogram.
5404 CTC
:= Contract_Test_Cases
(Contract
(S
));
5405 while Present
(CTC
) loop
5407 -- Omit pragma Contract_Cases because it does not introduce
5408 -- a unique case name and it does not follow the syntax of
5411 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5414 elsif String_Equal
(Name
, Get_Name_From_CTC_Pragma
(CTC
)) then
5415 Error_Msg_Sloc
:= Sloc
(CTC
);
5416 Error_Pragma
("name for pragma% is already used#");
5419 CTC
:= Next_Pragma
(CTC
);
5422 -- Chain spec CTC pragma to list for subprogram
5424 Add_Contract_Item
(N
, S
);
5427 -- Start of processing for Check_Test_Case
5430 -- First check pragma arguments
5432 Check_At_Least_N_Arguments
(2);
5433 Check_At_Most_N_Arguments
(4);
5435 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5437 Check_Optional_Identifier
(Arg1
, Name_Name
);
5438 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
5440 -- In ASIS mode, for a pragma generated from a source aspect, also
5441 -- analyze the original aspect expression.
5443 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5444 Check_Expr_Is_OK_Static_Expression
5445 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5448 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5449 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5451 if Arg_Count
= 4 then
5452 Check_Identifier
(Arg3
, Name_Requires
);
5453 Check_Identifier
(Arg4
, Name_Ensures
);
5455 elsif Arg_Count
= 3 then
5456 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5459 -- Check pragma placement
5461 if not Is_List_Member
(N
) then
5465 -- Test-case should only appear in package spec unit
5467 if Get_Source_Unit
(N
) = No_Unit
5468 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Current_Sem_Unit
)),
5469 N_Package_Declaration
,
5470 N_Generic_Package_Declaration
)
5475 -- Search prior declarations
5478 while Present
(Prev
(P
)) loop
5481 -- If the previous node is a generic subprogram, do not go to to
5482 -- the original node, which is the unanalyzed tree: we need to
5483 -- attach the test-case to the analyzed version at this point.
5484 -- They get propagated to the original tree when analyzing the
5485 -- corresponding body.
5487 if Nkind
(P
) not in N_Generic_Declaration
then
5488 PO
:= Original_Node
(P
);
5493 -- Skip past prior pragma
5495 if Nkind
(PO
) = N_Pragma
then
5498 -- Skip stuff not coming from source
5500 elsif not Comes_From_Source
(PO
) then
5503 -- Only remaining possibility is subprogram declaration. First
5504 -- check that it is declared directly in a package declaration.
5505 -- This may be either the package declaration for the current unit
5506 -- being defined or a local package declaration.
5508 elsif not Present
(Parent
(Parent
(PO
)))
5509 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5510 or else not Nkind_In
(Parent
(Parent
(PO
)),
5511 N_Package_Declaration
,
5512 N_Generic_Package_Declaration
)
5522 -- If we fall through, pragma was misplaced
5525 end Check_Test_Case
;
5527 --------------------------------------
5528 -- Check_Valid_Configuration_Pragma --
5529 --------------------------------------
5531 -- A configuration pragma must appear in the context clause of a
5532 -- compilation unit, and only other pragmas may precede it. Note that
5533 -- the test also allows use in a configuration pragma file.
5535 procedure Check_Valid_Configuration_Pragma
is
5537 if not Is_Configuration_Pragma
then
5538 Error_Pragma
("incorrect placement for configuration pragma%");
5540 end Check_Valid_Configuration_Pragma
;
5542 -------------------------------------
5543 -- Check_Valid_Library_Unit_Pragma --
5544 -------------------------------------
5546 procedure Check_Valid_Library_Unit_Pragma
is
5548 Parent_Node
: Node_Id
;
5549 Unit_Name
: Entity_Id
;
5550 Unit_Kind
: Node_Kind
;
5551 Unit_Node
: Node_Id
;
5552 Sindex
: Source_File_Index
;
5555 if not Is_List_Member
(N
) then
5559 Plist
:= List_Containing
(N
);
5560 Parent_Node
:= Parent
(Plist
);
5562 if Parent_Node
= Empty
then
5565 -- Case of pragma appearing after a compilation unit. In this case
5566 -- it must have an argument with the corresponding name and must
5567 -- be part of the following pragmas of its parent.
5569 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5570 if Plist
/= Pragmas_After
(Parent_Node
) then
5573 elsif Arg_Count
= 0 then
5575 ("argument required if outside compilation unit");
5578 Check_No_Identifiers
;
5579 Check_Arg_Count
(1);
5580 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5581 Unit_Kind
:= Nkind
(Unit_Node
);
5583 Analyze
(Get_Pragma_Arg
(Arg1
));
5585 if Unit_Kind
= N_Generic_Subprogram_Declaration
5586 or else Unit_Kind
= N_Subprogram_Declaration
5588 Unit_Name
:= Defining_Entity
(Unit_Node
);
5590 elsif Unit_Kind
in N_Generic_Instantiation
then
5591 Unit_Name
:= Defining_Entity
(Unit_Node
);
5594 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5597 if Chars
(Unit_Name
) /=
5598 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5601 ("pragma% argument is not current unit name", Arg1
);
5604 if Ekind
(Unit_Name
) = E_Package
5605 and then Present
(Renamed_Entity
(Unit_Name
))
5607 Error_Pragma
("pragma% not allowed for renamed package");
5611 -- Pragma appears other than after a compilation unit
5614 -- Here we check for the generic instantiation case and also
5615 -- for the case of processing a generic formal package. We
5616 -- detect these cases by noting that the Sloc on the node
5617 -- does not belong to the current compilation unit.
5619 Sindex
:= Source_Index
(Current_Sem_Unit
);
5621 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5622 Rewrite
(N
, Make_Null_Statement
(Loc
));
5625 -- If before first declaration, the pragma applies to the
5626 -- enclosing unit, and the name if present must be this name.
5628 elsif Is_Before_First_Decl
(N
, Plist
) then
5629 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5630 Unit_Kind
:= Nkind
(Unit_Node
);
5632 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5635 elsif Unit_Kind
= N_Subprogram_Body
5636 and then not Acts_As_Spec
(Unit_Node
)
5640 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5643 elsif Nkind
(Parent_Node
) = N_Package_Specification
5644 and then Plist
= Private_Declarations
(Parent_Node
)
5648 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5649 or else Nkind
(Parent_Node
) =
5650 N_Generic_Subprogram_Declaration
)
5651 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5655 elsif Arg_Count
> 0 then
5656 Analyze
(Get_Pragma_Arg
(Arg1
));
5658 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5660 ("name in pragma% must be enclosing unit", Arg1
);
5663 -- It is legal to have no argument in this context
5669 -- Error if not before first declaration. This is because a
5670 -- library unit pragma argument must be the name of a library
5671 -- unit (RM 10.1.5(7)), but the only names permitted in this
5672 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5673 -- generic subprogram declarations or generic instantiations.
5677 ("pragma% misplaced, must be before first declaration");
5681 end Check_Valid_Library_Unit_Pragma
;
5687 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5688 Clist
: constant Node_Id
:= Component_List
(Variant
);
5692 Comp
:= First
(Component_Items
(Clist
));
5693 while Present
(Comp
) loop
5694 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5699 ---------------------------
5700 -- Ensure_Aggregate_Form --
5701 ---------------------------
5703 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5704 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5705 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5706 Nam
: constant Name_Id
:= Chars
(Arg
);
5707 Comps
: List_Id
:= No_List
;
5708 Exprs
: List_Id
:= No_List
;
5710 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5711 -- Used to restore Comes_From_Source_Default
5714 -- The argument is already in aggregate form, but the presence of a
5715 -- name causes this to be interpreted as a named association which in
5716 -- turn must be converted into an aggregate.
5718 -- pragma Global (In_Out => (A, B, C))
5722 -- pragma Global ((In_Out => (A, B, C)))
5724 -- aggregate aggregate
5726 if Nkind
(Expr
) = N_Aggregate
then
5727 if Nam
= No_Name
then
5731 -- Do not transform a null argument into an aggregate as N_Null has
5732 -- special meaning in formal verification pragmas.
5734 elsif Nkind
(Expr
) = N_Null
then
5738 -- Everything comes from source if the original comes from source
5740 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5742 -- Positional argument is transformed into an aggregate with an
5743 -- Expressions list.
5745 if Nam
= No_Name
then
5746 Exprs
:= New_List
(Relocate_Node
(Expr
));
5748 -- An associative argument is transformed into an aggregate with
5749 -- Component_Associations.
5753 Make_Component_Association
(Loc
,
5754 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5755 Expression
=> Relocate_Node
(Expr
)));
5758 -- Remove the pragma argument name as this information has been
5759 -- captured in the aggregate.
5761 Set_Chars
(Arg
, No_Name
);
5763 Set_Expression
(Arg
,
5764 Make_Aggregate
(Loc
,
5765 Component_Associations
=> Comps
,
5766 Expressions
=> Exprs
));
5768 -- Restore Comes_From_Source default
5770 Set_Comes_From_Source_Default
(CFSD
);
5771 end Ensure_Aggregate_Form
;
5777 procedure Error_Pragma
(Msg
: String) is
5779 Error_Msg_Name_1
:= Pname
;
5780 Error_Msg_N
(Fix_Error
(Msg
), N
);
5784 ----------------------
5785 -- Error_Pragma_Arg --
5786 ----------------------
5788 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5790 Error_Msg_Name_1
:= Pname
;
5791 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5793 end Error_Pragma_Arg
;
5795 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5797 Error_Msg_Name_1
:= Pname
;
5798 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5799 Error_Pragma_Arg
(Msg2
, Arg
);
5800 end Error_Pragma_Arg
;
5802 ----------------------------
5803 -- Error_Pragma_Arg_Ident --
5804 ----------------------------
5806 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5808 Error_Msg_Name_1
:= Pname
;
5809 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5811 end Error_Pragma_Arg_Ident
;
5813 ----------------------
5814 -- Error_Pragma_Ref --
5815 ----------------------
5817 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5819 Error_Msg_Name_1
:= Pname
;
5820 Error_Msg_Sloc
:= Sloc
(Ref
);
5821 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5823 end Error_Pragma_Ref
;
5825 ------------------------
5826 -- Find_Lib_Unit_Name --
5827 ------------------------
5829 function Find_Lib_Unit_Name
return Entity_Id
is
5831 -- Return inner compilation unit entity, for case of nested
5832 -- categorization pragmas. This happens in generic unit.
5834 if Nkind
(Parent
(N
)) = N_Package_Specification
5835 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5837 return Defining_Entity
(Parent
(N
));
5839 return Current_Scope
;
5841 end Find_Lib_Unit_Name
;
5843 ----------------------------
5844 -- Find_Program_Unit_Name --
5845 ----------------------------
5847 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5848 Unit_Name
: Entity_Id
;
5849 Unit_Kind
: Node_Kind
;
5850 P
: constant Node_Id
:= Parent
(N
);
5853 if Nkind
(P
) = N_Compilation_Unit
then
5854 Unit_Kind
:= Nkind
(Unit
(P
));
5856 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5857 N_Package_Declaration
)
5858 or else Unit_Kind
in N_Generic_Declaration
5860 Unit_Name
:= Defining_Entity
(Unit
(P
));
5862 if Chars
(Id
) = Chars
(Unit_Name
) then
5863 Set_Entity
(Id
, Unit_Name
);
5864 Set_Etype
(Id
, Etype
(Unit_Name
));
5866 Set_Etype
(Id
, Any_Type
);
5868 ("cannot find program unit referenced by pragma%");
5872 Set_Etype
(Id
, Any_Type
);
5873 Error_Pragma
("pragma% inapplicable to this unit");
5879 end Find_Program_Unit_Name
;
5881 -----------------------------------------
5882 -- Find_Unique_Parameterless_Procedure --
5883 -----------------------------------------
5885 function Find_Unique_Parameterless_Procedure
5887 Arg
: Node_Id
) return Entity_Id
5889 Proc
: Entity_Id
:= Empty
;
5892 -- The body of this procedure needs some comments ???
5894 if not Is_Entity_Name
(Name
) then
5896 ("argument of pragma% must be entity name", Arg
);
5898 elsif not Is_Overloaded
(Name
) then
5899 Proc
:= Entity
(Name
);
5901 if Ekind
(Proc
) /= E_Procedure
5902 or else Present
(First_Formal
(Proc
))
5905 ("argument of pragma% must be parameterless procedure", Arg
);
5910 Found
: Boolean := False;
5912 Index
: Interp_Index
;
5915 Get_First_Interp
(Name
, Index
, It
);
5916 while Present
(It
.Nam
) loop
5919 if Ekind
(Proc
) = E_Procedure
5920 and then No
(First_Formal
(Proc
))
5924 Set_Entity
(Name
, Proc
);
5925 Set_Is_Overloaded
(Name
, False);
5928 ("ambiguous handler name for pragma% ", Arg
);
5932 Get_Next_Interp
(Index
, It
);
5937 ("argument of pragma% must be parameterless procedure",
5940 Proc
:= Entity
(Name
);
5946 end Find_Unique_Parameterless_Procedure
;
5952 function Fix_Error
(Msg
: String) return String is
5953 Res
: String (Msg
'Range) := Msg
;
5954 Res_Last
: Natural := Msg
'Last;
5958 -- If we have a rewriting of another pragma, go to that pragma
5960 if Is_Rewrite_Substitution
(N
)
5961 and then Nkind
(Original_Node
(N
)) = N_Pragma
5963 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5966 -- Case where pragma comes from an aspect specification
5968 if From_Aspect_Specification
(N
) then
5970 -- Change appearence of "pragma" in message to "aspect"
5973 while J
<= Res_Last
- 5 loop
5974 if Res
(J
.. J
+ 5) = "pragma" then
5975 Res
(J
.. J
+ 5) := "aspect";
5983 -- Change "argument of" at start of message to "entity for"
5986 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5988 Res
(Res
'First .. Res
'First + 9) := "entity for";
5989 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5990 Res
(Res
'First + 11 .. Res_Last
);
5991 Res_Last
:= Res_Last
- 1;
5994 -- Change "argument" at start of message to "entity"
5997 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5999 Res
(Res
'First .. Res
'First + 5) := "entity";
6000 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6001 Res
(Res
'First + 8 .. Res_Last
);
6002 Res_Last
:= Res_Last
- 2;
6005 -- Get name from corresponding aspect
6007 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
6010 -- Return possibly modified message
6012 return Res
(Res
'First .. Res_Last
);
6015 -------------------------
6016 -- Gather_Associations --
6017 -------------------------
6019 procedure Gather_Associations
6021 Args
: out Args_List
)
6026 -- Initialize all parameters to Empty
6028 for J
in Args
'Range loop
6032 -- That's all we have to do if there are no argument associations
6034 if No
(Pragma_Argument_Associations
(N
)) then
6038 -- Otherwise first deal with any positional parameters present
6040 Arg
:= First
(Pragma_Argument_Associations
(N
));
6041 for Index
in Args
'Range loop
6042 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6043 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6047 -- Positional parameters all processed, if any left, then we
6048 -- have too many positional parameters.
6050 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6052 ("too many positional associations for pragma%", Arg
);
6055 -- Process named parameters if any are present
6057 while Present
(Arg
) loop
6058 if Chars
(Arg
) = No_Name
then
6060 ("positional association cannot follow named association",
6064 for Index
in Names
'Range loop
6065 if Names
(Index
) = Chars
(Arg
) then
6066 if Present
(Args
(Index
)) then
6068 ("duplicate argument association for pragma%", Arg
);
6070 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6075 if Index
= Names
'Last then
6076 Error_Msg_Name_1
:= Pname
;
6077 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6079 -- Check for possible misspelling
6081 for Index1
in Names
'Range loop
6082 if Is_Bad_Spelling_Of
6083 (Chars
(Arg
), Names
(Index1
))
6085 Error_Msg_Name_1
:= Names
(Index1
);
6086 Error_Msg_N
-- CODEFIX
6087 ("\possible misspelling of%", Arg
);
6099 end Gather_Associations
;
6105 procedure GNAT_Pragma
is
6107 -- We need to check the No_Implementation_Pragmas restriction for
6108 -- the case of a pragma from source. Note that the case of aspects
6109 -- generating corresponding pragmas marks these pragmas as not being
6110 -- from source, so this test also catches that case.
6112 if Comes_From_Source
(N
) then
6113 Check_Restriction
(No_Implementation_Pragmas
, N
);
6117 --------------------------
6118 -- Is_Before_First_Decl --
6119 --------------------------
6121 function Is_Before_First_Decl
6122 (Pragma_Node
: Node_Id
;
6123 Decls
: List_Id
) return Boolean
6125 Item
: Node_Id
:= First
(Decls
);
6128 -- Only other pragmas can come before this pragma
6131 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6134 elsif Item
= Pragma_Node
then
6140 end Is_Before_First_Decl
;
6142 -----------------------------
6143 -- Is_Configuration_Pragma --
6144 -----------------------------
6146 -- A configuration pragma must appear in the context clause of a
6147 -- compilation unit, and only other pragmas may precede it. Note that
6148 -- the test below also permits use in a configuration pragma file.
6150 function Is_Configuration_Pragma
return Boolean is
6151 Lis
: constant List_Id
:= List_Containing
(N
);
6152 Par
: constant Node_Id
:= Parent
(N
);
6156 -- If no parent, then we are in the configuration pragma file,
6157 -- so the placement is definitely appropriate.
6162 -- Otherwise we must be in the context clause of a compilation unit
6163 -- and the only thing allowed before us in the context list is more
6164 -- configuration pragmas.
6166 elsif Nkind
(Par
) = N_Compilation_Unit
6167 and then Context_Items
(Par
) = Lis
6174 elsif Nkind
(Prg
) /= N_Pragma
then
6184 end Is_Configuration_Pragma
;
6186 --------------------------
6187 -- Is_In_Context_Clause --
6188 --------------------------
6190 function Is_In_Context_Clause
return Boolean is
6192 Parent_Node
: Node_Id
;
6195 if not Is_List_Member
(N
) then
6199 Plist
:= List_Containing
(N
);
6200 Parent_Node
:= Parent
(Plist
);
6202 if Parent_Node
= Empty
6203 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6204 or else Context_Items
(Parent_Node
) /= Plist
6211 end Is_In_Context_Clause
;
6213 ---------------------------------
6214 -- Is_Static_String_Expression --
6215 ---------------------------------
6217 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6218 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6219 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6222 Analyze_And_Resolve
(Argx
);
6224 -- Special case Ada 83, where the expression will never be static,
6225 -- but we will return true if we had a string literal to start with.
6227 if Ada_Version
= Ada_83
then
6230 -- Normal case, true only if we end up with a string literal that
6231 -- is marked as being the result of evaluating a static expression.
6234 return Is_OK_Static_Expression
(Argx
)
6235 and then Nkind
(Argx
) = N_String_Literal
;
6238 end Is_Static_String_Expression
;
6240 ----------------------
6241 -- Pragma_Misplaced --
6242 ----------------------
6244 procedure Pragma_Misplaced
is
6246 Error_Pragma
("incorrect placement of pragma%");
6247 end Pragma_Misplaced
;
6249 ------------------------------------
6250 -- Process_Atomic_Shared_Volatile --
6251 ------------------------------------
6253 procedure Process_Atomic_Shared_Volatile
is
6260 procedure Set_Atomic
(E
: Entity_Id
);
6261 -- Set given type as atomic, and if no explicit alignment was given,
6262 -- set alignment to unknown, since back end knows what the alignment
6263 -- requirements are for atomic arrays. Note: this step is necessary
6264 -- for derived types.
6270 procedure Set_Atomic
(E
: Entity_Id
) is
6274 if not Has_Alignment_Clause
(E
) then
6275 Set_Alignment
(E
, Uint_0
);
6279 -- Start of processing for Process_Atomic_Shared_Volatile
6282 Check_Ada_83_Warning
;
6283 Check_No_Identifiers
;
6284 Check_Arg_Count
(1);
6285 Check_Arg_Is_Local_Name
(Arg1
);
6286 E_Id
:= Get_Pragma_Arg
(Arg1
);
6288 if Etype
(E_Id
) = Any_Type
then
6293 D
:= Declaration_Node
(E
);
6296 -- Check duplicate before we chain ourselves
6298 Check_Duplicate_Pragma
(E
);
6300 -- Now check appropriateness of the entity
6303 if Rep_Item_Too_Early
(E
, N
)
6305 Rep_Item_Too_Late
(E
, N
)
6309 Check_First_Subtype
(Arg1
);
6312 if Prag_Id
/= Pragma_Volatile
then
6314 Set_Atomic
(Underlying_Type
(E
));
6315 Set_Atomic
(Base_Type
(E
));
6318 -- Attribute belongs on the base type. If the view of the type is
6319 -- currently private, it also belongs on the underlying type.
6321 Set_Is_Volatile
(Base_Type
(E
));
6322 Set_Is_Volatile
(Underlying_Type
(E
));
6324 Set_Treat_As_Volatile
(E
);
6325 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6327 elsif K
= N_Object_Declaration
6328 or else (K
= N_Component_Declaration
6329 and then Original_Record_Component
(E
) = E
)
6331 if Rep_Item_Too_Late
(E
, N
) then
6335 if Prag_Id
/= Pragma_Volatile
then
6338 -- If the object declaration has an explicit initialization, a
6339 -- temporary may have to be created to hold the expression, to
6340 -- ensure that access to the object remain atomic.
6342 if Nkind
(Parent
(E
)) = N_Object_Declaration
6343 and then Present
(Expression
(Parent
(E
)))
6345 Set_Has_Delayed_Freeze
(E
);
6348 -- An interesting improvement here. If an object of composite
6349 -- type X is declared atomic, and the type X isn't, that's a
6350 -- pity, since it may not have appropriate alignment etc. We
6351 -- can rescue this in the special case where the object and
6352 -- type are in the same unit by just setting the type as
6353 -- atomic, so that the back end will process it as atomic.
6355 -- Note: we used to do this for elementary types as well,
6356 -- but that turns out to be a bad idea and can have unwanted
6357 -- effects, most notably if the type is elementary, the object
6358 -- a simple component within a record, and both are in a spec:
6359 -- every object of this type in the entire program will be
6360 -- treated as atomic, thus incurring a potentially costly
6361 -- synchronization operation for every access.
6363 -- Of course it would be best if the back end could just adjust
6364 -- the alignment etc for the specific object, but that's not
6365 -- something we are capable of doing at this point.
6367 Utyp
:= Underlying_Type
(Etype
(E
));
6370 and then Is_Composite_Type
(Utyp
)
6371 and then Sloc
(E
) > No_Location
6372 and then Sloc
(Utyp
) > No_Location
6374 Get_Source_File_Index
(Sloc
(E
)) =
6375 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6377 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6381 Set_Is_Volatile
(E
);
6382 Set_Treat_As_Volatile
(E
);
6385 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6388 -- The following check is only relevant when SPARK_Mode is on as
6389 -- this is not a standard Ada legality rule. Pragma Volatile can
6390 -- only apply to a full type declaration or an object declaration
6391 -- (SPARK RM C.6(1)).
6394 and then Prag_Id
= Pragma_Volatile
6395 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6396 N_Object_Declaration
)
6399 ("argument of pragma % must denote a full type or object "
6400 & "declaration", Arg1
);
6402 end Process_Atomic_Shared_Volatile
;
6404 -------------------------------------------
6405 -- Process_Compile_Time_Warning_Or_Error --
6406 -------------------------------------------
6408 procedure Process_Compile_Time_Warning_Or_Error
is
6409 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6412 Check_Arg_Count
(2);
6413 Check_No_Identifiers
;
6414 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6415 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6417 if Compile_Time_Known_Value
(Arg1x
) then
6418 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6420 Str
: constant String_Id
:=
6421 Strval
(Get_Pragma_Arg
(Arg2
));
6422 Len
: constant Int
:= String_Length
(Str
);
6427 Cent
: constant Entity_Id
:=
6428 Cunit_Entity
(Current_Sem_Unit
);
6430 Force
: constant Boolean :=
6431 Prag_Id
= Pragma_Compile_Time_Warning
6433 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6434 and then (Ekind
(Cent
) /= E_Package
6435 or else not In_Private_Part
(Cent
));
6436 -- Set True if this is the warning case, and we are in the
6437 -- visible part of a package spec, or in a subprogram spec,
6438 -- in which case we want to force the client to see the
6439 -- warning, even though it is not in the main unit.
6442 -- Loop through segments of message separated by line feeds.
6443 -- We output these segments as separate messages with
6444 -- continuation marks for all but the first.
6449 Error_Msg_Strlen
:= 0;
6451 -- Loop to copy characters from argument to error message
6455 exit when Ptr
> Len
;
6456 CC
:= Get_String_Char
(Str
, Ptr
);
6459 -- Ignore wide chars ??? else store character
6461 if In_Character_Range
(CC
) then
6462 C
:= Get_Character
(CC
);
6463 exit when C
= ASCII
.LF
;
6464 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6465 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6469 -- Here with one line ready to go
6471 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6473 -- If this is a warning in a spec, then we want clients
6474 -- to see the warning, so mark the message with the
6475 -- special sequence !! to force the warning. In the case
6476 -- of a package spec, we do not force this if we are in
6477 -- the private part of the spec.
6480 if Cont
= False then
6481 Error_Msg_N
("<<~!!", Arg1
);
6484 Error_Msg_N
("\<<~!!", Arg1
);
6487 -- Error, rather than warning, or in a body, so we do not
6488 -- need to force visibility for client (error will be
6489 -- output in any case, and this is the situation in which
6490 -- we do not want a client to get a warning, since the
6491 -- warning is in the body or the spec private part).
6494 if Cont
= False then
6495 Error_Msg_N
("<<~", Arg1
);
6498 Error_Msg_N
("\<<~", Arg1
);
6502 exit when Ptr
> Len
;
6507 end Process_Compile_Time_Warning_Or_Error
;
6509 ------------------------
6510 -- Process_Convention --
6511 ------------------------
6513 procedure Process_Convention
6514 (C
: out Convention_Id
;
6515 Ent
: out Entity_Id
)
6521 Comp_Unit
: Unit_Number_Type
;
6523 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6524 -- Called if we have more than one Export/Import/Convention pragma.
6525 -- This is generally illegal, but we have a special case of allowing
6526 -- Import and Interface to coexist if they specify the convention in
6527 -- a consistent manner. We are allowed to do this, since Interface is
6528 -- an implementation defined pragma, and we choose to do it since we
6529 -- know Rational allows this combination. S is the entity id of the
6530 -- subprogram in question. This procedure also sets the special flag
6531 -- Import_Interface_Present in both pragmas in the case where we do
6532 -- have matching Import and Interface pragmas.
6534 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6535 -- Set convention in entity E, and also flag that the entity has a
6536 -- convention pragma. If entity is for a private or incomplete type,
6537 -- also set convention and flag on underlying type. This procedure
6538 -- also deals with the special case of C_Pass_By_Copy convention,
6539 -- and error checks for inappropriate convention specification.
6541 -------------------------------
6542 -- Diagnose_Multiple_Pragmas --
6543 -------------------------------
6545 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6546 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6550 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6551 -- Decl is a pragma node. This function returns True if this
6552 -- pragma has a first argument that is an identifier with a
6553 -- Chars field corresponding to the Convention_Id C.
6555 function Same_Name
(Decl
: Node_Id
) return Boolean;
6556 -- Decl is a pragma node. This function returns True if this
6557 -- pragma has a second argument that is an identifier with a
6558 -- Chars field that matches the Chars of the current subprogram.
6560 ---------------------
6561 -- Same_Convention --
6562 ---------------------
6564 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6565 Arg1
: constant Node_Id
:=
6566 First
(Pragma_Argument_Associations
(Decl
));
6569 if Present
(Arg1
) then
6571 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6573 if Nkind
(Arg
) = N_Identifier
6574 and then Is_Convention_Name
(Chars
(Arg
))
6575 and then Get_Convention_Id
(Chars
(Arg
)) = C
6583 end Same_Convention
;
6589 function Same_Name
(Decl
: Node_Id
) return Boolean is
6590 Arg1
: constant Node_Id
:=
6591 First
(Pragma_Argument_Associations
(Decl
));
6599 Arg2
:= Next
(Arg1
);
6606 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6608 if Nkind
(Arg
) = N_Identifier
6609 and then Chars
(Arg
) = Chars
(S
)
6618 -- Start of processing for Diagnose_Multiple_Pragmas
6623 -- Definitely give message if we have Convention/Export here
6625 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6628 -- If we have an Import or Export, scan back from pragma to
6629 -- find any previous pragma applying to the same procedure.
6630 -- The scan will be terminated by the start of the list, or
6631 -- hitting the subprogram declaration. This won't allow one
6632 -- pragma to appear in the public part and one in the private
6633 -- part, but that seems very unlikely in practice.
6637 while Present
(Decl
) and then Decl
/= Pdec
loop
6639 -- Look for pragma with same name as us
6641 if Nkind
(Decl
) = N_Pragma
6642 and then Same_Name
(Decl
)
6644 -- Give error if same as our pragma or Export/Convention
6646 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6652 -- Case of Import/Interface or the other way round
6654 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6657 -- Here we know that we have Import and Interface. It
6658 -- doesn't matter which way round they are. See if
6659 -- they specify the same convention. If so, all OK,
6660 -- and set special flags to stop other messages
6662 if Same_Convention
(Decl
) then
6663 Set_Import_Interface_Present
(N
);
6664 Set_Import_Interface_Present
(Decl
);
6667 -- If different conventions, special message
6670 Error_Msg_Sloc
:= Sloc
(Decl
);
6672 ("convention differs from that given#", Arg1
);
6682 -- Give message if needed if we fall through those tests
6683 -- except on Relaxed_RM_Semantics where we let go: either this
6684 -- is a case accepted/ignored by other Ada compilers (e.g.
6685 -- a mix of Convention and Import), or another error will be
6686 -- generated later (e.g. using both Import and Export).
6688 if Err
and not Relaxed_RM_Semantics
then
6690 ("at most one Convention/Export/Import pragma is allowed",
6693 end Diagnose_Multiple_Pragmas
;
6695 --------------------------------
6696 -- Set_Convention_From_Pragma --
6697 --------------------------------
6699 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6701 -- Ghost convention is allowed only for functions
6703 if Ekind
(E
) /= E_Function
and then C
= Convention_Ghost
then
6705 ("& may not have Ghost convention", E
);
6707 ("\only functions are permitted to have Ghost convention",
6712 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6713 -- for an overridden dispatching operation. Technically this is
6714 -- an amendment and should only be done in Ada 2005 mode. However,
6715 -- this is clearly a mistake, since the problem that is addressed
6716 -- by this AI is that there is a clear gap in the RM.
6718 if Is_Dispatching_Operation
(E
)
6719 and then Present
(Overridden_Operation
(E
))
6720 and then C
/= Convention
(Overridden_Operation
(E
))
6722 -- An attempt to override a function with a ghost function
6723 -- appears as a mismatch in conventions.
6725 if C
= Convention_Ghost
then
6726 Error_Msg_N
("ghost function & cannot be overriding", E
);
6729 ("cannot change convention for overridden dispatching "
6730 & "operation", Arg1
);
6734 -- Special checks for Convention_Stdcall
6736 if C
= Convention_Stdcall
then
6738 -- A dispatching call is not allowed. A dispatching subprogram
6739 -- cannot be used to interface to the Win32 API, so in fact
6740 -- this check does not impose any effective restriction.
6742 if Is_Dispatching_Operation
(E
) then
6743 Error_Msg_Sloc
:= Sloc
(E
);
6745 -- Note: make this unconditional so that if there is more
6746 -- than one call to which the pragma applies, we get a
6747 -- message for each call. Also don't use Error_Pragma,
6748 -- so that we get multiple messages.
6751 ("dispatching subprogram# cannot use Stdcall convention!",
6754 -- Subprograms are not allowed
6756 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6760 and then Ekind
(E
) /= E_Variable
6762 -- An access to subprogram is also allowed
6766 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6768 -- Allow internal call to set convention of subprogram type
6770 and then not (Ekind
(E
) = E_Subprogram_Type
)
6773 ("second argument of pragma% must be subprogram (type)",
6778 -- Set the convention
6780 Set_Convention
(E
, C
);
6781 Set_Has_Convention_Pragma
(E
);
6783 -- For the case of a record base type, also set the convention of
6784 -- any anonymous access types declared in the record which do not
6785 -- currently have a specified convention.
6787 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6792 Comp
:= First_Component
(E
);
6793 while Present
(Comp
) loop
6794 if Present
(Etype
(Comp
))
6795 and then Ekind_In
(Etype
(Comp
),
6796 E_Anonymous_Access_Type
,
6797 E_Anonymous_Access_Subprogram_Type
)
6798 and then not Has_Convention_Pragma
(Comp
)
6800 Set_Convention
(Comp
, C
);
6803 Next_Component
(Comp
);
6808 -- Deal with incomplete/private type case, where underlying type
6809 -- is available, so set convention of that underlying type.
6811 if Is_Incomplete_Or_Private_Type
(E
)
6812 and then Present
(Underlying_Type
(E
))
6814 Set_Convention
(Underlying_Type
(E
), C
);
6815 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6818 -- A class-wide type should inherit the convention of the specific
6819 -- root type (although this isn't specified clearly by the RM).
6821 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6822 Set_Convention
(Class_Wide_Type
(E
), C
);
6825 -- If the entity is a record type, then check for special case of
6826 -- C_Pass_By_Copy, which is treated the same as C except that the
6827 -- special record flag is set. This convention is only permitted
6828 -- on record types (see AI95-00131).
6830 if Cname
= Name_C_Pass_By_Copy
then
6831 if Is_Record_Type
(E
) then
6832 Set_C_Pass_By_Copy
(Base_Type
(E
));
6833 elsif Is_Incomplete_Or_Private_Type
(E
)
6834 and then Is_Record_Type
(Underlying_Type
(E
))
6836 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6839 ("C_Pass_By_Copy convention allowed only for record type",
6844 -- If the entity is a derived boolean type, check for the special
6845 -- case of convention C, C++, or Fortran, where we consider any
6846 -- nonzero value to represent true.
6848 if Is_Discrete_Type
(E
)
6849 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6855 C
= Convention_Fortran
)
6857 Set_Nonzero_Is_True
(Base_Type
(E
));
6859 end Set_Convention_From_Pragma
;
6861 -- Start of processing for Process_Convention
6864 Check_At_Least_N_Arguments
(2);
6865 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6866 Check_Arg_Is_Identifier
(Arg1
);
6867 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6869 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6870 -- tested again below to set the critical flag).
6872 if Cname
= Name_C_Pass_By_Copy
then
6875 -- Otherwise we must have something in the standard convention list
6877 elsif Is_Convention_Name
(Cname
) then
6878 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6880 -- Otherwise warn on unrecognized convention
6883 if Warn_On_Export_Import
then
6885 ("??unrecognized convention name, C assumed",
6886 Get_Pragma_Arg
(Arg1
));
6892 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6893 Check_Arg_Is_Local_Name
(Arg2
);
6895 Id
:= Get_Pragma_Arg
(Arg2
);
6898 if not Is_Entity_Name
(Id
) then
6899 Error_Pragma_Arg
("entity name required", Arg2
);
6904 -- Set entity to return
6908 -- Ada_Pass_By_Copy special checking
6910 if C
= Convention_Ada_Pass_By_Copy
then
6911 if not Is_First_Subtype
(E
) then
6913 ("convention `Ada_Pass_By_Copy` only allowed for types",
6917 if Is_By_Reference_Type
(E
) then
6919 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6924 -- Ada_Pass_By_Reference special checking
6926 if C
= Convention_Ada_Pass_By_Reference
then
6927 if not Is_First_Subtype
(E
) then
6929 ("convention `Ada_Pass_By_Reference` only allowed for types",
6933 if Is_By_Copy_Type
(E
) then
6935 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6940 -- Ghost special checking
6942 if Is_Ghost_Subprogram
(E
)
6943 and then Present
(Overridden_Operation
(E
))
6945 Error_Msg_N
("ghost function & cannot be overriding", E
);
6948 -- Go to renamed subprogram if present, since convention applies to
6949 -- the actual renamed entity, not to the renaming entity. If the
6950 -- subprogram is inherited, go to parent subprogram.
6952 if Is_Subprogram
(E
)
6953 and then Present
(Alias
(E
))
6955 if Nkind
(Parent
(Declaration_Node
(E
))) =
6956 N_Subprogram_Renaming_Declaration
6958 if Scope
(E
) /= Scope
(Alias
(E
)) then
6960 ("cannot apply pragma% to non-local entity&#", E
);
6965 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6966 N_Private_Extension_Declaration
)
6967 and then Scope
(E
) = Scope
(Alias
(E
))
6971 -- Return the parent subprogram the entity was inherited from
6977 -- Check that we are not applying this to a specless body
6978 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
6981 if Is_Subprogram
(E
)
6982 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6983 and then not Relaxed_RM_Semantics
6986 ("pragma% requires separate spec and must come before body");
6989 -- Check that we are not applying this to a named constant
6991 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6992 Error_Msg_Name_1
:= Pname
;
6994 ("cannot apply pragma% to named constant!",
6995 Get_Pragma_Arg
(Arg2
));
6997 ("\supply appropriate type for&!", Arg2
);
7000 if Ekind
(E
) = E_Enumeration_Literal
then
7001 Error_Pragma
("enumeration literal not allowed for pragma%");
7004 -- Check for rep item appearing too early or too late
7006 if Etype
(E
) = Any_Type
7007 or else Rep_Item_Too_Early
(E
, N
)
7011 elsif Present
(Underlying_Type
(E
)) then
7012 E
:= Underlying_Type
(E
);
7015 if Rep_Item_Too_Late
(E
, N
) then
7019 if Has_Convention_Pragma
(E
) then
7020 Diagnose_Multiple_Pragmas
(E
);
7022 elsif Convention
(E
) = Convention_Protected
7023 or else Ekind
(Scope
(E
)) = E_Protected_Type
7026 ("a protected operation cannot be given a different convention",
7030 -- For Intrinsic, a subprogram is required
7032 if C
= Convention_Intrinsic
7033 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7036 ("second argument of pragma% must be a subprogram", Arg2
);
7039 -- Deal with non-subprogram cases
7041 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7042 Set_Convention_From_Pragma
(E
);
7045 Check_First_Subtype
(Arg2
);
7046 Set_Convention_From_Pragma
(Base_Type
(E
));
7048 -- For access subprograms, we must set the convention on the
7049 -- internally generated directly designated type as well.
7051 if Ekind
(E
) = E_Access_Subprogram_Type
then
7052 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7056 -- For the subprogram case, set proper convention for all homonyms
7057 -- in same scope and the same declarative part, i.e. the same
7058 -- compilation unit.
7061 Comp_Unit
:= Get_Source_Unit
(E
);
7062 Set_Convention_From_Pragma
(E
);
7064 -- Treat a pragma Import as an implicit body, and pragma import
7065 -- as implicit reference (for navigation in GPS).
7067 if Prag_Id
= Pragma_Import
then
7068 Generate_Reference
(E
, Id
, 'b');
7070 -- For exported entities we restrict the generation of references
7071 -- to entities exported to foreign languages since entities
7072 -- exported to Ada do not provide further information to GPS and
7073 -- add undesired references to the output of the gnatxref tool.
7075 elsif Prag_Id
= Pragma_Export
7076 and then Convention
(E
) /= Convention_Ada
7078 Generate_Reference
(E
, Id
, 'i');
7081 -- If the pragma comes from from an aspect, it only applies to the
7082 -- given entity, not its homonyms.
7084 if From_Aspect_Specification
(N
) then
7088 -- Otherwise Loop through the homonyms of the pragma argument's
7089 -- entity, an apply convention to those in the current scope.
7095 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7097 -- Ignore entry for which convention is already set
7099 if Has_Convention_Pragma
(E1
) then
7103 -- Do not set the pragma on inherited operations or on formal
7106 if Comes_From_Source
(E1
)
7107 and then Comp_Unit
= Get_Source_Unit
(E1
)
7108 and then not Is_Formal_Subprogram
(E1
)
7109 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7110 N_Full_Type_Declaration
7112 if Present
(Alias
(E1
))
7113 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7116 ("cannot apply pragma% to non-local entity& declared#",
7120 Set_Convention_From_Pragma
(E1
);
7122 if Prag_Id
= Pragma_Import
then
7123 Generate_Reference
(E1
, Id
, 'b');
7131 end Process_Convention
;
7133 ----------------------------------------
7134 -- Process_Disable_Enable_Atomic_Sync --
7135 ----------------------------------------
7137 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7139 Check_No_Identifiers
;
7140 Check_At_Most_N_Arguments
(1);
7142 -- Modeled internally as
7143 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7147 Pragma_Identifier
=>
7148 Make_Identifier
(Loc
, Nam
),
7149 Pragma_Argument_Associations
=> New_List
(
7150 Make_Pragma_Argument_Association
(Loc
,
7152 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7154 if Present
(Arg1
) then
7155 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7159 end Process_Disable_Enable_Atomic_Sync
;
7161 -------------------------------------------------
7162 -- Process_Extended_Import_Export_Internal_Arg --
7163 -------------------------------------------------
7165 procedure Process_Extended_Import_Export_Internal_Arg
7166 (Arg_Internal
: Node_Id
:= Empty
)
7169 if No
(Arg_Internal
) then
7170 Error_Pragma
("Internal parameter required for pragma%");
7173 if Nkind
(Arg_Internal
) = N_Identifier
then
7176 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7177 and then (Prag_Id
= Pragma_Import_Function
7179 Prag_Id
= Pragma_Export_Function
)
7185 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7188 Check_Arg_Is_Local_Name
(Arg_Internal
);
7189 end Process_Extended_Import_Export_Internal_Arg
;
7191 --------------------------------------------------
7192 -- Process_Extended_Import_Export_Object_Pragma --
7193 --------------------------------------------------
7195 procedure Process_Extended_Import_Export_Object_Pragma
7196 (Arg_Internal
: Node_Id
;
7197 Arg_External
: Node_Id
;
7203 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7204 Def_Id
:= Entity
(Arg_Internal
);
7206 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7208 ("pragma% must designate an object", Arg_Internal
);
7211 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7213 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7216 ("previous Common/Psect_Object applies, pragma % not permitted",
7220 if Rep_Item_Too_Late
(Def_Id
, N
) then
7224 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7226 if Present
(Arg_Size
) then
7227 Check_Arg_Is_External_Name
(Arg_Size
);
7230 -- Export_Object case
7232 if Prag_Id
= Pragma_Export_Object
then
7233 if not Is_Library_Level_Entity
(Def_Id
) then
7235 ("argument for pragma% must be library level entity",
7239 if Ekind
(Current_Scope
) = E_Generic_Package
then
7240 Error_Pragma
("pragma& cannot appear in a generic unit");
7243 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7245 ("exported object must have compile time known size",
7249 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7250 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7252 Set_Exported
(Def_Id
, Arg_Internal
);
7255 -- Import_Object case
7258 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7260 ("cannot use pragma% for task/protected object",
7264 if Ekind
(Def_Id
) = E_Constant
then
7266 ("cannot import a constant", Arg_Internal
);
7269 if Warn_On_Export_Import
7270 and then Has_Discriminants
(Etype
(Def_Id
))
7273 ("imported value must be initialized??", Arg_Internal
);
7276 if Warn_On_Export_Import
7277 and then Is_Access_Type
(Etype
(Def_Id
))
7280 ("cannot import object of an access type??", Arg_Internal
);
7283 if Warn_On_Export_Import
7284 and then Is_Imported
(Def_Id
)
7286 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7288 -- Check for explicit initialization present. Note that an
7289 -- initialization generated by the code generator, e.g. for an
7290 -- access type, does not count here.
7292 elsif Present
(Expression
(Parent
(Def_Id
)))
7295 (Original_Node
(Expression
(Parent
(Def_Id
))))
7297 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7299 ("imported entities cannot be initialized (RM B.1(24))",
7300 "\no initialization allowed for & declared#", Arg1
);
7302 Set_Imported
(Def_Id
);
7303 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7306 end Process_Extended_Import_Export_Object_Pragma
;
7308 ------------------------------------------------------
7309 -- Process_Extended_Import_Export_Subprogram_Pragma --
7310 ------------------------------------------------------
7312 procedure Process_Extended_Import_Export_Subprogram_Pragma
7313 (Arg_Internal
: Node_Id
;
7314 Arg_External
: Node_Id
;
7315 Arg_Parameter_Types
: Node_Id
;
7316 Arg_Result_Type
: Node_Id
:= Empty
;
7317 Arg_Mechanism
: Node_Id
;
7318 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7324 Ambiguous
: Boolean;
7327 function Same_Base_Type
7329 Formal
: Entity_Id
) return Boolean;
7330 -- Determines if Ptype references the type of Formal. Note that only
7331 -- the base types need to match according to the spec. Ptype here is
7332 -- the argument from the pragma, which is either a type name, or an
7333 -- access attribute.
7335 --------------------
7336 -- Same_Base_Type --
7337 --------------------
7339 function Same_Base_Type
7341 Formal
: Entity_Id
) return Boolean
7343 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7347 -- Case where pragma argument is typ'Access
7349 if Nkind
(Ptype
) = N_Attribute_Reference
7350 and then Attribute_Name
(Ptype
) = Name_Access
7352 Pref
:= Prefix
(Ptype
);
7355 if not Is_Entity_Name
(Pref
)
7356 or else Entity
(Pref
) = Any_Type
7361 -- We have a match if the corresponding argument is of an
7362 -- anonymous access type, and its designated type matches the
7363 -- type of the prefix of the access attribute
7365 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7366 and then Base_Type
(Entity
(Pref
)) =
7367 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7369 -- Case where pragma argument is a type name
7374 if not Is_Entity_Name
(Ptype
)
7375 or else Entity
(Ptype
) = Any_Type
7380 -- We have a match if the corresponding argument is of the type
7381 -- given in the pragma (comparing base types)
7383 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7387 -- Start of processing for
7388 -- Process_Extended_Import_Export_Subprogram_Pragma
7391 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7395 -- Loop through homonyms (overloadings) of the entity
7397 Hom_Id
:= Entity
(Arg_Internal
);
7398 while Present
(Hom_Id
) loop
7399 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7401 -- We need a subprogram in the current scope
7403 if not Is_Subprogram
(Def_Id
)
7404 or else Scope
(Def_Id
) /= Current_Scope
7411 -- Pragma cannot apply to subprogram body
7413 if Is_Subprogram
(Def_Id
)
7414 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7418 ("pragma% requires separate spec"
7419 & " and must come before body");
7422 -- Test result type if given, note that the result type
7423 -- parameter can only be present for the function cases.
7425 if Present
(Arg_Result_Type
)
7426 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7430 elsif Etype
(Def_Id
) /= Standard_Void_Type
7432 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7436 -- Test parameter types if given. Note that this parameter
7437 -- has not been analyzed (and must not be, since it is
7438 -- semantic nonsense), so we get it as the parser left it.
7440 elsif Present
(Arg_Parameter_Types
) then
7441 Check_Matching_Types
: declare
7446 Formal
:= First_Formal
(Def_Id
);
7448 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7449 if Present
(Formal
) then
7453 -- A list of one type, e.g. (List) is parsed as
7454 -- a parenthesized expression.
7456 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7457 and then Paren_Count
(Arg_Parameter_Types
) = 1
7460 or else Present
(Next_Formal
(Formal
))
7465 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7468 -- A list of more than one type is parsed as a aggregate
7470 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7471 and then Paren_Count
(Arg_Parameter_Types
) = 0
7473 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7474 while Present
(Ptype
) or else Present
(Formal
) loop
7477 or else not Same_Base_Type
(Ptype
, Formal
)
7482 Next_Formal
(Formal
);
7487 -- Anything else is of the wrong form
7491 ("wrong form for Parameter_Types parameter",
7492 Arg_Parameter_Types
);
7494 end Check_Matching_Types
;
7497 -- Match is now False if the entry we found did not match
7498 -- either a supplied Parameter_Types or Result_Types argument
7504 -- Ambiguous case, the flag Ambiguous shows if we already
7505 -- detected this and output the initial messages.
7508 if not Ambiguous
then
7510 Error_Msg_Name_1
:= Pname
;
7512 ("pragma% does not uniquely identify subprogram!",
7514 Error_Msg_Sloc
:= Sloc
(Ent
);
7515 Error_Msg_N
("matching subprogram #!", N
);
7519 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7520 Error_Msg_N
("matching subprogram #!", N
);
7525 Hom_Id
:= Homonym
(Hom_Id
);
7528 -- See if we found an entry
7531 if not Ambiguous
then
7532 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7534 ("pragma% cannot be given for generic subprogram");
7537 ("pragma% does not identify local subprogram");
7544 -- Import pragmas must be for imported entities
7546 if Prag_Id
= Pragma_Import_Function
7548 Prag_Id
= Pragma_Import_Procedure
7550 Prag_Id
= Pragma_Import_Valued_Procedure
7552 if not Is_Imported
(Ent
) then
7554 ("pragma Import or Interface must precede pragma%");
7557 -- Here we have the Export case which can set the entity as exported
7559 -- But does not do so if the specified external name is null, since
7560 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7561 -- compatible) to request no external name.
7563 elsif Nkind
(Arg_External
) = N_String_Literal
7564 and then String_Length
(Strval
(Arg_External
)) = 0
7568 -- In all other cases, set entity as exported
7571 Set_Exported
(Ent
, Arg_Internal
);
7574 -- Special processing for Valued_Procedure cases
7576 if Prag_Id
= Pragma_Import_Valued_Procedure
7578 Prag_Id
= Pragma_Export_Valued_Procedure
7580 Formal
:= First_Formal
(Ent
);
7583 Error_Pragma
("at least one parameter required for pragma%");
7585 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7586 Error_Pragma
("first parameter must have mode out for pragma%");
7589 Set_Is_Valued_Procedure
(Ent
);
7593 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7595 -- Process Result_Mechanism argument if present. We have already
7596 -- checked that this is only allowed for the function case.
7598 if Present
(Arg_Result_Mechanism
) then
7599 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7602 -- Process Mechanism parameter if present. Note that this parameter
7603 -- is not analyzed, and must not be analyzed since it is semantic
7604 -- nonsense, so we get it in exactly as the parser left it.
7606 if Present
(Arg_Mechanism
) then
7614 -- A single mechanism association without a formal parameter
7615 -- name is parsed as a parenthesized expression. All other
7616 -- cases are parsed as aggregates, so we rewrite the single
7617 -- parameter case as an aggregate for consistency.
7619 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7620 and then Paren_Count
(Arg_Mechanism
) = 1
7622 Rewrite
(Arg_Mechanism
,
7623 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7624 Expressions
=> New_List
(
7625 Relocate_Node
(Arg_Mechanism
))));
7628 -- Case of only mechanism name given, applies to all formals
7630 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7631 Formal
:= First_Formal
(Ent
);
7632 while Present
(Formal
) loop
7633 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7634 Next_Formal
(Formal
);
7637 -- Case of list of mechanism associations given
7640 if Null_Record_Present
(Arg_Mechanism
) then
7642 ("inappropriate form for Mechanism parameter",
7646 -- Deal with positional ones first
7648 Formal
:= First_Formal
(Ent
);
7650 if Present
(Expressions
(Arg_Mechanism
)) then
7651 Mname
:= First
(Expressions
(Arg_Mechanism
));
7652 while Present
(Mname
) loop
7655 ("too many mechanism associations", Mname
);
7658 Set_Mechanism_Value
(Formal
, Mname
);
7659 Next_Formal
(Formal
);
7664 -- Deal with named entries
7666 if Present
(Component_Associations
(Arg_Mechanism
)) then
7667 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7668 while Present
(Massoc
) loop
7669 Choice
:= First
(Choices
(Massoc
));
7671 if Nkind
(Choice
) /= N_Identifier
7672 or else Present
(Next
(Choice
))
7675 ("incorrect form for mechanism association",
7679 Formal
:= First_Formal
(Ent
);
7683 ("parameter name & not present", Choice
);
7686 if Chars
(Choice
) = Chars
(Formal
) then
7688 (Formal
, Expression
(Massoc
));
7690 -- Set entity on identifier (needed by ASIS)
7692 Set_Entity
(Choice
, Formal
);
7697 Next_Formal
(Formal
);
7706 end Process_Extended_Import_Export_Subprogram_Pragma
;
7708 --------------------------
7709 -- Process_Generic_List --
7710 --------------------------
7712 procedure Process_Generic_List
is
7717 Check_No_Identifiers
;
7718 Check_At_Least_N_Arguments
(1);
7720 -- Check all arguments are names of generic units or instances
7723 while Present
(Arg
) loop
7724 Exp
:= Get_Pragma_Arg
(Arg
);
7727 if not Is_Entity_Name
(Exp
)
7729 (not Is_Generic_Instance
(Entity
(Exp
))
7731 not Is_Generic_Unit
(Entity
(Exp
)))
7734 ("pragma% argument must be name of generic unit/instance",
7740 end Process_Generic_List
;
7742 ------------------------------------
7743 -- Process_Import_Predefined_Type --
7744 ------------------------------------
7746 procedure Process_Import_Predefined_Type
is
7747 Loc
: constant Source_Ptr
:= Sloc
(N
);
7749 Ftyp
: Node_Id
:= Empty
;
7755 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7758 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7759 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7763 Ftyp
:= Node
(Elmt
);
7765 if Present
(Ftyp
) then
7767 -- Don't build a derived type declaration, because predefined C
7768 -- types have no declaration anywhere, so cannot really be named.
7769 -- Instead build a full type declaration, starting with an
7770 -- appropriate type definition is built
7772 if Is_Floating_Point_Type
(Ftyp
) then
7773 Def
:= Make_Floating_Point_Definition
(Loc
,
7774 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7775 Make_Real_Range_Specification
(Loc
,
7776 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7777 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7779 -- Should never have a predefined type we cannot handle
7782 raise Program_Error
;
7785 -- Build and insert a Full_Type_Declaration, which will be
7786 -- analyzed as soon as this list entry has been analyzed.
7788 Decl
:= Make_Full_Type_Declaration
(Loc
,
7789 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7790 Type_Definition
=> Def
);
7792 Insert_After
(N
, Decl
);
7793 Mark_Rewrite_Insertion
(Decl
);
7796 Error_Pragma_Arg
("no matching type found for pragma%",
7799 end Process_Import_Predefined_Type
;
7801 ---------------------------------
7802 -- Process_Import_Or_Interface --
7803 ---------------------------------
7805 procedure Process_Import_Or_Interface
is
7811 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7812 -- pragma Import (Entity, "external name");
7814 if Relaxed_RM_Semantics
7815 and then Arg_Count
= 2
7816 and then Prag_Id
= Pragma_Import
7817 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7820 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7823 if not Is_Entity_Name
(Def_Id
) then
7824 Error_Pragma_Arg
("entity name required", Arg1
);
7827 Def_Id
:= Entity
(Def_Id
);
7828 Kill_Size_Check_Code
(Def_Id
);
7829 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7832 Process_Convention
(C
, Def_Id
);
7833 Kill_Size_Check_Code
(Def_Id
);
7834 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7837 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7839 -- We do not permit Import to apply to a renaming declaration
7841 if Present
(Renamed_Object
(Def_Id
)) then
7843 ("pragma% not allowed for object renaming", Arg2
);
7845 -- User initialization is not allowed for imported object, but
7846 -- the object declaration may contain a default initialization,
7847 -- that will be discarded. Note that an explicit initialization
7848 -- only counts if it comes from source, otherwise it is simply
7849 -- the code generator making an implicit initialization explicit.
7851 elsif Present
(Expression
(Parent
(Def_Id
)))
7852 and then Comes_From_Source
7853 (Original_Node
(Expression
(Parent
(Def_Id
))))
7855 -- Set imported flag to prevent cascaded errors
7857 Set_Is_Imported
(Def_Id
);
7859 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7861 ("no initialization allowed for declaration of& #",
7862 "\imported entities cannot be initialized (RM B.1(24))",
7866 -- If the pragma comes from an aspect specification the
7867 -- Is_Imported flag has already been set.
7869 if not From_Aspect_Specification
(N
) then
7870 Set_Imported
(Def_Id
);
7873 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7875 -- Note that we do not set Is_Public here. That's because we
7876 -- only want to set it if there is no address clause, and we
7877 -- don't know that yet, so we delay that processing till
7880 -- pragma Import completes deferred constants
7882 if Ekind
(Def_Id
) = E_Constant
then
7883 Set_Has_Completion
(Def_Id
);
7886 -- It is not possible to import a constant of an unconstrained
7887 -- array type (e.g. string) because there is no simple way to
7888 -- write a meaningful subtype for it.
7890 if Is_Array_Type
(Etype
(Def_Id
))
7891 and then not Is_Constrained
(Etype
(Def_Id
))
7894 ("imported constant& must have a constrained subtype",
7899 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7901 -- If the name is overloaded, pragma applies to all of the denoted
7902 -- entities in the same declarative part, unless the pragma comes
7903 -- from an aspect specification or was generated by the compiler
7904 -- (such as for pragma Provide_Shift_Operators).
7907 while Present
(Hom_Id
) loop
7909 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7911 -- Ignore inherited subprograms because the pragma will apply
7912 -- to the parent operation, which is the one called.
7914 if Is_Overloadable
(Def_Id
)
7915 and then Present
(Alias
(Def_Id
))
7919 -- If it is not a subprogram, it must be in an outer scope and
7920 -- pragma does not apply.
7922 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7925 -- The pragma does not apply to primitives of interfaces
7927 elsif Is_Dispatching_Operation
(Def_Id
)
7928 and then Present
(Find_Dispatching_Type
(Def_Id
))
7929 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7933 -- Verify that the homonym is in the same declarative part (not
7934 -- just the same scope). If the pragma comes from an aspect
7935 -- specification we know that it is part of the declaration.
7937 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7938 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7939 and then not From_Aspect_Specification
(N
)
7944 -- If the pragma comes from an aspect specification the
7945 -- Is_Imported flag has already been set.
7947 if not From_Aspect_Specification
(N
) then
7948 Set_Imported
(Def_Id
);
7951 -- Reject an Import applied to an abstract subprogram
7953 if Is_Subprogram
(Def_Id
)
7954 and then Is_Abstract_Subprogram
(Def_Id
)
7956 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7958 ("cannot import abstract subprogram& declared#",
7962 -- Special processing for Convention_Intrinsic
7964 if C
= Convention_Intrinsic
then
7966 -- Link_Name argument not allowed for intrinsic
7970 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7972 -- If no external name is present, then check that this
7973 -- is a valid intrinsic subprogram. If an external name
7974 -- is present, then this is handled by the back end.
7977 Check_Intrinsic_Subprogram
7978 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7982 -- Verify that the subprogram does not have a completion
7983 -- through a renaming declaration. For other completions the
7984 -- pragma appears as a too late representation.
7987 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7991 and then Nkind
(Decl
) = N_Subprogram_Declaration
7992 and then Present
(Corresponding_Body
(Decl
))
7993 and then Nkind
(Unit_Declaration_Node
7994 (Corresponding_Body
(Decl
))) =
7995 N_Subprogram_Renaming_Declaration
7997 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7999 ("cannot import&, renaming already provided for "
8000 & "declaration #", N
, Def_Id
);
8004 -- If the pragma comes from an aspect specification, there
8005 -- must be an Import aspect specified as well. In the rare
8006 -- case where Import is set to False, the suprogram needs to
8007 -- have a local completion.
8010 Imp_Aspect
: constant Node_Id
:=
8011 Find_Aspect
(Def_Id
, Aspect_Import
);
8015 if Present
(Imp_Aspect
)
8016 and then Present
(Expression
(Imp_Aspect
))
8018 Expr
:= Expression
(Imp_Aspect
);
8019 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8021 if Is_Entity_Name
(Expr
)
8022 and then Entity
(Expr
) = Standard_True
8024 Set_Has_Completion
(Def_Id
);
8027 -- If there is no expression, the default is True, as for
8028 -- all boolean aspects. Same for the older pragma.
8031 Set_Has_Completion
(Def_Id
);
8035 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8038 if Is_Compilation_Unit
(Hom_Id
) then
8040 -- Its possible homonyms are not affected by the pragma.
8041 -- Such homonyms might be present in the context of other
8042 -- units being compiled.
8046 elsif From_Aspect_Specification
(N
) then
8049 -- If the pragma was created by the compiler, then we don't
8050 -- want it to apply to other homonyms. This kind of case can
8051 -- occur when using pragma Provide_Shift_Operators, which
8052 -- generates implicit shift and rotate operators with Import
8053 -- pragmas that might apply to earlier explicit or implicit
8054 -- declarations marked with Import (for example, coming from
8055 -- an earlier pragma Provide_Shift_Operators for another type),
8056 -- and we don't generally want other homonyms being treated
8057 -- as imported or the pragma flagged as an illegal duplicate.
8059 elsif not Comes_From_Source
(N
) then
8063 Hom_Id
:= Homonym
(Hom_Id
);
8067 -- When the convention is Java or CIL, we also allow Import to
8068 -- be given for packages, generic packages, exceptions, record
8069 -- components, and access to subprograms.
8071 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
8073 (Is_Package_Or_Generic_Package
(Def_Id
)
8074 or else Ekind
(Def_Id
) = E_Exception
8075 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
8076 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
8078 Set_Imported
(Def_Id
);
8079 Set_Is_Public
(Def_Id
);
8080 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8082 -- Import a CPP class
8084 elsif C
= Convention_CPP
8085 and then (Is_Record_Type
(Def_Id
)
8086 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8088 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8089 if Present
(Full_View
(Def_Id
)) then
8090 Def_Id
:= Full_View
(Def_Id
);
8094 ("cannot import 'C'P'P type before full declaration seen",
8095 Get_Pragma_Arg
(Arg2
));
8097 -- Although we have reported the error we decorate it as
8098 -- CPP_Class to avoid reporting spurious errors
8100 Set_Is_CPP_Class
(Def_Id
);
8105 -- Types treated as CPP classes must be declared limited (note:
8106 -- this used to be a warning but there is no real benefit to it
8107 -- since we did effectively intend to treat the type as limited
8110 if not Is_Limited_Type
(Def_Id
) then
8112 ("imported 'C'P'P type must be limited",
8113 Get_Pragma_Arg
(Arg2
));
8116 if Etype
(Def_Id
) /= Def_Id
8117 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8119 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8122 Set_Is_CPP_Class
(Def_Id
);
8124 -- Imported CPP types must not have discriminants (because C++
8125 -- classes do not have discriminants).
8127 if Has_Discriminants
(Def_Id
) then
8129 ("imported 'C'P'P type cannot have discriminants",
8130 First
(Discriminant_Specifications
8131 (Declaration_Node
(Def_Id
))));
8134 -- Check that components of imported CPP types do not have default
8135 -- expressions. For private types this check is performed when the
8136 -- full view is analyzed (see Process_Full_View).
8138 if not Is_Private_Type
(Def_Id
) then
8139 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8142 -- Import a CPP exception
8144 elsif C
= Convention_CPP
8145 and then Ekind
(Def_Id
) = E_Exception
8149 ("'External_'Name arguments is required for 'Cpp exception",
8152 -- As only a string is allowed, Check_Arg_Is_External_Name
8155 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8158 if Present
(Arg4
) then
8160 ("Link_Name argument not allowed for imported Cpp exception",
8164 -- Do not call Set_Interface_Name as the name of the exception
8165 -- shouldn't be modified (and in particular it shouldn't be
8166 -- the External_Name). For exceptions, the External_Name is the
8167 -- name of the RTTI structure.
8169 -- ??? Emit an error if pragma Import/Export_Exception is present
8171 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8173 Check_Arg_Count
(3);
8174 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8176 Process_Import_Predefined_Type
;
8180 ("second argument of pragma% must be object, subprogram "
8181 & "or incomplete type",
8185 -- If this pragma applies to a compilation unit, then the unit, which
8186 -- is a subprogram, does not require (or allow) a body. We also do
8187 -- not need to elaborate imported procedures.
8189 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8191 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8193 Set_Body_Required
(Cunit
, False);
8196 end Process_Import_Or_Interface
;
8198 --------------------
8199 -- Process_Inline --
8200 --------------------
8202 procedure Process_Inline
(Status
: Inline_Status
) is
8209 Effective
: Boolean := False;
8210 -- Set True if inline has some effect, i.e. if there is at least one
8211 -- subprogram set as inlined as a result of the use of the pragma.
8213 procedure Make_Inline
(Subp
: Entity_Id
);
8214 -- Subp is the defining unit name of the subprogram declaration. Set
8215 -- the flag, as well as the flag in the corresponding body, if there
8218 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8219 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8220 -- Has_Pragma_Inline_Always for the Inline_Always case.
8222 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8223 -- Returns True if it can be determined at this stage that inlining
8224 -- is not possible, for example if the body is available and contains
8225 -- exception handlers, we prevent inlining, since otherwise we can
8226 -- get undefined symbols at link time. This function also emits a
8227 -- warning if front-end inlining is enabled and the pragma appears
8230 -- ??? is business with link symbols still valid, or does it relate
8231 -- to front end ZCX which is being phased out ???
8233 ---------------------------
8234 -- Inlining_Not_Possible --
8235 ---------------------------
8237 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8238 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8242 if Nkind
(Decl
) = N_Subprogram_Body
then
8243 Stats
:= Handled_Statement_Sequence
(Decl
);
8244 return Present
(Exception_Handlers
(Stats
))
8245 or else Present
(At_End_Proc
(Stats
));
8247 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8248 and then Present
(Corresponding_Body
(Decl
))
8250 if Front_End_Inlining
8251 and then Analyzed
(Corresponding_Body
(Decl
))
8253 Error_Msg_N
("pragma appears too late, ignored??", N
);
8256 -- If the subprogram is a renaming as body, the body is just a
8257 -- call to the renamed subprogram, and inlining is trivially
8261 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8262 N_Subprogram_Renaming_Declaration
8268 Handled_Statement_Sequence
8269 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8272 Present
(Exception_Handlers
(Stats
))
8273 or else Present
(At_End_Proc
(Stats
));
8277 -- If body is not available, assume the best, the check is
8278 -- performed again when compiling enclosing package bodies.
8282 end Inlining_Not_Possible
;
8288 procedure Make_Inline
(Subp
: Entity_Id
) is
8289 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8290 Inner_Subp
: Entity_Id
:= Subp
;
8293 -- Ignore if bad type, avoid cascaded error
8295 if Etype
(Subp
) = Any_Type
then
8299 -- Ignore if all inlining is suppressed
8301 elsif Suppress_All_Inlining
then
8305 -- If inlining is not possible, for now do not treat as an error
8307 elsif Status
/= Suppressed
8308 and then Inlining_Not_Possible
(Subp
)
8313 -- Here we have a candidate for inlining, but we must exclude
8314 -- derived operations. Otherwise we would end up trying to inline
8315 -- a phantom declaration, and the result would be to drag in a
8316 -- body which has no direct inlining associated with it. That
8317 -- would not only be inefficient but would also result in the
8318 -- backend doing cross-unit inlining in cases where it was
8319 -- definitely inappropriate to do so.
8321 -- However, a simple Comes_From_Source test is insufficient, since
8322 -- we do want to allow inlining of generic instances which also do
8323 -- not come from source. We also need to recognize specs generated
8324 -- by the front-end for bodies that carry the pragma. Finally,
8325 -- predefined operators do not come from source but are not
8326 -- inlineable either.
8328 elsif Is_Generic_Instance
(Subp
)
8329 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8333 elsif not Comes_From_Source
(Subp
)
8334 and then Scope
(Subp
) /= Standard_Standard
8340 -- The referenced entity must either be the enclosing entity, or
8341 -- an entity declared within the current open scope.
8343 if Present
(Scope
(Subp
))
8344 and then Scope
(Subp
) /= Current_Scope
8345 and then Subp
/= Current_Scope
8348 ("argument of% must be entity in current scope", Assoc
);
8352 -- Processing for procedure, operator or function. If subprogram
8353 -- is aliased (as for an instance) indicate that the renamed
8354 -- entity (if declared in the same unit) is inlined.
8356 if Is_Subprogram
(Subp
) then
8357 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8359 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8360 Set_Inline_Flags
(Inner_Subp
);
8362 Decl
:= Parent
(Parent
(Inner_Subp
));
8364 if Nkind
(Decl
) = N_Subprogram_Declaration
8365 and then Present
(Corresponding_Body
(Decl
))
8367 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8369 elsif Is_Generic_Instance
(Subp
) then
8371 -- Indicate that the body needs to be created for
8372 -- inlining subsequent calls. The instantiation node
8373 -- follows the declaration of the wrapper package
8376 if Scope
(Subp
) /= Standard_Standard
8378 Need_Subprogram_Instance_Body
8379 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8385 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8386 -- appear in a formal part to apply to a formal subprogram.
8387 -- Do not apply check within an instance or a formal package
8388 -- the test will have been applied to the original generic.
8390 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8391 and then List_Containing
(Decl
) = List_Containing
(N
)
8392 and then not In_Instance
8395 ("Inline cannot apply to a formal subprogram", N
);
8397 -- If Subp is a renaming, it is the renamed entity that
8398 -- will appear in any call, and be inlined. However, for
8399 -- ASIS uses it is convenient to indicate that the renaming
8400 -- itself is an inlined subprogram, so that some gnatcheck
8401 -- rules can be applied in the absence of expansion.
8403 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8404 Set_Inline_Flags
(Subp
);
8410 -- For a generic subprogram set flag as well, for use at the point
8411 -- of instantiation, to determine whether the body should be
8414 elsif Is_Generic_Subprogram
(Subp
) then
8415 Set_Inline_Flags
(Subp
);
8418 -- Literals are by definition inlined
8420 elsif Kind
= E_Enumeration_Literal
then
8423 -- Anything else is an error
8427 ("expect subprogram name for pragma%", Assoc
);
8431 ----------------------
8432 -- Set_Inline_Flags --
8433 ----------------------
8435 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8437 -- First set the Has_Pragma_XXX flags and issue the appropriate
8438 -- errors and warnings for suspicious combinations.
8440 if Prag_Id
= Pragma_No_Inline
then
8441 if Has_Pragma_Inline_Always
(Subp
) then
8443 ("Inline_Always and No_Inline are mutually exclusive", N
);
8444 elsif Has_Pragma_Inline
(Subp
) then
8446 ("Inline and No_Inline both specified for& ??",
8447 N
, Entity
(Subp_Id
));
8450 Set_Has_Pragma_No_Inline
(Subp
);
8452 if Prag_Id
= Pragma_Inline_Always
then
8453 if Has_Pragma_No_Inline
(Subp
) then
8455 ("Inline_Always and No_Inline are mutually exclusive",
8459 Set_Has_Pragma_Inline_Always
(Subp
);
8461 if Has_Pragma_No_Inline
(Subp
) then
8463 ("Inline and No_Inline both specified for& ??",
8464 N
, Entity
(Subp_Id
));
8468 if not Has_Pragma_Inline
(Subp
) then
8469 Set_Has_Pragma_Inline
(Subp
);
8474 -- Then adjust the Is_Inlined flag. It can never be set if the
8475 -- subprogram is subject to pragma No_Inline.
8479 Set_Is_Inlined
(Subp
, False);
8483 if not Has_Pragma_No_Inline
(Subp
) then
8484 Set_Is_Inlined
(Subp
, True);
8487 end Set_Inline_Flags
;
8489 -- Start of processing for Process_Inline
8492 Check_No_Identifiers
;
8493 Check_At_Least_N_Arguments
(1);
8495 if Status
= Enabled
then
8496 Inline_Processing_Required
:= True;
8500 while Present
(Assoc
) loop
8501 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8505 if Is_Entity_Name
(Subp_Id
) then
8506 Subp
:= Entity
(Subp_Id
);
8508 if Subp
= Any_Id
then
8510 -- If previous error, avoid cascaded errors
8512 Check_Error_Detected
;
8519 -- For the pragma case, climb homonym chain. This is
8520 -- what implements allowing the pragma in the renaming
8521 -- case, with the result applying to the ancestors, and
8522 -- also allows Inline to apply to all previous homonyms.
8524 if not From_Aspect_Specification
(N
) then
8525 while Present
(Homonym
(Subp
))
8526 and then Scope
(Homonym
(Subp
)) = Current_Scope
8528 Make_Inline
(Homonym
(Subp
));
8529 Subp
:= Homonym
(Subp
);
8537 ("inappropriate argument for pragma%", Assoc
);
8540 and then Warn_On_Redundant_Constructs
8541 and then not (Status
= Suppressed
or else Suppress_All_Inlining
)
8543 if Inlining_Not_Possible
(Subp
) then
8545 ("pragma Inline for& is ignored?r?",
8546 N
, Entity
(Subp_Id
));
8549 ("pragma Inline for& is redundant?r?",
8550 N
, Entity
(Subp_Id
));
8558 ----------------------------
8559 -- Process_Interface_Name --
8560 ----------------------------
8562 procedure Process_Interface_Name
8563 (Subprogram_Def
: Entity_Id
;
8569 String_Val
: String_Id
;
8571 procedure Check_Form_Of_Interface_Name
8573 Ext_Name_Case
: Boolean);
8574 -- SN is a string literal node for an interface name. This routine
8575 -- performs some minimal checks that the name is reasonable. In
8576 -- particular that no spaces or other obviously incorrect characters
8577 -- appear. This is only a warning, since any characters are allowed.
8578 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8580 ----------------------------------
8581 -- Check_Form_Of_Interface_Name --
8582 ----------------------------------
8584 procedure Check_Form_Of_Interface_Name
8586 Ext_Name_Case
: Boolean)
8588 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8589 SL
: constant Nat
:= String_Length
(S
);
8594 Error_Msg_N
("interface name cannot be null string", SN
);
8597 for J
in 1 .. SL
loop
8598 C
:= Get_String_Char
(S
, J
);
8600 -- Look for dubious character and issue unconditional warning.
8601 -- Definitely dubious if not in character range.
8603 if not In_Character_Range
(C
)
8605 -- For all cases except CLI target,
8606 -- commas, spaces and slashes are dubious (in CLI, we use
8607 -- commas and backslashes in external names to specify
8608 -- assembly version and public key, while slashes and spaces
8609 -- can be used in names to mark nested classes and
8612 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8613 and then (Get_Character
(C
) = ','
8615 Get_Character
(C
) = '\'))
8616 or else (VM_Target
/= CLI_Target
8617 and then (Get_Character
(C
) = ' '
8619 Get_Character
(C
) = '/'))
8622 ("??interface name contains illegal character",
8623 Sloc
(SN
) + Source_Ptr
(J
));
8626 end Check_Form_Of_Interface_Name
;
8628 -- Start of processing for Process_Interface_Name
8631 if No
(Link_Arg
) then
8632 if No
(Ext_Arg
) then
8633 if VM_Target
= CLI_Target
8634 and then Ekind
(Subprogram_Def
) = E_Package
8635 and then Nkind
(Parent
(Subprogram_Def
)) =
8636 N_Package_Specification
8637 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8642 (Generic_Parent
(Parent
(Subprogram_Def
))));
8647 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8649 Link_Nam
:= Expression
(Ext_Arg
);
8652 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8653 Ext_Nam
:= Expression
(Ext_Arg
);
8658 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8659 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8660 Ext_Nam
:= Expression
(Ext_Arg
);
8661 Link_Nam
:= Expression
(Link_Arg
);
8664 -- Check expressions for external name and link name are static
8666 if Present
(Ext_Nam
) then
8667 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8668 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8670 -- Verify that external name is not the name of a local entity,
8671 -- which would hide the imported one and could lead to run-time
8672 -- surprises. The problem can only arise for entities declared in
8673 -- a package body (otherwise the external name is fully qualified
8674 -- and will not conflict).
8682 if Prag_Id
= Pragma_Import
then
8683 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8685 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
8687 if Nam
/= Chars
(Subprogram_Def
)
8688 and then Present
(E
)
8689 and then not Is_Overloadable
(E
)
8690 and then Is_Immediately_Visible
(E
)
8691 and then not Is_Imported
(E
)
8692 and then Ekind
(Scope
(E
)) = E_Package
8695 while Present
(Par
) loop
8696 if Nkind
(Par
) = N_Package_Body
then
8697 Error_Msg_Sloc
:= Sloc
(E
);
8699 ("imported entity is hidden by & declared#",
8704 Par
:= Parent
(Par
);
8711 if Present
(Link_Nam
) then
8712 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8713 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8716 -- If there is no link name, just set the external name
8718 if No
(Link_Nam
) then
8719 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8721 -- For the Link_Name case, the given literal is preceded by an
8722 -- asterisk, which indicates to GCC that the given name should be
8723 -- taken literally, and in particular that no prepending of
8724 -- underlines should occur, even in systems where this is the
8730 if VM_Target
= No_VM
then
8731 Store_String_Char
(Get_Char_Code
('*'));
8734 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8735 Store_String_Chars
(String_Val
);
8737 Make_String_Literal
(Sloc
(Link_Nam
),
8738 Strval
=> End_String
);
8741 -- Set the interface name. If the entity is a generic instance, use
8742 -- its alias, which is the callable entity.
8744 if Is_Generic_Instance
(Subprogram_Def
) then
8745 Set_Encoded_Interface_Name
8746 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8748 Set_Encoded_Interface_Name
8749 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8752 -- We allow duplicated export names in CIL/Java, as they are always
8753 -- enclosed in a namespace that differentiates them, and overloaded
8754 -- entities are supported by the VM.
8756 if Convention
(Subprogram_Def
) /= Convention_CIL
8758 Convention
(Subprogram_Def
) /= Convention_Java
8760 Check_Duplicated_Export_Name
(Link_Nam
);
8762 end Process_Interface_Name
;
8764 -----------------------------------------
8765 -- Process_Interrupt_Or_Attach_Handler --
8766 -----------------------------------------
8768 procedure Process_Interrupt_Or_Attach_Handler
is
8769 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8770 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8771 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8774 Set_Is_Interrupt_Handler
(Handler_Proc
);
8776 -- If the pragma is not associated with a handler procedure within a
8777 -- protected type, then it must be for a nonprotected procedure for
8778 -- the AAMP target, in which case we don't associate a representation
8779 -- item with the procedure's scope.
8781 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8782 if Prag_Id
= Pragma_Interrupt_Handler
8784 Prag_Id
= Pragma_Attach_Handler
8786 Record_Rep_Item
(Proc_Scope
, N
);
8789 end Process_Interrupt_Or_Attach_Handler
;
8791 --------------------------------------------------
8792 -- Process_Restrictions_Or_Restriction_Warnings --
8793 --------------------------------------------------
8795 -- Note: some of the simple identifier cases were handled in par-prag,
8796 -- but it is harmless (and more straightforward) to simply handle all
8797 -- cases here, even if it means we repeat a bit of work in some cases.
8799 procedure Process_Restrictions_Or_Restriction_Warnings
8803 R_Id
: Restriction_Id
;
8809 -- Ignore all Restrictions pragmas in CodePeer mode
8811 if CodePeer_Mode
then
8815 Check_Ada_83_Warning
;
8816 Check_At_Least_N_Arguments
(1);
8817 Check_Valid_Configuration_Pragma
;
8820 while Present
(Arg
) loop
8822 Expr
:= Get_Pragma_Arg
(Arg
);
8824 -- Case of no restriction identifier present
8826 if Id
= No_Name
then
8827 if Nkind
(Expr
) /= N_Identifier
then
8829 ("invalid form for restriction", Arg
);
8834 (Process_Restriction_Synonyms
(Expr
));
8836 if R_Id
not in All_Boolean_Restrictions
then
8837 Error_Msg_Name_1
:= Pname
;
8839 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8841 -- Check for possible misspelling
8843 for J
in Restriction_Id
loop
8845 Rnm
: constant String := Restriction_Id
'Image (J
);
8848 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8849 Name_Len
:= Rnm
'Length;
8850 Set_Casing
(All_Lower_Case
);
8852 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8854 (Identifier_Casing
(Current_Source_File
));
8855 Error_Msg_String
(1 .. Rnm
'Length) :=
8856 Name_Buffer
(1 .. Name_Len
);
8857 Error_Msg_Strlen
:= Rnm
'Length;
8858 Error_Msg_N
-- CODEFIX
8859 ("\possible misspelling of ""~""",
8860 Get_Pragma_Arg
(Arg
));
8869 if Implementation_Restriction
(R_Id
) then
8870 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8873 -- Special processing for No_Elaboration_Code restriction
8875 if R_Id
= No_Elaboration_Code
then
8877 -- Restriction is only recognized within a configuration
8878 -- pragma file, or within a unit of the main extended
8879 -- program. Note: the test for Main_Unit is needed to
8880 -- properly include the case of configuration pragma files.
8882 if not (Current_Sem_Unit
= Main_Unit
8883 or else In_Extended_Main_Source_Unit
(N
))
8887 -- Don't allow in a subunit unless already specified in
8890 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8891 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8892 and then not Restriction_Active
(No_Elaboration_Code
)
8895 ("invalid specification of ""No_Elaboration_Code""",
8898 ("\restriction cannot be specified in a subunit", N
);
8900 ("\unless also specified in body or spec", N
);
8903 -- If we accept a No_Elaboration_Code restriction, then it
8904 -- needs to be added to the configuration restriction set so
8905 -- that we get proper application to other units in the main
8906 -- extended source as required.
8909 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8913 -- If this is a warning, then set the warning unless we already
8914 -- have a real restriction active (we never want a warning to
8915 -- override a real restriction).
8918 if not Restriction_Active
(R_Id
) then
8919 Set_Restriction
(R_Id
, N
);
8920 Restriction_Warnings
(R_Id
) := True;
8923 -- If real restriction case, then set it and make sure that the
8924 -- restriction warning flag is off, since a real restriction
8925 -- always overrides a warning.
8928 Set_Restriction
(R_Id
, N
);
8929 Restriction_Warnings
(R_Id
) := False;
8932 -- Check for obsolescent restrictions in Ada 2005 mode
8935 and then Ada_Version
>= Ada_2005
8936 and then (R_Id
= No_Asynchronous_Control
8938 R_Id
= No_Unchecked_Deallocation
8940 R_Id
= No_Unchecked_Conversion
)
8942 Check_Restriction
(No_Obsolescent_Features
, N
);
8945 -- A very special case that must be processed here: pragma
8946 -- Restrictions (No_Exceptions) turns off all run-time
8947 -- checking. This is a bit dubious in terms of the formal
8948 -- language definition, but it is what is intended by RM
8949 -- H.4(12). Restriction_Warnings never affects generated code
8950 -- so this is done only in the real restriction case.
8952 -- Atomic_Synchronization is not a real check, so it is not
8953 -- affected by this processing).
8955 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8956 -- run-time checks in CodePeer and GNATprove modes: we want to
8957 -- generate checks for analysis purposes, as set respectively
8958 -- by -gnatC and -gnatd.F
8961 and then not (CodePeer_Mode
or GNATprove_Mode
)
8962 and then R_Id
= No_Exceptions
8964 for J
in Scope_Suppress
.Suppress
'Range loop
8965 if J
/= Atomic_Synchronization
then
8966 Scope_Suppress
.Suppress
(J
) := True;
8971 -- Case of No_Dependence => unit-name. Note that the parser
8972 -- already made the necessary entry in the No_Dependence table.
8974 elsif Id
= Name_No_Dependence
then
8975 if not OK_No_Dependence_Unit_Name
(Expr
) then
8979 -- Case of No_Specification_Of_Aspect => Identifier.
8981 elsif Id
= Name_No_Specification_Of_Aspect
then
8986 if Nkind
(Expr
) /= N_Identifier
then
8989 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8992 if A_Id
= No_Aspect
then
8993 Error_Pragma_Arg
("invalid restriction name", Arg
);
8995 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8999 elsif Id
= Name_No_Use_Of_Attribute
then
9000 if Nkind
(Expr
) /= N_Identifier
9001 or else not Is_Attribute_Name
(Chars
(Expr
))
9003 Error_Msg_N
("unknown attribute name??", Expr
);
9006 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9009 elsif Id
= Name_No_Use_Of_Pragma
then
9010 if Nkind
(Expr
) /= N_Identifier
9011 or else not Is_Pragma_Name
(Chars
(Expr
))
9013 Error_Msg_N
("unknown pragma name??", Expr
);
9016 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9019 -- All other cases of restriction identifier present
9022 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9023 Analyze_And_Resolve
(Expr
, Any_Integer
);
9025 if R_Id
not in All_Parameter_Restrictions
then
9027 ("invalid restriction parameter identifier", Arg
);
9029 elsif not Is_OK_Static_Expression
(Expr
) then
9030 Flag_Non_Static_Expr
9031 ("value must be static expression!", Expr
);
9034 elsif not Is_Integer_Type
(Etype
(Expr
))
9035 or else Expr_Value
(Expr
) < 0
9038 ("value must be non-negative integer", Arg
);
9041 -- Restriction pragma is active
9043 Val
:= Expr_Value
(Expr
);
9045 if not UI_Is_In_Int_Range
(Val
) then
9047 ("pragma ignored, value too large??", Arg
);
9050 -- Warning case. If the real restriction is active, then we
9051 -- ignore the request, since warning never overrides a real
9052 -- restriction. Otherwise we set the proper warning. Note that
9053 -- this circuit sets the warning again if it is already set,
9054 -- which is what we want, since the constant may have changed.
9057 if not Restriction_Active
(R_Id
) then
9059 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9060 Restriction_Warnings
(R_Id
) := True;
9063 -- Real restriction case, set restriction and make sure warning
9064 -- flag is off since real restriction always overrides warning.
9067 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9068 Restriction_Warnings
(R_Id
) := False;
9074 end Process_Restrictions_Or_Restriction_Warnings
;
9076 ---------------------------------
9077 -- Process_Suppress_Unsuppress --
9078 ---------------------------------
9080 -- Note: this procedure makes entries in the check suppress data
9081 -- structures managed by Sem. See spec of package Sem for full
9082 -- details on how we handle recording of check suppression.
9084 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9089 In_Package_Spec
: constant Boolean :=
9090 Is_Package_Or_Generic_Package
(Current_Scope
)
9091 and then not In_Package_Body
(Current_Scope
);
9093 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9094 -- Used to suppress a single check on the given entity
9096 --------------------------------
9097 -- Suppress_Unsuppress_Echeck --
9098 --------------------------------
9100 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9102 -- Check for error of trying to set atomic synchronization for
9103 -- a non-atomic variable.
9105 if C
= Atomic_Synchronization
9106 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9109 ("pragma & requires atomic type or variable",
9110 Pragma_Identifier
(Original_Node
(N
)));
9113 Set_Checks_May_Be_Suppressed
(E
);
9115 if In_Package_Spec
then
9116 Push_Global_Suppress_Stack_Entry
9119 Suppress
=> Suppress_Case
);
9121 Push_Local_Suppress_Stack_Entry
9124 Suppress
=> Suppress_Case
);
9127 -- If this is a first subtype, and the base type is distinct,
9128 -- then also set the suppress flags on the base type.
9130 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9131 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9133 end Suppress_Unsuppress_Echeck
;
9135 -- Start of processing for Process_Suppress_Unsuppress
9138 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9139 -- on user code: we want to generate checks for analysis purposes, as
9140 -- set respectively by -gnatC and -gnatd.F
9142 if (CodePeer_Mode
or GNATprove_Mode
)
9143 and then Comes_From_Source
(N
)
9148 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9149 -- declarative part or a package spec (RM 11.5(5)).
9151 if not Is_Configuration_Pragma
then
9152 Check_Is_In_Decl_Part_Or_Package_Spec
;
9155 Check_At_Least_N_Arguments
(1);
9156 Check_At_Most_N_Arguments
(2);
9157 Check_No_Identifier
(Arg1
);
9158 Check_Arg_Is_Identifier
(Arg1
);
9160 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9162 if C
= No_Check_Id
then
9164 ("argument of pragma% is not valid check name", Arg1
);
9167 if Arg_Count
= 1 then
9169 -- Make an entry in the local scope suppress table. This is the
9170 -- table that directly shows the current value of the scope
9171 -- suppress check for any check id value.
9173 if C
= All_Checks
then
9175 -- For All_Checks, we set all specific predefined checks with
9176 -- the exception of Elaboration_Check, which is handled
9177 -- specially because of not wanting All_Checks to have the
9178 -- effect of deactivating static elaboration order processing.
9179 -- Atomic_Synchronization is also not affected, since this is
9180 -- not a real check.
9182 for J
in Scope_Suppress
.Suppress
'Range loop
9183 if J
/= Elaboration_Check
9185 J
/= Atomic_Synchronization
9187 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9191 -- If not All_Checks, and predefined check, then set appropriate
9192 -- scope entry. Note that we will set Elaboration_Check if this
9193 -- is explicitly specified. Atomic_Synchronization is allowed
9194 -- only if internally generated and entity is atomic.
9196 elsif C
in Predefined_Check_Id
9197 and then (not Comes_From_Source
(N
)
9198 or else C
/= Atomic_Synchronization
)
9200 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9203 -- Also make an entry in the Local_Entity_Suppress table
9205 Push_Local_Suppress_Stack_Entry
9208 Suppress
=> Suppress_Case
);
9210 -- Case of two arguments present, where the check is suppressed for
9211 -- a specified entity (given as the second argument of the pragma)
9214 -- This is obsolescent in Ada 2005 mode
9216 if Ada_Version
>= Ada_2005
then
9217 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9220 Check_Optional_Identifier
(Arg2
, Name_On
);
9221 E_Id
:= Get_Pragma_Arg
(Arg2
);
9224 if not Is_Entity_Name
(E_Id
) then
9226 ("second argument of pragma% must be entity name", Arg2
);
9235 -- Enforce RM 11.5(7) which requires that for a pragma that
9236 -- appears within a package spec, the named entity must be
9237 -- within the package spec. We allow the package name itself
9238 -- to be mentioned since that makes sense, although it is not
9239 -- strictly allowed by 11.5(7).
9242 and then E
/= Current_Scope
9243 and then Scope
(E
) /= Current_Scope
9246 ("entity in pragma% is not in package spec (RM 11.5(7))",
9250 -- Loop through homonyms. As noted below, in the case of a package
9251 -- spec, only homonyms within the package spec are considered.
9254 Suppress_Unsuppress_Echeck
(E
, C
);
9256 if Is_Generic_Instance
(E
)
9257 and then Is_Subprogram
(E
)
9258 and then Present
(Alias
(E
))
9260 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9263 -- Move to next homonym if not aspect spec case
9265 exit when From_Aspect_Specification
(N
);
9269 -- If we are within a package specification, the pragma only
9270 -- applies to homonyms in the same scope.
9272 exit when In_Package_Spec
9273 and then Scope
(E
) /= Current_Scope
;
9276 end Process_Suppress_Unsuppress
;
9282 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9284 if Is_Imported
(E
) then
9286 ("cannot export entity& that was previously imported", Arg
);
9288 elsif Present
(Address_Clause
(E
))
9289 and then not Relaxed_RM_Semantics
9292 ("cannot export entity& that has an address clause", Arg
);
9295 Set_Is_Exported
(E
);
9297 -- Generate a reference for entity explicitly, because the
9298 -- identifier may be overloaded and name resolution will not
9301 Generate_Reference
(E
, Arg
);
9303 -- Deal with exporting non-library level entity
9305 if not Is_Library_Level_Entity
(E
) then
9307 -- Not allowed at all for subprograms
9309 if Is_Subprogram
(E
) then
9310 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9312 -- Otherwise set public and statically allocated
9316 Set_Is_Statically_Allocated
(E
);
9318 -- Warn if the corresponding W flag is set
9320 if Warn_On_Export_Import
9322 -- Only do this for something that was in the source. Not
9323 -- clear if this can be False now (there used for sure to be
9324 -- cases on some systems where it was False), but anyway the
9325 -- test is harmless if not needed, so it is retained.
9327 and then Comes_From_Source
(Arg
)
9330 ("?x?& has been made static as a result of Export",
9333 ("\?x?this usage is non-standard and non-portable",
9339 if Warn_On_Export_Import
and then Is_Type
(E
) then
9340 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9343 if Warn_On_Export_Import
and Inside_A_Generic
then
9345 ("all instances of& will have the same external name?x?",
9350 ----------------------------------------------
9351 -- Set_Extended_Import_Export_External_Name --
9352 ----------------------------------------------
9354 procedure Set_Extended_Import_Export_External_Name
9355 (Internal_Ent
: Entity_Id
;
9356 Arg_External
: Node_Id
)
9358 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9362 if No
(Arg_External
) then
9366 Check_Arg_Is_External_Name
(Arg_External
);
9368 if Nkind
(Arg_External
) = N_String_Literal
then
9369 if String_Length
(Strval
(Arg_External
)) = 0 then
9372 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9375 elsif Nkind
(Arg_External
) = N_Identifier
then
9376 New_Name
:= Get_Default_External_Name
(Arg_External
);
9378 -- Check_Arg_Is_External_Name should let through only identifiers and
9379 -- string literals or static string expressions (which are folded to
9380 -- string literals).
9383 raise Program_Error
;
9386 -- If we already have an external name set (by a prior normal Import
9387 -- or Export pragma), then the external names must match
9389 if Present
(Interface_Name
(Internal_Ent
)) then
9391 -- Ignore mismatching names in CodePeer mode, to support some
9392 -- old compilers which would export the same procedure under
9393 -- different names, e.g:
9395 -- pragma Export_Procedure (P, "a");
9396 -- pragma Export_Procedure (P, "b");
9398 if CodePeer_Mode
then
9402 Check_Matching_Internal_Names
: declare
9403 S1
: constant String_Id
:= Strval
(Old_Name
);
9404 S2
: constant String_Id
:= Strval
(New_Name
);
9407 pragma No_Return
(Mismatch
);
9408 -- Called if names do not match
9414 procedure Mismatch
is
9416 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9418 ("external name does not match that given #",
9422 -- Start of processing for Check_Matching_Internal_Names
9425 if String_Length
(S1
) /= String_Length
(S2
) then
9429 for J
in 1 .. String_Length
(S1
) loop
9430 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9435 end Check_Matching_Internal_Names
;
9437 -- Otherwise set the given name
9440 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9441 Check_Duplicated_Export_Name
(New_Name
);
9443 end Set_Extended_Import_Export_External_Name
;
9449 procedure Set_Imported
(E
: Entity_Id
) is
9451 -- Error message if already imported or exported
9453 if Is_Exported
(E
) or else Is_Imported
(E
) then
9455 -- Error if being set Exported twice
9457 if Is_Exported
(E
) then
9458 Error_Msg_NE
("entity& was previously exported", N
, E
);
9460 -- Ignore error in CodePeer mode where we treat all imported
9461 -- subprograms as unknown.
9463 elsif CodePeer_Mode
then
9466 -- OK if Import/Interface case
9468 elsif Import_Interface_Present
(N
) then
9471 -- Error if being set Imported twice
9474 Error_Msg_NE
("entity& was previously imported", N
, E
);
9477 Error_Msg_Name_1
:= Pname
;
9479 ("\(pragma% applies to all previous entities)", N
);
9481 Error_Msg_Sloc
:= Sloc
(E
);
9482 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9484 -- Here if not previously imported or exported, OK to import
9487 Set_Is_Imported
(E
);
9489 -- For subprogram, set Import_Pragma field
9491 if Is_Subprogram
(E
) then
9492 Set_Import_Pragma
(E
, N
);
9495 -- If the entity is an object that is not at the library level,
9496 -- then it is statically allocated. We do not worry about objects
9497 -- with address clauses in this context since they are not really
9498 -- imported in the linker sense.
9501 and then not Is_Library_Level_Entity
(E
)
9502 and then No
(Address_Clause
(E
))
9504 Set_Is_Statically_Allocated
(E
);
9511 -------------------------
9512 -- Set_Mechanism_Value --
9513 -------------------------
9515 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9516 -- analyzed, since it is semantic nonsense), so we get it in the exact
9517 -- form created by the parser.
9519 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9520 procedure Bad_Mechanism
;
9521 pragma No_Return
(Bad_Mechanism
);
9522 -- Signal bad mechanism name
9524 -------------------------
9525 -- Bad_Mechanism_Value --
9526 -------------------------
9528 procedure Bad_Mechanism
is
9530 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9533 -- Start of processing for Set_Mechanism_Value
9536 if Mechanism
(Ent
) /= Default_Mechanism
then
9538 ("mechanism for & has already been set", Mech_Name
, Ent
);
9541 -- MECHANISM_NAME ::= value | reference
9543 if Nkind
(Mech_Name
) = N_Identifier
then
9544 if Chars
(Mech_Name
) = Name_Value
then
9545 Set_Mechanism
(Ent
, By_Copy
);
9548 elsif Chars
(Mech_Name
) = Name_Reference
then
9549 Set_Mechanism
(Ent
, By_Reference
);
9552 elsif Chars
(Mech_Name
) = Name_Copy
then
9554 ("bad mechanism name, Value assumed", Mech_Name
);
9563 end Set_Mechanism_Value
;
9565 --------------------------
9566 -- Set_Rational_Profile --
9567 --------------------------
9569 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9570 -- and extension to the semantics of renaming declarations.
9572 procedure Set_Rational_Profile
is
9574 Implicit_Packing
:= True;
9575 Overriding_Renamings
:= True;
9576 Use_VADS_Size
:= True;
9577 end Set_Rational_Profile
;
9579 ---------------------------
9580 -- Set_Ravenscar_Profile --
9581 ---------------------------
9583 -- The tasks to be done here are
9585 -- Set required policies
9587 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9588 -- pragma Locking_Policy (Ceiling_Locking)
9590 -- Set Detect_Blocking mode
9592 -- Set required restrictions (see System.Rident for detailed list)
9594 -- Set the No_Dependence rules
9595 -- No_Dependence => Ada.Asynchronous_Task_Control
9596 -- No_Dependence => Ada.Calendar
9597 -- No_Dependence => Ada.Execution_Time.Group_Budget
9598 -- No_Dependence => Ada.Execution_Time.Timers
9599 -- No_Dependence => Ada.Task_Attributes
9600 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9602 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9603 Prefix_Entity
: Entity_Id
;
9604 Selector_Entity
: Entity_Id
;
9605 Prefix_Node
: Node_Id
;
9609 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9611 if Task_Dispatching_Policy
/= ' '
9612 and then Task_Dispatching_Policy
/= 'F'
9614 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9615 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9617 -- Set the FIFO_Within_Priorities policy, but always preserve
9618 -- System_Location since we like the error message with the run time
9622 Task_Dispatching_Policy
:= 'F';
9624 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9625 Task_Dispatching_Policy_Sloc
:= Loc
;
9629 -- pragma Locking_Policy (Ceiling_Locking)
9631 if Locking_Policy
/= ' '
9632 and then Locking_Policy
/= 'C'
9634 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9635 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9637 -- Set the Ceiling_Locking policy, but preserve System_Location since
9638 -- we like the error message with the run time name.
9641 Locking_Policy
:= 'C';
9643 if Locking_Policy_Sloc
/= System_Location
then
9644 Locking_Policy_Sloc
:= Loc
;
9648 -- pragma Detect_Blocking
9650 Detect_Blocking
:= True;
9652 -- Set the corresponding restrictions
9654 Set_Profile_Restrictions
9655 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9657 -- Set the No_Dependence restrictions
9659 -- The following No_Dependence restrictions:
9660 -- No_Dependence => Ada.Asynchronous_Task_Control
9661 -- No_Dependence => Ada.Calendar
9662 -- No_Dependence => Ada.Task_Attributes
9663 -- are already set by previous call to Set_Profile_Restrictions.
9665 -- Set the following restrictions which were added to Ada 2005:
9666 -- No_Dependence => Ada.Execution_Time.Group_Budget
9667 -- No_Dependence => Ada.Execution_Time.Timers
9669 if Ada_Version
>= Ada_2005
then
9670 Name_Buffer
(1 .. 3) := "ada";
9673 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9675 Name_Buffer
(1 .. 14) := "execution_time";
9678 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9681 Make_Selected_Component
9683 Prefix
=> Prefix_Entity
,
9684 Selector_Name
=> Selector_Entity
);
9686 Name_Buffer
(1 .. 13) := "group_budgets";
9689 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9692 Make_Selected_Component
9694 Prefix
=> Prefix_Node
,
9695 Selector_Name
=> Selector_Entity
);
9697 Set_Restriction_No_Dependence
9699 Warn
=> Treat_Restrictions_As_Warnings
,
9700 Profile
=> Ravenscar
);
9702 Name_Buffer
(1 .. 6) := "timers";
9705 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9708 Make_Selected_Component
9710 Prefix
=> Prefix_Node
,
9711 Selector_Name
=> Selector_Entity
);
9713 Set_Restriction_No_Dependence
9715 Warn
=> Treat_Restrictions_As_Warnings
,
9716 Profile
=> Ravenscar
);
9719 -- Set the following restrictions which was added to Ada 2012 (see
9721 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9723 if Ada_Version
>= Ada_2012
then
9724 Name_Buffer
(1 .. 6) := "system";
9727 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9729 Name_Buffer
(1 .. 15) := "multiprocessors";
9732 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9735 Make_Selected_Component
9737 Prefix
=> Prefix_Entity
,
9738 Selector_Name
=> Selector_Entity
);
9740 Name_Buffer
(1 .. 19) := "dispatching_domains";
9743 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9746 Make_Selected_Component
9748 Prefix
=> Prefix_Node
,
9749 Selector_Name
=> Selector_Entity
);
9751 Set_Restriction_No_Dependence
9753 Warn
=> Treat_Restrictions_As_Warnings
,
9754 Profile
=> Ravenscar
);
9756 end Set_Ravenscar_Profile
;
9758 -- Start of processing for Analyze_Pragma
9761 -- The following code is a defense against recursion. Not clear that
9762 -- this can happen legitimately, but perhaps some error situations
9763 -- can cause it, and we did see this recursion during testing.
9765 if Analyzed
(N
) then
9768 Set_Analyzed
(N
, True);
9771 -- Deal with unrecognized pragma
9773 Pname
:= Pragma_Name
(N
);
9775 if not Is_Pragma_Name
(Pname
) then
9776 if Warn_On_Unrecognized_Pragma
then
9777 Error_Msg_Name_1
:= Pname
;
9778 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9780 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9781 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9782 Error_Msg_Name_1
:= PN
;
9783 Error_Msg_N
-- CODEFIX
9784 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9793 -- Here to start processing for recognized pragma
9795 Prag_Id
:= Get_Pragma_Id
(Pname
);
9796 Pname
:= Original_Aspect_Name
(N
);
9798 -- Capture setting of Opt.Uneval_Old
9800 case Opt
.Uneval_Old
is
9802 Set_Uneval_Old_Accept
(N
);
9806 Set_Uneval_Old_Warn
(N
);
9808 raise Program_Error
;
9811 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9812 -- is already set, indicating that we have already checked the policy
9813 -- at the right point. This happens for example in the case of a pragma
9814 -- that is derived from an Aspect.
9816 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9819 -- For a pragma that is a rewriting of another pragma, copy the
9820 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9822 elsif Is_Rewrite_Substitution
(N
)
9823 and then Nkind
(Original_Node
(N
)) = N_Pragma
9824 and then Original_Node
(N
) /= N
9826 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9827 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9829 -- Otherwise query the applicable policy at this point
9832 Check_Applicable_Policy
(N
);
9834 -- If pragma is disabled, rewrite as NULL and skip analysis
9836 if Is_Disabled
(N
) then
9837 Rewrite
(N
, Make_Null_Statement
(Loc
));
9851 if Present
(Pragma_Argument_Associations
(N
)) then
9852 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9853 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9855 if Present
(Arg1
) then
9856 Arg2
:= Next
(Arg1
);
9858 if Present
(Arg2
) then
9859 Arg3
:= Next
(Arg2
);
9861 if Present
(Arg3
) then
9862 Arg4
:= Next
(Arg3
);
9868 Check_Restriction_No_Use_Of_Pragma
(N
);
9870 -- An enumeration type defines the pragmas that are supported by the
9871 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9872 -- into the corresponding enumeration value for the following case.
9880 -- pragma Abort_Defer;
9882 when Pragma_Abort_Defer
=>
9884 Check_Arg_Count
(0);
9886 -- The only required semantic processing is to check the
9887 -- placement. This pragma must appear at the start of the
9888 -- statement sequence of a handled sequence of statements.
9890 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9891 or else N
/= First
(Statements
(Parent
(N
)))
9896 --------------------
9897 -- Abstract_State --
9898 --------------------
9900 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9902 -- ABSTRACT_STATE_LIST ::=
9904 -- | STATE_NAME_WITH_OPTIONS
9905 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9907 -- STATE_NAME_WITH_OPTIONS ::=
9909 -- | (STATE_NAME with OPTION_LIST)
9911 -- OPTION_LIST ::= OPTION {, OPTION}
9915 -- | NAME_VALUE_OPTION
9917 -- SIMPLE_OPTION ::= identifier
9919 -- NAME_VALUE_OPTION ::=
9920 -- Part_Of => ABSTRACT_STATE
9921 -- | External [=> EXTERNAL_PROPERTY_LIST]
9923 -- EXTERNAL_PROPERTY_LIST ::=
9924 -- EXTERNAL_PROPERTY
9925 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9927 -- EXTERNAL_PROPERTY ::=
9928 -- Async_Readers [=> boolean_EXPRESSION]
9929 -- | Async_Writers [=> boolean_EXPRESSION]
9930 -- | Effective_Reads [=> boolean_EXPRESSION]
9931 -- | Effective_Writes [=> boolean_EXPRESSION]
9932 -- others => boolean_EXPRESSION
9934 -- STATE_NAME ::= defining_identifier
9936 -- ABSTRACT_STATE ::= name
9938 when Pragma_Abstract_State
=> Abstract_State
: declare
9939 Missing_Parentheses
: Boolean := False;
9940 -- Flag set when a state declaration with options is not properly
9943 -- Flags used to verify the consistency of states
9945 Non_Null_Seen
: Boolean := False;
9946 Null_Seen
: Boolean := False;
9948 Pack_Id
: Entity_Id
;
9949 -- Entity of related package when pragma Abstract_State appears
9951 procedure Analyze_Abstract_State
(State
: Node_Id
);
9952 -- Verify the legality of a single state declaration. Create and
9953 -- decorate a state abstraction entity and introduce it into the
9954 -- visibility chain.
9956 ----------------------------
9957 -- Analyze_Abstract_State --
9958 ----------------------------
9960 procedure Analyze_Abstract_State
(State
: Node_Id
) is
9962 -- Flags used to verify the consistency of options
9964 AR_Seen
: Boolean := False;
9965 AW_Seen
: Boolean := False;
9966 ER_Seen
: Boolean := False;
9967 EW_Seen
: Boolean := False;
9968 External_Seen
: Boolean := False;
9969 Others_Seen
: Boolean := False;
9970 Part_Of_Seen
: Boolean := False;
9972 -- Flags used to store the static value of all external states'
9975 AR_Val
: Boolean := False;
9976 AW_Val
: Boolean := False;
9977 ER_Val
: Boolean := False;
9978 EW_Val
: Boolean := False;
9980 State_Id
: Entity_Id
:= Empty
;
9981 -- The entity to be generated for the current state declaration
9983 procedure Analyze_External_Option
(Opt
: Node_Id
);
9984 -- Verify the legality of option External
9986 procedure Analyze_External_Property
9988 Expr
: Node_Id
:= Empty
);
9989 -- Verify the legailty of a single external property. Prop
9990 -- denotes the external property. Expr is the expression used
9991 -- to set the property.
9993 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9994 -- Verify the legality of option Part_Of
9996 procedure Check_Duplicate_Option
9998 Status
: in out Boolean);
9999 -- Flag Status denotes whether a particular option has been
10000 -- seen while processing a state. This routine verifies that
10001 -- Opt is not a duplicate option and sets the flag Status
10002 -- (SPARK RM 7.1.4(1)).
10004 procedure Check_Duplicate_Property
10006 Status
: in out Boolean);
10007 -- Flag Status denotes whether a particular property has been
10008 -- seen while processing option External. This routine verifies
10009 -- that Prop is not a duplicate property and sets flag Status.
10010 -- Opt is not a duplicate property and sets the flag Status.
10011 -- (SPARK RM 7.1.4(2))
10013 procedure Create_Abstract_State
10017 Is_Null
: Boolean);
10018 -- Generate an abstract state entity with name Nam and enter it
10019 -- into visibility. Decl is the "declaration" of the state as
10020 -- it appears in pragma Abstract_State. Loc is the location of
10021 -- the related state "declaration". Flag Is_Null should be set
10022 -- when the associated Abstract_State pragma defines a null
10025 -----------------------------
10026 -- Analyze_External_Option --
10027 -----------------------------
10029 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10030 Errors
: constant Nat
:= Serious_Errors_Detected
;
10032 Props
: Node_Id
:= Empty
;
10035 Check_Duplicate_Option
(Opt
, External_Seen
);
10037 if Nkind
(Opt
) = N_Component_Association
then
10038 Props
:= Expression
(Opt
);
10041 -- External state with properties
10043 if Present
(Props
) then
10045 -- Multiple properties appear as an aggregate
10047 if Nkind
(Props
) = N_Aggregate
then
10049 -- Simple property form
10051 Prop
:= First
(Expressions
(Props
));
10052 while Present
(Prop
) loop
10053 Analyze_External_Property
(Prop
);
10057 -- Property with expression form
10059 Prop
:= First
(Component_Associations
(Props
));
10060 while Present
(Prop
) loop
10061 Analyze_External_Property
10062 (Prop
=> First
(Choices
(Prop
)),
10063 Expr
=> Expression
(Prop
));
10071 Analyze_External_Property
(Props
);
10074 -- An external state defined without any properties defaults
10075 -- all properties to True.
10084 -- Once all external properties have been processed, verify
10085 -- their mutual interaction. Do not perform the check when
10086 -- at least one of the properties is illegal as this will
10087 -- produce a bogus error.
10089 if Errors
= Serious_Errors_Detected
then
10090 Check_External_Properties
10091 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10093 end Analyze_External_Option
;
10095 -------------------------------
10096 -- Analyze_External_Property --
10097 -------------------------------
10099 procedure Analyze_External_Property
10101 Expr
: Node_Id
:= Empty
)
10103 Expr_Val
: Boolean;
10106 -- Check the placement of "others" (if available)
10108 if Nkind
(Prop
) = N_Others_Choice
then
10109 if Others_Seen
then
10111 ("only one others choice allowed in option External",
10114 Others_Seen
:= True;
10117 elsif Others_Seen
then
10119 ("others must be the last property in option External",
10122 -- The only remaining legal options are the four predefined
10123 -- external properties.
10125 elsif Nkind
(Prop
) = N_Identifier
10126 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10127 Name_Async_Writers
,
10128 Name_Effective_Reads
,
10129 Name_Effective_Writes
)
10133 -- Otherwise the construct is not a valid property
10136 SPARK_Msg_N
("invalid external state property", Prop
);
10140 -- Ensure that the expression of the external state property
10141 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10143 if Present
(Expr
) then
10144 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10146 if Is_OK_Static_Expression
(Expr
) then
10147 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10150 ("expression of external state property must be "
10154 -- The lack of expression defaults the property to True
10160 -- Named properties
10162 if Nkind
(Prop
) = N_Identifier
then
10163 if Chars
(Prop
) = Name_Async_Readers
then
10164 Check_Duplicate_Property
(Prop
, AR_Seen
);
10165 AR_Val
:= Expr_Val
;
10167 elsif Chars
(Prop
) = Name_Async_Writers
then
10168 Check_Duplicate_Property
(Prop
, AW_Seen
);
10169 AW_Val
:= Expr_Val
;
10171 elsif Chars
(Prop
) = Name_Effective_Reads
then
10172 Check_Duplicate_Property
(Prop
, ER_Seen
);
10173 ER_Val
:= Expr_Val
;
10176 Check_Duplicate_Property
(Prop
, EW_Seen
);
10177 EW_Val
:= Expr_Val
;
10180 -- The handling of property "others" must take into account
10181 -- all other named properties that have been encountered so
10182 -- far. Only those that have not been seen are affected by
10186 if not AR_Seen
then
10187 AR_Val
:= Expr_Val
;
10190 if not AW_Seen
then
10191 AW_Val
:= Expr_Val
;
10194 if not ER_Seen
then
10195 ER_Val
:= Expr_Val
;
10198 if not EW_Seen
then
10199 EW_Val
:= Expr_Val
;
10202 end Analyze_External_Property
;
10204 ----------------------------
10205 -- Analyze_Part_Of_Option --
10206 ----------------------------
10208 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10209 Encaps
: constant Node_Id
:= Expression
(Opt
);
10210 Encaps_Id
: Entity_Id
;
10214 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10217 (Item_Id
=> State_Id
,
10219 Indic
=> First
(Choices
(Opt
)),
10222 -- The Part_Of indicator turns an abstract state into a
10223 -- constituent of the encapsulating state.
10226 Encaps_Id
:= Entity
(Encaps
);
10228 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10229 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10231 end Analyze_Part_Of_Option
;
10233 ----------------------------
10234 -- Check_Duplicate_Option --
10235 ----------------------------
10237 procedure Check_Duplicate_Option
10239 Status
: in out Boolean)
10243 SPARK_Msg_N
("duplicate state option", Opt
);
10247 end Check_Duplicate_Option
;
10249 ------------------------------
10250 -- Check_Duplicate_Property --
10251 ------------------------------
10253 procedure Check_Duplicate_Property
10255 Status
: in out Boolean)
10259 SPARK_Msg_N
("duplicate external property", Prop
);
10263 end Check_Duplicate_Property
;
10265 ---------------------------
10266 -- Create_Abstract_State --
10267 ---------------------------
10269 procedure Create_Abstract_State
10276 -- The abstract state may be semi-declared when the related
10277 -- package was withed through a limited with clause. In that
10278 -- case reuse the entity to fully declare the state.
10280 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10281 State_Id
:= Entity
(Decl
);
10283 -- Otherwise the elaboration of pragma Abstract_State
10284 -- declares the state.
10287 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10289 if Present
(Decl
) then
10290 Set_Entity
(Decl
, State_Id
);
10294 -- Null states never come from source
10296 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10297 Set_Parent
(State_Id
, State
);
10298 Set_Ekind
(State_Id
, E_Abstract_State
);
10299 Set_Etype
(State_Id
, Standard_Void_Type
);
10300 Set_Encapsulating_State
(State_Id
, Empty
);
10301 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10302 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10304 -- Establish a link between the state declaration and the
10305 -- abstract state entity. Note that a null state remains as
10306 -- N_Null and does not carry any linkages.
10308 if not Is_Null
then
10309 if Present
(Decl
) then
10310 Set_Entity
(Decl
, State_Id
);
10311 Set_Etype
(Decl
, Standard_Void_Type
);
10314 -- Every non-null state must be defined, nameable and
10317 Push_Scope
(Pack_Id
);
10318 Generate_Definition
(State_Id
);
10319 Enter_Name
(State_Id
);
10322 end Create_Abstract_State
;
10329 -- Start of processing for Analyze_Abstract_State
10332 -- A package with a null abstract state is not allowed to
10333 -- declare additional states.
10337 ("package & has null abstract state", State
, Pack_Id
);
10339 -- Null states appear as internally generated entities
10341 elsif Nkind
(State
) = N_Null
then
10342 Create_Abstract_State
10343 (Nam
=> New_Internal_Name
('S'),
10345 Loc
=> Sloc
(State
),
10349 -- Catch a case where a null state appears in a list of
10350 -- non-null states.
10352 if Non_Null_Seen
then
10354 ("package & has non-null abstract state",
10358 -- Simple state declaration
10360 elsif Nkind
(State
) = N_Identifier
then
10361 Create_Abstract_State
10362 (Nam
=> Chars
(State
),
10364 Loc
=> Sloc
(State
),
10366 Non_Null_Seen
:= True;
10368 -- State declaration with various options. This construct
10369 -- appears as an extension aggregate in the tree.
10371 elsif Nkind
(State
) = N_Extension_Aggregate
then
10372 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10373 Create_Abstract_State
10374 (Nam
=> Chars
(Ancestor_Part
(State
)),
10375 Decl
=> Ancestor_Part
(State
),
10376 Loc
=> Sloc
(Ancestor_Part
(State
)),
10378 Non_Null_Seen
:= True;
10381 ("state name must be an identifier",
10382 Ancestor_Part
(State
));
10385 -- Catch an attempt to introduce a simple option which is
10386 -- currently not allowed. An exception to this is External
10387 -- defined without any properties.
10389 Opt
:= First
(Expressions
(State
));
10390 while Present
(Opt
) loop
10391 if Nkind
(Opt
) = N_Identifier
then
10392 if Chars
(Opt
) = Name_External
then
10393 Analyze_External_Option
(Opt
);
10395 -- Option Part_Of without an encapsulating state is
10396 -- illegal. (SPARK RM 7.1.4(9)).
10398 elsif Chars
(Opt
) = Name_Part_Of
then
10400 ("indicator Part_Of must denote an abstract "
10403 -- Do not emit an error message when a previous state
10404 -- declaration with options was not parenthesized as
10405 -- the option is actually another state declaration.
10407 -- with Abstract_State
10408 -- (State_1 with ..., -- missing parentheses
10409 -- (State_2 with ...),
10410 -- State_3) -- ok state declaration
10412 elsif Missing_Parentheses
then
10415 -- Otherwise the option is not allowed. Note that it
10416 -- is not possible to distinguish between an option
10417 -- and a state declaration when a previous state with
10418 -- options not properly parentheses.
10420 -- with Abstract_State
10421 -- (State_1 with ..., -- missing parentheses
10422 -- State_2); -- could be an option
10426 ("simple option not allowed in state declaration",
10430 -- Catch a case where missing parentheses around a state
10431 -- declaration with options cause a subsequent state
10432 -- declaration with options to be treated as an option.
10434 -- with Abstract_State
10435 -- (State_1 with ..., -- missing parentheses
10436 -- (State_2 with ...))
10438 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10439 Missing_Parentheses
:= True;
10441 ("state declaration must be parenthesized",
10442 Ancestor_Part
(State
));
10444 -- Otherwise the option is malformed
10447 SPARK_Msg_N
("malformed option", Opt
);
10453 -- Options External and Part_Of appear as component
10456 Opt
:= First
(Component_Associations
(State
));
10457 while Present
(Opt
) loop
10458 Opt_Nam
:= First
(Choices
(Opt
));
10460 if Nkind
(Opt_Nam
) = N_Identifier
then
10461 if Chars
(Opt_Nam
) = Name_External
then
10462 Analyze_External_Option
(Opt
);
10464 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10465 Analyze_Part_Of_Option
(Opt
);
10468 SPARK_Msg_N
("invalid state option", Opt
);
10471 SPARK_Msg_N
("invalid state option", Opt
);
10477 -- Any other attempt to declare a state is illegal. This is a
10478 -- syntax error, always report.
10481 Error_Msg_N
("malformed abstract state declaration", State
);
10485 -- Guard against a junk state. In such cases no entity is
10486 -- generated and the subsequent checks cannot be applied.
10488 if Present
(State_Id
) then
10490 -- Verify whether the state does not introduce an illegal
10491 -- hidden state within a package subject to a null abstract
10494 Check_No_Hidden_State
(State_Id
);
10496 -- Check whether the lack of option Part_Of agrees with the
10497 -- placement of the abstract state with respect to the state
10500 if not Part_Of_Seen
then
10501 Check_Missing_Part_Of
(State_Id
);
10504 -- Associate the state with its related package
10506 if No
(Abstract_States
(Pack_Id
)) then
10507 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10510 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10512 end Analyze_Abstract_State
;
10516 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10519 -- Start of processing for Abstract_State
10523 Check_No_Identifiers
;
10524 Check_Arg_Count
(1);
10525 Ensure_Aggregate_Form
(Arg1
);
10527 -- Ensure the proper placement of the pragma. Abstract states must
10528 -- be associated with a package declaration.
10530 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10531 N_Package_Declaration
)
10537 State
:= Expression
(Arg1
);
10538 Pack_Id
:= Defining_Entity
(Context
);
10540 -- Multiple non-null abstract states appear as an aggregate
10542 if Nkind
(State
) = N_Aggregate
then
10543 State
:= First
(Expressions
(State
));
10544 while Present
(State
) loop
10545 Analyze_Abstract_State
(State
);
10549 -- Various forms of a single abstract state. Note that these may
10550 -- include malformed state declarations.
10553 Analyze_Abstract_State
(State
);
10556 -- Save the pragma for retrieval by other tools
10558 Add_Contract_Item
(N
, Pack_Id
);
10560 -- Verify the declaration order of pragmas Abstract_State and
10563 Check_Declaration_Order
10565 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10566 end Abstract_State
;
10574 -- Note: this pragma also has some specific processing in Par.Prag
10575 -- because we want to set the Ada version mode during parsing.
10577 when Pragma_Ada_83
=>
10579 Check_Arg_Count
(0);
10581 -- We really should check unconditionally for proper configuration
10582 -- pragma placement, since we really don't want mixed Ada modes
10583 -- within a single unit, and the GNAT reference manual has always
10584 -- said this was a configuration pragma, but we did not check and
10585 -- are hesitant to add the check now.
10587 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10588 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10589 -- or Ada 2012 mode.
10591 if Ada_Version
>= Ada_2005
then
10592 Check_Valid_Configuration_Pragma
;
10595 -- Now set Ada 83 mode
10597 Ada_Version
:= Ada_83
;
10598 Ada_Version_Explicit
:= Ada_83
;
10599 Ada_Version_Pragma
:= N
;
10607 -- Note: this pragma also has some specific processing in Par.Prag
10608 -- because we want to set the Ada 83 version mode during parsing.
10610 when Pragma_Ada_95
=>
10612 Check_Arg_Count
(0);
10614 -- We really should check unconditionally for proper configuration
10615 -- pragma placement, since we really don't want mixed Ada modes
10616 -- within a single unit, and the GNAT reference manual has always
10617 -- said this was a configuration pragma, but we did not check and
10618 -- are hesitant to add the check now.
10620 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10621 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10623 if Ada_Version
>= Ada_2005
then
10624 Check_Valid_Configuration_Pragma
;
10627 -- Now set Ada 95 mode
10629 Ada_Version
:= Ada_95
;
10630 Ada_Version_Explicit
:= Ada_95
;
10631 Ada_Version_Pragma
:= N
;
10633 ---------------------
10634 -- Ada_05/Ada_2005 --
10635 ---------------------
10638 -- pragma Ada_05 (LOCAL_NAME);
10640 -- pragma Ada_2005;
10641 -- pragma Ada_2005 (LOCAL_NAME):
10643 -- Note: these pragmas also have some specific processing in Par.Prag
10644 -- because we want to set the Ada 2005 version mode during parsing.
10646 -- The one argument form is used for managing the transition from
10647 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10648 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10649 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10650 -- mode, a preference rule is established which does not choose
10651 -- such an entity unless it is unambiguously specified. This avoids
10652 -- extra subprograms marked this way from generating ambiguities in
10653 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10654 -- intended for exclusive use in the GNAT run-time library.
10656 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10662 if Arg_Count
= 1 then
10663 Check_Arg_Is_Local_Name
(Arg1
);
10664 E_Id
:= Get_Pragma_Arg
(Arg1
);
10666 if Etype
(E_Id
) = Any_Type
then
10670 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10671 Record_Rep_Item
(Entity
(E_Id
), N
);
10674 Check_Arg_Count
(0);
10676 -- For Ada_2005 we unconditionally enforce the documented
10677 -- configuration pragma placement, since we do not want to
10678 -- tolerate mixed modes in a unit involving Ada 2005. That
10679 -- would cause real difficulties for those cases where there
10680 -- are incompatibilities between Ada 95 and Ada 2005.
10682 Check_Valid_Configuration_Pragma
;
10684 -- Now set appropriate Ada mode
10686 Ada_Version
:= Ada_2005
;
10687 Ada_Version_Explicit
:= Ada_2005
;
10688 Ada_Version_Pragma
:= N
;
10692 ---------------------
10693 -- Ada_12/Ada_2012 --
10694 ---------------------
10697 -- pragma Ada_12 (LOCAL_NAME);
10699 -- pragma Ada_2012;
10700 -- pragma Ada_2012 (LOCAL_NAME):
10702 -- Note: these pragmas also have some specific processing in Par.Prag
10703 -- because we want to set the Ada 2012 version mode during parsing.
10705 -- The one argument form is used for managing the transition from Ada
10706 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10707 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10708 -- mode will generate a warning. In addition, in any pre-Ada_2012
10709 -- mode, a preference rule is established which does not choose
10710 -- such an entity unless it is unambiguously specified. This avoids
10711 -- extra subprograms marked this way from generating ambiguities in
10712 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10713 -- intended for exclusive use in the GNAT run-time library.
10715 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10721 if Arg_Count
= 1 then
10722 Check_Arg_Is_Local_Name
(Arg1
);
10723 E_Id
:= Get_Pragma_Arg
(Arg1
);
10725 if Etype
(E_Id
) = Any_Type
then
10729 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10730 Record_Rep_Item
(Entity
(E_Id
), N
);
10733 Check_Arg_Count
(0);
10735 -- For Ada_2012 we unconditionally enforce the documented
10736 -- configuration pragma placement, since we do not want to
10737 -- tolerate mixed modes in a unit involving Ada 2012. That
10738 -- would cause real difficulties for those cases where there
10739 -- are incompatibilities between Ada 95 and Ada 2012. We could
10740 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10742 Check_Valid_Configuration_Pragma
;
10744 -- Now set appropriate Ada mode
10746 Ada_Version
:= Ada_2012
;
10747 Ada_Version_Explicit
:= Ada_2012
;
10748 Ada_Version_Pragma
:= N
;
10752 ----------------------
10753 -- All_Calls_Remote --
10754 ----------------------
10756 -- pragma All_Calls_Remote [(library_package_NAME)];
10758 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10759 Lib_Entity
: Entity_Id
;
10762 Check_Ada_83_Warning
;
10763 Check_Valid_Library_Unit_Pragma
;
10765 if Nkind
(N
) = N_Null_Statement
then
10769 Lib_Entity
:= Find_Lib_Unit_Name
;
10771 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10773 if Present
(Lib_Entity
)
10774 and then not Debug_Flag_U
10776 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10777 Error_Pragma
("pragma% only apply to rci unit");
10779 -- Set flag for entity of the library unit
10782 Set_Has_All_Calls_Remote
(Lib_Entity
);
10786 end All_Calls_Remote
;
10788 ---------------------------
10789 -- Allow_Integer_Address --
10790 ---------------------------
10792 -- pragma Allow_Integer_Address;
10794 when Pragma_Allow_Integer_Address
=>
10796 Check_Valid_Configuration_Pragma
;
10797 Check_Arg_Count
(0);
10799 -- If Address is a private type, then set the flag to allow
10800 -- integer address values. If Address is not private, then this
10801 -- pragma has no purpose, so it is simply ignored. Not clear if
10802 -- there are any such targets now.
10804 if Opt
.Address_Is_Private
then
10805 Opt
.Allow_Integer_Address
:= True;
10813 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10814 -- ARG ::= NAME | EXPRESSION
10816 -- The first two arguments are by convention intended to refer to an
10817 -- external tool and a tool-specific function. These arguments are
10820 when Pragma_Annotate
=> Annotate
: declare
10826 Check_At_Least_N_Arguments
(1);
10828 -- See if last argument is Entity => local_Name, and if so process
10829 -- and then remove it for remaining processing.
10832 Last_Arg
: constant Node_Id
:=
10833 Last
(Pragma_Argument_Associations
(N
));
10836 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10837 and then Chars
(Last_Arg
) = Name_Entity
10839 Check_Arg_Is_Local_Name
(Last_Arg
);
10840 Arg_Count
:= Arg_Count
- 1;
10842 -- Not allowed in compiler units (bootstrap issues)
10844 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10848 -- Continue processing with last argument removed for now
10850 Check_Arg_Is_Identifier
(Arg1
);
10851 Check_No_Identifiers
;
10854 -- Second parameter is optional, it is never analyzed
10859 -- Here if we have a second parameter
10862 -- Second parameter must be identifier
10864 Check_Arg_Is_Identifier
(Arg2
);
10866 -- Process remaining parameters if any
10868 Arg
:= Next
(Arg2
);
10869 while Present
(Arg
) loop
10870 Exp
:= Get_Pragma_Arg
(Arg
);
10873 if Is_Entity_Name
(Exp
) then
10876 -- For string literals, we assume Standard_String as the
10877 -- type, unless the string contains wide or wide_wide
10880 elsif Nkind
(Exp
) = N_String_Literal
then
10881 if Has_Wide_Wide_Character
(Exp
) then
10882 Resolve
(Exp
, Standard_Wide_Wide_String
);
10883 elsif Has_Wide_Character
(Exp
) then
10884 Resolve
(Exp
, Standard_Wide_String
);
10886 Resolve
(Exp
, Standard_String
);
10889 elsif Is_Overloaded
(Exp
) then
10891 ("ambiguous argument for pragma%", Exp
);
10902 -------------------------------------------------
10903 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10904 -------------------------------------------------
10907 -- ( [Check => ] Boolean_EXPRESSION
10908 -- [, [Message =>] Static_String_EXPRESSION]);
10910 -- pragma Assert_And_Cut
10911 -- ( [Check => ] Boolean_EXPRESSION
10912 -- [, [Message =>] Static_String_EXPRESSION]);
10915 -- ( [Check => ] Boolean_EXPRESSION
10916 -- [, [Message =>] Static_String_EXPRESSION]);
10918 -- pragma Loop_Invariant
10919 -- ( [Check => ] Boolean_EXPRESSION
10920 -- [, [Message =>] Static_String_EXPRESSION]);
10922 when Pragma_Assert |
10923 Pragma_Assert_And_Cut |
10925 Pragma_Loop_Invariant
=>
10927 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10928 -- Determine whether expression Expr contains a Loop_Entry
10929 -- attribute reference.
10931 -------------------------
10932 -- Contains_Loop_Entry --
10933 -------------------------
10935 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10936 Has_Loop_Entry
: Boolean := False;
10938 function Process
(N
: Node_Id
) return Traverse_Result
;
10939 -- Process function for traversal to look for Loop_Entry
10945 function Process
(N
: Node_Id
) return Traverse_Result
is
10947 if Nkind
(N
) = N_Attribute_Reference
10948 and then Attribute_Name
(N
) = Name_Loop_Entry
10950 Has_Loop_Entry
:= True;
10957 procedure Traverse
is new Traverse_Proc
(Process
);
10959 -- Start of processing for Contains_Loop_Entry
10963 return Has_Loop_Entry
;
10964 end Contains_Loop_Entry
;
10971 -- Start of processing for Assert
10974 -- Assert is an Ada 2005 RM-defined pragma
10976 if Prag_Id
= Pragma_Assert
then
10979 -- The remaining ones are GNAT pragmas
10985 Check_At_Least_N_Arguments
(1);
10986 Check_At_Most_N_Arguments
(2);
10987 Check_Arg_Order
((Name_Check
, Name_Message
));
10988 Check_Optional_Identifier
(Arg1
, Name_Check
);
10989 Expr
:= Get_Pragma_Arg
(Arg1
);
10991 -- Special processing for Loop_Invariant, Loop_Variant or for
10992 -- other cases where a Loop_Entry attribute is present. If the
10993 -- assertion pragma contains attribute Loop_Entry, ensure that
10994 -- the related pragma is within a loop.
10996 if Prag_Id
= Pragma_Loop_Invariant
10997 or else Prag_Id
= Pragma_Loop_Variant
10998 or else Contains_Loop_Entry
(Expr
)
11000 Check_Loop_Pragma_Placement
;
11002 -- Perform preanalysis to deal with embedded Loop_Entry
11005 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
11008 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11009 -- a corresponding Check pragma:
11011 -- pragma Check (name, condition [, msg]);
11013 -- Where name is the identifier matching the pragma name. So
11014 -- rewrite pragma in this manner, transfer the message argument
11015 -- if present, and analyze the result
11017 -- Note: When dealing with a semantically analyzed tree, the
11018 -- information that a Check node N corresponds to a source Assert,
11019 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11020 -- pragma kind of Original_Node(N).
11023 Make_Pragma_Argument_Association
(Loc
,
11024 Expression
=> Make_Identifier
(Loc
, Pname
)),
11025 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11026 Expression
=> Expr
));
11028 if Arg_Count
> 1 then
11029 Check_Optional_Identifier
(Arg2
, Name_Message
);
11031 -- Provide semantic annnotations for optional argument, for
11032 -- ASIS use, before rewriting.
11034 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11035 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
11038 -- Rewrite as Check pragma
11042 Chars
=> Name_Check
,
11043 Pragma_Argument_Associations
=> Newa
));
11047 ----------------------
11048 -- Assertion_Policy --
11049 ----------------------
11051 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11053 -- The following form is Ada 2012 only, but we allow it in all modes
11055 -- Pragma Assertion_Policy (
11056 -- ASSERTION_KIND => POLICY_IDENTIFIER
11057 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11059 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11061 -- RM_ASSERTION_KIND ::= Assert |
11062 -- Static_Predicate |
11063 -- Dynamic_Predicate |
11068 -- Type_Invariant |
11069 -- Type_Invariant'Class
11071 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11073 -- Contract_Cases |
11075 -- Default_Initial_Condition |
11076 -- Initial_Condition |
11077 -- Loop_Invariant |
11083 -- Statement_Assertions
11085 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11086 -- ID_ASSERTION_KIND list contains implementation-defined additions
11087 -- recognized by GNAT. The effect is to control the behavior of
11088 -- identically named aspects and pragmas, depending on the specified
11089 -- policy identifier:
11091 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11093 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11094 -- implementation defined addition that results in totally ignoring
11095 -- the corresponding assertion. If Disable is specified, then the
11096 -- argument of the assertion is not even analyzed. This is useful
11097 -- when the aspect/pragma argument references entities in a with'ed
11098 -- package that is replaced by a dummy package in the final build.
11100 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11101 -- and Type_Invariant'Class were recognized by the parser and
11102 -- transformed into references to the special internal identifiers
11103 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11104 -- processing is required here.
11106 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11115 -- This can always appear as a configuration pragma
11117 if Is_Configuration_Pragma
then
11120 -- It can also appear in a declarative part or package spec in Ada
11121 -- 2012 mode. We allow this in other modes, but in that case we
11122 -- consider that we have an Ada 2012 pragma on our hands.
11125 Check_Is_In_Decl_Part_Or_Package_Spec
;
11129 -- One argument case with no identifier (first form above)
11132 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11133 or else Chars
(Arg1
) = No_Name
)
11135 Check_Arg_Is_One_Of
11136 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11138 -- Treat one argument Assertion_Policy as equivalent to:
11140 -- pragma Check_Policy (Assertion, policy)
11142 -- So rewrite pragma in that manner and link on to the chain
11143 -- of Check_Policy pragmas, marking the pragma as analyzed.
11145 Policy
:= Get_Pragma_Arg
(Arg1
);
11149 Chars
=> Name_Check_Policy
,
11150 Pragma_Argument_Associations
=> New_List
(
11151 Make_Pragma_Argument_Association
(Loc
,
11152 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11154 Make_Pragma_Argument_Association
(Loc
,
11156 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11159 -- Here if we have two or more arguments
11162 Check_At_Least_N_Arguments
(1);
11165 -- Loop through arguments
11168 while Present
(Arg
) loop
11169 LocP
:= Sloc
(Arg
);
11171 -- Kind must be specified
11173 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11174 or else Chars
(Arg
) = No_Name
11177 ("missing assertion kind for pragma%", Arg
);
11180 -- Check Kind and Policy have allowed forms
11182 Kind
:= Chars
(Arg
);
11184 if not Is_Valid_Assertion_Kind
(Kind
) then
11186 ("invalid assertion kind for pragma%", Arg
);
11189 Check_Arg_Is_One_Of
11190 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11192 -- We rewrite the Assertion_Policy pragma as a series of
11193 -- Check_Policy pragmas:
11195 -- Check_Policy (Kind, Policy);
11199 Chars
=> Name_Check_Policy
,
11200 Pragma_Argument_Associations
=> New_List
(
11201 Make_Pragma_Argument_Association
(LocP
,
11202 Expression
=> Make_Identifier
(LocP
, Kind
)),
11203 Make_Pragma_Argument_Association
(LocP
,
11204 Expression
=> Get_Pragma_Arg
(Arg
)))));
11209 -- Rewrite the Assertion_Policy pragma as null since we have
11210 -- now inserted all the equivalent Check pragmas.
11212 Rewrite
(N
, Make_Null_Statement
(Loc
));
11215 end Assertion_Policy
;
11217 ------------------------------
11218 -- Assume_No_Invalid_Values --
11219 ------------------------------
11221 -- pragma Assume_No_Invalid_Values (On | Off);
11223 when Pragma_Assume_No_Invalid_Values
=>
11225 Check_Valid_Configuration_Pragma
;
11226 Check_Arg_Count
(1);
11227 Check_No_Identifiers
;
11228 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11230 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11231 Assume_No_Invalid_Values
:= True;
11233 Assume_No_Invalid_Values
:= False;
11236 --------------------------
11237 -- Attribute_Definition --
11238 --------------------------
11240 -- pragma Attribute_Definition
11241 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11242 -- [Entity =>] LOCAL_NAME,
11243 -- [Expression =>] EXPRESSION | NAME);
11245 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11246 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11251 Check_Arg_Count
(3);
11252 Check_Optional_Identifier
(Arg1
, "attribute");
11253 Check_Optional_Identifier
(Arg2
, "entity");
11254 Check_Optional_Identifier
(Arg3
, "expression");
11256 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11257 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11261 Check_Arg_Is_Local_Name
(Arg2
);
11263 -- If the attribute is not recognized, then issue a warning (not
11264 -- an error), and ignore the pragma.
11266 Aname
:= Chars
(Attribute_Designator
);
11268 if not Is_Attribute_Name
(Aname
) then
11269 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11273 -- Otherwise, rewrite the pragma as an attribute definition clause
11276 Make_Attribute_Definition_Clause
(Loc
,
11277 Name
=> Get_Pragma_Arg
(Arg2
),
11279 Expression
=> Get_Pragma_Arg
(Arg3
)));
11281 end Attribute_Definition
;
11283 ------------------------------------------------------------------
11284 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11285 ------------------------------------------------------------------
11287 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11288 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11289 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11290 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11292 -- FLAG ::= boolean_EXPRESSION
11294 when Pragma_Async_Readers |
11295 Pragma_Async_Writers |
11296 Pragma_Effective_Reads |
11297 Pragma_Effective_Writes
=>
11298 Async_Effective
: declare
11302 Obj_Id
: Entity_Id
;
11306 Check_No_Identifiers
;
11307 Check_At_Least_N_Arguments
(1);
11308 Check_At_Most_N_Arguments
(2);
11309 Check_Arg_Is_Local_Name
(Arg1
);
11310 Error_Msg_Name_1
:= Pname
;
11312 Obj
:= Get_Pragma_Arg
(Arg1
);
11313 Expr
:= Get_Pragma_Arg
(Arg2
);
11315 -- Perform minimal verification to ensure that the argument is at
11316 -- least a variable. Subsequent finer grained checks will be done
11317 -- at the end of the declarative region the contains the pragma.
11319 if Is_Entity_Name
(Obj
)
11320 and then Present
(Entity
(Obj
))
11321 and then Ekind
(Entity
(Obj
)) = E_Variable
11323 Obj_Id
:= Entity
(Obj
);
11325 -- Detect a duplicate pragma. Note that it is not efficient to
11326 -- examine preceding statements as Boolean aspects may appear
11327 -- anywhere between the related object declaration and its
11328 -- freeze point. As an alternative, inspect the contents of the
11329 -- variable contract.
11331 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11333 if Present
(Duplic
) then
11334 Error_Msg_Sloc
:= Sloc
(Duplic
);
11335 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11337 -- No duplicate detected
11340 if Present
(Expr
) then
11341 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11344 -- Chain the pragma on the contract for further processing
11346 Add_Contract_Item
(N
, Obj_Id
);
11349 Error_Pragma
("pragma % must apply to a volatile object");
11351 end Async_Effective
;
11357 -- pragma Asynchronous (LOCAL_NAME);
11359 when Pragma_Asynchronous
=> Asynchronous
: declare
11365 Formal
: Entity_Id
;
11367 procedure Process_Async_Pragma
;
11368 -- Common processing for procedure and access-to-procedure case
11370 --------------------------
11371 -- Process_Async_Pragma --
11372 --------------------------
11374 procedure Process_Async_Pragma
is
11377 Set_Is_Asynchronous
(Nm
);
11381 -- The formals should be of mode IN (RM E.4.1(6))
11384 while Present
(S
) loop
11385 Formal
:= Defining_Identifier
(S
);
11387 if Nkind
(Formal
) = N_Defining_Identifier
11388 and then Ekind
(Formal
) /= E_In_Parameter
11391 ("pragma% procedure can only have IN parameter",
11398 Set_Is_Asynchronous
(Nm
);
11399 end Process_Async_Pragma
;
11401 -- Start of processing for pragma Asynchronous
11404 Check_Ada_83_Warning
;
11405 Check_No_Identifiers
;
11406 Check_Arg_Count
(1);
11407 Check_Arg_Is_Local_Name
(Arg1
);
11409 if Debug_Flag_U
then
11413 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11414 Analyze
(Get_Pragma_Arg
(Arg1
));
11415 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11417 if not Is_Remote_Call_Interface
(C_Ent
)
11418 and then not Is_Remote_Types
(C_Ent
)
11420 -- This pragma should only appear in an RCI or Remote Types
11421 -- unit (RM E.4.1(4)).
11424 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11427 if Ekind
(Nm
) = E_Procedure
11428 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11430 if not Is_Remote_Call_Interface
(Nm
) then
11432 ("pragma% cannot be applied on non-remote procedure",
11436 L
:= Parameter_Specifications
(Parent
(Nm
));
11437 Process_Async_Pragma
;
11440 elsif Ekind
(Nm
) = E_Function
then
11442 ("pragma% cannot be applied to function", Arg1
);
11444 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11445 if Is_Record_Type
(Nm
) then
11447 -- A record type that is the Equivalent_Type for a remote
11448 -- access-to-subprogram type.
11450 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11453 -- A non-expanded RAS type (distribution is not enabled)
11455 N
:= Declaration_Node
(Nm
);
11458 if Nkind
(N
) = N_Full_Type_Declaration
11459 and then Nkind
(Type_Definition
(N
)) =
11460 N_Access_Procedure_Definition
11462 L
:= Parameter_Specifications
(Type_Definition
(N
));
11463 Process_Async_Pragma
;
11465 if Is_Asynchronous
(Nm
)
11466 and then Expander_Active
11467 and then Get_PCS_Name
/= Name_No_DSA
11469 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11474 ("pragma% cannot reference access-to-function type",
11478 -- Only other possibility is Access-to-class-wide type
11480 elsif Is_Access_Type
(Nm
)
11481 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11483 Check_First_Subtype
(Arg1
);
11484 Set_Is_Asynchronous
(Nm
);
11485 if Expander_Active
then
11486 RACW_Type_Is_Asynchronous
(Nm
);
11490 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11498 -- pragma Atomic (LOCAL_NAME);
11500 when Pragma_Atomic
=>
11501 Process_Atomic_Shared_Volatile
;
11503 -----------------------
11504 -- Atomic_Components --
11505 -----------------------
11507 -- pragma Atomic_Components (array_LOCAL_NAME);
11509 -- This processing is shared by Volatile_Components
11511 when Pragma_Atomic_Components |
11512 Pragma_Volatile_Components
=>
11514 Atomic_Components
: declare
11521 Check_Ada_83_Warning
;
11522 Check_No_Identifiers
;
11523 Check_Arg_Count
(1);
11524 Check_Arg_Is_Local_Name
(Arg1
);
11525 E_Id
:= Get_Pragma_Arg
(Arg1
);
11527 if Etype
(E_Id
) = Any_Type
then
11531 E
:= Entity
(E_Id
);
11533 Check_Duplicate_Pragma
(E
);
11535 if Rep_Item_Too_Early
(E
, N
)
11537 Rep_Item_Too_Late
(E
, N
)
11542 D
:= Declaration_Node
(E
);
11545 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11547 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11548 and then Nkind
(D
) = N_Object_Declaration
11549 and then Nkind
(Object_Definition
(D
)) =
11550 N_Constrained_Array_Definition
)
11552 -- The flag is set on the object, or on the base type
11554 if Nkind
(D
) /= N_Object_Declaration
then
11555 E
:= Base_Type
(E
);
11558 Set_Has_Volatile_Components
(E
);
11560 if Prag_Id
= Pragma_Atomic_Components
then
11561 Set_Has_Atomic_Components
(E
);
11565 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11567 end Atomic_Components
;
11569 --------------------
11570 -- Attach_Handler --
11571 --------------------
11573 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11575 when Pragma_Attach_Handler
=>
11576 Check_Ada_83_Warning
;
11577 Check_No_Identifiers
;
11578 Check_Arg_Count
(2);
11580 if No_Run_Time_Mode
then
11581 Error_Msg_CRT
("Attach_Handler pragma", N
);
11583 Check_Interrupt_Or_Attach_Handler
;
11585 -- The expression that designates the attribute may depend on a
11586 -- discriminant, and is therefore a per-object expression, to
11587 -- be expanded in the init proc. If expansion is enabled, then
11588 -- perform semantic checks on a copy only.
11593 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11596 -- In Relaxed_RM_Semantics mode, we allow any static
11597 -- integer value, for compatibility with other compilers.
11599 if Relaxed_RM_Semantics
11600 and then Nkind
(Parg2
) = N_Integer_Literal
11602 Typ
:= Standard_Integer
;
11604 Typ
:= RTE
(RE_Interrupt_ID
);
11607 if Expander_Active
then
11608 Temp
:= New_Copy_Tree
(Parg2
);
11609 Set_Parent
(Temp
, N
);
11610 Preanalyze_And_Resolve
(Temp
, Typ
);
11613 Resolve
(Parg2
, Typ
);
11617 Process_Interrupt_Or_Attach_Handler
;
11620 --------------------
11621 -- C_Pass_By_Copy --
11622 --------------------
11624 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11626 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11632 Check_Valid_Configuration_Pragma
;
11633 Check_Arg_Count
(1);
11634 Check_Optional_Identifier
(Arg1
, "max_size");
11636 Arg
:= Get_Pragma_Arg
(Arg1
);
11637 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11639 Val
:= Expr_Value
(Arg
);
11643 ("maximum size for pragma% must be positive", Arg1
);
11645 elsif UI_Is_In_Int_Range
(Val
) then
11646 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11648 -- If a giant value is given, Int'Last will do well enough.
11649 -- If sometime someone complains that a record larger than
11650 -- two gigabytes is not copied, we will worry about it then.
11653 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11655 end C_Pass_By_Copy
;
11661 -- pragma Check ([Name =>] CHECK_KIND,
11662 -- [Check =>] Boolean_EXPRESSION
11663 -- [,[Message =>] String_EXPRESSION]);
11665 -- CHECK_KIND ::= IDENTIFIER |
11668 -- Invariant'Class |
11669 -- Type_Invariant'Class
11671 -- The identifiers Assertions and Statement_Assertions are not
11672 -- allowed, since they have special meaning for Check_Policy.
11674 when Pragma_Check
=> Check
: declare
11682 Check_At_Least_N_Arguments
(2);
11683 Check_At_Most_N_Arguments
(3);
11684 Check_Optional_Identifier
(Arg1
, Name_Name
);
11685 Check_Optional_Identifier
(Arg2
, Name_Check
);
11687 if Arg_Count
= 3 then
11688 Check_Optional_Identifier
(Arg3
, Name_Message
);
11689 Str
:= Get_Pragma_Arg
(Arg3
);
11692 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11693 Check_Arg_Is_Identifier
(Arg1
);
11694 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11696 -- Check forbidden name Assertions or Statement_Assertions
11699 when Name_Assertions
=>
11701 ("""Assertions"" is not allowed as a check kind "
11702 & "for pragma%", Arg1
);
11704 when Name_Statement_Assertions
=>
11706 ("""Statement_Assertions"" is not allowed as a check kind "
11707 & "for pragma%", Arg1
);
11713 -- Check applicable policy. We skip this if Checked/Ignored status
11714 -- is already set (e.g. in the casse of a pragma from an aspect).
11716 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11719 -- For a non-source pragma that is a rewriting of another pragma,
11720 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11722 elsif Is_Rewrite_Substitution
(N
)
11723 and then Nkind
(Original_Node
(N
)) = N_Pragma
11724 and then Original_Node
(N
) /= N
11726 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11727 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11729 -- Otherwise query the applicable policy at this point
11732 case Check_Kind
(Cname
) is
11733 when Name_Ignore
=>
11734 Set_Is_Ignored
(N
, True);
11735 Set_Is_Checked
(N
, False);
11738 Set_Is_Ignored
(N
, False);
11739 Set_Is_Checked
(N
, True);
11741 -- For disable, rewrite pragma as null statement and skip
11742 -- rest of the analysis of the pragma.
11744 when Name_Disable
=>
11745 Rewrite
(N
, Make_Null_Statement
(Loc
));
11749 -- No other possibilities
11752 raise Program_Error
;
11756 -- If check kind was not Disable, then continue pragma analysis
11758 Expr
:= Get_Pragma_Arg
(Arg2
);
11760 -- Deal with SCO generation
11763 when Name_Predicate |
11766 -- Nothing to do: since checks occur in client units,
11767 -- the SCO for the aspect in the declaration unit is
11768 -- conservatively always enabled.
11774 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11776 -- Mark aspect/pragma SCO as enabled
11778 Set_SCO_Pragma_Enabled
(Loc
);
11782 -- Deal with analyzing the string argument.
11784 if Arg_Count
= 3 then
11786 -- If checks are not on we don't want any expansion (since
11787 -- such expansion would not get properly deleted) but
11788 -- we do want to analyze (to get proper references).
11789 -- The Preanalyze_And_Resolve routine does just what we want
11791 if Is_Ignored
(N
) then
11792 Preanalyze_And_Resolve
(Str
, Standard_String
);
11794 -- Otherwise we need a proper analysis and expansion
11797 Analyze_And_Resolve
(Str
, Standard_String
);
11801 -- Now you might think we could just do the same with the Boolean
11802 -- expression if checks are off (and expansion is on) and then
11803 -- rewrite the check as a null statement. This would work but we
11804 -- would lose the useful warnings about an assertion being bound
11805 -- to fail even if assertions are turned off.
11807 -- So instead we wrap the boolean expression in an if statement
11808 -- that looks like:
11810 -- if False and then condition then
11814 -- The reason we do this rewriting during semantic analysis rather
11815 -- than as part of normal expansion is that we cannot analyze and
11816 -- expand the code for the boolean expression directly, or it may
11817 -- cause insertion of actions that would escape the attempt to
11818 -- suppress the check code.
11820 -- Note that the Sloc for the if statement corresponds to the
11821 -- argument condition, not the pragma itself. The reason for
11822 -- this is that we may generate a warning if the condition is
11823 -- False at compile time, and we do not want to delete this
11824 -- warning when we delete the if statement.
11826 if Expander_Active
and Is_Ignored
(N
) then
11827 Eloc
:= Sloc
(Expr
);
11830 Make_If_Statement
(Eloc
,
11832 Make_And_Then
(Eloc
,
11833 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
11834 Right_Opnd
=> Expr
),
11835 Then_Statements
=> New_List
(
11836 Make_Null_Statement
(Eloc
))));
11838 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11840 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11842 -- Check is active or expansion not active. In these cases we can
11843 -- just go ahead and analyze the boolean with no worries.
11846 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11847 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11848 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11852 --------------------------
11853 -- Check_Float_Overflow --
11854 --------------------------
11856 -- pragma Check_Float_Overflow;
11858 when Pragma_Check_Float_Overflow
=>
11860 Check_Valid_Configuration_Pragma
;
11861 Check_Arg_Count
(0);
11862 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11868 -- pragma Check_Name (check_IDENTIFIER);
11870 when Pragma_Check_Name
=>
11872 Check_No_Identifiers
;
11873 Check_Valid_Configuration_Pragma
;
11874 Check_Arg_Count
(1);
11875 Check_Arg_Is_Identifier
(Arg1
);
11878 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11881 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11882 if Check_Names
.Table
(J
) = Nam
then
11887 Check_Names
.Append
(Nam
);
11894 -- This is the old style syntax, which is still allowed in all modes:
11896 -- pragma Check_Policy ([Name =>] CHECK_KIND
11897 -- [Policy =>] POLICY_IDENTIFIER);
11899 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11901 -- CHECK_KIND ::= IDENTIFIER |
11904 -- Type_Invariant'Class |
11907 -- This is the new style syntax, compatible with Assertion_Policy
11908 -- and also allowed in all modes.
11910 -- Pragma Check_Policy (
11911 -- CHECK_KIND => POLICY_IDENTIFIER
11912 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11914 -- Note: the identifiers Name and Policy are not allowed as
11915 -- Check_Kind values. This avoids ambiguities between the old and
11916 -- new form syntax.
11918 when Pragma_Check_Policy
=> Check_Policy
: declare
11923 Check_At_Least_N_Arguments
(1);
11925 -- A Check_Policy pragma can appear either as a configuration
11926 -- pragma, or in a declarative part or a package spec (see RM
11927 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11928 -- followed for Check_Policy).
11930 if not Is_Configuration_Pragma
then
11931 Check_Is_In_Decl_Part_Or_Package_Spec
;
11934 -- Figure out if we have the old or new syntax. We have the
11935 -- old syntax if the first argument has no identifier, or the
11936 -- identifier is Name.
11938 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11939 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11943 Check_Arg_Count
(2);
11944 Check_Optional_Identifier
(Arg1
, Name_Name
);
11945 Kind
:= Get_Pragma_Arg
(Arg1
);
11946 Rewrite_Assertion_Kind
(Kind
);
11947 Check_Arg_Is_Identifier
(Arg1
);
11949 -- Check forbidden check kind
11951 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11952 Error_Msg_Name_2
:= Chars
(Kind
);
11954 ("pragma% does not allow% as check name", Arg1
);
11959 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11960 Check_Arg_Is_One_Of
11962 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11964 -- And chain pragma on the Check_Policy_List for search
11966 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11967 Opt
.Check_Policy_List
:= N
;
11969 -- For the new syntax, what we do is to convert each argument to
11970 -- an old syntax equivalent. We do that because we want to chain
11971 -- old style Check_Policy pragmas for the search (we don't want
11972 -- to have to deal with multiple arguments in the search).
11982 while Present
(Arg
) loop
11983 LocP
:= Sloc
(Arg
);
11984 Argx
:= Get_Pragma_Arg
(Arg
);
11986 -- Kind must be specified
11988 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11989 or else Chars
(Arg
) = No_Name
11992 ("missing assertion kind for pragma%", Arg
);
11995 -- Construct equivalent old form syntax Check_Policy
11996 -- pragma and insert it to get remaining checks.
12000 Chars
=> Name_Check_Policy
,
12001 Pragma_Argument_Associations
=> New_List
(
12002 Make_Pragma_Argument_Association
(LocP
,
12004 Make_Identifier
(LocP
, Chars
(Arg
))),
12005 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12006 Expression
=> Argx
))));
12011 -- Rewrite original Check_Policy pragma to null, since we
12012 -- have converted it into a series of old syntax pragmas.
12014 Rewrite
(N
, Make_Null_Statement
(Loc
));
12020 ---------------------
12021 -- CIL_Constructor --
12022 ---------------------
12024 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12026 -- Processing for this pragma is shared with Java_Constructor
12032 -- pragma Comment (static_string_EXPRESSION)
12034 -- Processing for pragma Comment shares the circuitry for pragma
12035 -- Ident. The only differences are that Ident enforces a limit of 31
12036 -- characters on its argument, and also enforces limitations on
12037 -- placement for DEC compatibility. Pragma Comment shares neither of
12038 -- these restrictions.
12040 -------------------
12041 -- Common_Object --
12042 -------------------
12044 -- pragma Common_Object (
12045 -- [Internal =>] LOCAL_NAME
12046 -- [, [External =>] EXTERNAL_SYMBOL]
12047 -- [, [Size =>] EXTERNAL_SYMBOL]);
12049 -- Processing for this pragma is shared with Psect_Object
12051 ------------------------
12052 -- Compile_Time_Error --
12053 ------------------------
12055 -- pragma Compile_Time_Error
12056 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12058 when Pragma_Compile_Time_Error
=>
12060 Process_Compile_Time_Warning_Or_Error
;
12062 --------------------------
12063 -- Compile_Time_Warning --
12064 --------------------------
12066 -- pragma Compile_Time_Warning
12067 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12069 when Pragma_Compile_Time_Warning
=>
12071 Process_Compile_Time_Warning_Or_Error
;
12073 ---------------------------
12074 -- Compiler_Unit_Warning --
12075 ---------------------------
12077 -- pragma Compiler_Unit_Warning;
12081 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12082 -- errors not warnings. This means that we had introduced a big extra
12083 -- inertia to compiler changes, since even if we implemented a new
12084 -- feature, and even if all versions to be used for bootstrapping
12085 -- implemented this new feature, we could not use it, since old
12086 -- compilers would give errors for using this feature in units
12087 -- having Compiler_Unit pragmas.
12089 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12090 -- problem. We no longer have any units mentioning Compiler_Unit,
12091 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12092 -- and thus generates a warning which can be ignored. So that deals
12093 -- with the problem of old compilers not implementing the newer form
12096 -- Newer compilers recognize the new pragma, but generate warning
12097 -- messages instead of errors, which again can be ignored in the
12098 -- case of an old compiler which implements a wanted new feature
12099 -- but at the time felt like warning about it for older compilers.
12101 -- We retain Compiler_Unit so that new compilers can be used to build
12102 -- older run-times that use this pragma. That's an unusual case, but
12103 -- it's easy enough to handle, so why not?
12105 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12107 Check_Arg_Count
(0);
12109 -- Only recognized in main unit
12111 if Current_Sem_Unit
= Main_Unit
then
12112 Compiler_Unit
:= True;
12115 -----------------------------
12116 -- Complete_Representation --
12117 -----------------------------
12119 -- pragma Complete_Representation;
12121 when Pragma_Complete_Representation
=>
12123 Check_Arg_Count
(0);
12125 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12127 ("pragma & must appear within record representation clause");
12130 ----------------------------
12131 -- Complex_Representation --
12132 ----------------------------
12134 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12136 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12143 Check_Arg_Count
(1);
12144 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12145 Check_Arg_Is_Local_Name
(Arg1
);
12146 E_Id
:= Get_Pragma_Arg
(Arg1
);
12148 if Etype
(E_Id
) = Any_Type
then
12152 E
:= Entity
(E_Id
);
12154 if not Is_Record_Type
(E
) then
12156 ("argument for pragma% must be record type", Arg1
);
12159 Ent
:= First_Entity
(E
);
12162 or else No
(Next_Entity
(Ent
))
12163 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12164 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12165 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12168 ("record for pragma% must have two fields of the same "
12169 & "floating-point type", Arg1
);
12172 Set_Has_Complex_Representation
(Base_Type
(E
));
12174 -- We need to treat the type has having a non-standard
12175 -- representation, for back-end purposes, even though in
12176 -- general a complex will have the default representation
12177 -- of a record with two real components.
12179 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12181 end Complex_Representation
;
12183 -------------------------
12184 -- Component_Alignment --
12185 -------------------------
12187 -- pragma Component_Alignment (
12188 -- [Form =>] ALIGNMENT_CHOICE
12189 -- [, [Name =>] type_LOCAL_NAME]);
12191 -- ALIGNMENT_CHOICE ::=
12193 -- | Component_Size_4
12197 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12198 Args
: Args_List
(1 .. 2);
12199 Names
: constant Name_List
(1 .. 2) := (
12203 Form
: Node_Id
renames Args
(1);
12204 Name
: Node_Id
renames Args
(2);
12206 Atype
: Component_Alignment_Kind
;
12211 Gather_Associations
(Names
, Args
);
12214 Error_Pragma
("missing Form argument for pragma%");
12217 Check_Arg_Is_Identifier
(Form
);
12219 -- Get proper alignment, note that Default = Component_Size on all
12220 -- machines we have so far, and we want to set this value rather
12221 -- than the default value to indicate that it has been explicitly
12222 -- set (and thus will not get overridden by the default component
12223 -- alignment for the current scope)
12225 if Chars
(Form
) = Name_Component_Size
then
12226 Atype
:= Calign_Component_Size
;
12228 elsif Chars
(Form
) = Name_Component_Size_4
then
12229 Atype
:= Calign_Component_Size_4
;
12231 elsif Chars
(Form
) = Name_Default
then
12232 Atype
:= Calign_Component_Size
;
12234 elsif Chars
(Form
) = Name_Storage_Unit
then
12235 Atype
:= Calign_Storage_Unit
;
12239 ("invalid Form parameter for pragma%", Form
);
12242 -- Case with no name, supplied, affects scope table entry
12246 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12248 -- Case of name supplied
12251 Check_Arg_Is_Local_Name
(Name
);
12253 Typ
:= Entity
(Name
);
12256 or else Rep_Item_Too_Early
(Typ
, N
)
12260 Typ
:= Underlying_Type
(Typ
);
12263 if not Is_Record_Type
(Typ
)
12264 and then not Is_Array_Type
(Typ
)
12267 ("Name parameter of pragma% must identify record or "
12268 & "array type", Name
);
12271 -- An explicit Component_Alignment pragma overrides an
12272 -- implicit pragma Pack, but not an explicit one.
12274 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12275 Set_Is_Packed
(Base_Type
(Typ
), False);
12276 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12279 end Component_AlignmentP
;
12281 --------------------
12282 -- Contract_Cases --
12283 --------------------
12285 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12287 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12289 -- CASE_GUARD ::= boolean_EXPRESSION | others
12291 -- CONSEQUENCE ::= boolean_EXPRESSION
12293 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12294 Subp_Decl
: Node_Id
;
12298 Check_No_Identifiers
;
12299 Check_Arg_Count
(1);
12300 Ensure_Aggregate_Form
(Arg1
);
12302 -- The pragma is analyzed at the end of the declarative part which
12303 -- contains the related subprogram. Reset the analyzed flag.
12305 Set_Analyzed
(N
, False);
12307 -- Ensure the proper placement of the pragma. Contract_Cases must
12308 -- be associated with a subprogram declaration or a body that acts
12312 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12314 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12317 -- Body acts as spec
12319 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12320 and then No
(Corresponding_Spec
(Subp_Decl
))
12324 -- Body stub acts as spec
12326 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12327 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12336 -- When the pragma appears on a subprogram body, perform the full
12339 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12340 Analyze_Contract_Cases_In_Decl_Part
(N
);
12342 -- When Contract_Cases applies to a subprogram compilation unit,
12343 -- the corresponding pragma is placed after the unit's declaration
12344 -- node and needs to be analyzed immediately.
12346 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12347 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12349 Analyze_Contract_Cases_In_Decl_Part
(N
);
12352 -- Chain the pragma on the contract for further processing
12354 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12355 end Contract_Cases
;
12361 -- pragma Controlled (first_subtype_LOCAL_NAME);
12363 when Pragma_Controlled
=> Controlled
: declare
12367 Check_No_Identifiers
;
12368 Check_Arg_Count
(1);
12369 Check_Arg_Is_Local_Name
(Arg1
);
12370 Arg
:= Get_Pragma_Arg
(Arg1
);
12372 if not Is_Entity_Name
(Arg
)
12373 or else not Is_Access_Type
(Entity
(Arg
))
12375 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12377 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12385 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12386 -- [Entity =>] LOCAL_NAME);
12388 when Pragma_Convention
=> Convention
: declare
12391 pragma Warnings
(Off
, C
);
12392 pragma Warnings
(Off
, E
);
12394 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12395 Check_Ada_83_Warning
;
12396 Check_Arg_Count
(2);
12397 Process_Convention
(C
, E
);
12400 ---------------------------
12401 -- Convention_Identifier --
12402 ---------------------------
12404 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12405 -- [Convention =>] convention_IDENTIFIER);
12407 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12413 Check_Arg_Order
((Name_Name
, Name_Convention
));
12414 Check_Arg_Count
(2);
12415 Check_Optional_Identifier
(Arg1
, Name_Name
);
12416 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12417 Check_Arg_Is_Identifier
(Arg1
);
12418 Check_Arg_Is_Identifier
(Arg2
);
12419 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12420 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12422 if Is_Convention_Name
(Cname
) then
12423 Record_Convention_Identifier
12424 (Idnam
, Get_Convention_Id
(Cname
));
12427 ("second arg for % pragma must be convention", Arg2
);
12429 end Convention_Identifier
;
12435 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12437 when Pragma_CPP_Class
=> CPP_Class
: declare
12441 if Warn_On_Obsolescent_Feature
then
12443 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12444 & "effect; replace it by pragma import?j?", N
);
12447 Check_Arg_Count
(1);
12451 Chars
=> Name_Import
,
12452 Pragma_Argument_Associations
=> New_List
(
12453 Make_Pragma_Argument_Association
(Loc
,
12454 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12455 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12459 ---------------------
12460 -- CPP_Constructor --
12461 ---------------------
12463 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12464 -- [, [External_Name =>] static_string_EXPRESSION ]
12465 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12467 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12470 Def_Id
: Entity_Id
;
12471 Tag_Typ
: Entity_Id
;
12475 Check_At_Least_N_Arguments
(1);
12476 Check_At_Most_N_Arguments
(3);
12477 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12478 Check_Arg_Is_Local_Name
(Arg1
);
12480 Id
:= Get_Pragma_Arg
(Arg1
);
12481 Find_Program_Unit_Name
(Id
);
12483 -- If we did not find the name, we are done
12485 if Etype
(Id
) = Any_Type
then
12489 Def_Id
:= Entity
(Id
);
12491 -- Check if already defined as constructor
12493 if Is_Constructor
(Def_Id
) then
12495 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12499 if Ekind
(Def_Id
) = E_Function
12500 and then (Is_CPP_Class
(Etype
(Def_Id
))
12501 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12503 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12505 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12507 ("'C'P'P constructor must be defined in the scope of "
12508 & "its returned type", Arg1
);
12511 if Arg_Count
>= 2 then
12512 Set_Imported
(Def_Id
);
12513 Set_Is_Public
(Def_Id
);
12514 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12517 Set_Has_Completion
(Def_Id
);
12518 Set_Is_Constructor
(Def_Id
);
12519 Set_Convention
(Def_Id
, Convention_CPP
);
12521 -- Imported C++ constructors are not dispatching primitives
12522 -- because in C++ they don't have a dispatch table slot.
12523 -- However, in Ada the constructor has the profile of a
12524 -- function that returns a tagged type and therefore it has
12525 -- been treated as a primitive operation during semantic
12526 -- analysis. We now remove it from the list of primitive
12527 -- operations of the type.
12529 if Is_Tagged_Type
(Etype
(Def_Id
))
12530 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12531 and then Is_Dispatching_Operation
(Def_Id
)
12533 Tag_Typ
:= Etype
(Def_Id
);
12535 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12536 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12540 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12541 Set_Is_Dispatching_Operation
(Def_Id
, False);
12544 -- For backward compatibility, if the constructor returns a
12545 -- class wide type, and we internally change the return type to
12546 -- the corresponding root type.
12548 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12549 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12553 ("pragma% requires function returning a 'C'P'P_Class type",
12556 end CPP_Constructor
;
12562 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12566 if Warn_On_Obsolescent_Feature
then
12568 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12577 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12581 if Warn_On_Obsolescent_Feature
then
12583 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12592 -- pragma CPU (EXPRESSION);
12594 when Pragma_CPU
=> CPU
: declare
12595 P
: constant Node_Id
:= Parent
(N
);
12601 Check_No_Identifiers
;
12602 Check_Arg_Count
(1);
12606 if Nkind
(P
) = N_Subprogram_Body
then
12607 Check_In_Main_Program
;
12609 Arg
:= Get_Pragma_Arg
(Arg1
);
12610 Analyze_And_Resolve
(Arg
, Any_Integer
);
12612 Ent
:= Defining_Unit_Name
(Specification
(P
));
12614 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12615 Ent
:= Defining_Identifier
(Ent
);
12620 if not Is_OK_Static_Expression
(Arg
) then
12621 Flag_Non_Static_Expr
12622 ("main subprogram affinity is not static!", Arg
);
12625 -- If constraint error, then we already signalled an error
12627 elsif Raises_Constraint_Error
(Arg
) then
12630 -- Otherwise check in range
12634 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12635 -- This is the entity System.Multiprocessors.CPU_Range;
12637 Val
: constant Uint
:= Expr_Value
(Arg
);
12640 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12642 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12645 ("main subprogram CPU is out of range", Arg1
);
12651 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12655 elsif Nkind
(P
) = N_Task_Definition
then
12656 Arg
:= Get_Pragma_Arg
(Arg1
);
12657 Ent
:= Defining_Identifier
(Parent
(P
));
12659 -- The expression must be analyzed in the special manner
12660 -- described in "Handling of Default and Per-Object
12661 -- Expressions" in sem.ads.
12663 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12665 -- Anything else is incorrect
12671 -- Check duplicate pragma before we chain the pragma in the Rep
12672 -- Item chain of Ent.
12674 Check_Duplicate_Pragma
(Ent
);
12675 Record_Rep_Item
(Ent
, N
);
12682 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12684 when Pragma_Debug
=> Debug
: declare
12691 -- The condition for executing the call is that the expander
12692 -- is active and that we are not ignoring this debug pragma.
12697 (Expander_Active
and then not Is_Ignored
(N
)),
12700 if not Is_Ignored
(N
) then
12701 Set_SCO_Pragma_Enabled
(Loc
);
12704 if Arg_Count
= 2 then
12706 Make_And_Then
(Loc
,
12707 Left_Opnd
=> Relocate_Node
(Cond
),
12708 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12709 Call
:= Get_Pragma_Arg
(Arg2
);
12711 Call
:= Get_Pragma_Arg
(Arg1
);
12715 N_Indexed_Component
,
12719 N_Selected_Component
)
12721 -- If this pragma Debug comes from source, its argument was
12722 -- parsed as a name form (which is syntactically identical).
12723 -- In a generic context a parameterless call will be left as
12724 -- an expanded name (if global) or selected_component if local.
12725 -- Change it to a procedure call statement now.
12727 Change_Name_To_Procedure_Call_Statement
(Call
);
12729 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12731 -- Already in the form of a procedure call statement: nothing
12732 -- to do (could happen in case of an internally generated
12738 -- All other cases: diagnose error
12741 ("argument of pragma ""Debug"" is not procedure call",
12746 -- Rewrite into a conditional with an appropriate condition. We
12747 -- wrap the procedure call in a block so that overhead from e.g.
12748 -- use of the secondary stack does not generate execution overhead
12749 -- for suppressed conditions.
12751 -- Normally the analysis that follows will freeze the subprogram
12752 -- being called. However, if the call is to a null procedure,
12753 -- we want to freeze it before creating the block, because the
12754 -- analysis that follows may be done with expansion disabled, in
12755 -- which case the body will not be generated, leading to spurious
12758 if Nkind
(Call
) = N_Procedure_Call_Statement
12759 and then Is_Entity_Name
(Name
(Call
))
12761 Analyze
(Name
(Call
));
12762 Freeze_Before
(N
, Entity
(Name
(Call
)));
12766 Make_Implicit_If_Statement
(N
,
12768 Then_Statements
=> New_List
(
12769 Make_Block_Statement
(Loc
,
12770 Handled_Statement_Sequence
=>
12771 Make_Handled_Sequence_Of_Statements
(Loc
,
12772 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12775 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12776 -- after analysis of the normally rewritten node, to capture all
12777 -- references to entities, which avoids issuing wrong warnings
12778 -- about unused entities.
12780 if GNATprove_Mode
then
12781 Rewrite
(N
, Make_Null_Statement
(Loc
));
12789 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12791 when Pragma_Debug_Policy
=>
12793 Check_Arg_Count
(1);
12794 Check_No_Identifiers
;
12795 Check_Arg_Is_Identifier
(Arg1
);
12797 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12798 -- rewrite it that way, and let the rest of the checking come
12799 -- from analyzing the rewritten pragma.
12803 Chars
=> Name_Check_Policy
,
12804 Pragma_Argument_Associations
=> New_List
(
12805 Make_Pragma_Argument_Association
(Loc
,
12806 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12808 Make_Pragma_Argument_Association
(Loc
,
12809 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12812 -------------------------------
12813 -- Default_Initial_Condition --
12814 -------------------------------
12816 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12818 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12825 Check_No_Identifiers
;
12826 Check_At_Most_N_Arguments
(1);
12829 while Present
(Stmt
) loop
12831 -- Skip prior pragmas, but check for duplicates
12833 if Nkind
(Stmt
) = N_Pragma
then
12834 if Pragma_Name
(Stmt
) = Pname
then
12835 Error_Msg_Name_1
:= Pname
;
12836 Error_Msg_Sloc
:= Sloc
(Stmt
);
12837 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12840 -- Skip internally generated code
12842 elsif not Comes_From_Source
(Stmt
) then
12845 -- The associated private type [extension] has been found, stop
12848 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12849 N_Private_Type_Declaration
)
12851 Typ
:= Defining_Entity
(Stmt
);
12854 -- The pragma does not apply to a legal construct, issue an
12855 -- error and stop the analysis.
12862 Stmt
:= Prev
(Stmt
);
12865 Set_Has_Default_Init_Cond
(Typ
);
12866 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12868 -- Chain the pragma on the rep item chain for further processing
12870 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12871 end Default_Init_Cond
;
12873 ----------------------------------
12874 -- Default_Scalar_Storage_Order --
12875 ----------------------------------
12877 -- pragma Default_Scalar_Storage_Order
12878 -- (High_Order_First | Low_Order_First);
12880 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12881 Default
: Character;
12885 Check_Arg_Count
(1);
12887 -- Default_Scalar_Storage_Order can appear as a configuration
12888 -- pragma, or in a declarative part of a package spec.
12890 if not Is_Configuration_Pragma
then
12891 Check_Is_In_Decl_Part_Or_Package_Spec
;
12894 Check_No_Identifiers
;
12895 Check_Arg_Is_One_Of
12896 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12897 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12898 Default
:= Fold_Upper
(Name_Buffer
(1));
12900 if not Support_Nondefault_SSO_On_Target
12901 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12903 if Warn_On_Unrecognized_Pragma
then
12905 ("non-default Scalar_Storage_Order not supported "
12906 & "on target?g?", N
);
12908 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12911 -- Here set the specified default
12914 Opt
.Default_SSO
:= Default
;
12918 --------------------------
12919 -- Default_Storage_Pool --
12920 --------------------------
12922 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12924 when Pragma_Default_Storage_Pool
=>
12926 Check_Arg_Count
(1);
12928 -- Default_Storage_Pool can appear as a configuration pragma, or
12929 -- in a declarative part of a package spec.
12931 if not Is_Configuration_Pragma
then
12932 Check_Is_In_Decl_Part_Or_Package_Spec
;
12935 -- Case of Default_Storage_Pool (null);
12937 if Nkind
(Expression
(Arg1
)) = N_Null
then
12938 Analyze
(Expression
(Arg1
));
12940 -- This is an odd case, this is not really an expression, so
12941 -- we don't have a type for it. So just set the type to Empty.
12943 Set_Etype
(Expression
(Arg1
), Empty
);
12945 -- Case of Default_Storage_Pool (storage_pool_NAME);
12948 -- If it's a configuration pragma, then the only allowed
12949 -- argument is "null".
12951 if Is_Configuration_Pragma
then
12952 Error_Pragma_Arg
("NULL expected", Arg1
);
12955 -- The expected type for a non-"null" argument is
12956 -- Root_Storage_Pool'Class, and the pool must be a variable.
12958 Analyze_And_Resolve
12959 (Get_Pragma_Arg
(Arg1
),
12960 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12962 if not Is_Variable
(Expression
(Arg1
)) then
12964 ("default storage pool must be a variable", Arg1
);
12968 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12969 -- for an access type will use this information to set the
12970 -- appropriate attributes of the access type.
12972 Default_Pool
:= Expression
(Arg1
);
12978 -- pragma Depends (DEPENDENCY_RELATION);
12980 -- DEPENDENCY_RELATION ::=
12982 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12984 -- DEPENDENCY_CLAUSE ::=
12985 -- OUTPUT_LIST =>[+] INPUT_LIST
12986 -- | NULL_DEPENDENCY_CLAUSE
12988 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12990 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12992 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12994 -- OUTPUT ::= NAME | FUNCTION_RESULT
12997 -- where FUNCTION_RESULT is a function Result attribute_reference
12999 when Pragma_Depends
=> Depends
: declare
13000 Subp_Decl
: Node_Id
;
13004 Check_Arg_Count
(1);
13005 Ensure_Aggregate_Form
(Arg1
);
13007 -- Ensure the proper placement of the pragma. Depends must be
13008 -- associated with a subprogram declaration or a body that acts
13012 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
13014 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13017 -- Body acts as spec
13019 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13020 and then No
(Corresponding_Spec
(Subp_Decl
))
13024 -- Body stub acts as spec
13026 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13027 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13036 -- When the pragma appears on a subprogram body, perform the full
13039 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
13040 Analyze_Depends_In_Decl_Part
(N
);
13042 -- When Depends applies to a subprogram compilation unit, the
13043 -- corresponding pragma is placed after the unit's declaration
13044 -- node and needs to be analyzed immediately.
13046 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13047 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
13049 Analyze_Depends_In_Decl_Part
(N
);
13052 -- Chain the pragma on the contract for further processing
13054 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13057 ---------------------
13058 -- Detect_Blocking --
13059 ---------------------
13061 -- pragma Detect_Blocking;
13063 when Pragma_Detect_Blocking
=>
13065 Check_Arg_Count
(0);
13066 Check_Valid_Configuration_Pragma
;
13067 Detect_Blocking
:= True;
13069 ------------------------------------
13070 -- Disable_Atomic_Synchronization --
13071 ------------------------------------
13073 -- pragma Disable_Atomic_Synchronization [(Entity)];
13075 when Pragma_Disable_Atomic_Synchronization
=>
13077 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13079 -------------------
13080 -- Discard_Names --
13081 -------------------
13083 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13085 when Pragma_Discard_Names
=> Discard_Names
: declare
13090 Check_Ada_83_Warning
;
13092 -- Deal with configuration pragma case
13094 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13095 Global_Discard_Names
:= True;
13098 -- Otherwise, check correct appropriate context
13101 Check_Is_In_Decl_Part_Or_Package_Spec
;
13103 if Arg_Count
= 0 then
13105 -- If there is no parameter, then from now on this pragma
13106 -- applies to any enumeration, exception or tagged type
13107 -- defined in the current declarative part, and recursively
13108 -- to any nested scope.
13110 Set_Discard_Names
(Current_Scope
);
13114 Check_Arg_Count
(1);
13115 Check_Optional_Identifier
(Arg1
, Name_On
);
13116 Check_Arg_Is_Local_Name
(Arg1
);
13118 E_Id
:= Get_Pragma_Arg
(Arg1
);
13120 if Etype
(E_Id
) = Any_Type
then
13123 E
:= Entity
(E_Id
);
13126 if (Is_First_Subtype
(E
)
13128 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13129 or else Ekind
(E
) = E_Exception
13131 Set_Discard_Names
(E
);
13132 Record_Rep_Item
(E
, N
);
13136 ("inappropriate entity for pragma%", Arg1
);
13143 ------------------------
13144 -- Dispatching_Domain --
13145 ------------------------
13147 -- pragma Dispatching_Domain (EXPRESSION);
13149 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13150 P
: constant Node_Id
:= Parent
(N
);
13156 Check_No_Identifiers
;
13157 Check_Arg_Count
(1);
13159 -- This pragma is born obsolete, but not the aspect
13161 if not From_Aspect_Specification
(N
) then
13163 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13166 if Nkind
(P
) = N_Task_Definition
then
13167 Arg
:= Get_Pragma_Arg
(Arg1
);
13168 Ent
:= Defining_Identifier
(Parent
(P
));
13170 -- The expression must be analyzed in the special manner
13171 -- described in "Handling of Default and Per-Object
13172 -- Expressions" in sem.ads.
13174 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13176 -- Check duplicate pragma before we chain the pragma in the Rep
13177 -- Item chain of Ent.
13179 Check_Duplicate_Pragma
(Ent
);
13180 Record_Rep_Item
(Ent
, N
);
13182 -- Anything else is incorrect
13187 end Dispatching_Domain
;
13193 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13195 when Pragma_Elaborate
=> Elaborate
: declare
13200 -- Pragma must be in context items list of a compilation unit
13202 if not Is_In_Context_Clause
then
13206 -- Must be at least one argument
13208 if Arg_Count
= 0 then
13209 Error_Pragma
("pragma% requires at least one argument");
13212 -- In Ada 83 mode, there can be no items following it in the
13213 -- context list except other pragmas and implicit with clauses
13214 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13215 -- placement rule does not apply.
13217 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13219 while Present
(Citem
) loop
13220 if Nkind
(Citem
) = N_Pragma
13221 or else (Nkind
(Citem
) = N_With_Clause
13222 and then Implicit_With
(Citem
))
13227 ("(Ada 83) pragma% must be at end of context clause");
13234 -- Finally, the arguments must all be units mentioned in a with
13235 -- clause in the same context clause. Note we already checked (in
13236 -- Par.Prag) that the arguments are all identifiers or selected
13240 Outer
: while Present
(Arg
) loop
13241 Citem
:= First
(List_Containing
(N
));
13242 Inner
: while Citem
/= N
loop
13243 if Nkind
(Citem
) = N_With_Clause
13244 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13246 Set_Elaborate_Present
(Citem
, True);
13247 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13248 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
13250 -- With the pragma present, elaboration calls on
13251 -- subprograms from the named unit need no further
13252 -- checks, as long as the pragma appears in the current
13253 -- compilation unit. If the pragma appears in some unit
13254 -- in the context, there might still be a need for an
13255 -- Elaborate_All_Desirable from the current compilation
13256 -- to the named unit, so we keep the check enabled.
13258 if In_Extended_Main_Source_Unit
(N
) then
13259 Set_Suppress_Elaboration_Warnings
13260 (Entity
(Name
(Citem
)));
13271 ("argument of pragma% is not withed unit", Arg
);
13277 -- Give a warning if operating in static mode with one of the
13278 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13280 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
13282 ("?l?use of pragma Elaborate may not be safe", N
);
13284 ("?l?use pragma Elaborate_All instead if possible", N
);
13288 -------------------
13289 -- Elaborate_All --
13290 -------------------
13292 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13294 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13299 Check_Ada_83_Warning
;
13301 -- Pragma must be in context items list of a compilation unit
13303 if not Is_In_Context_Clause
then
13307 -- Must be at least one argument
13309 if Arg_Count
= 0 then
13310 Error_Pragma
("pragma% requires at least one argument");
13313 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13314 -- have to appear at the end of the context clause, but may
13315 -- appear mixed in with other items, even in Ada 83 mode.
13317 -- Final check: the arguments must all be units mentioned in
13318 -- a with clause in the same context clause. Note that we
13319 -- already checked (in Par.Prag) that all the arguments are
13320 -- either identifiers or selected components.
13323 Outr
: while Present
(Arg
) loop
13324 Citem
:= First
(List_Containing
(N
));
13325 Innr
: while Citem
/= N
loop
13326 if Nkind
(Citem
) = N_With_Clause
13327 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13329 Set_Elaborate_All_Present
(Citem
, True);
13330 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13332 -- Suppress warnings and elaboration checks on the named
13333 -- unit if the pragma is in the current compilation, as
13334 -- for pragma Elaborate.
13336 if In_Extended_Main_Source_Unit
(N
) then
13337 Set_Suppress_Elaboration_Warnings
13338 (Entity
(Name
(Citem
)));
13347 Set_Error_Posted
(N
);
13349 ("argument of pragma% is not withed unit", Arg
);
13356 --------------------
13357 -- Elaborate_Body --
13358 --------------------
13360 -- pragma Elaborate_Body [( library_unit_NAME )];
13362 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13363 Cunit_Node
: Node_Id
;
13364 Cunit_Ent
: Entity_Id
;
13367 Check_Ada_83_Warning
;
13368 Check_Valid_Library_Unit_Pragma
;
13370 if Nkind
(N
) = N_Null_Statement
then
13374 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13375 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13377 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13380 Error_Pragma
("pragma% must refer to a spec, not a body");
13382 Set_Body_Required
(Cunit_Node
, True);
13383 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13385 -- If we are in dynamic elaboration mode, then we suppress
13386 -- elaboration warnings for the unit, since it is definitely
13387 -- fine NOT to do dynamic checks at the first level (and such
13388 -- checks will be suppressed because no elaboration boolean
13389 -- is created for Elaborate_Body packages).
13391 -- But in the static model of elaboration, Elaborate_Body is
13392 -- definitely NOT good enough to ensure elaboration safety on
13393 -- its own, since the body may WITH other units that are not
13394 -- safe from an elaboration point of view, so a client must
13395 -- still do an Elaborate_All on such units.
13397 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13398 -- Elaborate_Body always suppressed elab warnings.
13400 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13401 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13404 end Elaborate_Body
;
13406 ------------------------
13407 -- Elaboration_Checks --
13408 ------------------------
13410 -- pragma Elaboration_Checks (Static | Dynamic);
13412 when Pragma_Elaboration_Checks
=>
13414 Check_Arg_Count
(1);
13415 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13416 Dynamic_Elaboration_Checks
:=
13417 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
13423 -- pragma Eliminate (
13424 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13425 -- [,[Entity =>] IDENTIFIER |
13426 -- SELECTED_COMPONENT |
13428 -- [, OVERLOADING_RESOLUTION]);
13430 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13433 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13434 -- FUNCTION_PROFILE
13436 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13438 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13439 -- Result_Type => result_SUBTYPE_NAME]
13441 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13442 -- SUBTYPE_NAME ::= STRING_LITERAL
13444 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13445 -- SOURCE_TRACE ::= STRING_LITERAL
13447 when Pragma_Eliminate
=> Eliminate
: declare
13448 Args
: Args_List
(1 .. 5);
13449 Names
: constant Name_List
(1 .. 5) := (
13452 Name_Parameter_Types
,
13454 Name_Source_Location
);
13456 Unit_Name
: Node_Id
renames Args
(1);
13457 Entity
: Node_Id
renames Args
(2);
13458 Parameter_Types
: Node_Id
renames Args
(3);
13459 Result_Type
: Node_Id
renames Args
(4);
13460 Source_Location
: Node_Id
renames Args
(5);
13464 Check_Valid_Configuration_Pragma
;
13465 Gather_Associations
(Names
, Args
);
13467 if No
(Unit_Name
) then
13468 Error_Pragma
("missing Unit_Name argument for pragma%");
13472 and then (Present
(Parameter_Types
)
13474 Present
(Result_Type
)
13476 Present
(Source_Location
))
13478 Error_Pragma
("missing Entity argument for pragma%");
13481 if (Present
(Parameter_Types
)
13483 Present
(Result_Type
))
13485 Present
(Source_Location
)
13488 ("parameter profile and source location cannot be used "
13489 & "together in pragma%");
13492 Process_Eliminate_Pragma
13501 -----------------------------------
13502 -- Enable_Atomic_Synchronization --
13503 -----------------------------------
13505 -- pragma Enable_Atomic_Synchronization [(Entity)];
13507 when Pragma_Enable_Atomic_Synchronization
=>
13509 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13516 -- [ Convention =>] convention_IDENTIFIER,
13517 -- [ Entity =>] LOCAL_NAME
13518 -- [, [External_Name =>] static_string_EXPRESSION ]
13519 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13521 when Pragma_Export
=> Export
: declare
13523 Def_Id
: Entity_Id
;
13525 pragma Warnings
(Off
, C
);
13528 Check_Ada_83_Warning
;
13532 Name_External_Name
,
13535 Check_At_Least_N_Arguments
(2);
13536 Check_At_Most_N_Arguments
(4);
13538 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13539 -- pragma Export (Entity, "external name");
13541 if Relaxed_RM_Semantics
13542 and then Arg_Count
= 2
13543 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13546 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13549 if not Is_Entity_Name
(Def_Id
) then
13550 Error_Pragma_Arg
("entity name required", Arg1
);
13553 Def_Id
:= Entity
(Def_Id
);
13554 Set_Exported
(Def_Id
, Arg1
);
13557 Process_Convention
(C
, Def_Id
);
13559 if Ekind
(Def_Id
) /= E_Constant
then
13560 Note_Possible_Modification
13561 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13564 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13565 Set_Exported
(Def_Id
, Arg2
);
13568 -- If the entity is a deferred constant, propagate the information
13569 -- to the full view, because gigi elaborates the full view only.
13571 if Ekind
(Def_Id
) = E_Constant
13572 and then Present
(Full_View
(Def_Id
))
13575 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13577 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13578 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13579 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13584 ---------------------
13585 -- Export_Function --
13586 ---------------------
13588 -- pragma Export_Function (
13589 -- [Internal =>] LOCAL_NAME
13590 -- [, [External =>] EXTERNAL_SYMBOL]
13591 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13592 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13593 -- [, [Mechanism =>] MECHANISM]
13594 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13596 -- EXTERNAL_SYMBOL ::=
13598 -- | static_string_EXPRESSION
13600 -- PARAMETER_TYPES ::=
13602 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13604 -- TYPE_DESIGNATOR ::=
13606 -- | subtype_Name ' Access
13610 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13612 -- MECHANISM_ASSOCIATION ::=
13613 -- [formal_parameter_NAME =>] MECHANISM_NAME
13615 -- MECHANISM_NAME ::=
13619 when Pragma_Export_Function
=> Export_Function
: declare
13620 Args
: Args_List
(1 .. 6);
13621 Names
: constant Name_List
(1 .. 6) := (
13624 Name_Parameter_Types
,
13627 Name_Result_Mechanism
);
13629 Internal
: Node_Id
renames Args
(1);
13630 External
: Node_Id
renames Args
(2);
13631 Parameter_Types
: Node_Id
renames Args
(3);
13632 Result_Type
: Node_Id
renames Args
(4);
13633 Mechanism
: Node_Id
renames Args
(5);
13634 Result_Mechanism
: Node_Id
renames Args
(6);
13638 Gather_Associations
(Names
, Args
);
13639 Process_Extended_Import_Export_Subprogram_Pragma
(
13640 Arg_Internal
=> Internal
,
13641 Arg_External
=> External
,
13642 Arg_Parameter_Types
=> Parameter_Types
,
13643 Arg_Result_Type
=> Result_Type
,
13644 Arg_Mechanism
=> Mechanism
,
13645 Arg_Result_Mechanism
=> Result_Mechanism
);
13646 end Export_Function
;
13648 -------------------
13649 -- Export_Object --
13650 -------------------
13652 -- pragma Export_Object (
13653 -- [Internal =>] LOCAL_NAME
13654 -- [, [External =>] EXTERNAL_SYMBOL]
13655 -- [, [Size =>] EXTERNAL_SYMBOL]);
13657 -- EXTERNAL_SYMBOL ::=
13659 -- | static_string_EXPRESSION
13661 -- PARAMETER_TYPES ::=
13663 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13665 -- TYPE_DESIGNATOR ::=
13667 -- | subtype_Name ' Access
13671 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13673 -- MECHANISM_ASSOCIATION ::=
13674 -- [formal_parameter_NAME =>] MECHANISM_NAME
13676 -- MECHANISM_NAME ::=
13680 when Pragma_Export_Object
=> Export_Object
: declare
13681 Args
: Args_List
(1 .. 3);
13682 Names
: constant Name_List
(1 .. 3) := (
13687 Internal
: Node_Id
renames Args
(1);
13688 External
: Node_Id
renames Args
(2);
13689 Size
: Node_Id
renames Args
(3);
13693 Gather_Associations
(Names
, Args
);
13694 Process_Extended_Import_Export_Object_Pragma
(
13695 Arg_Internal
=> Internal
,
13696 Arg_External
=> External
,
13700 ----------------------
13701 -- Export_Procedure --
13702 ----------------------
13704 -- pragma Export_Procedure (
13705 -- [Internal =>] LOCAL_NAME
13706 -- [, [External =>] EXTERNAL_SYMBOL]
13707 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13708 -- [, [Mechanism =>] MECHANISM]);
13710 -- EXTERNAL_SYMBOL ::=
13712 -- | static_string_EXPRESSION
13714 -- PARAMETER_TYPES ::=
13716 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13718 -- TYPE_DESIGNATOR ::=
13720 -- | subtype_Name ' Access
13724 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13726 -- MECHANISM_ASSOCIATION ::=
13727 -- [formal_parameter_NAME =>] MECHANISM_NAME
13729 -- MECHANISM_NAME ::=
13733 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13734 Args
: Args_List
(1 .. 4);
13735 Names
: constant Name_List
(1 .. 4) := (
13738 Name_Parameter_Types
,
13741 Internal
: Node_Id
renames Args
(1);
13742 External
: Node_Id
renames Args
(2);
13743 Parameter_Types
: Node_Id
renames Args
(3);
13744 Mechanism
: Node_Id
renames Args
(4);
13748 Gather_Associations
(Names
, Args
);
13749 Process_Extended_Import_Export_Subprogram_Pragma
(
13750 Arg_Internal
=> Internal
,
13751 Arg_External
=> External
,
13752 Arg_Parameter_Types
=> Parameter_Types
,
13753 Arg_Mechanism
=> Mechanism
);
13754 end Export_Procedure
;
13760 -- pragma Export_Value (
13761 -- [Value =>] static_integer_EXPRESSION,
13762 -- [Link_Name =>] static_string_EXPRESSION);
13764 when Pragma_Export_Value
=>
13766 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13767 Check_Arg_Count
(2);
13769 Check_Optional_Identifier
(Arg1
, Name_Value
);
13770 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13772 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13773 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13775 -----------------------------
13776 -- Export_Valued_Procedure --
13777 -----------------------------
13779 -- pragma Export_Valued_Procedure (
13780 -- [Internal =>] LOCAL_NAME
13781 -- [, [External =>] EXTERNAL_SYMBOL,]
13782 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13783 -- [, [Mechanism =>] MECHANISM]);
13785 -- EXTERNAL_SYMBOL ::=
13787 -- | static_string_EXPRESSION
13789 -- PARAMETER_TYPES ::=
13791 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13793 -- TYPE_DESIGNATOR ::=
13795 -- | subtype_Name ' Access
13799 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13801 -- MECHANISM_ASSOCIATION ::=
13802 -- [formal_parameter_NAME =>] MECHANISM_NAME
13804 -- MECHANISM_NAME ::=
13808 when Pragma_Export_Valued_Procedure
=>
13809 Export_Valued_Procedure
: declare
13810 Args
: Args_List
(1 .. 4);
13811 Names
: constant Name_List
(1 .. 4) := (
13814 Name_Parameter_Types
,
13817 Internal
: Node_Id
renames Args
(1);
13818 External
: Node_Id
renames Args
(2);
13819 Parameter_Types
: Node_Id
renames Args
(3);
13820 Mechanism
: Node_Id
renames Args
(4);
13824 Gather_Associations
(Names
, Args
);
13825 Process_Extended_Import_Export_Subprogram_Pragma
(
13826 Arg_Internal
=> Internal
,
13827 Arg_External
=> External
,
13828 Arg_Parameter_Types
=> Parameter_Types
,
13829 Arg_Mechanism
=> Mechanism
);
13830 end Export_Valued_Procedure
;
13832 -------------------
13833 -- Extend_System --
13834 -------------------
13836 -- pragma Extend_System ([Name =>] Identifier);
13838 when Pragma_Extend_System
=> Extend_System
: declare
13841 Check_Valid_Configuration_Pragma
;
13842 Check_Arg_Count
(1);
13843 Check_Optional_Identifier
(Arg1
, Name_Name
);
13844 Check_Arg_Is_Identifier
(Arg1
);
13846 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13849 and then Name_Buffer
(1 .. 4) = "aux_"
13851 if Present
(System_Extend_Pragma_Arg
) then
13852 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13853 Chars
(Expression
(System_Extend_Pragma_Arg
))
13857 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13858 Error_Pragma
("pragma% conflicts with that #");
13862 System_Extend_Pragma_Arg
:= Arg1
;
13864 if not GNAT_Mode
then
13865 System_Extend_Unit
:= Arg1
;
13869 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13873 ------------------------
13874 -- Extensions_Allowed --
13875 ------------------------
13877 -- pragma Extensions_Allowed (ON | OFF);
13879 when Pragma_Extensions_Allowed
=>
13881 Check_Arg_Count
(1);
13882 Check_No_Identifiers
;
13883 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13885 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13886 Extensions_Allowed
:= True;
13887 Ada_Version
:= Ada_Version_Type
'Last;
13890 Extensions_Allowed
:= False;
13891 Ada_Version
:= Ada_Version_Explicit
;
13892 Ada_Version_Pragma
:= Empty
;
13895 ------------------------
13896 -- Extensions_Visible --
13897 ------------------------
13899 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13901 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13902 Context
: constant Node_Id
:= Parent
(N
);
13904 Formal
: Entity_Id
;
13908 Has_OK_Formal
: Boolean := False;
13912 Check_No_Identifiers
;
13913 Check_At_Most_N_Arguments
(1);
13917 while Present
(Stmt
) loop
13919 -- Skip prior pragmas, but check for duplicates
13921 if Nkind
(Stmt
) = N_Pragma
then
13922 if Pragma_Name
(Stmt
) = Pname
then
13923 Error_Msg_Name_1
:= Pname
;
13924 Error_Msg_Sloc
:= Sloc
(Stmt
);
13925 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13928 -- Skip internally generated code
13930 elsif not Comes_From_Source
(Stmt
) then
13933 -- The associated [generic] subprogram declaration has been
13934 -- found, stop the search.
13936 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
13937 N_Subprogram_Declaration
)
13939 Subp
:= Defining_Entity
(Stmt
);
13942 -- The pragma does not apply to a legal construct, issue an
13943 -- error and stop the analysis.
13946 Error_Pragma
("pragma % must apply to a subprogram");
13950 Stmt
:= Prev
(Stmt
);
13953 -- When the pragma applies to a stand alone subprogram body, it
13954 -- appears within the declarations of the body. In that case the
13955 -- enclosing construct is the proper context. This check is done
13956 -- after the traversal above to allow for duplicate detection.
13958 if Nkind
(Context
) = N_Subprogram_Body
13959 and then No
(Corresponding_Spec
(Context
))
13961 Subp
:= Defining_Entity
(Context
);
13965 Error_Pragma
("pragma % must apply to a subprogram");
13969 -- Examine the formals of the related subprogram
13971 Formal
:= First_Formal
(Subp
);
13972 while Present
(Formal
) loop
13974 -- At least one of the formals is of a specific tagged type,
13975 -- the pragma is legal.
13977 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13978 Has_OK_Formal
:= True;
13981 -- A generic subprogram with at least one formal of a private
13982 -- type ensures the legality of the pragma because the actual
13983 -- may be specifically tagged. Note that this is verified by
13984 -- the check above at instantiation time.
13986 elsif Is_Private_Type
(Etype
(Formal
))
13987 and then Is_Generic_Type
(Etype
(Formal
))
13989 Has_OK_Formal
:= True;
13993 Next_Formal
(Formal
);
13996 if not Has_OK_Formal
then
13997 Error_Msg_Name_1
:= Pname
;
13998 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
14000 ("\subprogram & lacks parameter of specific tagged or "
14001 & "generic private type", N
, Subp
);
14005 -- Analyze the Boolean expression (if any)
14007 if Present
(Arg1
) then
14008 Expr
:= Get_Pragma_Arg
(Arg1
);
14010 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14012 if not Is_OK_Static_Expression
(Expr
) then
14014 ("expression of pragma % must be static", Expr
);
14019 -- Chain the pragma on the contract for further processing
14021 Add_Contract_Item
(N
, Subp
);
14022 end Extensions_Visible
;
14028 -- pragma External (
14029 -- [ Convention =>] convention_IDENTIFIER,
14030 -- [ Entity =>] LOCAL_NAME
14031 -- [, [External_Name =>] static_string_EXPRESSION ]
14032 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14034 when Pragma_External
=> External
: declare
14035 Def_Id
: Entity_Id
;
14038 pragma Warnings
(Off
, C
);
14045 Name_External_Name
,
14047 Check_At_Least_N_Arguments
(2);
14048 Check_At_Most_N_Arguments
(4);
14049 Process_Convention
(C
, Def_Id
);
14050 Note_Possible_Modification
14051 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14052 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14053 Set_Exported
(Def_Id
, Arg2
);
14056 --------------------------
14057 -- External_Name_Casing --
14058 --------------------------
14060 -- pragma External_Name_Casing (
14061 -- UPPERCASE | LOWERCASE
14062 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14064 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14067 Check_No_Identifiers
;
14069 if Arg_Count
= 2 then
14070 Check_Arg_Is_One_Of
14071 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14073 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14075 Opt
.External_Name_Exp_Casing
:= As_Is
;
14077 when Name_Uppercase
=>
14078 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14080 when Name_Lowercase
=>
14081 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14088 Check_Arg_Count
(1);
14091 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14093 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14094 when Name_Uppercase
=>
14095 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14097 when Name_Lowercase
=>
14098 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14103 end External_Name_Casing
;
14109 -- pragma Fast_Math;
14111 when Pragma_Fast_Math
=>
14113 Check_No_Identifiers
;
14114 Check_Valid_Configuration_Pragma
;
14117 --------------------------
14118 -- Favor_Top_Level --
14119 --------------------------
14121 -- pragma Favor_Top_Level (type_NAME);
14123 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14124 Named_Entity
: Entity_Id
;
14128 Check_No_Identifiers
;
14129 Check_Arg_Count
(1);
14130 Check_Arg_Is_Local_Name
(Arg1
);
14131 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14133 -- If it's an access-to-subprogram type (in particular, not a
14134 -- subtype), set the flag on that type.
14136 if Is_Access_Subprogram_Type
(Named_Entity
) then
14137 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14139 -- Otherwise it's an error (name denotes the wrong sort of entity)
14143 ("access-to-subprogram type expected",
14144 Get_Pragma_Arg
(Arg1
));
14146 end Favor_Top_Level
;
14148 ---------------------------
14149 -- Finalize_Storage_Only --
14150 ---------------------------
14152 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14154 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14155 Assoc
: constant Node_Id
:= Arg1
;
14156 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14161 Check_No_Identifiers
;
14162 Check_Arg_Count
(1);
14163 Check_Arg_Is_Local_Name
(Arg1
);
14165 Find_Type
(Type_Id
);
14166 Typ
:= Entity
(Type_Id
);
14169 or else Rep_Item_Too_Early
(Typ
, N
)
14173 Typ
:= Underlying_Type
(Typ
);
14176 if not Is_Controlled
(Typ
) then
14177 Error_Pragma
("pragma% must specify controlled type");
14180 Check_First_Subtype
(Arg1
);
14182 if Finalize_Storage_Only
(Typ
) then
14183 Error_Pragma
("duplicate pragma%, only one allowed");
14185 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14186 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14188 end Finalize_Storage
;
14194 -- pragma Global (GLOBAL_SPECIFICATION);
14196 -- GLOBAL_SPECIFICATION ::=
14199 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14201 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14203 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14204 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14205 -- GLOBAL_ITEM ::= NAME
14207 when Pragma_Global
=> Global
: declare
14208 Subp_Decl
: Node_Id
;
14212 Check_Arg_Count
(1);
14213 Ensure_Aggregate_Form
(Arg1
);
14215 -- Ensure the proper placement of the pragma. Global must be
14216 -- associated with a subprogram declaration or a body that acts
14220 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14222 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14225 -- Body acts as spec
14227 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14228 and then No
(Corresponding_Spec
(Subp_Decl
))
14232 -- Body stub acts as spec
14234 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14235 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14244 -- When the pragma appears on a subprogram body, perform the full
14247 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14248 Analyze_Global_In_Decl_Part
(N
);
14250 -- When Global applies to a subprogram compilation unit, the
14251 -- corresponding pragma is placed after the unit's declaration
14252 -- node and needs to be analyzed immediately.
14254 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14255 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14257 Analyze_Global_In_Decl_Part
(N
);
14260 -- Chain the pragma on the contract for further processing
14262 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14269 -- pragma Ident (static_string_EXPRESSION)
14271 -- Note: pragma Comment shares this processing. Pragma Ident is
14272 -- identical in effect to pragma Commment.
14274 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14279 Check_Arg_Count
(1);
14280 Check_No_Identifiers
;
14281 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14284 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14291 GP
:= Parent
(Parent
(N
));
14293 if Nkind_In
(GP
, N_Package_Declaration
,
14294 N_Generic_Package_Declaration
)
14299 -- If we have a compilation unit, then record the ident value,
14300 -- checking for improper duplication.
14302 if Nkind
(GP
) = N_Compilation_Unit
then
14303 CS
:= Ident_String
(Current_Sem_Unit
);
14305 if Present
(CS
) then
14307 -- If we have multiple instances, concatenate them, but
14308 -- not in ASIS, where we want the original tree.
14310 if not ASIS_Mode
then
14311 Start_String
(Strval
(CS
));
14312 Store_String_Char
(' ');
14313 Store_String_Chars
(Strval
(Str
));
14314 Set_Strval
(CS
, End_String
);
14318 Set_Ident_String
(Current_Sem_Unit
, Str
);
14321 -- For subunits, we just ignore the Ident, since in GNAT these
14322 -- are not separate object files, and hence not separate units
14323 -- in the unit table.
14325 elsif Nkind
(GP
) = N_Subunit
then
14331 ----------------------------
14332 -- Implementation_Defined --
14333 ----------------------------
14335 -- pragma Implementation_Defined (LOCAL_NAME);
14337 -- Marks previously declared entity as implementation defined. For
14338 -- an overloaded entity, applies to the most recent homonym.
14340 -- pragma Implementation_Defined;
14342 -- The form with no arguments appears anywhere within a scope, most
14343 -- typically a package spec, and indicates that all entities that are
14344 -- defined within the package spec are Implementation_Defined.
14346 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14351 Check_No_Identifiers
;
14353 -- Form with no arguments
14355 if Arg_Count
= 0 then
14356 Set_Is_Implementation_Defined
(Current_Scope
);
14358 -- Form with one argument
14361 Check_Arg_Count
(1);
14362 Check_Arg_Is_Local_Name
(Arg1
);
14363 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14364 Set_Is_Implementation_Defined
(Ent
);
14366 end Implementation_Defined
;
14372 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14374 -- IMPLEMENTATION_KIND ::=
14375 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14377 -- "By_Any" and "Optional" are treated as synonyms in order to
14378 -- support Ada 2012 aspect Synchronization.
14380 when Pragma_Implemented
=> Implemented
: declare
14381 Proc_Id
: Entity_Id
;
14386 Check_Arg_Count
(2);
14387 Check_No_Identifiers
;
14388 Check_Arg_Is_Identifier
(Arg1
);
14389 Check_Arg_Is_Local_Name
(Arg1
);
14390 Check_Arg_Is_One_Of
(Arg2
,
14393 Name_By_Protected_Procedure
,
14396 -- Extract the name of the local procedure
14398 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14400 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14401 -- primitive procedure of a synchronized tagged type.
14403 if Ekind
(Proc_Id
) = E_Procedure
14404 and then Is_Primitive
(Proc_Id
)
14405 and then Present
(First_Formal
(Proc_Id
))
14407 Typ
:= Etype
(First_Formal
(Proc_Id
));
14409 if Is_Tagged_Type
(Typ
)
14412 -- Check for a protected, a synchronized or a task interface
14414 ((Is_Interface
(Typ
)
14415 and then Is_Synchronized_Interface
(Typ
))
14417 -- Check for a protected type or a task type that implements
14421 (Is_Concurrent_Record_Type
(Typ
)
14422 and then Present
(Interfaces
(Typ
)))
14424 -- Check for a private record extension with keyword
14428 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14429 E_Record_Subtype_With_Private
)
14430 and then Synchronized_Present
(Parent
(Typ
))))
14435 ("controlling formal must be of synchronized tagged type",
14440 -- Procedures declared inside a protected type must be accepted
14442 elsif Ekind
(Proc_Id
) = E_Procedure
14443 and then Is_Protected_Type
(Scope
(Proc_Id
))
14447 -- The first argument is not a primitive procedure
14451 ("pragma % must be applied to a primitive procedure", Arg1
);
14455 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14456 -- By_Protected_Procedure to the primitive procedure of a task
14459 if Chars
(Arg2
) = Name_By_Protected_Procedure
14460 and then Is_Interface
(Typ
)
14461 and then Is_Task_Interface
(Typ
)
14464 ("implementation kind By_Protected_Procedure cannot be "
14465 & "applied to a task interface primitive", Arg2
);
14469 Record_Rep_Item
(Proc_Id
, N
);
14472 ----------------------
14473 -- Implicit_Packing --
14474 ----------------------
14476 -- pragma Implicit_Packing;
14478 when Pragma_Implicit_Packing
=>
14480 Check_Arg_Count
(0);
14481 Implicit_Packing
:= True;
14488 -- [Convention =>] convention_IDENTIFIER,
14489 -- [Entity =>] LOCAL_NAME
14490 -- [, [External_Name =>] static_string_EXPRESSION ]
14491 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14493 when Pragma_Import
=>
14494 Check_Ada_83_Warning
;
14498 Name_External_Name
,
14501 Check_At_Least_N_Arguments
(2);
14502 Check_At_Most_N_Arguments
(4);
14503 Process_Import_Or_Interface
;
14505 ---------------------
14506 -- Import_Function --
14507 ---------------------
14509 -- pragma Import_Function (
14510 -- [Internal =>] LOCAL_NAME,
14511 -- [, [External =>] EXTERNAL_SYMBOL]
14512 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14513 -- [, [Result_Type =>] SUBTYPE_MARK]
14514 -- [, [Mechanism =>] MECHANISM]
14515 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14517 -- EXTERNAL_SYMBOL ::=
14519 -- | static_string_EXPRESSION
14521 -- PARAMETER_TYPES ::=
14523 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14525 -- TYPE_DESIGNATOR ::=
14527 -- | subtype_Name ' Access
14531 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14533 -- MECHANISM_ASSOCIATION ::=
14534 -- [formal_parameter_NAME =>] MECHANISM_NAME
14536 -- MECHANISM_NAME ::=
14540 when Pragma_Import_Function
=> Import_Function
: declare
14541 Args
: Args_List
(1 .. 6);
14542 Names
: constant Name_List
(1 .. 6) := (
14545 Name_Parameter_Types
,
14548 Name_Result_Mechanism
);
14550 Internal
: Node_Id
renames Args
(1);
14551 External
: Node_Id
renames Args
(2);
14552 Parameter_Types
: Node_Id
renames Args
(3);
14553 Result_Type
: Node_Id
renames Args
(4);
14554 Mechanism
: Node_Id
renames Args
(5);
14555 Result_Mechanism
: Node_Id
renames Args
(6);
14559 Gather_Associations
(Names
, Args
);
14560 Process_Extended_Import_Export_Subprogram_Pragma
(
14561 Arg_Internal
=> Internal
,
14562 Arg_External
=> External
,
14563 Arg_Parameter_Types
=> Parameter_Types
,
14564 Arg_Result_Type
=> Result_Type
,
14565 Arg_Mechanism
=> Mechanism
,
14566 Arg_Result_Mechanism
=> Result_Mechanism
);
14567 end Import_Function
;
14569 -------------------
14570 -- Import_Object --
14571 -------------------
14573 -- pragma Import_Object (
14574 -- [Internal =>] LOCAL_NAME
14575 -- [, [External =>] EXTERNAL_SYMBOL]
14576 -- [, [Size =>] EXTERNAL_SYMBOL]);
14578 -- EXTERNAL_SYMBOL ::=
14580 -- | static_string_EXPRESSION
14582 when Pragma_Import_Object
=> Import_Object
: declare
14583 Args
: Args_List
(1 .. 3);
14584 Names
: constant Name_List
(1 .. 3) := (
14589 Internal
: Node_Id
renames Args
(1);
14590 External
: Node_Id
renames Args
(2);
14591 Size
: Node_Id
renames Args
(3);
14595 Gather_Associations
(Names
, Args
);
14596 Process_Extended_Import_Export_Object_Pragma
(
14597 Arg_Internal
=> Internal
,
14598 Arg_External
=> External
,
14602 ----------------------
14603 -- Import_Procedure --
14604 ----------------------
14606 -- pragma Import_Procedure (
14607 -- [Internal =>] LOCAL_NAME
14608 -- [, [External =>] EXTERNAL_SYMBOL]
14609 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14610 -- [, [Mechanism =>] MECHANISM]);
14612 -- EXTERNAL_SYMBOL ::=
14614 -- | static_string_EXPRESSION
14616 -- PARAMETER_TYPES ::=
14618 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14620 -- TYPE_DESIGNATOR ::=
14622 -- | subtype_Name ' Access
14626 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14628 -- MECHANISM_ASSOCIATION ::=
14629 -- [formal_parameter_NAME =>] MECHANISM_NAME
14631 -- MECHANISM_NAME ::=
14635 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14636 Args
: Args_List
(1 .. 4);
14637 Names
: constant Name_List
(1 .. 4) := (
14640 Name_Parameter_Types
,
14643 Internal
: Node_Id
renames Args
(1);
14644 External
: Node_Id
renames Args
(2);
14645 Parameter_Types
: Node_Id
renames Args
(3);
14646 Mechanism
: Node_Id
renames Args
(4);
14650 Gather_Associations
(Names
, Args
);
14651 Process_Extended_Import_Export_Subprogram_Pragma
(
14652 Arg_Internal
=> Internal
,
14653 Arg_External
=> External
,
14654 Arg_Parameter_Types
=> Parameter_Types
,
14655 Arg_Mechanism
=> Mechanism
);
14656 end Import_Procedure
;
14658 -----------------------------
14659 -- Import_Valued_Procedure --
14660 -----------------------------
14662 -- pragma Import_Valued_Procedure (
14663 -- [Internal =>] LOCAL_NAME
14664 -- [, [External =>] EXTERNAL_SYMBOL]
14665 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14666 -- [, [Mechanism =>] MECHANISM]);
14668 -- EXTERNAL_SYMBOL ::=
14670 -- | static_string_EXPRESSION
14672 -- PARAMETER_TYPES ::=
14674 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14676 -- TYPE_DESIGNATOR ::=
14678 -- | subtype_Name ' Access
14682 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14684 -- MECHANISM_ASSOCIATION ::=
14685 -- [formal_parameter_NAME =>] MECHANISM_NAME
14687 -- MECHANISM_NAME ::=
14691 when Pragma_Import_Valued_Procedure
=>
14692 Import_Valued_Procedure
: declare
14693 Args
: Args_List
(1 .. 4);
14694 Names
: constant Name_List
(1 .. 4) := (
14697 Name_Parameter_Types
,
14700 Internal
: Node_Id
renames Args
(1);
14701 External
: Node_Id
renames Args
(2);
14702 Parameter_Types
: Node_Id
renames Args
(3);
14703 Mechanism
: Node_Id
renames Args
(4);
14707 Gather_Associations
(Names
, Args
);
14708 Process_Extended_Import_Export_Subprogram_Pragma
(
14709 Arg_Internal
=> Internal
,
14710 Arg_External
=> External
,
14711 Arg_Parameter_Types
=> Parameter_Types
,
14712 Arg_Mechanism
=> Mechanism
);
14713 end Import_Valued_Procedure
;
14719 -- pragma Independent (record_component_LOCAL_NAME);
14721 when Pragma_Independent
=> Independent
: declare
14726 Check_Ada_83_Warning
;
14728 Check_No_Identifiers
;
14729 Check_Arg_Count
(1);
14730 Check_Arg_Is_Local_Name
(Arg1
);
14731 E_Id
:= Get_Pragma_Arg
(Arg1
);
14733 if Etype
(E_Id
) = Any_Type
then
14737 E
:= Entity
(E_Id
);
14739 -- Check we have a record component. We have not yet setup
14740 -- components fully, so identify by syntactic structure.
14742 if Nkind
(Declaration_Node
(E
)) /= N_Component_Declaration
then
14744 ("argument for pragma% must be record component", Arg1
);
14747 -- Check duplicate before we chain ourselves
14749 Check_Duplicate_Pragma
(E
);
14753 if Rep_Item_Too_Early
(E
, N
)
14755 Rep_Item_Too_Late
(E
, N
)
14760 -- Set flag in component
14762 Set_Is_Independent
(E
);
14764 Independence_Checks
.Append
((N
, E
));
14767 ----------------------------
14768 -- Independent_Components --
14769 ----------------------------
14771 -- pragma Atomic_Components (array_LOCAL_NAME);
14773 -- This processing is shared by Volatile_Components
14775 when Pragma_Independent_Components
=> Independent_Components
: declare
14783 Check_Ada_83_Warning
;
14785 Check_No_Identifiers
;
14786 Check_Arg_Count
(1);
14787 Check_Arg_Is_Local_Name
(Arg1
);
14788 E_Id
:= Get_Pragma_Arg
(Arg1
);
14790 if Etype
(E_Id
) = Any_Type
then
14794 E
:= Entity
(E_Id
);
14796 -- Check duplicate before we chain ourselves
14798 Check_Duplicate_Pragma
(E
);
14800 -- Check appropriate entity
14802 if Rep_Item_Too_Early
(E
, N
)
14804 Rep_Item_Too_Late
(E
, N
)
14809 D
:= Declaration_Node
(E
);
14812 if K
= N_Full_Type_Declaration
14813 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
14815 Independence_Checks
.Append
((N
, Base_Type
(E
)));
14816 Set_Has_Independent_Components
(Base_Type
(E
));
14818 -- For record type, set all components independent
14820 if Is_Record_Type
(E
) then
14821 C
:= First_Component
(E
);
14822 while Present
(C
) loop
14823 Set_Is_Independent
(C
);
14824 Next_Component
(C
);
14828 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
14829 and then Nkind
(D
) = N_Object_Declaration
14830 and then Nkind
(Object_Definition
(D
)) =
14831 N_Constrained_Array_Definition
14833 Independence_Checks
.Append
((N
, Base_Type
(Etype
(E
))));
14834 Set_Has_Independent_Components
(Base_Type
(Etype
(E
)));
14837 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
14839 end Independent_Components
;
14841 -----------------------
14842 -- Initial_Condition --
14843 -----------------------
14845 -- pragma Initial_Condition (boolean_EXPRESSION);
14847 when Pragma_Initial_Condition
=> Initial_Condition
: declare
14848 Context
: constant Node_Id
:= Parent
(Parent
(N
));
14849 Pack_Id
: Entity_Id
;
14854 Check_No_Identifiers
;
14855 Check_Arg_Count
(1);
14857 -- Ensure the proper placement of the pragma. Initial_Condition
14858 -- must be associated with a package declaration.
14860 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
14861 N_Package_Declaration
)
14868 while Present
(Stmt
) loop
14870 -- Skip prior pragmas, but check for duplicates
14872 if Nkind
(Stmt
) = N_Pragma
then
14873 if Pragma_Name
(Stmt
) = Pname
then
14874 Error_Msg_Name_1
:= Pname
;
14875 Error_Msg_Sloc
:= Sloc
(Stmt
);
14876 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
14879 -- Skip internally generated code
14881 elsif not Comes_From_Source
(Stmt
) then
14884 -- The pragma does not apply to a legal construct, issue an
14885 -- error and stop the analysis.
14892 Stmt
:= Prev
(Stmt
);
14895 -- The pragma must be analyzed at the end of the visible
14896 -- declarations of the related package. Save the pragma for later
14897 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
14898 -- the contract of the package.
14900 Pack_Id
:= Defining_Entity
(Context
);
14901 Add_Contract_Item
(N
, Pack_Id
);
14903 -- Verify the declaration order of pragma Initial_Condition with
14904 -- respect to pragmas Abstract_State and Initializes when SPARK
14905 -- checks are enabled.
14907 if SPARK_Mode
/= Off
then
14908 Check_Declaration_Order
14909 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
14912 Check_Declaration_Order
14913 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
14916 end Initial_Condition
;
14918 ------------------------
14919 -- Initialize_Scalars --
14920 ------------------------
14922 -- pragma Initialize_Scalars;
14924 when Pragma_Initialize_Scalars
=>
14926 Check_Arg_Count
(0);
14927 Check_Valid_Configuration_Pragma
;
14928 Check_Restriction
(No_Initialize_Scalars
, N
);
14930 -- Initialize_Scalars creates false positives in CodePeer, and
14931 -- incorrect negative results in GNATprove mode, so ignore this
14932 -- pragma in these modes.
14934 if not Restriction_Active
(No_Initialize_Scalars
)
14935 and then not (CodePeer_Mode
or GNATprove_Mode
)
14937 Init_Or_Norm_Scalars
:= True;
14938 Initialize_Scalars
:= True;
14945 -- pragma Initializes (INITIALIZATION_SPEC);
14947 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
14949 -- INITIALIZATION_LIST ::=
14950 -- INITIALIZATION_ITEM
14951 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
14953 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
14958 -- | (INPUT {, INPUT})
14962 when Pragma_Initializes
=> Initializes
: declare
14963 Context
: constant Node_Id
:= Parent
(Parent
(N
));
14964 Pack_Id
: Entity_Id
;
14969 Check_No_Identifiers
;
14970 Check_Arg_Count
(1);
14971 Ensure_Aggregate_Form
(Arg1
);
14973 -- Ensure the proper placement of the pragma. Initializes must be
14974 -- associated with a package declaration.
14976 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
14977 N_Package_Declaration
)
14984 while Present
(Stmt
) loop
14986 -- Skip prior pragmas, but check for duplicates
14988 if Nkind
(Stmt
) = N_Pragma
then
14989 if Pragma_Name
(Stmt
) = Pname
then
14990 Error_Msg_Name_1
:= Pname
;
14991 Error_Msg_Sloc
:= Sloc
(Stmt
);
14992 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
14995 -- Skip internally generated code
14997 elsif not Comes_From_Source
(Stmt
) then
15000 -- The pragma does not apply to a legal construct, issue an
15001 -- error and stop the analysis.
15008 Stmt
:= Prev
(Stmt
);
15011 -- The pragma must be analyzed at the end of the visible
15012 -- declarations of the related package. Save the pragma for later
15013 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15014 -- contract of the package.
15016 Pack_Id
:= Defining_Entity
(Context
);
15017 Add_Contract_Item
(N
, Pack_Id
);
15019 -- Verify the declaration order of pragmas Abstract_State and
15020 -- Initializes when SPARK checks are enabled.
15022 if SPARK_Mode
/= Off
then
15023 Check_Declaration_Order
15024 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15033 -- pragma Inline ( NAME {, NAME} );
15035 when Pragma_Inline
=>
15037 -- Pragma always active unless in GNATprove mode. It is disabled
15038 -- in GNATprove mode because frontend inlining is applied
15039 -- independently of pragmas Inline and Inline_Always for
15040 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15043 if not GNATprove_Mode
then
15045 -- Inline status is Enabled if inlining option is active
15047 if Inline_Active
then
15048 Process_Inline
(Enabled
);
15050 Process_Inline
(Disabled
);
15054 -------------------
15055 -- Inline_Always --
15056 -------------------
15058 -- pragma Inline_Always ( NAME {, NAME} );
15060 when Pragma_Inline_Always
=>
15063 -- Pragma always active unless in CodePeer mode or GNATprove
15064 -- mode. It is disabled in CodePeer mode because inlining is
15065 -- not helpful, and enabling it caused walk order issues. It
15066 -- is disabled in GNATprove mode because frontend inlining is
15067 -- applied independently of pragmas Inline and Inline_Always for
15068 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15071 if not CodePeer_Mode
and not GNATprove_Mode
then
15072 Process_Inline
(Enabled
);
15075 --------------------
15076 -- Inline_Generic --
15077 --------------------
15079 -- pragma Inline_Generic (NAME {, NAME});
15081 when Pragma_Inline_Generic
=>
15083 Process_Generic_List
;
15085 ----------------------
15086 -- Inspection_Point --
15087 ----------------------
15089 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15091 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15098 if Arg_Count
> 0 then
15101 Exp
:= Get_Pragma_Arg
(Arg
);
15104 if not Is_Entity_Name
(Exp
)
15105 or else not Is_Object
(Entity
(Exp
))
15107 Error_Pragma_Arg
("object name required", Arg
);
15111 exit when No
(Arg
);
15114 end Inspection_Point
;
15120 -- pragma Interface (
15121 -- [ Convention =>] convention_IDENTIFIER,
15122 -- [ Entity =>] LOCAL_NAME
15123 -- [, [External_Name =>] static_string_EXPRESSION ]
15124 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15126 when Pragma_Interface
=>
15131 Name_External_Name
,
15133 Check_At_Least_N_Arguments
(2);
15134 Check_At_Most_N_Arguments
(4);
15135 Process_Import_Or_Interface
;
15137 -- In Ada 2005, the permission to use Interface (a reserved word)
15138 -- as a pragma name is considered an obsolescent feature, and this
15139 -- pragma was already obsolescent in Ada 95.
15141 if Ada_Version
>= Ada_95
then
15143 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15145 if Warn_On_Obsolescent_Feature
then
15147 ("pragma Interface is an obsolescent feature?j?", N
);
15149 ("|use pragma Import instead?j?", N
);
15153 --------------------
15154 -- Interface_Name --
15155 --------------------
15157 -- pragma Interface_Name (
15158 -- [ Entity =>] LOCAL_NAME
15159 -- [,[External_Name =>] static_string_EXPRESSION ]
15160 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15162 when Pragma_Interface_Name
=> Interface_Name
: declare
15164 Def_Id
: Entity_Id
;
15165 Hom_Id
: Entity_Id
;
15171 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15172 Check_At_Least_N_Arguments
(2);
15173 Check_At_Most_N_Arguments
(3);
15174 Id
:= Get_Pragma_Arg
(Arg1
);
15177 -- This is obsolete from Ada 95 on, but it is an implementation
15178 -- defined pragma, so we do not consider that it violates the
15179 -- restriction (No_Obsolescent_Features).
15181 if Ada_Version
>= Ada_95
then
15182 if Warn_On_Obsolescent_Feature
then
15184 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15186 ("|use pragma Import instead?j?", N
);
15190 if not Is_Entity_Name
(Id
) then
15192 ("first argument for pragma% must be entity name", Arg1
);
15193 elsif Etype
(Id
) = Any_Type
then
15196 Def_Id
:= Entity
(Id
);
15199 -- Special DEC-compatible processing for the object case, forces
15200 -- object to be imported.
15202 if Ekind
(Def_Id
) = E_Variable
then
15203 Kill_Size_Check_Code
(Def_Id
);
15204 Note_Possible_Modification
(Id
, Sure
=> False);
15206 -- Initialization is not allowed for imported variable
15208 if Present
(Expression
(Parent
(Def_Id
)))
15209 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15211 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15213 ("no initialization allowed for declaration of& #",
15217 -- For compatibility, support VADS usage of providing both
15218 -- pragmas Interface and Interface_Name to obtain the effect
15219 -- of a single Import pragma.
15221 if Is_Imported
(Def_Id
)
15222 and then Present
(First_Rep_Item
(Def_Id
))
15223 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15225 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15229 Set_Imported
(Def_Id
);
15232 Set_Is_Public
(Def_Id
);
15233 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15236 -- Otherwise must be subprogram
15238 elsif not Is_Subprogram
(Def_Id
) then
15240 ("argument of pragma% is not subprogram", Arg1
);
15243 Check_At_Most_N_Arguments
(3);
15247 -- Loop through homonyms
15250 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15252 if Is_Imported
(Def_Id
) then
15253 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15257 exit when From_Aspect_Specification
(N
);
15258 Hom_Id
:= Homonym
(Hom_Id
);
15260 exit when No
(Hom_Id
)
15261 or else Scope
(Hom_Id
) /= Current_Scope
;
15266 ("argument of pragma% is not imported subprogram",
15270 end Interface_Name
;
15272 -----------------------
15273 -- Interrupt_Handler --
15274 -----------------------
15276 -- pragma Interrupt_Handler (handler_NAME);
15278 when Pragma_Interrupt_Handler
=>
15279 Check_Ada_83_Warning
;
15280 Check_Arg_Count
(1);
15281 Check_No_Identifiers
;
15283 if No_Run_Time_Mode
then
15284 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15286 Check_Interrupt_Or_Attach_Handler
;
15287 Process_Interrupt_Or_Attach_Handler
;
15290 ------------------------
15291 -- Interrupt_Priority --
15292 ------------------------
15294 -- pragma Interrupt_Priority [(EXPRESSION)];
15296 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15297 P
: constant Node_Id
:= Parent
(N
);
15302 Check_Ada_83_Warning
;
15304 if Arg_Count
/= 0 then
15305 Arg
:= Get_Pragma_Arg
(Arg1
);
15306 Check_Arg_Count
(1);
15307 Check_No_Identifiers
;
15309 -- The expression must be analyzed in the special manner
15310 -- described in "Handling of Default and Per-Object
15311 -- Expressions" in sem.ads.
15313 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15316 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15321 Ent
:= Defining_Identifier
(Parent
(P
));
15323 -- Check duplicate pragma before we chain the pragma in the Rep
15324 -- Item chain of Ent.
15326 Check_Duplicate_Pragma
(Ent
);
15327 Record_Rep_Item
(Ent
, N
);
15329 end Interrupt_Priority
;
15331 ---------------------
15332 -- Interrupt_State --
15333 ---------------------
15335 -- pragma Interrupt_State (
15336 -- [Name =>] INTERRUPT_ID,
15337 -- [State =>] INTERRUPT_STATE);
15339 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15340 -- INTERRUPT_STATE => System | Runtime | User
15342 -- Note: if the interrupt id is given as an identifier, then it must
15343 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15344 -- given as a static integer expression which must be in the range of
15345 -- Ada.Interrupts.Interrupt_ID.
15347 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15348 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15349 -- This is the entity Ada.Interrupts.Interrupt_ID;
15351 State_Type
: Character;
15352 -- Set to 's'/'r'/'u' for System/Runtime/User
15355 -- Index to entry in Interrupt_States table
15358 -- Value of interrupt
15360 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15361 -- The first argument to the pragma
15363 Int_Ent
: Entity_Id
;
15364 -- Interrupt entity in Ada.Interrupts.Names
15368 Check_Arg_Order
((Name_Name
, Name_State
));
15369 Check_Arg_Count
(2);
15371 Check_Optional_Identifier
(Arg1
, Name_Name
);
15372 Check_Optional_Identifier
(Arg2
, Name_State
);
15373 Check_Arg_Is_Identifier
(Arg2
);
15375 -- First argument is identifier
15377 if Nkind
(Arg1X
) = N_Identifier
then
15379 -- Search list of names in Ada.Interrupts.Names
15381 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15383 if No
(Int_Ent
) then
15384 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15386 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15387 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15391 Next_Entity
(Int_Ent
);
15394 -- First argument is not an identifier, so it must be a static
15395 -- expression of type Ada.Interrupts.Interrupt_ID.
15398 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15399 Int_Val
:= Expr_Value
(Arg1X
);
15401 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15403 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15406 ("value not in range of type "
15407 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15413 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15414 when Name_Runtime
=> State_Type
:= 'r';
15415 when Name_System
=> State_Type
:= 's';
15416 when Name_User
=> State_Type
:= 'u';
15419 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15422 -- Check if entry is already stored
15424 IST_Num
:= Interrupt_States
.First
;
15426 -- If entry not found, add it
15428 if IST_Num
> Interrupt_States
.Last
then
15429 Interrupt_States
.Append
15430 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15431 Interrupt_State
=> State_Type
,
15432 Pragma_Loc
=> Loc
));
15435 -- Case of entry for the same entry
15437 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15440 -- If state matches, done, no need to make redundant entry
15443 State_Type
= Interrupt_States
.Table
(IST_Num
).
15446 -- Otherwise if state does not match, error
15449 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15451 ("state conflicts with that given #", Arg2
);
15455 IST_Num
:= IST_Num
+ 1;
15457 end Interrupt_State
;
15463 -- pragma Invariant
15464 -- ([Entity =>] type_LOCAL_NAME,
15465 -- [Check =>] EXPRESSION
15466 -- [,[Message =>] String_Expression]);
15468 when Pragma_Invariant
=> Invariant
: declare
15475 Check_At_Least_N_Arguments
(2);
15476 Check_At_Most_N_Arguments
(3);
15477 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15478 Check_Optional_Identifier
(Arg2
, Name_Check
);
15480 if Arg_Count
= 3 then
15481 Check_Optional_Identifier
(Arg3
, Name_Message
);
15482 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15485 Check_Arg_Is_Local_Name
(Arg1
);
15487 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15488 Find_Type
(Type_Id
);
15489 Typ
:= Entity
(Type_Id
);
15491 if Typ
= Any_Type
then
15494 -- An invariant must apply to a private type, or appear in the
15495 -- private part of a package spec and apply to a completion.
15496 -- a class-wide invariant can only appear on a private declaration
15497 -- or private extension, not a completion.
15499 elsif Ekind_In
(Typ
, E_Private_Type
,
15500 E_Record_Type_With_Private
,
15501 E_Limited_Private_Type
)
15505 elsif In_Private_Part
(Current_Scope
)
15506 and then Has_Private_Declaration
(Typ
)
15507 and then not Class_Present
(N
)
15511 elsif In_Private_Part
(Current_Scope
) then
15513 ("pragma% only allowed for private type declared in "
15514 & "visible part", Arg1
);
15518 ("pragma% only allowed for private type", Arg1
);
15521 -- Note that the type has at least one invariant, and also that
15522 -- it has inheritable invariants if we have Invariant'Class
15523 -- or Type_Invariant'Class. Build the corresponding invariant
15524 -- procedure declaration, so that calls to it can be generated
15525 -- before the body is built (e.g. within an expression function).
15527 Insert_After_And_Analyze
15528 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15530 if Class_Present
(N
) then
15531 Set_Has_Inheritable_Invariants
(Typ
);
15534 -- The remaining processing is simply to link the pragma on to
15535 -- the rep item chain, for processing when the type is frozen.
15536 -- This is accomplished by a call to Rep_Item_Too_Late.
15538 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15541 ----------------------
15542 -- Java_Constructor --
15543 ----------------------
15545 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15547 -- Also handles pragma CIL_Constructor
15549 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15550 Java_Constructor
: declare
15551 Convention
: Convention_Id
;
15552 Def_Id
: Entity_Id
;
15553 Hom_Id
: Entity_Id
;
15555 This_Formal
: Entity_Id
;
15559 Check_Arg_Count
(1);
15560 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15561 Check_Arg_Is_Local_Name
(Arg1
);
15563 Id
:= Get_Pragma_Arg
(Arg1
);
15564 Find_Program_Unit_Name
(Id
);
15566 -- If we did not find the name, we are done
15568 if Etype
(Id
) = Any_Type
then
15572 -- Check wrong use of pragma in wrong VM target
15574 if VM_Target
= No_VM
then
15577 elsif VM_Target
= CLI_Target
15578 and then Prag_Id
= Pragma_Java_Constructor
15580 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15582 elsif VM_Target
= JVM_Target
15583 and then Prag_Id
= Pragma_CIL_Constructor
15585 Error_Pragma
("must use pragma 'Java_'Constructor");
15589 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15590 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15591 when others => null;
15594 Hom_Id
:= Entity
(Id
);
15596 -- Loop through homonyms
15599 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15601 -- The constructor is required to be a function
15603 if Ekind
(Def_Id
) /= E_Function
then
15604 if VM_Target
= JVM_Target
then
15606 ("pragma% requires function returning a 'Java access "
15610 ("pragma% requires function returning a 'C'I'L access "
15615 -- Check arguments: For tagged type the first formal must be
15616 -- named "this" and its type must be a named access type
15617 -- designating a class-wide tagged type that has convention
15618 -- CIL/Java. The first formal must also have a null default
15619 -- value. For example:
15621 -- type Typ is tagged ...
15622 -- type Ref is access all Typ;
15623 -- pragma Convention (CIL, Typ);
15625 -- function New_Typ (This : Ref) return Ref;
15626 -- function New_Typ (This : Ref; I : Integer) return Ref;
15627 -- pragma Cil_Constructor (New_Typ);
15629 -- Reason: The first formal must NOT be a primitive of the
15632 -- This rule also applies to constructors of delegates used
15633 -- to interface with standard target libraries. For example:
15635 -- type Delegate is access procedure ...
15636 -- pragma Import (CIL, Delegate, ...);
15638 -- function new_Delegate
15639 -- (This : Delegate := null; ... ) return Delegate;
15641 -- For value-types this rule does not apply.
15643 if not Is_Value_Type
(Etype
(Def_Id
)) then
15644 if No
(First_Formal
(Def_Id
)) then
15645 Error_Msg_Name_1
:= Pname
;
15646 Error_Msg_N
("% function must have parameters", Def_Id
);
15650 -- In the JRE library we have several occurrences in which
15651 -- the "this" parameter is not the first formal.
15653 This_Formal
:= First_Formal
(Def_Id
);
15655 -- In the JRE library we have several occurrences in which
15656 -- the "this" parameter is not the first formal. Search for
15659 if VM_Target
= JVM_Target
then
15660 while Present
(This_Formal
)
15661 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15663 Next_Formal
(This_Formal
);
15666 if No
(This_Formal
) then
15667 This_Formal
:= First_Formal
(Def_Id
);
15671 -- Warning: The first parameter should be named "this".
15672 -- We temporarily allow it because we have the following
15673 -- case in the Java runtime (file s-osinte.ads) ???
15675 -- function new_Thread
15676 -- (Self_Id : System.Address) return Thread_Id;
15677 -- pragma Java_Constructor (new_Thread);
15679 if VM_Target
= JVM_Target
15680 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15682 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15686 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15687 Error_Msg_Name_1
:= Pname
;
15689 ("first formal of % function must be named `this`",
15690 Parent
(This_Formal
));
15692 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15693 Error_Msg_Name_1
:= Pname
;
15695 ("first formal of % function must be an access type",
15696 Parameter_Type
(Parent
(This_Formal
)));
15698 -- For delegates the type of the first formal must be a
15699 -- named access-to-subprogram type (see previous example)
15701 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15702 and then Ekind
(Etype
(This_Formal
))
15703 /= E_Access_Subprogram_Type
15705 Error_Msg_Name_1
:= Pname
;
15707 ("first formal of % function must be a named access "
15708 & "to subprogram type",
15709 Parameter_Type
(Parent
(This_Formal
)));
15711 -- Warning: We should reject anonymous access types because
15712 -- the constructor must not be handled as a primitive of the
15713 -- tagged type. We temporarily allow it because this profile
15714 -- is currently generated by cil2ada???
15716 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15717 and then not Ekind_In
(Etype
(This_Formal
),
15719 E_General_Access_Type
,
15720 E_Anonymous_Access_Type
)
15722 Error_Msg_Name_1
:= Pname
;
15724 ("first formal of % function must be a named access "
15725 & "type", Parameter_Type
(Parent
(This_Formal
)));
15727 elsif Atree
.Convention
15728 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15730 Error_Msg_Name_1
:= Pname
;
15732 if Convention
= Convention_Java
then
15734 ("pragma% requires convention 'Cil in designated "
15735 & "type", Parameter_Type
(Parent
(This_Formal
)));
15738 ("pragma% requires convention 'Java in designated "
15739 & "type", Parameter_Type
(Parent
(This_Formal
)));
15742 elsif No
(Expression
(Parent
(This_Formal
)))
15743 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15745 Error_Msg_Name_1
:= Pname
;
15747 ("pragma% requires first formal with default `null`",
15748 Parameter_Type
(Parent
(This_Formal
)));
15752 -- Check result type: the constructor must be a function
15754 -- * a value type (only allowed in the CIL compiler)
15755 -- * an access-to-subprogram type with convention Java/CIL
15756 -- * an access-type designating a type that has convention
15759 if Is_Value_Type
(Etype
(Def_Id
)) then
15762 -- Access-to-subprogram type with convention Java/CIL
15764 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15765 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15766 if Convention
= Convention_Java
then
15768 ("pragma% requires function returning a 'Java "
15769 & "access type", Arg1
);
15771 pragma Assert
(Convention
= Convention_CIL
);
15773 ("pragma% requires function returning a 'C'I'L "
15774 & "access type", Arg1
);
15778 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15779 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15780 E_General_Access_Type
)
15783 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15785 Error_Msg_Name_1
:= Pname
;
15787 if Convention
= Convention_Java
then
15789 ("pragma% requires function returning a named "
15790 & "'Java access type", Arg1
);
15793 ("pragma% requires function returning a named "
15794 & "'C'I'L access type", Arg1
);
15799 Set_Is_Constructor
(Def_Id
);
15800 Set_Convention
(Def_Id
, Convention
);
15801 Set_Is_Imported
(Def_Id
);
15803 exit when From_Aspect_Specification
(N
);
15804 Hom_Id
:= Homonym
(Hom_Id
);
15806 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
15808 end Java_Constructor
;
15810 ----------------------
15811 -- Java_Interface --
15812 ----------------------
15814 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
15816 when Pragma_Java_Interface
=> Java_Interface
: declare
15822 Check_Arg_Count
(1);
15823 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15824 Check_Arg_Is_Local_Name
(Arg1
);
15826 Arg
:= Get_Pragma_Arg
(Arg1
);
15829 if Etype
(Arg
) = Any_Type
then
15833 if not Is_Entity_Name
(Arg
)
15834 or else not Is_Type
(Entity
(Arg
))
15836 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
15839 Typ
:= Underlying_Type
(Entity
(Arg
));
15841 -- For now simply check some of the semantic constraints on the
15842 -- type. This currently leaves out some restrictions on interface
15843 -- types, namely that the parent type must be java.lang.Object.Typ
15844 -- and that all primitives of the type should be declared
15847 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
15849 ("pragma% requires an abstract tagged type", Arg1
);
15851 elsif not Has_Discriminants
(Typ
)
15852 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
15853 /= E_Anonymous_Access_Type
15855 not Is_Class_Wide_Type
15856 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
15859 ("type must have a class-wide access discriminant", Arg1
);
15861 end Java_Interface
;
15867 -- pragma Keep_Names ([On => ] LOCAL_NAME);
15869 when Pragma_Keep_Names
=> Keep_Names
: declare
15874 Check_Arg_Count
(1);
15875 Check_Optional_Identifier
(Arg1
, Name_On
);
15876 Check_Arg_Is_Local_Name
(Arg1
);
15878 Arg
:= Get_Pragma_Arg
(Arg1
);
15881 if Etype
(Arg
) = Any_Type
then
15885 if not Is_Entity_Name
(Arg
)
15886 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
15889 ("pragma% requires a local enumeration type", Arg1
);
15892 Set_Discard_Names
(Entity
(Arg
), False);
15899 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
15901 when Pragma_License
=>
15904 -- Do not analyze pragma any further in CodePeer mode, to avoid
15905 -- extraneous errors in this implementation-dependent pragma,
15906 -- which has a different profile on other compilers.
15908 if CodePeer_Mode
then
15912 Check_Arg_Count
(1);
15913 Check_No_Identifiers
;
15914 Check_Valid_Configuration_Pragma
;
15915 Check_Arg_Is_Identifier
(Arg1
);
15918 Sind
: constant Source_File_Index
:=
15919 Source_Index
(Current_Sem_Unit
);
15922 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15924 Set_License
(Sind
, GPL
);
15926 when Name_Modified_GPL
=>
15927 Set_License
(Sind
, Modified_GPL
);
15929 when Name_Restricted
=>
15930 Set_License
(Sind
, Restricted
);
15932 when Name_Unrestricted
=>
15933 Set_License
(Sind
, Unrestricted
);
15936 Error_Pragma_Arg
("invalid license name", Arg1
);
15944 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
15946 when Pragma_Link_With
=> Link_With
: declare
15952 if Operating_Mode
= Generate_Code
15953 and then In_Extended_Main_Source_Unit
(N
)
15955 Check_At_Least_N_Arguments
(1);
15956 Check_No_Identifiers
;
15957 Check_Is_In_Decl_Part_Or_Package_Spec
;
15958 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15962 while Present
(Arg
) loop
15963 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
15965 -- Store argument, converting sequences of spaces to a
15966 -- single null character (this is one of the differences
15967 -- in processing between Link_With and Linker_Options).
15969 Arg_Store
: declare
15970 C
: constant Char_Code
:= Get_Char_Code
(' ');
15971 S
: constant String_Id
:=
15972 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
15973 L
: constant Nat
:= String_Length
(S
);
15976 procedure Skip_Spaces
;
15977 -- Advance F past any spaces
15983 procedure Skip_Spaces
is
15985 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
15990 -- Start of processing for Arg_Store
15993 Skip_Spaces
; -- skip leading spaces
15995 -- Loop through characters, changing any embedded
15996 -- sequence of spaces to a single null character (this
15997 -- is how Link_With/Linker_Options differ)
16000 if Get_String_Char
(S
, F
) = C
then
16003 Store_String_Char
(ASCII
.NUL
);
16006 Store_String_Char
(Get_String_Char
(S
, F
));
16014 if Present
(Arg
) then
16015 Store_String_Char
(ASCII
.NUL
);
16019 Store_Linker_Option_String
(End_String
);
16027 -- pragma Linker_Alias (
16028 -- [Entity =>] LOCAL_NAME
16029 -- [Target =>] static_string_EXPRESSION);
16031 when Pragma_Linker_Alias
=>
16033 Check_Arg_Order
((Name_Entity
, Name_Target
));
16034 Check_Arg_Count
(2);
16035 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16036 Check_Optional_Identifier
(Arg2
, Name_Target
);
16037 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16038 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16040 -- The only processing required is to link this item on to the
16041 -- list of rep items for the given entity. This is accomplished
16042 -- by the call to Rep_Item_Too_Late (when no error is detected
16043 -- and False is returned).
16045 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16048 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16051 ------------------------
16052 -- Linker_Constructor --
16053 ------------------------
16055 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16057 -- Code is shared with Linker_Destructor
16059 -----------------------
16060 -- Linker_Destructor --
16061 -----------------------
16063 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16065 when Pragma_Linker_Constructor |
16066 Pragma_Linker_Destructor
=>
16067 Linker_Constructor
: declare
16073 Check_Arg_Count
(1);
16074 Check_No_Identifiers
;
16075 Check_Arg_Is_Local_Name
(Arg1
);
16076 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16078 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16080 if not Is_Library_Level_Entity
(Proc
) then
16082 ("argument for pragma% must be library level entity", Arg1
);
16085 -- The only processing required is to link this item on to the
16086 -- list of rep items for the given entity. This is accomplished
16087 -- by the call to Rep_Item_Too_Late (when no error is detected
16088 -- and False is returned).
16090 if Rep_Item_Too_Late
(Proc
, N
) then
16093 Set_Has_Gigi_Rep_Item
(Proc
);
16095 end Linker_Constructor
;
16097 --------------------
16098 -- Linker_Options --
16099 --------------------
16101 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16103 when Pragma_Linker_Options
=> Linker_Options
: declare
16107 Check_Ada_83_Warning
;
16108 Check_No_Identifiers
;
16109 Check_Arg_Count
(1);
16110 Check_Is_In_Decl_Part_Or_Package_Spec
;
16111 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16112 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16115 while Present
(Arg
) loop
16116 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16117 Store_String_Char
(ASCII
.NUL
);
16119 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16123 if Operating_Mode
= Generate_Code
16124 and then In_Extended_Main_Source_Unit
(N
)
16126 Store_Linker_Option_String
(End_String
);
16128 end Linker_Options
;
16130 --------------------
16131 -- Linker_Section --
16132 --------------------
16134 -- pragma Linker_Section (
16135 -- [Entity =>] LOCAL_NAME
16136 -- [Section =>] static_string_EXPRESSION);
16138 when Pragma_Linker_Section
=> Linker_Section
: declare
16144 Check_Arg_Order
((Name_Entity
, Name_Section
));
16145 Check_Arg_Count
(2);
16146 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16147 Check_Optional_Identifier
(Arg2
, Name_Section
);
16148 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16149 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16151 -- Check kind of entity
16153 Arg
:= Get_Pragma_Arg
(Arg1
);
16154 Ent
:= Entity
(Arg
);
16156 case Ekind
(Ent
) is
16158 -- Objects (constants and variables) and types. For these cases
16159 -- all we need to do is to set the Linker_Section_pragma field.
16161 when E_Constant | E_Variable | Type_Kind
=>
16162 Set_Linker_Section_Pragma
(Ent
, N
);
16166 when Subprogram_Kind
=>
16168 -- Aspect case, entity already set
16170 if From_Aspect_Specification
(N
) then
16171 Set_Linker_Section_Pragma
16172 (Entity
(Corresponding_Aspect
(N
)), N
);
16174 -- Pragma case, we must climb the homonym chain, but skip
16175 -- any for which the linker section is already set.
16179 if No
(Linker_Section_Pragma
(Ent
)) then
16180 Set_Linker_Section_Pragma
(Ent
, N
);
16183 Ent
:= Homonym
(Ent
);
16185 or else Scope
(Ent
) /= Current_Scope
;
16189 -- All other cases are illegal
16193 ("pragma% applies only to objects, subprograms, and types",
16196 end Linker_Section
;
16202 -- pragma List (On | Off)
16204 -- There is nothing to do here, since we did all the processing for
16205 -- this pragma in Par.Prag (so that it works properly even in syntax
16208 when Pragma_List
=>
16215 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16217 when Pragma_Lock_Free
=> Lock_Free
: declare
16218 P
: constant Node_Id
:= Parent
(N
);
16224 Check_No_Identifiers
;
16225 Check_At_Most_N_Arguments
(1);
16227 -- Protected definition case
16229 if Nkind
(P
) = N_Protected_Definition
then
16230 Ent
:= Defining_Identifier
(Parent
(P
));
16234 if Arg_Count
= 1 then
16235 Arg
:= Get_Pragma_Arg
(Arg1
);
16236 Val
:= Is_True
(Static_Boolean
(Arg
));
16238 -- No arguments (expression is considered to be True)
16244 -- Check duplicate pragma before we chain the pragma in the Rep
16245 -- Item chain of Ent.
16247 Check_Duplicate_Pragma
(Ent
);
16248 Record_Rep_Item
(Ent
, N
);
16249 Set_Uses_Lock_Free
(Ent
, Val
);
16251 -- Anything else is incorrect placement
16258 --------------------
16259 -- Locking_Policy --
16260 --------------------
16262 -- pragma Locking_Policy (policy_IDENTIFIER);
16264 when Pragma_Locking_Policy
=> declare
16265 subtype LP_Range
is Name_Id
16266 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16271 Check_Ada_83_Warning
;
16272 Check_Arg_Count
(1);
16273 Check_No_Identifiers
;
16274 Check_Arg_Is_Locking_Policy
(Arg1
);
16275 Check_Valid_Configuration_Pragma
;
16276 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16279 when Name_Ceiling_Locking
=>
16281 when Name_Inheritance_Locking
=>
16283 when Name_Concurrent_Readers_Locking
=>
16287 if Locking_Policy
/= ' '
16288 and then Locking_Policy
/= LP
16290 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16291 Error_Pragma
("locking policy incompatible with policy#");
16293 -- Set new policy, but always preserve System_Location since we
16294 -- like the error message with the run time name.
16297 Locking_Policy
:= LP
;
16299 if Locking_Policy_Sloc
/= System_Location
then
16300 Locking_Policy_Sloc
:= Loc
;
16305 -------------------
16306 -- Loop_Optimize --
16307 -------------------
16309 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16311 -- OPTIMIZATION_HINT ::=
16312 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16314 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16319 Check_At_Least_N_Arguments
(1);
16320 Check_No_Identifiers
;
16322 Hint
:= First
(Pragma_Argument_Associations
(N
));
16323 while Present
(Hint
) loop
16324 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16332 Check_Loop_Pragma_Placement
;
16339 -- pragma Loop_Variant
16340 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16342 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16344 -- CHANGE_DIRECTION ::= Increases | Decreases
16346 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16351 Check_At_Least_N_Arguments
(1);
16352 Check_Loop_Pragma_Placement
;
16354 -- Process all increasing / decreasing expressions
16356 Variant
:= First
(Pragma_Argument_Associations
(N
));
16357 while Present
(Variant
) loop
16358 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16361 Error_Pragma_Arg
("wrong change modifier", Variant
);
16364 Preanalyze_Assert_Expression
16365 (Expression
(Variant
), Any_Discrete
);
16371 -----------------------
16372 -- Machine_Attribute --
16373 -----------------------
16375 -- pragma Machine_Attribute (
16376 -- [Entity =>] LOCAL_NAME,
16377 -- [Attribute_Name =>] static_string_EXPRESSION
16378 -- [, [Info =>] static_EXPRESSION] );
16380 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16381 Def_Id
: Entity_Id
;
16385 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16387 if Arg_Count
= 3 then
16388 Check_Optional_Identifier
(Arg3
, Name_Info
);
16389 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16391 Check_Arg_Count
(2);
16394 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16395 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16396 Check_Arg_Is_Local_Name
(Arg1
);
16397 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16398 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16400 if Is_Access_Type
(Def_Id
) then
16401 Def_Id
:= Designated_Type
(Def_Id
);
16404 if Rep_Item_Too_Early
(Def_Id
, N
) then
16408 Def_Id
:= Underlying_Type
(Def_Id
);
16410 -- The only processing required is to link this item on to the
16411 -- list of rep items for the given entity. This is accomplished
16412 -- by the call to Rep_Item_Too_Late (when no error is detected
16413 -- and False is returned).
16415 if Rep_Item_Too_Late
(Def_Id
, N
) then
16418 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16420 end Machine_Attribute
;
16427 -- (MAIN_OPTION [, MAIN_OPTION]);
16430 -- [STACK_SIZE =>] static_integer_EXPRESSION
16431 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16432 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16434 when Pragma_Main
=> Main
: declare
16435 Args
: Args_List
(1 .. 3);
16436 Names
: constant Name_List
(1 .. 3) := (
16438 Name_Task_Stack_Size_Default
,
16439 Name_Time_Slicing_Enabled
);
16445 Gather_Associations
(Names
, Args
);
16447 for J
in 1 .. 2 loop
16448 if Present
(Args
(J
)) then
16449 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16453 if Present
(Args
(3)) then
16454 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16458 while Present
(Nod
) loop
16459 if Nkind
(Nod
) = N_Pragma
16460 and then Pragma_Name
(Nod
) = Name_Main
16462 Error_Msg_Name_1
:= Pname
;
16463 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16474 -- pragma Main_Storage
16475 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16477 -- MAIN_STORAGE_OPTION ::=
16478 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16479 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16481 when Pragma_Main_Storage
=> Main_Storage
: declare
16482 Args
: Args_List
(1 .. 2);
16483 Names
: constant Name_List
(1 .. 2) := (
16484 Name_Working_Storage
,
16491 Gather_Associations
(Names
, Args
);
16493 for J
in 1 .. 2 loop
16494 if Present
(Args
(J
)) then
16495 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16499 Check_In_Main_Program
;
16502 while Present
(Nod
) loop
16503 if Nkind
(Nod
) = N_Pragma
16504 and then Pragma_Name
(Nod
) = Name_Main_Storage
16506 Error_Msg_Name_1
:= Pname
;
16507 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16518 -- pragma Memory_Size (NUMERIC_LITERAL)
16520 when Pragma_Memory_Size
=>
16523 -- Memory size is simply ignored
16525 Check_No_Identifiers
;
16526 Check_Arg_Count
(1);
16527 Check_Arg_Is_Integer_Literal
(Arg1
);
16535 -- The only correct use of this pragma is on its own in a file, in
16536 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16537 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16538 -- check for a file containing nothing but a No_Body pragma). If we
16539 -- attempt to process it during normal semantics processing, it means
16540 -- it was misplaced.
16542 when Pragma_No_Body
=>
16546 -----------------------------
16547 -- No_Elaboration_Code_All --
16548 -----------------------------
16550 -- pragma No_Elaboration_Code_All;
16552 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16555 Check_Valid_Library_Unit_Pragma
;
16557 if Nkind
(N
) = N_Null_Statement
then
16561 -- Must appear for a spec
16563 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16564 N_Package_Declaration
,
16565 N_Subprogram_Declaration
)
16569 ("pragma% can only occur for package "
16570 & "or subprogram spec"));
16573 -- Set flag in unit table
16575 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16577 -- Set restriction No_Elaboration_Code
16579 Set_Restriction
(No_Elaboration_Code
, N
);
16581 -- If we are in the main unit or in an extended main source unit,
16582 -- then we also add it to the configuration restrictions so that
16583 -- it will apply to all units in the extended main source.
16585 if Current_Sem_Unit
= Main_Unit
16586 or else In_Extended_Main_Source_Unit
(N
)
16588 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16591 -- If in main extended unit, activate transitive with test
16593 if In_Extended_Main_Source_Unit
(N
) then
16594 Opt
.No_Elab_Code_All_Pragma
:= N
;
16602 -- pragma No_Inline ( NAME {, NAME} );
16604 when Pragma_No_Inline
=>
16606 Process_Inline
(Suppressed
);
16612 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16614 when Pragma_No_Return
=> No_Return
: declare
16622 Check_At_Least_N_Arguments
(1);
16624 -- Loop through arguments of pragma
16627 while Present
(Arg
) loop
16628 Check_Arg_Is_Local_Name
(Arg
);
16629 Id
:= Get_Pragma_Arg
(Arg
);
16632 if not Is_Entity_Name
(Id
) then
16633 Error_Pragma_Arg
("entity name required", Arg
);
16636 if Etype
(Id
) = Any_Type
then
16640 -- Loop to find matching procedures
16645 and then Scope
(E
) = Current_Scope
16647 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16650 -- Set flag on any alias as well
16652 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16653 Set_No_Return
(Alias
(E
));
16659 exit when From_Aspect_Specification
(N
);
16663 -- If entity in not in current scope it may be the enclosing
16664 -- suprogram body to which the aspect applies.
16667 if Entity
(Id
) = Current_Scope
16668 and then From_Aspect_Specification
(N
)
16670 Set_No_Return
(Entity
(Id
));
16672 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16684 -- pragma No_Run_Time;
16686 -- Note: this pragma is retained for backwards compatibility. See
16687 -- body of Rtsfind for full details on its handling.
16689 when Pragma_No_Run_Time
=>
16691 Check_Valid_Configuration_Pragma
;
16692 Check_Arg_Count
(0);
16694 No_Run_Time_Mode
:= True;
16695 Configurable_Run_Time_Mode
:= True;
16697 -- Set Duration to 32 bits if word size is 32
16699 if Ttypes
.System_Word_Size
= 32 then
16700 Duration_32_Bits_On_Target
:= True;
16703 -- Set appropriate restrictions
16705 Set_Restriction
(No_Finalization
, N
);
16706 Set_Restriction
(No_Exception_Handlers
, N
);
16707 Set_Restriction
(Max_Tasks
, N
, 0);
16708 Set_Restriction
(No_Tasking
, N
);
16710 -----------------------
16711 -- No_Tagged_Streams --
16712 -----------------------
16714 -- pragma No_Tagged_Streams;
16715 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16717 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16723 Check_At_Most_N_Arguments
(1);
16725 -- One argument case
16727 if Arg_Count
= 1 then
16728 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16729 Check_Arg_Is_Local_Name
(Arg1
);
16730 E_Id
:= Get_Pragma_Arg
(Arg1
);
16732 if Etype
(E_Id
) = Any_Type
then
16736 E
:= Entity
(E_Id
);
16738 Check_Duplicate_Pragma
(E
);
16740 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16742 ("argument for pragma% must be root tagged type", Arg1
);
16745 if Rep_Item_Too_Early
(E
, N
)
16747 Rep_Item_Too_Late
(E
, N
)
16751 Set_No_Tagged_Streams_Pragma
(E
, N
);
16754 -- Zero argument case
16757 Check_Is_In_Decl_Part_Or_Package_Spec
;
16758 No_Tagged_Streams
:= N
;
16760 end No_Tagged_Strms
;
16762 ------------------------
16763 -- No_Strict_Aliasing --
16764 ------------------------
16766 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16768 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16773 Check_At_Most_N_Arguments
(1);
16775 if Arg_Count
= 0 then
16776 Check_Valid_Configuration_Pragma
;
16777 Opt
.No_Strict_Aliasing
:= True;
16780 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16781 Check_Arg_Is_Local_Name
(Arg1
);
16782 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16784 if E_Id
= Any_Type
then
16786 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16787 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16790 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16792 end No_Strict_Aliasing
;
16794 -----------------------
16795 -- Normalize_Scalars --
16796 -----------------------
16798 -- pragma Normalize_Scalars;
16800 when Pragma_Normalize_Scalars
=>
16801 Check_Ada_83_Warning
;
16802 Check_Arg_Count
(0);
16803 Check_Valid_Configuration_Pragma
;
16805 -- Normalize_Scalars creates false positives in CodePeer, and
16806 -- incorrect negative results in GNATprove mode, so ignore this
16807 -- pragma in these modes.
16809 if not (CodePeer_Mode
or GNATprove_Mode
) then
16810 Normalize_Scalars
:= True;
16811 Init_Or_Norm_Scalars
:= True;
16818 -- pragma Obsolescent;
16820 -- pragma Obsolescent (
16821 -- [Message =>] static_string_EXPRESSION
16822 -- [,[Version =>] Ada_05]]);
16824 -- pragma Obsolescent (
16825 -- [Entity =>] NAME
16826 -- [,[Message =>] static_string_EXPRESSION
16827 -- [,[Version =>] Ada_05]] );
16829 when Pragma_Obsolescent
=> Obsolescent
: declare
16833 procedure Set_Obsolescent
(E
: Entity_Id
);
16834 -- Given an entity Ent, mark it as obsolescent if appropriate
16836 ---------------------
16837 -- Set_Obsolescent --
16838 ---------------------
16840 procedure Set_Obsolescent
(E
: Entity_Id
) is
16849 -- Entity name was given
16851 if Present
(Ename
) then
16853 -- If entity name matches, we are fine. Save entity in
16854 -- pragma argument, for ASIS use.
16856 if Chars
(Ename
) = Chars
(Ent
) then
16857 Set_Entity
(Ename
, Ent
);
16858 Generate_Reference
(Ent
, Ename
);
16860 -- If entity name does not match, only possibility is an
16861 -- enumeration literal from an enumeration type declaration.
16863 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
16865 ("pragma % entity name does not match declaration");
16868 Ent
:= First_Literal
(E
);
16872 ("pragma % entity name does not match any "
16873 & "enumeration literal");
16875 elsif Chars
(Ent
) = Chars
(Ename
) then
16876 Set_Entity
(Ename
, Ent
);
16877 Generate_Reference
(Ent
, Ename
);
16881 Ent
:= Next_Literal
(Ent
);
16887 -- Ent points to entity to be marked
16889 if Arg_Count
>= 1 then
16891 -- Deal with static string argument
16893 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16894 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
16896 for J
in 1 .. String_Length
(S
) loop
16897 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
16899 ("pragma% argument does not allow wide characters",
16904 Obsolescent_Warnings
.Append
16905 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
16907 -- Check for Ada_05 parameter
16909 if Arg_Count
/= 1 then
16910 Check_Arg_Count
(2);
16913 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
16916 Check_Arg_Is_Identifier
(Argx
);
16918 if Chars
(Argx
) /= Name_Ada_05
then
16919 Error_Msg_Name_2
:= Name_Ada_05
;
16921 ("only allowed argument for pragma% is %", Argx
);
16924 if Ada_Version_Explicit
< Ada_2005
16925 or else not Warn_On_Ada_2005_Compatibility
16933 -- Set flag if pragma active
16936 Set_Is_Obsolescent
(Ent
);
16940 end Set_Obsolescent
;
16942 -- Start of processing for pragma Obsolescent
16947 Check_At_Most_N_Arguments
(3);
16949 -- See if first argument specifies an entity name
16953 (Chars
(Arg1
) = Name_Entity
16955 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
16957 N_Operator_Symbol
))
16959 Ename
:= Get_Pragma_Arg
(Arg1
);
16961 -- Eliminate first argument, so we can share processing
16965 Arg_Count
:= Arg_Count
- 1;
16967 -- No Entity name argument given
16973 if Arg_Count
>= 1 then
16974 Check_Optional_Identifier
(Arg1
, Name_Message
);
16976 if Arg_Count
= 2 then
16977 Check_Optional_Identifier
(Arg2
, Name_Version
);
16981 -- Get immediately preceding declaration
16984 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
16988 -- Cases where we do not follow anything other than another pragma
16992 -- First case: library level compilation unit declaration with
16993 -- the pragma immediately following the declaration.
16995 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
16997 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17000 -- Case 2: library unit placement for package
17004 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17006 if Is_Package_Or_Generic_Package
(Ent
) then
17007 Set_Obsolescent
(Ent
);
17013 -- Cases where we must follow a declaration
17016 if Nkind
(Decl
) not in N_Declaration
17017 and then Nkind
(Decl
) not in N_Later_Decl_Item
17018 and then Nkind
(Decl
) not in N_Generic_Declaration
17019 and then Nkind
(Decl
) not in N_Renaming_Declaration
17022 ("pragma% misplaced, "
17023 & "must immediately follow a declaration");
17026 Set_Obsolescent
(Defining_Entity
(Decl
));
17036 -- pragma Optimize (Time | Space | Off);
17038 -- The actual check for optimize is done in Gigi. Note that this
17039 -- pragma does not actually change the optimization setting, it
17040 -- simply checks that it is consistent with the pragma.
17042 when Pragma_Optimize
=>
17043 Check_No_Identifiers
;
17044 Check_Arg_Count
(1);
17045 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17047 ------------------------
17048 -- Optimize_Alignment --
17049 ------------------------
17051 -- pragma Optimize_Alignment (Time | Space | Off);
17053 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17055 Check_No_Identifiers
;
17056 Check_Arg_Count
(1);
17057 Check_Valid_Configuration_Pragma
;
17060 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17064 Opt
.Optimize_Alignment
:= 'T';
17066 Opt
.Optimize_Alignment
:= 'S';
17068 Opt
.Optimize_Alignment
:= 'O';
17070 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17074 -- Set indication that mode is set locally. If we are in fact in a
17075 -- configuration pragma file, this setting is harmless since the
17076 -- switch will get reset anyway at the start of each unit.
17078 Optimize_Alignment_Local
:= True;
17079 end Optimize_Alignment
;
17085 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17087 when Pragma_Ordered
=> Ordered
: declare
17088 Assoc
: constant Node_Id
:= Arg1
;
17094 Check_No_Identifiers
;
17095 Check_Arg_Count
(1);
17096 Check_Arg_Is_Local_Name
(Arg1
);
17098 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17099 Find_Type
(Type_Id
);
17100 Typ
:= Entity
(Type_Id
);
17102 if Typ
= Any_Type
then
17105 Typ
:= Underlying_Type
(Typ
);
17108 if not Is_Enumeration_Type
(Typ
) then
17109 Error_Pragma
("pragma% must specify enumeration type");
17112 Check_First_Subtype
(Arg1
);
17113 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17116 -------------------
17117 -- Overflow_Mode --
17118 -------------------
17120 -- pragma Overflow_Mode
17121 -- ([General => ] MODE [, [Assertions => ] MODE]);
17123 -- MODE := STRICT | MINIMIZED | ELIMINATED
17125 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17126 -- since System.Bignums makes this assumption. This is true of nearly
17127 -- all (all?) targets.
17129 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17130 function Get_Overflow_Mode
17132 Arg
: Node_Id
) return Overflow_Mode_Type
;
17133 -- Function to process one pragma argument, Arg. If an identifier
17134 -- is present, it must be Name. Mode type is returned if a valid
17135 -- argument exists, otherwise an error is signalled.
17137 -----------------------
17138 -- Get_Overflow_Mode --
17139 -----------------------
17141 function Get_Overflow_Mode
17143 Arg
: Node_Id
) return Overflow_Mode_Type
17145 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17148 Check_Optional_Identifier
(Arg
, Name
);
17149 Check_Arg_Is_Identifier
(Argx
);
17151 if Chars
(Argx
) = Name_Strict
then
17154 elsif Chars
(Argx
) = Name_Minimized
then
17157 elsif Chars
(Argx
) = Name_Eliminated
then
17158 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17160 ("Eliminated not implemented on this target", Argx
);
17166 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17168 end Get_Overflow_Mode
;
17170 -- Start of processing for Overflow_Mode
17174 Check_At_Least_N_Arguments
(1);
17175 Check_At_Most_N_Arguments
(2);
17177 -- Process first argument
17179 Scope_Suppress
.Overflow_Mode_General
:=
17180 Get_Overflow_Mode
(Name_General
, Arg1
);
17182 -- Case of only one argument
17184 if Arg_Count
= 1 then
17185 Scope_Suppress
.Overflow_Mode_Assertions
:=
17186 Scope_Suppress
.Overflow_Mode_General
;
17188 -- Case of two arguments present
17191 Scope_Suppress
.Overflow_Mode_Assertions
:=
17192 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17196 --------------------------
17197 -- Overriding Renamings --
17198 --------------------------
17200 -- pragma Overriding_Renamings;
17202 when Pragma_Overriding_Renamings
=>
17204 Check_Arg_Count
(0);
17205 Check_Valid_Configuration_Pragma
;
17206 Overriding_Renamings
:= True;
17212 -- pragma Pack (first_subtype_LOCAL_NAME);
17214 when Pragma_Pack
=> Pack
: declare
17215 Assoc
: constant Node_Id
:= Arg1
;
17219 Ignore
: Boolean := False;
17222 Check_No_Identifiers
;
17223 Check_Arg_Count
(1);
17224 Check_Arg_Is_Local_Name
(Arg1
);
17225 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17227 if not Is_Entity_Name
(Type_Id
)
17228 or else not Is_Type
(Entity
(Type_Id
))
17231 ("argument for pragma% must be type or subtype", Arg1
);
17234 Find_Type
(Type_Id
);
17235 Typ
:= Entity
(Type_Id
);
17238 or else Rep_Item_Too_Early
(Typ
, N
)
17242 Typ
:= Underlying_Type
(Typ
);
17245 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17246 Error_Pragma
("pragma% must specify array or record type");
17249 Check_First_Subtype
(Arg1
);
17250 Check_Duplicate_Pragma
(Typ
);
17254 if Is_Array_Type
(Typ
) then
17255 Ctyp
:= Component_Type
(Typ
);
17257 -- Ignore pack that does nothing
17259 if Known_Static_Esize
(Ctyp
)
17260 and then Known_Static_RM_Size
(Ctyp
)
17261 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17262 and then Addressable
(Esize
(Ctyp
))
17267 -- Process OK pragma Pack. Note that if there is a separate
17268 -- component clause present, the Pack will be cancelled. This
17269 -- processing is in Freeze.
17271 if not Rep_Item_Too_Late
(Typ
, N
) then
17273 -- In CodePeer mode, we do not need complex front-end
17274 -- expansions related to pragma Pack, so disable handling
17277 if CodePeer_Mode
then
17280 -- Don't attempt any packing for VM targets. We possibly
17281 -- could deal with some cases of array bit-packing, but we
17282 -- don't bother, since this is not a typical kind of
17283 -- representation in the VM context anyway (and would not
17284 -- for example work nicely with the debugger).
17286 elsif VM_Target
/= No_VM
then
17287 if not GNAT_Mode
then
17289 ("??pragma% ignored in this configuration");
17292 -- Normal case where we do the pack action
17296 Set_Is_Packed
(Base_Type
(Typ
));
17297 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17300 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17304 -- For record types, the pack is always effective
17306 else pragma Assert
(Is_Record_Type
(Typ
));
17307 if not Rep_Item_Too_Late
(Typ
, N
) then
17309 -- Ignore pack request with warning in VM mode (skip warning
17310 -- if we are compiling GNAT run time library).
17312 if VM_Target
/= No_VM
then
17313 if not GNAT_Mode
then
17315 ("??pragma% ignored in this configuration");
17318 -- Normal case of pack request active
17321 Set_Is_Packed
(Base_Type
(Typ
));
17322 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17323 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17335 -- There is nothing to do here, since we did all the processing for
17336 -- this pragma in Par.Prag (so that it works properly even in syntax
17339 when Pragma_Page
=>
17346 -- pragma Part_Of (ABSTRACT_STATE);
17348 -- ABSTRACT_STATE ::= NAME
17350 when Pragma_Part_Of
=> Part_Of
: declare
17351 procedure Propagate_Part_Of
17352 (Pack_Id
: Entity_Id
;
17353 State_Id
: Entity_Id
;
17354 Instance
: Node_Id
);
17355 -- Propagate the Part_Of indicator to all abstract states and
17356 -- variables declared in the visible state space of a package
17357 -- denoted by Pack_Id. State_Id is the encapsulating state.
17358 -- Instance is the package instantiation node.
17360 -----------------------
17361 -- Propagate_Part_Of --
17362 -----------------------
17364 procedure Propagate_Part_Of
17365 (Pack_Id
: Entity_Id
;
17366 State_Id
: Entity_Id
;
17367 Instance
: Node_Id
)
17369 Has_Item
: Boolean := False;
17370 -- Flag set when the visible state space contains at least one
17371 -- abstract state or variable.
17373 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17374 -- Propagate the Part_Of indicator to all abstract states and
17375 -- variables declared in the visible state space of a package
17376 -- denoted by Pack_Id.
17378 -----------------------
17379 -- Propagate_Part_Of --
17380 -----------------------
17382 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17383 Item_Id
: Entity_Id
;
17386 -- Traverse the entity chain of the package and set relevant
17387 -- attributes of abstract states and variables declared in
17388 -- the visible state space of the package.
17390 Item_Id
:= First_Entity
(Pack_Id
);
17391 while Present
(Item_Id
)
17392 and then not In_Private_Part
(Item_Id
)
17394 -- Do not consider internally generated items
17396 if not Comes_From_Source
(Item_Id
) then
17399 -- The Part_Of indicator turns an abstract state or
17400 -- variable into a constituent of the encapsulating
17403 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17408 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17409 Set_Encapsulating_State
(Item_Id
, State_Id
);
17411 -- Recursively handle nested packages and instantiations
17413 elsif Ekind
(Item_Id
) = E_Package
then
17414 Propagate_Part_Of
(Item_Id
);
17417 Next_Entity
(Item_Id
);
17419 end Propagate_Part_Of
;
17421 -- Start of processing for Propagate_Part_Of
17424 Propagate_Part_Of
(Pack_Id
);
17426 -- Detect a package instantiation that is subject to a Part_Of
17427 -- indicator, but has no visible state.
17429 if not Has_Item
then
17431 ("package instantiation & has Part_Of indicator but "
17432 & "lacks visible state", Instance
, Pack_Id
);
17434 end Propagate_Part_Of
;
17438 Item_Id
: Entity_Id
;
17441 State_Id
: Entity_Id
;
17444 -- Start of processing for Part_Of
17448 Check_No_Identifiers
;
17449 Check_Arg_Count
(1);
17451 -- Ensure the proper placement of the pragma. Part_Of must appear
17452 -- on a variable declaration or a package instantiation.
17455 while Present
(Stmt
) loop
17457 -- Skip prior pragmas, but check for duplicates
17459 if Nkind
(Stmt
) = N_Pragma
then
17460 if Pragma_Name
(Stmt
) = Pname
then
17461 Error_Msg_Name_1
:= Pname
;
17462 Error_Msg_Sloc
:= Sloc
(Stmt
);
17463 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17466 -- Skip internally generated code
17468 elsif not Comes_From_Source
(Stmt
) then
17471 -- The pragma applies to an object declaration (possibly a
17472 -- variable) or a package instantiation. Stop the traversal
17473 -- and continue the analysis.
17475 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17476 N_Package_Instantiation
)
17480 -- The pragma does not apply to a legal construct, issue an
17481 -- error and stop the analysis.
17488 Stmt
:= Prev
(Stmt
);
17491 -- When the context is an object declaration, ensure that we are
17492 -- dealing with a variable.
17494 if Nkind
(Stmt
) = N_Object_Declaration
17495 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17497 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17501 -- Extract the entity of the related object declaration or package
17502 -- instantiation. In the case of the instantiation, use the entity
17503 -- of the instance spec.
17505 if Nkind
(Stmt
) = N_Package_Instantiation
then
17506 Stmt
:= Instance_Spec
(Stmt
);
17509 Item_Id
:= Defining_Entity
(Stmt
);
17510 State
:= Get_Pragma_Arg
(Arg1
);
17512 -- Detect any discrepancies between the placement of the object
17513 -- or package instantiation with respect to state space and the
17514 -- encapsulating state.
17517 (Item_Id
=> Item_Id
,
17523 State_Id
:= Entity
(State
);
17525 -- Add the pragma to the contract of the item. This aids with
17526 -- the detection of a missing but required Part_Of indicator.
17528 Add_Contract_Item
(N
, Item_Id
);
17530 -- The Part_Of indicator turns a variable into a constituent
17531 -- of the encapsulating state.
17533 if Ekind
(Item_Id
) = E_Variable
then
17534 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17535 Set_Encapsulating_State
(Item_Id
, State_Id
);
17537 -- Propagate the Part_Of indicator to the visible state space
17538 -- of the package instantiation.
17542 (Pack_Id
=> Item_Id
,
17543 State_Id
=> State_Id
,
17549 ----------------------------------
17550 -- Partition_Elaboration_Policy --
17551 ----------------------------------
17553 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17555 when Pragma_Partition_Elaboration_Policy
=> declare
17556 subtype PEP_Range
is Name_Id
17557 range First_Partition_Elaboration_Policy_Name
17558 .. Last_Partition_Elaboration_Policy_Name
;
17559 PEP_Val
: PEP_Range
;
17564 Check_Arg_Count
(1);
17565 Check_No_Identifiers
;
17566 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17567 Check_Valid_Configuration_Pragma
;
17568 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17571 when Name_Concurrent
=>
17573 when Name_Sequential
=>
17577 if Partition_Elaboration_Policy
/= ' '
17578 and then Partition_Elaboration_Policy
/= PEP
17580 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17582 ("partition elaboration policy incompatible with policy#");
17584 -- Set new policy, but always preserve System_Location since we
17585 -- like the error message with the run time name.
17588 Partition_Elaboration_Policy
:= PEP
;
17590 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17591 Partition_Elaboration_Policy_Sloc
:= Loc
;
17600 -- pragma Passive [(PASSIVE_FORM)];
17602 -- PASSIVE_FORM ::= Semaphore | No
17604 when Pragma_Passive
=>
17607 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17608 Error_Pragma
("pragma% must be within task definition");
17611 if Arg_Count
/= 0 then
17612 Check_Arg_Count
(1);
17613 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17616 ----------------------------------
17617 -- Preelaborable_Initialization --
17618 ----------------------------------
17620 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17622 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17627 Check_Arg_Count
(1);
17628 Check_No_Identifiers
;
17629 Check_Arg_Is_Identifier
(Arg1
);
17630 Check_Arg_Is_Local_Name
(Arg1
);
17631 Check_First_Subtype
(Arg1
);
17632 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17634 -- The pragma may come from an aspect on a private declaration,
17635 -- even if the freeze point at which this is analyzed in the
17636 -- private part after the full view.
17638 if Has_Private_Declaration
(Ent
)
17639 and then From_Aspect_Specification
(N
)
17643 elsif Is_Private_Type
(Ent
)
17644 or else Is_Protected_Type
(Ent
)
17645 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17651 ("pragma % can only be applied to private, formal derived or "
17652 & "protected type",
17656 -- Give an error if the pragma is applied to a protected type that
17657 -- does not qualify (due to having entries, or due to components
17658 -- that do not qualify).
17660 if Is_Protected_Type
(Ent
)
17661 and then not Has_Preelaborable_Initialization
(Ent
)
17664 ("protected type & does not have preelaborable "
17665 & "initialization", Ent
);
17667 -- Otherwise mark the type as definitely having preelaborable
17671 Set_Known_To_Have_Preelab_Init
(Ent
);
17674 if Has_Pragma_Preelab_Init
(Ent
)
17675 and then Warn_On_Redundant_Constructs
17677 Error_Pragma
("?r?duplicate pragma%!");
17679 Set_Has_Pragma_Preelab_Init
(Ent
);
17683 --------------------
17684 -- Persistent_BSS --
17685 --------------------
17687 -- pragma Persistent_BSS [(object_NAME)];
17689 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17696 Check_At_Most_N_Arguments
(1);
17698 -- Case of application to specific object (one argument)
17700 if Arg_Count
= 1 then
17701 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17703 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17705 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17708 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17711 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17712 Decl
:= Parent
(Ent
);
17714 -- Check for duplication before inserting in list of
17715 -- representation items.
17717 Check_Duplicate_Pragma
(Ent
);
17719 if Rep_Item_Too_Late
(Ent
, N
) then
17723 if Present
(Expression
(Decl
)) then
17725 ("object for pragma% cannot have initialization", Arg1
);
17728 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17730 ("object type for pragma% is not potentially persistent",
17735 Make_Linker_Section_Pragma
17736 (Ent
, Sloc
(N
), ".persistent.bss");
17737 Insert_After
(N
, Prag
);
17740 -- Case of use as configuration pragma with no arguments
17743 Check_Valid_Configuration_Pragma
;
17744 Persistent_BSS_Mode
:= True;
17746 end Persistent_BSS
;
17752 -- pragma Polling (ON | OFF);
17754 when Pragma_Polling
=>
17756 Check_Arg_Count
(1);
17757 Check_No_Identifiers
;
17758 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17759 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17765 -- pragma Post (Boolean_EXPRESSION);
17766 -- pragma Post_Class (Boolean_EXPRESSION);
17768 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
17769 PC_Pragma
: Node_Id
;
17773 Check_Arg_Count
(1);
17774 Check_No_Identifiers
;
17777 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
17778 -- flag Class_Present to True for the Post_Class case.
17780 Set_Class_Present
(N
, Prag_Id
= Pragma_Post_Class
);
17781 PC_Pragma
:= New_Copy
(N
);
17782 Set_Pragma_Identifier
17783 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
17784 Rewrite
(N
, PC_Pragma
);
17785 Set_Analyzed
(N
, False);
17789 -------------------
17790 -- Postcondition --
17791 -------------------
17793 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17794 -- [,[Message =>] String_EXPRESSION]);
17796 when Pragma_Postcondition
=> Postcondition
: declare
17801 Check_At_Least_N_Arguments
(1);
17802 Check_At_Most_N_Arguments
(2);
17803 Check_Optional_Identifier
(Arg1
, Name_Check
);
17805 -- Verify the proper placement of the pragma. The remainder of the
17806 -- processing is found in Sem_Ch6/Sem_Ch7.
17808 Check_Precondition_Postcondition
(In_Body
);
17810 -- When the pragma is a source construct appearing inside a body,
17811 -- preanalyze the boolean_expression to detect illegal forward
17815 -- pragma Postcondition (X'Old ...);
17818 if Comes_From_Source
(N
) and then In_Body
then
17819 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
17827 -- pragma Pre (Boolean_EXPRESSION);
17828 -- pragma Pre_Class (Boolean_EXPRESSION);
17830 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
17831 PC_Pragma
: Node_Id
;
17835 Check_Arg_Count
(1);
17836 Check_No_Identifiers
;
17839 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
17840 -- flag Class_Present to True for the Pre_Class case.
17842 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
17843 PC_Pragma
:= New_Copy
(N
);
17844 Set_Pragma_Identifier
17845 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
17846 Rewrite
(N
, PC_Pragma
);
17847 Set_Analyzed
(N
, False);
17855 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
17856 -- [,[Message =>] String_EXPRESSION]);
17858 when Pragma_Precondition
=> Precondition
: declare
17863 Check_At_Least_N_Arguments
(1);
17864 Check_At_Most_N_Arguments
(2);
17865 Check_Optional_Identifier
(Arg1
, Name_Check
);
17866 Check_Precondition_Postcondition
(In_Body
);
17868 -- If in spec, nothing more to do. If in body, then we convert
17869 -- the pragma to an equivalent pragma Check. That works fine since
17870 -- pragma Check will analyze the condition in the proper context.
17872 -- The form of the pragma Check is either:
17874 -- pragma Check (Precondition, cond [, msg])
17876 -- pragma Check (Pre, cond [, msg])
17878 -- We use the Pre form if this pragma derived from a Pre aspect.
17879 -- This is needed to make sure that the right set of Policy
17880 -- pragmas are checked.
17884 -- Rewrite as Check pragma
17888 Chars
=> Name_Check
,
17889 Pragma_Argument_Associations
=> New_List
(
17890 Make_Pragma_Argument_Association
(Loc
,
17891 Expression
=> Make_Identifier
(Loc
, Pname
)),
17893 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
17895 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
17897 if Arg_Count
= 2 then
17898 Append_To
(Pragma_Argument_Associations
(N
),
17899 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
17901 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
17912 -- pragma Predicate
17913 -- ([Entity =>] type_LOCAL_NAME,
17914 -- [Check =>] boolean_EXPRESSION);
17916 when Pragma_Predicate
=> Predicate
: declare
17923 Check_Arg_Count
(2);
17924 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17925 Check_Optional_Identifier
(Arg2
, Name_Check
);
17927 Check_Arg_Is_Local_Name
(Arg1
);
17929 Type_Id
:= Get_Pragma_Arg
(Arg1
);
17930 Find_Type
(Type_Id
);
17931 Typ
:= Entity
(Type_Id
);
17933 if Typ
= Any_Type
then
17937 -- The remaining processing is simply to link the pragma on to
17938 -- the rep item chain, for processing when the type is frozen.
17939 -- This is accomplished by a call to Rep_Item_Too_Late. We also
17940 -- mark the type as having predicates.
17942 Set_Has_Predicates
(Typ
);
17943 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17950 -- pragma Preelaborate [(library_unit_NAME)];
17952 -- Set the flag Is_Preelaborated of program unit name entity
17954 when Pragma_Preelaborate
=> Preelaborate
: declare
17955 Pa
: constant Node_Id
:= Parent
(N
);
17956 Pk
: constant Node_Kind
:= Nkind
(Pa
);
17960 Check_Ada_83_Warning
;
17961 Check_Valid_Library_Unit_Pragma
;
17963 if Nkind
(N
) = N_Null_Statement
then
17967 Ent
:= Find_Lib_Unit_Name
;
17968 Check_Duplicate_Pragma
(Ent
);
17970 -- This filters out pragmas inside generic parents that show up
17971 -- inside instantiations. Pragmas that come from aspects in the
17972 -- unit are not ignored.
17974 if Present
(Ent
) then
17975 if Pk
= N_Package_Specification
17976 and then Present
(Generic_Parent
(Pa
))
17977 and then not From_Aspect_Specification
(N
)
17982 if not Debug_Flag_U
then
17983 Set_Is_Preelaborated
(Ent
);
17984 Set_Suppress_Elaboration_Warnings
(Ent
);
17990 -------------------------------
17991 -- Prefix_Exception_Messages --
17992 -------------------------------
17994 -- pragma Prefix_Exception_Messages;
17996 when Pragma_Prefix_Exception_Messages
=>
17998 Check_Valid_Configuration_Pragma
;
17999 Check_Arg_Count
(0);
18000 Prefix_Exception_Messages
:= True;
18006 -- pragma Priority (EXPRESSION);
18008 when Pragma_Priority
=> Priority
: declare
18009 P
: constant Node_Id
:= Parent
(N
);
18014 Check_No_Identifiers
;
18015 Check_Arg_Count
(1);
18019 if Nkind
(P
) = N_Subprogram_Body
then
18020 Check_In_Main_Program
;
18022 Ent
:= Defining_Unit_Name
(Specification
(P
));
18024 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18025 Ent
:= Defining_Identifier
(Ent
);
18028 Arg
:= Get_Pragma_Arg
(Arg1
);
18029 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18033 if not Is_OK_Static_Expression
(Arg
) then
18034 Flag_Non_Static_Expr
18035 ("main subprogram priority is not static!", Arg
);
18038 -- If constraint error, then we already signalled an error
18040 elsif Raises_Constraint_Error
(Arg
) then
18043 -- Otherwise check in range except if Relaxed_RM_Semantics
18044 -- where we ignore the value if out of range.
18048 Val
: constant Uint
:= Expr_Value
(Arg
);
18050 if not Relaxed_RM_Semantics
18053 or else Val
> Expr_Value
(Expression
18054 (Parent
(RTE
(RE_Max_Priority
)))))
18057 ("main subprogram priority is out of range", Arg1
);
18060 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18065 -- Load an arbitrary entity from System.Tasking.Stages or
18066 -- System.Tasking.Restricted.Stages (depending on the
18067 -- supported profile) to make sure that one of these packages
18068 -- is implicitly with'ed, since we need to have the tasking
18069 -- run time active for the pragma Priority to have any effect.
18070 -- Previously we with'ed the package System.Tasking, but this
18071 -- package does not trigger the required initialization of the
18072 -- run-time library.
18075 Discard
: Entity_Id
;
18076 pragma Warnings
(Off
, Discard
);
18078 if Restricted_Profile
then
18079 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18081 Discard
:= RTE
(RE_Activate_Tasks
);
18085 -- Task or Protected, must be of type Integer
18087 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18088 Arg
:= Get_Pragma_Arg
(Arg1
);
18089 Ent
:= Defining_Identifier
(Parent
(P
));
18091 -- The expression must be analyzed in the special manner
18092 -- described in "Handling of Default and Per-Object
18093 -- Expressions" in sem.ads.
18095 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18097 if not Is_OK_Static_Expression
(Arg
) then
18098 Check_Restriction
(Static_Priorities
, Arg
);
18101 -- Anything else is incorrect
18107 -- Check duplicate pragma before we chain the pragma in the Rep
18108 -- Item chain of Ent.
18110 Check_Duplicate_Pragma
(Ent
);
18111 Record_Rep_Item
(Ent
, N
);
18114 -----------------------------------
18115 -- Priority_Specific_Dispatching --
18116 -----------------------------------
18118 -- pragma Priority_Specific_Dispatching (
18119 -- policy_IDENTIFIER,
18120 -- first_priority_EXPRESSION,
18121 -- last_priority_EXPRESSION);
18123 when Pragma_Priority_Specific_Dispatching
=>
18124 Priority_Specific_Dispatching
: declare
18125 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18126 -- This is the entity System.Any_Priority;
18129 Lower_Bound
: Node_Id
;
18130 Upper_Bound
: Node_Id
;
18136 Check_Arg_Count
(3);
18137 Check_No_Identifiers
;
18138 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18139 Check_Valid_Configuration_Pragma
;
18140 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18141 DP
:= Fold_Upper
(Name_Buffer
(1));
18143 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18144 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18145 Lower_Val
:= Expr_Value
(Lower_Bound
);
18147 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18148 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18149 Upper_Val
:= Expr_Value
(Upper_Bound
);
18151 -- It is not allowed to use Task_Dispatching_Policy and
18152 -- Priority_Specific_Dispatching in the same partition.
18154 if Task_Dispatching_Policy
/= ' ' then
18155 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18157 ("pragma% incompatible with Task_Dispatching_Policy#");
18159 -- Check lower bound in range
18161 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18163 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18166 ("first_priority is out of range", Arg2
);
18168 -- Check upper bound in range
18170 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18172 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18175 ("last_priority is out of range", Arg3
);
18177 -- Check that the priority range is valid
18179 elsif Lower_Val
> Upper_Val
then
18181 ("last_priority_expression must be greater than or equal to "
18182 & "first_priority_expression");
18184 -- Store the new policy, but always preserve System_Location since
18185 -- we like the error message with the run-time name.
18188 -- Check overlapping in the priority ranges specified in other
18189 -- Priority_Specific_Dispatching pragmas within the same
18190 -- partition. We can only check those we know about.
18193 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18195 if Specific_Dispatching
.Table
(J
).First_Priority
in
18196 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18197 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18198 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18201 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18203 ("priority range overlaps with "
18204 & "Priority_Specific_Dispatching#");
18208 -- The use of Priority_Specific_Dispatching is incompatible
18209 -- with Task_Dispatching_Policy.
18211 if Task_Dispatching_Policy
/= ' ' then
18212 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18214 ("Priority_Specific_Dispatching incompatible "
18215 & "with Task_Dispatching_Policy#");
18218 -- The use of Priority_Specific_Dispatching forces ceiling
18221 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18222 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18224 ("Priority_Specific_Dispatching incompatible "
18225 & "with Locking_Policy#");
18227 -- Set the Ceiling_Locking policy, but preserve System_Location
18228 -- since we like the error message with the run time name.
18231 Locking_Policy
:= 'C';
18233 if Locking_Policy_Sloc
/= System_Location
then
18234 Locking_Policy_Sloc
:= Loc
;
18238 -- Add entry in the table
18240 Specific_Dispatching
.Append
18241 ((Dispatching_Policy
=> DP
,
18242 First_Priority
=> UI_To_Int
(Lower_Val
),
18243 Last_Priority
=> UI_To_Int
(Upper_Val
),
18244 Pragma_Loc
=> Loc
));
18246 end Priority_Specific_Dispatching
;
18252 -- pragma Profile (profile_IDENTIFIER);
18254 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18256 when Pragma_Profile
=>
18258 Check_Arg_Count
(1);
18259 Check_Valid_Configuration_Pragma
;
18260 Check_No_Identifiers
;
18263 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18266 if Chars
(Argx
) = Name_Ravenscar
then
18267 Set_Ravenscar_Profile
(N
);
18269 elsif Chars
(Argx
) = Name_Restricted
then
18270 Set_Profile_Restrictions
18272 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18274 elsif Chars
(Argx
) = Name_Rational
then
18275 Set_Rational_Profile
;
18277 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18278 Set_Profile_Restrictions
18279 (No_Implementation_Extensions
,
18280 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18283 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18287 ----------------------
18288 -- Profile_Warnings --
18289 ----------------------
18291 -- pragma Profile_Warnings (profile_IDENTIFIER);
18293 -- profile_IDENTIFIER => Restricted | Ravenscar
18295 when Pragma_Profile_Warnings
=>
18297 Check_Arg_Count
(1);
18298 Check_Valid_Configuration_Pragma
;
18299 Check_No_Identifiers
;
18302 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18305 if Chars
(Argx
) = Name_Ravenscar
then
18306 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18308 elsif Chars
(Argx
) = Name_Restricted
then
18309 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18311 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18312 Set_Profile_Restrictions
18313 (No_Implementation_Extensions
, N
, Warn
=> True);
18316 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18320 --------------------------
18321 -- Propagate_Exceptions --
18322 --------------------------
18324 -- pragma Propagate_Exceptions;
18326 -- Note: this pragma is obsolete and has no effect
18328 when Pragma_Propagate_Exceptions
=>
18330 Check_Arg_Count
(0);
18332 if Warn_On_Obsolescent_Feature
then
18334 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18335 "and has no effect?j?", N
);
18338 -----------------------------
18339 -- Provide_Shift_Operators --
18340 -----------------------------
18342 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18344 when Pragma_Provide_Shift_Operators
=>
18345 Provide_Shift_Operators
: declare
18348 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18349 -- Insert declaration and pragma Instrinsic for named shift op
18351 ----------------------------
18352 -- Declare_Shift_Operator --
18353 ----------------------------
18355 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18361 Make_Subprogram_Declaration
(Loc
,
18362 Make_Function_Specification
(Loc
,
18363 Defining_Unit_Name
=>
18364 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18366 Result_Definition
=>
18367 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18369 Parameter_Specifications
=> New_List
(
18370 Make_Parameter_Specification
(Loc
,
18371 Defining_Identifier
=>
18372 Make_Defining_Identifier
(Loc
, Name_Value
),
18374 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18376 Make_Parameter_Specification
(Loc
,
18377 Defining_Identifier
=>
18378 Make_Defining_Identifier
(Loc
, Name_Amount
),
18380 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18384 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18385 Pragma_Argument_Associations
=> New_List
(
18386 Make_Pragma_Argument_Association
(Loc
,
18387 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18388 Make_Pragma_Argument_Association
(Loc
,
18389 Expression
=> Make_Identifier
(Loc
, Nam
))));
18391 Insert_After
(N
, Import
);
18392 Insert_After
(N
, Func
);
18393 end Declare_Shift_Operator
;
18395 -- Start of processing for Provide_Shift_Operators
18399 Check_Arg_Count
(1);
18400 Check_Arg_Is_Local_Name
(Arg1
);
18402 Arg1
:= Get_Pragma_Arg
(Arg1
);
18404 -- We must have an entity name
18406 if not Is_Entity_Name
(Arg1
) then
18408 ("pragma % must apply to integer first subtype", Arg1
);
18411 -- If no Entity, means there was a prior error so ignore
18413 if Present
(Entity
(Arg1
)) then
18414 Ent
:= Entity
(Arg1
);
18416 -- Apply error checks
18418 if not Is_First_Subtype
(Ent
) then
18420 ("cannot apply pragma %",
18421 "\& is not a first subtype",
18424 elsif not Is_Integer_Type
(Ent
) then
18426 ("cannot apply pragma %",
18427 "\& is not an integer type",
18430 elsif Has_Shift_Operator
(Ent
) then
18432 ("cannot apply pragma %",
18433 "\& already has declared shift operators",
18436 elsif Is_Frozen
(Ent
) then
18438 ("pragma % appears too late",
18439 "\& is already frozen",
18443 -- Now declare the operators. We do this during analysis rather
18444 -- than expansion, since we want the operators available if we
18445 -- are operating in -gnatc or ASIS mode.
18447 Declare_Shift_Operator
(Name_Rotate_Left
);
18448 Declare_Shift_Operator
(Name_Rotate_Right
);
18449 Declare_Shift_Operator
(Name_Shift_Left
);
18450 Declare_Shift_Operator
(Name_Shift_Right
);
18451 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18453 end Provide_Shift_Operators
;
18459 -- pragma Psect_Object (
18460 -- [Internal =>] LOCAL_NAME,
18461 -- [, [External =>] EXTERNAL_SYMBOL]
18462 -- [, [Size =>] EXTERNAL_SYMBOL]);
18464 when Pragma_Psect_Object | Pragma_Common_Object
=>
18465 Psect_Object
: declare
18466 Args
: Args_List
(1 .. 3);
18467 Names
: constant Name_List
(1 .. 3) := (
18472 Internal
: Node_Id
renames Args
(1);
18473 External
: Node_Id
renames Args
(2);
18474 Size
: Node_Id
renames Args
(3);
18476 Def_Id
: Entity_Id
;
18478 procedure Check_Arg
(Arg
: Node_Id
);
18479 -- Checks that argument is either a string literal or an
18480 -- identifier, and posts error message if not.
18486 procedure Check_Arg
(Arg
: Node_Id
) is
18488 if not Nkind_In
(Original_Node
(Arg
),
18493 ("inappropriate argument for pragma %", Arg
);
18497 -- Start of processing for Common_Object/Psect_Object
18501 Gather_Associations
(Names
, Args
);
18502 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18504 Def_Id
:= Entity
(Internal
);
18506 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18508 ("pragma% must designate an object", Internal
);
18511 Check_Arg
(Internal
);
18513 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18515 ("cannot use pragma% for imported/exported object",
18519 if Is_Concurrent_Type
(Etype
(Internal
)) then
18521 ("cannot specify pragma % for task/protected object",
18525 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18527 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18529 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18532 if Ekind
(Def_Id
) = E_Constant
then
18534 ("cannot specify pragma % for a constant", Internal
);
18537 if Is_Record_Type
(Etype
(Internal
)) then
18543 Ent
:= First_Entity
(Etype
(Internal
));
18544 while Present
(Ent
) loop
18545 Decl
:= Declaration_Node
(Ent
);
18547 if Ekind
(Ent
) = E_Component
18548 and then Nkind
(Decl
) = N_Component_Declaration
18549 and then Present
(Expression
(Decl
))
18550 and then Warn_On_Export_Import
18553 ("?x?object for pragma % has defaults", Internal
);
18563 if Present
(Size
) then
18567 if Present
(External
) then
18568 Check_Arg_Is_External_Name
(External
);
18571 -- If all error tests pass, link pragma on to the rep item chain
18573 Record_Rep_Item
(Def_Id
, N
);
18580 -- pragma Pure [(library_unit_NAME)];
18582 when Pragma_Pure
=> Pure
: declare
18586 Check_Ada_83_Warning
;
18587 Check_Valid_Library_Unit_Pragma
;
18589 if Nkind
(N
) = N_Null_Statement
then
18593 Ent
:= Find_Lib_Unit_Name
;
18595 Set_Has_Pragma_Pure
(Ent
);
18596 Set_Suppress_Elaboration_Warnings
(Ent
);
18599 -------------------
18600 -- Pure_Function --
18601 -------------------
18603 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18605 when Pragma_Pure_Function
=> Pure_Function
: declare
18608 Def_Id
: Entity_Id
;
18609 Effective
: Boolean := False;
18613 Check_Arg_Count
(1);
18614 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18615 Check_Arg_Is_Local_Name
(Arg1
);
18616 E_Id
:= Get_Pragma_Arg
(Arg1
);
18618 if Error_Posted
(E_Id
) then
18622 -- Loop through homonyms (overloadings) of referenced entity
18624 E
:= Entity
(E_Id
);
18626 if Present
(E
) then
18628 Def_Id
:= Get_Base_Subprogram
(E
);
18630 if not Ekind_In
(Def_Id
, E_Function
,
18631 E_Generic_Function
,
18635 ("pragma% requires a function name", Arg1
);
18638 Set_Is_Pure
(Def_Id
);
18640 if not Has_Pragma_Pure_Function
(Def_Id
) then
18641 Set_Has_Pragma_Pure_Function
(Def_Id
);
18645 exit when From_Aspect_Specification
(N
);
18647 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18651 and then Warn_On_Redundant_Constructs
18654 ("pragma Pure_Function on& is redundant?r?",
18660 --------------------
18661 -- Queuing_Policy --
18662 --------------------
18664 -- pragma Queuing_Policy (policy_IDENTIFIER);
18666 when Pragma_Queuing_Policy
=> declare
18670 Check_Ada_83_Warning
;
18671 Check_Arg_Count
(1);
18672 Check_No_Identifiers
;
18673 Check_Arg_Is_Queuing_Policy
(Arg1
);
18674 Check_Valid_Configuration_Pragma
;
18675 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18676 QP
:= Fold_Upper
(Name_Buffer
(1));
18678 if Queuing_Policy
/= ' '
18679 and then Queuing_Policy
/= QP
18681 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18682 Error_Pragma
("queuing policy incompatible with policy#");
18684 -- Set new policy, but always preserve System_Location since we
18685 -- like the error message with the run time name.
18688 Queuing_Policy
:= QP
;
18690 if Queuing_Policy_Sloc
/= System_Location
then
18691 Queuing_Policy_Sloc
:= Loc
;
18700 -- pragma Rational, for compatibility with foreign compiler
18702 when Pragma_Rational
=>
18703 Set_Rational_Profile
;
18705 ------------------------------------
18706 -- Refined_Depends/Refined_Global --
18707 ------------------------------------
18709 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18711 -- DEPENDENCY_RELATION ::=
18713 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18715 -- DEPENDENCY_CLAUSE ::=
18716 -- OUTPUT_LIST =>[+] INPUT_LIST
18717 -- | NULL_DEPENDENCY_CLAUSE
18719 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18721 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18723 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18725 -- OUTPUT ::= NAME | FUNCTION_RESULT
18728 -- where FUNCTION_RESULT is a function Result attribute_reference
18730 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18732 -- GLOBAL_SPECIFICATION ::=
18735 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18737 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18739 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18740 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18741 -- GLOBAL_ITEM ::= NAME
18743 when Pragma_Refined_Depends |
18744 Pragma_Refined_Global
=> Refined_Depends_Global
:
18746 Body_Id
: Entity_Id
;
18748 Spec_Id
: Entity_Id
;
18751 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18753 -- Save the pragma in the contract of the subprogram body. The
18754 -- remaining analysis is performed at the end of the enclosing
18758 Add_Contract_Item
(N
, Body_Id
);
18760 end Refined_Depends_Global
;
18766 -- pragma Refined_Post (boolean_EXPRESSION);
18768 when Pragma_Refined_Post
=> Refined_Post
: declare
18769 Body_Id
: Entity_Id
;
18771 Result_Seen
: Boolean := False;
18772 Spec_Id
: Entity_Id
;
18775 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18777 -- Analyze the boolean expression as a "spec expression"
18780 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
18782 -- Verify that the refined postcondition mentions attribute
18783 -- 'Result and its expression introduces a post-state.
18785 if Warn_On_Suspicious_Contract
18786 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
18788 Check_Result_And_Post_State
(N
, Result_Seen
);
18790 if not Result_Seen
then
18792 ("pragma % does not mention function result?T?");
18796 -- Chain the pragma on the contract for easy retrieval
18798 Add_Contract_Item
(N
, Body_Id
);
18802 -------------------
18803 -- Refined_State --
18804 -------------------
18806 -- pragma Refined_State (REFINEMENT_LIST);
18808 -- REFINEMENT_LIST ::=
18809 -- REFINEMENT_CLAUSE
18810 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
18812 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
18814 -- CONSTITUENT_LIST ::=
18817 -- | (CONSTITUENT {, CONSTITUENT})
18819 -- CONSTITUENT ::= object_NAME | state_NAME
18821 when Pragma_Refined_State
=> Refined_State
: declare
18822 Context
: constant Node_Id
:= Parent
(N
);
18823 Spec_Id
: Entity_Id
;
18828 Check_No_Identifiers
;
18829 Check_Arg_Count
(1);
18831 -- Ensure the proper placement of the pragma. Refined states must
18832 -- be associated with a package body.
18834 if Nkind
(Context
) /= N_Package_Body
then
18840 while Present
(Stmt
) loop
18842 -- Skip prior pragmas, but check for duplicates
18844 if Nkind
(Stmt
) = N_Pragma
then
18845 if Pragma_Name
(Stmt
) = Pname
then
18846 Error_Msg_Name_1
:= Pname
;
18847 Error_Msg_Sloc
:= Sloc
(Stmt
);
18848 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
18851 -- Skip internally generated code
18853 elsif not Comes_From_Source
(Stmt
) then
18856 -- The pragma does not apply to a legal construct, issue an
18857 -- error and stop the analysis.
18864 Stmt
:= Prev
(Stmt
);
18867 Spec_Id
:= Corresponding_Spec
(Context
);
18869 -- State refinement is allowed only when the corresponding package
18870 -- declaration has non-null pragma Abstract_State. Refinement not
18871 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
18873 if SPARK_Mode
/= Off
18875 (No
(Abstract_States
(Spec_Id
))
18876 or else Has_Null_Abstract_State
(Spec_Id
))
18879 ("useless refinement, package & does not define abstract "
18880 & "states", N
, Spec_Id
);
18884 -- The pragma must be analyzed at the end of the declarations as
18885 -- it has visibility over the whole declarative region. Save the
18886 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
18887 -- adding it to the contract of the package body.
18889 Add_Contract_Item
(N
, Defining_Entity
(Context
));
18892 -----------------------
18893 -- Relative_Deadline --
18894 -----------------------
18896 -- pragma Relative_Deadline (time_span_EXPRESSION);
18898 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
18899 P
: constant Node_Id
:= Parent
(N
);
18904 Check_No_Identifiers
;
18905 Check_Arg_Count
(1);
18907 Arg
:= Get_Pragma_Arg
(Arg1
);
18909 -- The expression must be analyzed in the special manner described
18910 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
18912 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
18916 if Nkind
(P
) = N_Subprogram_Body
then
18917 Check_In_Main_Program
;
18919 -- Only Task and subprogram cases allowed
18921 elsif Nkind
(P
) /= N_Task_Definition
then
18925 -- Check duplicate pragma before we set the corresponding flag
18927 if Has_Relative_Deadline_Pragma
(P
) then
18928 Error_Pragma
("duplicate pragma% not allowed");
18931 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
18932 -- Relative_Deadline pragma node cannot be inserted in the Rep
18933 -- Item chain of Ent since it is rewritten by the expander as a
18934 -- procedure call statement that will break the chain.
18936 Set_Has_Relative_Deadline_Pragma
(P
, True);
18937 end Relative_Deadline
;
18939 ------------------------
18940 -- Remote_Access_Type --
18941 ------------------------
18943 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
18945 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
18950 Check_Arg_Count
(1);
18951 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18952 Check_Arg_Is_Local_Name
(Arg1
);
18954 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
18956 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
18957 and then Ekind
(E
) = E_General_Access_Type
18958 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
18959 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
18961 and then Is_Valid_Remote_Object_Type
18962 (Root_Type
(Directly_Designated_Type
(E
)))
18964 Set_Is_Remote_Types
(E
);
18968 ("pragma% applies only to formal access to classwide types",
18971 end Remote_Access_Type
;
18973 ---------------------------
18974 -- Remote_Call_Interface --
18975 ---------------------------
18977 -- pragma Remote_Call_Interface [(library_unit_NAME)];
18979 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
18980 Cunit_Node
: Node_Id
;
18981 Cunit_Ent
: Entity_Id
;
18985 Check_Ada_83_Warning
;
18986 Check_Valid_Library_Unit_Pragma
;
18988 if Nkind
(N
) = N_Null_Statement
then
18992 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
18993 K
:= Nkind
(Unit
(Cunit_Node
));
18994 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
18996 if K
= N_Package_Declaration
18997 or else K
= N_Generic_Package_Declaration
18998 or else K
= N_Subprogram_Declaration
18999 or else K
= N_Generic_Subprogram_Declaration
19000 or else (K
= N_Subprogram_Body
19001 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19006 "pragma% must apply to package or subprogram declaration");
19009 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19010 end Remote_Call_Interface
;
19016 -- pragma Remote_Types [(library_unit_NAME)];
19018 when Pragma_Remote_Types
=> Remote_Types
: declare
19019 Cunit_Node
: Node_Id
;
19020 Cunit_Ent
: Entity_Id
;
19023 Check_Ada_83_Warning
;
19024 Check_Valid_Library_Unit_Pragma
;
19026 if Nkind
(N
) = N_Null_Statement
then
19030 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19031 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19033 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19034 N_Generic_Package_Declaration
)
19037 ("pragma% can only apply to a package declaration");
19040 Set_Is_Remote_Types
(Cunit_Ent
);
19047 -- pragma Ravenscar;
19049 when Pragma_Ravenscar
=>
19051 Check_Arg_Count
(0);
19052 Check_Valid_Configuration_Pragma
;
19053 Set_Ravenscar_Profile
(N
);
19055 if Warn_On_Obsolescent_Feature
then
19057 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19059 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19062 -------------------------
19063 -- Restricted_Run_Time --
19064 -------------------------
19066 -- pragma Restricted_Run_Time;
19068 when Pragma_Restricted_Run_Time
=>
19070 Check_Arg_Count
(0);
19071 Check_Valid_Configuration_Pragma
;
19072 Set_Profile_Restrictions
19073 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19075 if Warn_On_Obsolescent_Feature
then
19077 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19080 ("|use pragma Profile (Restricted) instead?j?", N
);
19087 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19090 -- restriction_IDENTIFIER
19091 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19093 when Pragma_Restrictions
=>
19094 Process_Restrictions_Or_Restriction_Warnings
19095 (Warn
=> Treat_Restrictions_As_Warnings
);
19097 --------------------------
19098 -- Restriction_Warnings --
19099 --------------------------
19101 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19104 -- restriction_IDENTIFIER
19105 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19107 when Pragma_Restriction_Warnings
=>
19109 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19115 -- pragma Reviewable;
19117 when Pragma_Reviewable
=>
19118 Check_Ada_83_Warning
;
19119 Check_Arg_Count
(0);
19121 -- Call dummy debugging function rv. This is done to assist front
19122 -- end debugging. By placing a Reviewable pragma in the source
19123 -- program, a breakpoint on rv catches this place in the source,
19124 -- allowing convenient stepping to the point of interest.
19128 --------------------------
19129 -- Short_Circuit_And_Or --
19130 --------------------------
19132 -- pragma Short_Circuit_And_Or;
19134 when Pragma_Short_Circuit_And_Or
=>
19136 Check_Arg_Count
(0);
19137 Check_Valid_Configuration_Pragma
;
19138 Short_Circuit_And_Or
:= True;
19140 -------------------
19141 -- Share_Generic --
19142 -------------------
19144 -- pragma Share_Generic (GNAME {, GNAME});
19146 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19148 when Pragma_Share_Generic
=>
19150 Process_Generic_List
;
19156 -- pragma Shared (LOCAL_NAME);
19158 when Pragma_Shared
=>
19160 Process_Atomic_Shared_Volatile
;
19162 --------------------
19163 -- Shared_Passive --
19164 --------------------
19166 -- pragma Shared_Passive [(library_unit_NAME)];
19168 -- Set the flag Is_Shared_Passive of program unit name entity
19170 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19171 Cunit_Node
: Node_Id
;
19172 Cunit_Ent
: Entity_Id
;
19175 Check_Ada_83_Warning
;
19176 Check_Valid_Library_Unit_Pragma
;
19178 if Nkind
(N
) = N_Null_Statement
then
19182 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19183 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19185 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19186 N_Generic_Package_Declaration
)
19189 ("pragma% can only apply to a package declaration");
19192 Set_Is_Shared_Passive
(Cunit_Ent
);
19193 end Shared_Passive
;
19195 -----------------------
19196 -- Short_Descriptors --
19197 -----------------------
19199 -- pragma Short_Descriptors;
19201 -- Recognize and validate, but otherwise ignore
19203 when Pragma_Short_Descriptors
=>
19205 Check_Arg_Count
(0);
19206 Check_Valid_Configuration_Pragma
;
19208 ------------------------------
19209 -- Simple_Storage_Pool_Type --
19210 ------------------------------
19212 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19214 when Pragma_Simple_Storage_Pool_Type
=>
19215 Simple_Storage_Pool_Type
: declare
19221 Check_Arg_Count
(1);
19222 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19224 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19225 Find_Type
(Type_Id
);
19226 Typ
:= Entity
(Type_Id
);
19228 if Typ
= Any_Type
then
19232 -- We require the pragma to apply to a type declared in a package
19233 -- declaration, but not (immediately) within a package body.
19235 if Ekind
(Current_Scope
) /= E_Package
19236 or else In_Package_Body
(Current_Scope
)
19239 ("pragma% can only apply to type declared immediately "
19240 & "within a package declaration");
19243 -- A simple storage pool type must be an immutably limited record
19244 -- or private type. If the pragma is given for a private type,
19245 -- the full type is similarly restricted (which is checked later
19246 -- in Freeze_Entity).
19248 if Is_Record_Type
(Typ
)
19249 and then not Is_Limited_View
(Typ
)
19252 ("pragma% can only apply to explicitly limited record type");
19254 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19256 ("pragma% can only apply to a private type that is limited");
19258 elsif not Is_Record_Type
(Typ
)
19259 and then not Is_Private_Type
(Typ
)
19262 ("pragma% can only apply to limited record or private type");
19265 Record_Rep_Item
(Typ
, N
);
19266 end Simple_Storage_Pool_Type
;
19268 ----------------------
19269 -- Source_File_Name --
19270 ----------------------
19272 -- There are five forms for this pragma:
19274 -- pragma Source_File_Name (
19275 -- [UNIT_NAME =>] unit_NAME,
19276 -- BODY_FILE_NAME => STRING_LITERAL
19277 -- [, [INDEX =>] INTEGER_LITERAL]);
19279 -- pragma Source_File_Name (
19280 -- [UNIT_NAME =>] unit_NAME,
19281 -- SPEC_FILE_NAME => STRING_LITERAL
19282 -- [, [INDEX =>] INTEGER_LITERAL]);
19284 -- pragma Source_File_Name (
19285 -- BODY_FILE_NAME => STRING_LITERAL
19286 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19287 -- [, CASING => CASING_SPEC]);
19289 -- pragma Source_File_Name (
19290 -- SPEC_FILE_NAME => STRING_LITERAL
19291 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19292 -- [, CASING => CASING_SPEC]);
19294 -- pragma Source_File_Name (
19295 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19296 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19297 -- [, CASING => CASING_SPEC]);
19299 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19301 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19302 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19303 -- only be used when no project file is used, while SFNP can only be
19304 -- used when a project file is used.
19306 -- No processing here. Processing was completed during parsing, since
19307 -- we need to have file names set as early as possible. Units are
19308 -- loaded well before semantic processing starts.
19310 -- The only processing we defer to this point is the check for
19311 -- correct placement.
19313 when Pragma_Source_File_Name
=>
19315 Check_Valid_Configuration_Pragma
;
19317 ------------------------------
19318 -- Source_File_Name_Project --
19319 ------------------------------
19321 -- See Source_File_Name for syntax
19323 -- No processing here. Processing was completed during parsing, since
19324 -- we need to have file names set as early as possible. Units are
19325 -- loaded well before semantic processing starts.
19327 -- The only processing we defer to this point is the check for
19328 -- correct placement.
19330 when Pragma_Source_File_Name_Project
=>
19332 Check_Valid_Configuration_Pragma
;
19334 -- Check that a pragma Source_File_Name_Project is used only in a
19335 -- configuration pragmas file.
19337 -- Pragmas Source_File_Name_Project should only be generated by
19338 -- the Project Manager in configuration pragmas files.
19340 -- This is really an ugly test. It seems to depend on some
19341 -- accidental and undocumented property. At the very least it
19342 -- needs to be documented, but it would be better to have a
19343 -- clean way of testing if we are in a configuration file???
19345 if Present
(Parent
(N
)) then
19347 ("pragma% can only appear in a configuration pragmas file");
19350 ----------------------
19351 -- Source_Reference --
19352 ----------------------
19354 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19356 -- Nothing to do, all processing completed in Par.Prag, since we need
19357 -- the information for possible parser messages that are output.
19359 when Pragma_Source_Reference
=>
19366 -- pragma SPARK_Mode [(On | Off)];
19368 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19369 procedure Check_Pragma_Conformance
19370 (Context_Pragma
: Node_Id
;
19371 Entity_Pragma
: Node_Id
;
19372 Entity
: Entity_Id
);
19373 -- If Context_Pragma is not Empty, verify that the new pragma N
19374 -- is compatible with the pragma Context_Pragma that was inherited
19375 -- from the context:
19376 -- . if Context_Pragma is ON, then the new mode can be anything
19377 -- . if Context_Pragma is OFF, then the only allowed new mode is
19380 -- If Entity is not Empty, verify that the new pragma N is
19381 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19382 -- for Entity (which may be Empty):
19383 -- . if Entity_Pragma is ON, then the new mode can be anything
19384 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19386 -- . if Entity_Pragma is Empty, we always issue an error, as this
19387 -- corresponds to a case where a previous section of Entity
19388 -- had no SPARK_Mode set.
19390 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19391 -- Verify that pragma is applied to library-level entity E
19393 ------------------------------
19394 -- Check_Pragma_Conformance --
19395 ------------------------------
19397 procedure Check_Pragma_Conformance
19398 (Context_Pragma
: Node_Id
;
19399 Entity_Pragma
: Node_Id
;
19400 Entity
: Entity_Id
)
19403 if Present
(Context_Pragma
) then
19404 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19406 -- New mode less restrictive than the established mode
19408 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19409 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19412 ("cannot change SPARK_Mode from Off to On", Arg1
);
19413 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19414 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg1
);
19419 if Present
(Entity
) then
19420 if Present
(Entity_Pragma
) then
19421 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19422 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19424 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19425 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19427 ("\value Off was set for SPARK_Mode on&#",
19433 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19434 Error_Msg_Sloc
:= Sloc
(Entity
);
19436 ("\no value was set for SPARK_Mode on&#",
19441 end Check_Pragma_Conformance
;
19443 --------------------------------
19444 -- Check_Library_Level_Entity --
19445 --------------------------------
19447 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19448 MsgF
: constant String := "incorrect placement of pragma%";
19451 if not Is_Library_Level_Entity
(E
) then
19452 Error_Msg_Name_1
:= Pname
;
19453 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19455 if Ekind_In
(E
, E_Generic_Package
,
19460 ("\& is not a library-level package", N
, E
);
19463 ("\& is not a library-level subprogram", N
, E
);
19468 end Check_Library_Level_Entity
;
19472 Body_Id
: Entity_Id
;
19475 Mode_Id
: SPARK_Mode_Type
;
19476 Spec_Id
: Entity_Id
;
19479 -- Start of processing for Do_SPARK_Mode
19482 -- When a SPARK_Mode pragma appears inside an instantiation whose
19483 -- enclosing context has SPARK_Mode set to "off", the pragma has
19484 -- no semantic effect.
19486 if Ignore_Pragma_SPARK_Mode
then
19487 Rewrite
(N
, Make_Null_Statement
(Loc
));
19493 Check_No_Identifiers
;
19494 Check_At_Most_N_Arguments
(1);
19496 -- Check the legality of the mode (no argument = ON)
19498 if Arg_Count
= 1 then
19499 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19500 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19505 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19506 Context
:= Parent
(N
);
19508 -- The pragma appears in a configuration pragmas file
19510 if No
(Context
) then
19511 Check_Valid_Configuration_Pragma
;
19513 if Present
(SPARK_Mode_Pragma
) then
19514 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19515 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19519 SPARK_Mode_Pragma
:= N
;
19520 SPARK_Mode
:= Mode_Id
;
19522 -- The pragma acts as a configuration pragma in a compilation unit
19524 -- pragma SPARK_Mode ...;
19525 -- package Pack is ...;
19527 elsif Nkind
(Context
) = N_Compilation_Unit
19528 and then List_Containing
(N
) = Context_Items
(Context
)
19530 Check_Valid_Configuration_Pragma
;
19531 SPARK_Mode_Pragma
:= N
;
19532 SPARK_Mode
:= Mode_Id
;
19534 -- Otherwise the placement of the pragma within the tree dictates
19535 -- its associated construct. Inspect the declarative list where
19536 -- the pragma resides to find a potential construct.
19540 while Present
(Stmt
) loop
19542 -- Skip prior pragmas, but check for duplicates
19544 if Nkind
(Stmt
) = N_Pragma
then
19545 if Pragma_Name
(Stmt
) = Pname
then
19546 Error_Msg_Name_1
:= Pname
;
19547 Error_Msg_Sloc
:= Sloc
(Stmt
);
19548 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19552 -- The pragma applies to a [generic] subprogram declaration.
19553 -- Note that this case covers an internally generated spec
19554 -- for a stand alone body.
19557 -- procedure Proc ...;
19558 -- pragma SPARK_Mode ..;
19560 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19561 N_Subprogram_Declaration
)
19563 Spec_Id
:= Defining_Entity
(Stmt
);
19564 Check_Library_Level_Entity
(Spec_Id
);
19565 Check_Pragma_Conformance
19566 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19567 Entity_Pragma
=> Empty
,
19570 Set_SPARK_Pragma
(Spec_Id
, N
);
19571 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19574 -- Skip internally generated code
19576 elsif not Comes_From_Source
(Stmt
) then
19579 -- Otherwise the pragma does not apply to a legal construct
19580 -- or it does not appear at the top of a declarative or a
19581 -- statement list. Issue an error and stop the analysis.
19591 -- The pragma applies to a package or a subprogram that acts as
19592 -- a compilation unit.
19594 -- procedure Proc ...;
19595 -- pragma SPARK_Mode ...;
19597 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19598 Context
:= Unit
(Parent
(Context
));
19601 -- The pragma appears within package declarations
19603 if Nkind
(Context
) = N_Package_Specification
then
19604 Spec_Id
:= Defining_Entity
(Context
);
19605 Check_Library_Level_Entity
(Spec_Id
);
19607 -- The pragma is at the top of the visible declarations
19610 -- pragma SPARK_Mode ...;
19612 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19613 Check_Pragma_Conformance
19614 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19615 Entity_Pragma
=> Empty
,
19617 SPARK_Mode_Pragma
:= N
;
19618 SPARK_Mode
:= Mode_Id
;
19620 Set_SPARK_Pragma
(Spec_Id
, N
);
19621 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19622 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19623 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19625 -- The pragma is at the top of the private declarations
19629 -- pragma SPARK_Mode ...;
19632 Check_Pragma_Conformance
19633 (Context_Pragma
=> Empty
,
19634 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19635 Entity
=> Spec_Id
);
19636 SPARK_Mode_Pragma
:= N
;
19637 SPARK_Mode
:= Mode_Id
;
19639 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19640 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19643 -- The pragma appears at the top of package body declarations
19645 -- package body Pack is
19646 -- pragma SPARK_Mode ...;
19648 elsif Nkind
(Context
) = N_Package_Body
then
19649 Spec_Id
:= Corresponding_Spec
(Context
);
19650 Body_Id
:= Defining_Entity
(Context
);
19651 Check_Library_Level_Entity
(Body_Id
);
19652 Check_Pragma_Conformance
19653 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19654 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19655 Entity
=> Spec_Id
);
19656 SPARK_Mode_Pragma
:= N
;
19657 SPARK_Mode
:= Mode_Id
;
19659 Set_SPARK_Pragma
(Body_Id
, N
);
19660 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19661 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19662 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19664 -- The pragma appears at the top of package body statements
19666 -- package body Pack is
19668 -- pragma SPARK_Mode;
19670 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19671 and then Nkind
(Parent
(Context
)) = N_Package_Body
19673 Context
:= Parent
(Context
);
19674 Spec_Id
:= Corresponding_Spec
(Context
);
19675 Body_Id
:= Defining_Entity
(Context
);
19676 Check_Library_Level_Entity
(Body_Id
);
19677 Check_Pragma_Conformance
19678 (Context_Pragma
=> Empty
,
19679 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19680 Entity
=> Body_Id
);
19681 SPARK_Mode_Pragma
:= N
;
19682 SPARK_Mode
:= Mode_Id
;
19684 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19685 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19687 -- The pragma appeared as an aspect of a [generic] subprogram
19688 -- declaration that acts as a compilation unit.
19691 -- procedure Proc ...;
19692 -- pragma SPARK_Mode ...;
19694 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19695 N_Subprogram_Declaration
)
19697 Spec_Id
:= Defining_Entity
(Context
);
19698 Check_Library_Level_Entity
(Spec_Id
);
19699 Check_Pragma_Conformance
19700 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19701 Entity_Pragma
=> Empty
,
19704 Set_SPARK_Pragma
(Spec_Id
, N
);
19705 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19707 -- The pragma appears at the top of subprogram body
19710 -- procedure Proc ... is
19711 -- pragma SPARK_Mode;
19713 elsif Nkind
(Context
) = N_Subprogram_Body
then
19714 Spec_Id
:= Corresponding_Spec
(Context
);
19715 Context
:= Specification
(Context
);
19716 Body_Id
:= Defining_Entity
(Context
);
19718 -- Ignore pragma when applied to the special body created
19719 -- for inlining, recognized by its internal name _Parent.
19721 if Chars
(Body_Id
) = Name_uParent
then
19725 Check_Library_Level_Entity
(Body_Id
);
19727 -- The body is a completion of a previous declaration
19729 if Present
(Spec_Id
) then
19730 Check_Pragma_Conformance
19731 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19732 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19733 Entity
=> Spec_Id
);
19735 -- The body acts as spec
19738 Check_Pragma_Conformance
19739 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19740 Entity_Pragma
=> Empty
,
19744 SPARK_Mode_Pragma
:= N
;
19745 SPARK_Mode
:= Mode_Id
;
19747 Set_SPARK_Pragma
(Body_Id
, N
);
19748 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19750 -- The pragma does not apply to a legal construct, issue error
19758 --------------------------------
19759 -- Static_Elaboration_Desired --
19760 --------------------------------
19762 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19764 when Pragma_Static_Elaboration_Desired
=>
19766 Check_At_Most_N_Arguments
(1);
19768 if Is_Compilation_Unit
(Current_Scope
)
19769 and then Ekind
(Current_Scope
) = E_Package
19771 Set_Static_Elaboration_Desired
(Current_Scope
, True);
19773 Error_Pragma
("pragma% must apply to a library-level package");
19780 -- pragma Storage_Size (EXPRESSION);
19782 when Pragma_Storage_Size
=> Storage_Size
: declare
19783 P
: constant Node_Id
:= Parent
(N
);
19787 Check_No_Identifiers
;
19788 Check_Arg_Count
(1);
19790 -- The expression must be analyzed in the special manner described
19791 -- in "Handling of Default Expressions" in sem.ads.
19793 Arg
:= Get_Pragma_Arg
(Arg1
);
19794 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
19796 if not Is_OK_Static_Expression
(Arg
) then
19797 Check_Restriction
(Static_Storage_Size
, Arg
);
19800 if Nkind
(P
) /= N_Task_Definition
then
19805 if Has_Storage_Size_Pragma
(P
) then
19806 Error_Pragma
("duplicate pragma% not allowed");
19808 Set_Has_Storage_Size_Pragma
(P
, True);
19811 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
19819 -- pragma Storage_Unit (NUMERIC_LITERAL);
19821 -- Only permitted argument is System'Storage_Unit value
19823 when Pragma_Storage_Unit
=>
19824 Check_No_Identifiers
;
19825 Check_Arg_Count
(1);
19826 Check_Arg_Is_Integer_Literal
(Arg1
);
19828 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
19829 UI_From_Int
(Ttypes
.System_Storage_Unit
)
19831 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
19833 ("the only allowed argument for pragma% is ^", Arg1
);
19836 --------------------
19837 -- Stream_Convert --
19838 --------------------
19840 -- pragma Stream_Convert (
19841 -- [Entity =>] type_LOCAL_NAME,
19842 -- [Read =>] function_NAME,
19843 -- [Write =>] function NAME);
19845 when Pragma_Stream_Convert
=> Stream_Convert
: declare
19847 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
19848 -- Check that the given argument is the name of a local function
19849 -- of one argument that is not overloaded earlier in the current
19850 -- local scope. A check is also made that the argument is a
19851 -- function with one parameter.
19853 --------------------------------------
19854 -- Check_OK_Stream_Convert_Function --
19855 --------------------------------------
19857 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
19861 Check_Arg_Is_Local_Name
(Arg
);
19862 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
19864 if Has_Homonym
(Ent
) then
19866 ("argument for pragma% may not be overloaded", Arg
);
19869 if Ekind
(Ent
) /= E_Function
19870 or else No
(First_Formal
(Ent
))
19871 or else Present
(Next_Formal
(First_Formal
(Ent
)))
19874 ("argument for pragma% must be function of one argument",
19877 end Check_OK_Stream_Convert_Function
;
19879 -- Start of processing for Stream_Convert
19883 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
19884 Check_Arg_Count
(3);
19885 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19886 Check_Optional_Identifier
(Arg2
, Name_Read
);
19887 Check_Optional_Identifier
(Arg3
, Name_Write
);
19888 Check_Arg_Is_Local_Name
(Arg1
);
19889 Check_OK_Stream_Convert_Function
(Arg2
);
19890 Check_OK_Stream_Convert_Function
(Arg3
);
19893 Typ
: constant Entity_Id
:=
19894 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
19895 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
19896 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
19899 Check_First_Subtype
(Arg1
);
19901 -- Check for too early or too late. Note that we don't enforce
19902 -- the rule about primitive operations in this case, since, as
19903 -- is the case for explicit stream attributes themselves, these
19904 -- restrictions are not appropriate. Note that the chaining of
19905 -- the pragma by Rep_Item_Too_Late is actually the critical
19906 -- processing done for this pragma.
19908 if Rep_Item_Too_Early
(Typ
, N
)
19910 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
19915 -- Return if previous error
19917 if Etype
(Typ
) = Any_Type
19919 Etype
(Read
) = Any_Type
19921 Etype
(Write
) = Any_Type
19928 if Underlying_Type
(Etype
(Read
)) /= Typ
then
19930 ("incorrect return type for function&", Arg2
);
19933 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
19935 ("incorrect parameter type for function&", Arg3
);
19938 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
19939 Underlying_Type
(Etype
(Write
))
19942 ("result type of & does not match Read parameter type",
19946 end Stream_Convert
;
19952 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
19954 -- This is processed by the parser since some of the style checks
19955 -- take place during source scanning and parsing. This means that
19956 -- we don't need to issue error messages here.
19958 when Pragma_Style_Checks
=> Style_Checks
: declare
19959 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19965 Check_No_Identifiers
;
19967 -- Two argument form
19969 if Arg_Count
= 2 then
19970 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19977 E_Id
:= Get_Pragma_Arg
(Arg2
);
19980 if not Is_Entity_Name
(E_Id
) then
19982 ("second argument of pragma% must be entity name",
19986 E
:= Entity
(E_Id
);
19988 if not Ignore_Style_Checks_Pragmas
then
19993 Set_Suppress_Style_Checks
19994 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
19995 exit when No
(Homonym
(E
));
20002 -- One argument form
20005 Check_Arg_Count
(1);
20007 if Nkind
(A
) = N_String_Literal
then
20011 Slen
: constant Natural := Natural (String_Length
(S
));
20012 Options
: String (1 .. Slen
);
20018 C
:= Get_String_Char
(S
, Int
(J
));
20019 exit when not In_Character_Range
(C
);
20020 Options
(J
) := Get_Character
(C
);
20022 -- If at end of string, set options. As per discussion
20023 -- above, no need to check for errors, since we issued
20024 -- them in the parser.
20027 if not Ignore_Style_Checks_Pragmas
then
20028 Set_Style_Check_Options
(Options
);
20038 elsif Nkind
(A
) = N_Identifier
then
20039 if Chars
(A
) = Name_All_Checks
then
20040 if not Ignore_Style_Checks_Pragmas
then
20042 Set_GNAT_Style_Check_Options
;
20044 Set_Default_Style_Check_Options
;
20048 elsif Chars
(A
) = Name_On
then
20049 if not Ignore_Style_Checks_Pragmas
then
20050 Style_Check
:= True;
20053 elsif Chars
(A
) = Name_Off
then
20054 if not Ignore_Style_Checks_Pragmas
then
20055 Style_Check
:= False;
20066 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20068 when Pragma_Subtitle
=>
20070 Check_Arg_Count
(1);
20071 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20072 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20079 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20081 when Pragma_Suppress
=>
20082 Process_Suppress_Unsuppress
(True);
20088 -- pragma Suppress_All;
20090 -- The only check made here is that the pragma has no arguments.
20091 -- There are no placement rules, and the processing required (setting
20092 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20093 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20094 -- then creates and inserts a pragma Suppress (All_Checks).
20096 when Pragma_Suppress_All
=>
20098 Check_Arg_Count
(0);
20100 -------------------------
20101 -- Suppress_Debug_Info --
20102 -------------------------
20104 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20106 when Pragma_Suppress_Debug_Info
=>
20108 Check_Arg_Count
(1);
20109 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20110 Check_Arg_Is_Local_Name
(Arg1
);
20111 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20113 ----------------------------------
20114 -- Suppress_Exception_Locations --
20115 ----------------------------------
20117 -- pragma Suppress_Exception_Locations;
20119 when Pragma_Suppress_Exception_Locations
=>
20121 Check_Arg_Count
(0);
20122 Check_Valid_Configuration_Pragma
;
20123 Exception_Locations_Suppressed
:= True;
20125 -----------------------------
20126 -- Suppress_Initialization --
20127 -----------------------------
20129 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20131 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20137 Check_Arg_Count
(1);
20138 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20139 Check_Arg_Is_Local_Name
(Arg1
);
20141 E_Id
:= Get_Pragma_Arg
(Arg1
);
20143 if Etype
(E_Id
) = Any_Type
then
20147 E
:= Entity
(E_Id
);
20149 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20151 ("pragma% requires variable, type or subtype", Arg1
);
20154 if Rep_Item_Too_Early
(E
, N
)
20156 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20161 -- For incomplete/private type, set flag on full view
20163 if Is_Incomplete_Or_Private_Type
(E
) then
20164 if No
(Full_View
(Base_Type
(E
))) then
20166 ("argument of pragma% cannot be an incomplete type", Arg1
);
20168 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20171 -- For first subtype, set flag on base type
20173 elsif Is_First_Subtype
(E
) then
20174 Set_Suppress_Initialization
(Base_Type
(E
));
20176 -- For other than first subtype, set flag on subtype or variable
20179 Set_Suppress_Initialization
(E
);
20187 -- pragma System_Name (DIRECT_NAME);
20189 -- Syntax check: one argument, which must be the identifier GNAT or
20190 -- the identifier GCC, no other identifiers are acceptable.
20192 when Pragma_System_Name
=>
20194 Check_No_Identifiers
;
20195 Check_Arg_Count
(1);
20196 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20198 -----------------------------
20199 -- Task_Dispatching_Policy --
20200 -----------------------------
20202 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20204 when Pragma_Task_Dispatching_Policy
=> declare
20208 Check_Ada_83_Warning
;
20209 Check_Arg_Count
(1);
20210 Check_No_Identifiers
;
20211 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20212 Check_Valid_Configuration_Pragma
;
20213 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20214 DP
:= Fold_Upper
(Name_Buffer
(1));
20216 if Task_Dispatching_Policy
/= ' '
20217 and then Task_Dispatching_Policy
/= DP
20219 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20221 ("task dispatching policy incompatible with policy#");
20223 -- Set new policy, but always preserve System_Location since we
20224 -- like the error message with the run time name.
20227 Task_Dispatching_Policy
:= DP
;
20229 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20230 Task_Dispatching_Policy_Sloc
:= Loc
;
20239 -- pragma Task_Info (EXPRESSION);
20241 when Pragma_Task_Info
=> Task_Info
: declare
20242 P
: constant Node_Id
:= Parent
(N
);
20248 if Warn_On_Obsolescent_Feature
then
20250 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20251 & "instead?j?", N
);
20254 if Nkind
(P
) /= N_Task_Definition
then
20255 Error_Pragma
("pragma% must appear in task definition");
20258 Check_No_Identifiers
;
20259 Check_Arg_Count
(1);
20261 Analyze_And_Resolve
20262 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20264 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20268 Ent
:= Defining_Identifier
(Parent
(P
));
20270 -- Check duplicate pragma before we chain the pragma in the Rep
20271 -- Item chain of Ent.
20274 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20276 Error_Pragma
("duplicate pragma% not allowed");
20279 Record_Rep_Item
(Ent
, N
);
20286 -- pragma Task_Name (string_EXPRESSION);
20288 when Pragma_Task_Name
=> Task_Name
: declare
20289 P
: constant Node_Id
:= Parent
(N
);
20294 Check_No_Identifiers
;
20295 Check_Arg_Count
(1);
20297 Arg
:= Get_Pragma_Arg
(Arg1
);
20299 -- The expression is used in the call to Create_Task, and must be
20300 -- expanded there, not in the context of the current spec. It must
20301 -- however be analyzed to capture global references, in case it
20302 -- appears in a generic context.
20304 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20306 if Nkind
(P
) /= N_Task_Definition
then
20310 Ent
:= Defining_Identifier
(Parent
(P
));
20312 -- Check duplicate pragma before we chain the pragma in the Rep
20313 -- Item chain of Ent.
20316 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20318 Error_Pragma
("duplicate pragma% not allowed");
20321 Record_Rep_Item
(Ent
, N
);
20328 -- pragma Task_Storage (
20329 -- [Task_Type =>] LOCAL_NAME,
20330 -- [Top_Guard =>] static_integer_EXPRESSION);
20332 when Pragma_Task_Storage
=> Task_Storage
: declare
20333 Args
: Args_List
(1 .. 2);
20334 Names
: constant Name_List
(1 .. 2) := (
20338 Task_Type
: Node_Id
renames Args
(1);
20339 Top_Guard
: Node_Id
renames Args
(2);
20345 Gather_Associations
(Names
, Args
);
20347 if No
(Task_Type
) then
20349 ("missing task_type argument for pragma%");
20352 Check_Arg_Is_Local_Name
(Task_Type
);
20354 Ent
:= Entity
(Task_Type
);
20356 if not Is_Task_Type
(Ent
) then
20358 ("argument for pragma% must be task type", Task_Type
);
20361 if No
(Top_Guard
) then
20363 ("pragma% takes two arguments", Task_Type
);
20365 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20368 Check_First_Subtype
(Task_Type
);
20370 if Rep_Item_Too_Late
(Ent
, N
) then
20379 -- pragma Test_Case
20380 -- ([Name =>] Static_String_EXPRESSION
20381 -- ,[Mode =>] MODE_TYPE
20382 -- [, Requires => Boolean_EXPRESSION]
20383 -- [, Ensures => Boolean_EXPRESSION]);
20385 -- MODE_TYPE ::= Nominal | Robustness
20387 when Pragma_Test_Case
=>
20391 --------------------------
20392 -- Thread_Local_Storage --
20393 --------------------------
20395 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20397 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20403 Check_Arg_Count
(1);
20404 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20405 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20407 Id
:= Get_Pragma_Arg
(Arg1
);
20410 if not Is_Entity_Name
(Id
)
20411 or else Ekind
(Entity
(Id
)) /= E_Variable
20413 Error_Pragma_Arg
("local variable name required", Arg1
);
20418 if Rep_Item_Too_Early
(E
, N
)
20419 or else Rep_Item_Too_Late
(E
, N
)
20424 Set_Has_Pragma_Thread_Local_Storage
(E
);
20425 Set_Has_Gigi_Rep_Item
(E
);
20426 end Thread_Local_Storage
;
20432 -- pragma Time_Slice (static_duration_EXPRESSION);
20434 when Pragma_Time_Slice
=> Time_Slice
: declare
20440 Check_Arg_Count
(1);
20441 Check_No_Identifiers
;
20442 Check_In_Main_Program
;
20443 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20445 if not Error_Posted
(Arg1
) then
20447 while Present
(Nod
) loop
20448 if Nkind
(Nod
) = N_Pragma
20449 and then Pragma_Name
(Nod
) = Name_Time_Slice
20451 Error_Msg_Name_1
:= Pname
;
20452 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20459 -- Process only if in main unit
20461 if Get_Source_Unit
(Loc
) = Main_Unit
then
20462 Opt
.Time_Slice_Set
:= True;
20463 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20465 if Val
<= Ureal_0
then
20466 Opt
.Time_Slice_Value
:= 0;
20468 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20469 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20472 Opt
.Time_Slice_Value
:=
20473 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20482 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20484 -- TITLING_OPTION ::=
20485 -- [Title =>] STRING_LITERAL
20486 -- | [Subtitle =>] STRING_LITERAL
20488 when Pragma_Title
=> Title
: declare
20489 Args
: Args_List
(1 .. 2);
20490 Names
: constant Name_List
(1 .. 2) := (
20496 Gather_Associations
(Names
, Args
);
20499 for J
in 1 .. 2 loop
20500 if Present
(Args
(J
)) then
20501 Check_Arg_Is_OK_Static_Expression
20502 (Args
(J
), Standard_String
);
20507 ----------------------------
20508 -- Type_Invariant[_Class] --
20509 ----------------------------
20511 -- pragma Type_Invariant[_Class]
20512 -- ([Entity =>] type_LOCAL_NAME,
20513 -- [Check =>] EXPRESSION);
20515 when Pragma_Type_Invariant |
20516 Pragma_Type_Invariant_Class
=>
20517 Type_Invariant
: declare
20518 I_Pragma
: Node_Id
;
20521 Check_Arg_Count
(2);
20523 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20524 -- setting Class_Present for the Type_Invariant_Class case.
20526 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20527 I_Pragma
:= New_Copy
(N
);
20528 Set_Pragma_Identifier
20529 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20530 Rewrite
(N
, I_Pragma
);
20531 Set_Analyzed
(N
, False);
20533 end Type_Invariant
;
20535 ---------------------
20536 -- Unchecked_Union --
20537 ---------------------
20539 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20541 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20542 Assoc
: constant Node_Id
:= Arg1
;
20543 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20553 Check_No_Identifiers
;
20554 Check_Arg_Count
(1);
20555 Check_Arg_Is_Local_Name
(Arg1
);
20557 Find_Type
(Type_Id
);
20559 Typ
:= Entity
(Type_Id
);
20562 or else Rep_Item_Too_Early
(Typ
, N
)
20566 Typ
:= Underlying_Type
(Typ
);
20569 if Rep_Item_Too_Late
(Typ
, N
) then
20573 Check_First_Subtype
(Arg1
);
20575 -- Note remaining cases are references to a type in the current
20576 -- declarative part. If we find an error, we post the error on
20577 -- the relevant type declaration at an appropriate point.
20579 if not Is_Record_Type
(Typ
) then
20580 Error_Msg_N
("unchecked union must be record type", Typ
);
20583 elsif Is_Tagged_Type
(Typ
) then
20584 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20587 elsif not Has_Discriminants
(Typ
) then
20589 ("unchecked union must have one discriminant", Typ
);
20592 -- Note: in previous versions of GNAT we used to check for limited
20593 -- types and give an error, but in fact the standard does allow
20594 -- Unchecked_Union on limited types, so this check was removed.
20596 -- Similarly, GNAT used to require that all discriminants have
20597 -- default values, but this is not mandated by the RM.
20599 -- Proceed with basic error checks completed
20602 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20603 Clist
:= Component_List
(Tdef
);
20605 -- Check presence of component list and variant part
20607 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20609 ("unchecked union must have variant part", Tdef
);
20613 -- Check components
20615 Comp
:= First
(Component_Items
(Clist
));
20616 while Present
(Comp
) loop
20617 Check_Component
(Comp
, Typ
);
20621 -- Check variant part
20623 Vpart
:= Variant_Part
(Clist
);
20625 Variant
:= First
(Variants
(Vpart
));
20626 while Present
(Variant
) loop
20627 Check_Variant
(Variant
, Typ
);
20632 Set_Is_Unchecked_Union
(Typ
);
20633 Set_Convention
(Typ
, Convention_C
);
20634 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20635 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20636 end Unchecked_Union
;
20638 ------------------------
20639 -- Unimplemented_Unit --
20640 ------------------------
20642 -- pragma Unimplemented_Unit;
20644 -- Note: this only gives an error if we are generating code, or if
20645 -- we are in a generic library unit (where the pragma appears in the
20646 -- body, not in the spec).
20648 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20649 Cunitent
: constant Entity_Id
:=
20650 Cunit_Entity
(Get_Source_Unit
(Loc
));
20651 Ent_Kind
: constant Entity_Kind
:=
20656 Check_Arg_Count
(0);
20658 if Operating_Mode
= Generate_Code
20659 or else Ent_Kind
= E_Generic_Function
20660 or else Ent_Kind
= E_Generic_Procedure
20661 or else Ent_Kind
= E_Generic_Package
20663 Get_Name_String
(Chars
(Cunitent
));
20664 Set_Casing
(Mixed_Case
);
20665 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20666 Write_Str
(" is not supported in this configuration");
20668 raise Unrecoverable_Error
;
20670 end Unimplemented_Unit
;
20672 ------------------------
20673 -- Universal_Aliasing --
20674 ------------------------
20676 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20678 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20683 Check_Arg_Count
(1);
20684 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20685 Check_Arg_Is_Local_Name
(Arg1
);
20686 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20688 if E_Id
= Any_Type
then
20690 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20691 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20694 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20695 Record_Rep_Item
(E_Id
, N
);
20696 end Universal_Alias
;
20698 --------------------
20699 -- Universal_Data --
20700 --------------------
20702 -- pragma Universal_Data [(library_unit_NAME)];
20704 when Pragma_Universal_Data
=>
20707 -- If this is a configuration pragma, then set the universal
20708 -- addressing option, otherwise confirm that the pragma satisfies
20709 -- the requirements of library unit pragma placement and leave it
20710 -- to the GNAAMP back end to detect the pragma (avoids transitive
20711 -- setting of the option due to withed units).
20713 if Is_Configuration_Pragma
then
20714 Universal_Addressing_On_AAMP
:= True;
20716 Check_Valid_Library_Unit_Pragma
;
20719 if not AAMP_On_Target
then
20720 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20727 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20729 when Pragma_Unmodified
=> Unmodified
: declare
20730 Arg_Node
: Node_Id
;
20731 Arg_Expr
: Node_Id
;
20732 Arg_Ent
: Entity_Id
;
20736 Check_At_Least_N_Arguments
(1);
20738 -- Loop through arguments
20741 while Present
(Arg_Node
) loop
20742 Check_No_Identifier
(Arg_Node
);
20744 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
20745 -- in fact generate reference, so that the entity will have a
20746 -- reference, which will inhibit any warnings about it not
20747 -- being referenced, and also properly show up in the ali file
20748 -- as a reference. But this reference is recorded before the
20749 -- Has_Pragma_Unreferenced flag is set, so that no warning is
20750 -- generated for this reference.
20752 Check_Arg_Is_Local_Name
(Arg_Node
);
20753 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20755 if Is_Entity_Name
(Arg_Expr
) then
20756 Arg_Ent
:= Entity
(Arg_Expr
);
20758 if not Is_Assignable
(Arg_Ent
) then
20760 ("pragma% can only be applied to a variable",
20763 Set_Has_Pragma_Unmodified
(Arg_Ent
);
20775 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
20777 -- or when used in a context clause:
20779 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
20781 when Pragma_Unreferenced
=> Unreferenced
: declare
20782 Arg_Node
: Node_Id
;
20783 Arg_Expr
: Node_Id
;
20784 Arg_Ent
: Entity_Id
;
20789 Check_At_Least_N_Arguments
(1);
20791 -- Check case of appearing within context clause
20793 if Is_In_Context_Clause
then
20795 -- The arguments must all be units mentioned in a with clause
20796 -- in the same context clause. Note we already checked (in
20797 -- Par.Prag) that the arguments are either identifiers or
20798 -- selected components.
20801 while Present
(Arg_Node
) loop
20802 Citem
:= First
(List_Containing
(N
));
20803 while Citem
/= N
loop
20804 if Nkind
(Citem
) = N_With_Clause
20806 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
20808 Set_Has_Pragma_Unreferenced
20811 (Library_Unit
(Citem
))));
20813 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
20822 ("argument of pragma% is not withed unit", Arg_Node
);
20828 -- Case of not in list of context items
20832 while Present
(Arg_Node
) loop
20833 Check_No_Identifier
(Arg_Node
);
20835 -- Note: the analyze call done by Check_Arg_Is_Local_Name
20836 -- will in fact generate reference, so that the entity will
20837 -- have a reference, which will inhibit any warnings about
20838 -- it not being referenced, and also properly show up in the
20839 -- ali file as a reference. But this reference is recorded
20840 -- before the Has_Pragma_Unreferenced flag is set, so that
20841 -- no warning is generated for this reference.
20843 Check_Arg_Is_Local_Name
(Arg_Node
);
20844 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20846 if Is_Entity_Name
(Arg_Expr
) then
20847 Arg_Ent
:= Entity
(Arg_Expr
);
20849 -- If the entity is overloaded, the pragma applies to the
20850 -- most recent overloading, as documented. In this case,
20851 -- name resolution does not generate a reference, so it
20852 -- must be done here explicitly.
20854 if Is_Overloaded
(Arg_Expr
) then
20855 Generate_Reference
(Arg_Ent
, N
);
20858 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
20866 --------------------------
20867 -- Unreferenced_Objects --
20868 --------------------------
20870 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
20872 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
20873 Arg_Node
: Node_Id
;
20874 Arg_Expr
: Node_Id
;
20878 Check_At_Least_N_Arguments
(1);
20881 while Present
(Arg_Node
) loop
20882 Check_No_Identifier
(Arg_Node
);
20883 Check_Arg_Is_Local_Name
(Arg_Node
);
20884 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20886 if not Is_Entity_Name
(Arg_Expr
)
20887 or else not Is_Type
(Entity
(Arg_Expr
))
20890 ("argument for pragma% must be type or subtype", Arg_Node
);
20893 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
20896 end Unreferenced_Objects
;
20898 ------------------------------
20899 -- Unreserve_All_Interrupts --
20900 ------------------------------
20902 -- pragma Unreserve_All_Interrupts;
20904 when Pragma_Unreserve_All_Interrupts
=>
20906 Check_Arg_Count
(0);
20908 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
20909 Unreserve_All_Interrupts
:= True;
20916 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
20918 when Pragma_Unsuppress
=>
20920 Process_Suppress_Unsuppress
(False);
20922 ----------------------------
20923 -- Unevaluated_Use_Of_Old --
20924 ----------------------------
20926 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
20928 when Pragma_Unevaluated_Use_Of_Old
=>
20930 Check_Arg_Count
(1);
20931 Check_No_Identifiers
;
20932 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
20934 -- Suppress/Unsuppress can appear as a configuration pragma, or in
20935 -- a declarative part or a package spec.
20937 if not Is_Configuration_Pragma
then
20938 Check_Is_In_Decl_Part_Or_Package_Spec
;
20941 -- Store proper setting of Uneval_Old
20943 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20944 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
20946 -------------------
20947 -- Use_VADS_Size --
20948 -------------------
20950 -- pragma Use_VADS_Size;
20952 when Pragma_Use_VADS_Size
=>
20954 Check_Arg_Count
(0);
20955 Check_Valid_Configuration_Pragma
;
20956 Use_VADS_Size
:= True;
20958 ---------------------
20959 -- Validity_Checks --
20960 ---------------------
20962 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20964 when Pragma_Validity_Checks
=> Validity_Checks
: declare
20965 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20971 Check_Arg_Count
(1);
20972 Check_No_Identifiers
;
20974 -- Pragma always active unless in CodePeer or GNATprove modes,
20975 -- which use a fixed configuration of validity checks.
20977 if not (CodePeer_Mode
or GNATprove_Mode
) then
20978 if Nkind
(A
) = N_String_Literal
then
20982 Slen
: constant Natural := Natural (String_Length
(S
));
20983 Options
: String (1 .. Slen
);
20987 -- Couldn't we use a for loop here over Options'Range???
20991 C
:= Get_String_Char
(S
, Int
(J
));
20993 -- This is a weird test, it skips setting validity
20994 -- checks entirely if any element of S is out of
20995 -- range of Character, what is that about ???
20997 exit when not In_Character_Range
(C
);
20998 Options
(J
) := Get_Character
(C
);
21001 Set_Validity_Check_Options
(Options
);
21009 elsif Nkind
(A
) = N_Identifier
then
21010 if Chars
(A
) = Name_All_Checks
then
21011 Set_Validity_Check_Options
("a");
21012 elsif Chars
(A
) = Name_On
then
21013 Validity_Checks_On
:= True;
21014 elsif Chars
(A
) = Name_Off
then
21015 Validity_Checks_On
:= False;
21019 end Validity_Checks
;
21025 -- pragma Volatile (LOCAL_NAME);
21027 when Pragma_Volatile
=>
21028 Process_Atomic_Shared_Volatile
;
21030 -------------------------
21031 -- Volatile_Components --
21032 -------------------------
21034 -- pragma Volatile_Components (array_LOCAL_NAME);
21036 -- Volatile is handled by the same circuit as Atomic_Components
21038 ----------------------
21039 -- Warning_As_Error --
21040 ----------------------
21042 -- pragma Warning_As_Error (static_string_EXPRESSION);
21044 when Pragma_Warning_As_Error
=>
21046 Check_Arg_Count
(1);
21047 Check_No_Identifiers
;
21048 Check_Valid_Configuration_Pragma
;
21050 if not Is_Static_String_Expression
(Arg1
) then
21052 ("argument of pragma% must be static string expression",
21055 -- OK static string expression
21058 Acquire_Warning_Match_String
(Arg1
);
21059 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21060 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21061 new String'(Name_Buffer (1 .. Name_Len));
21068 -- pragma Warnings (On | Off [,REASON]);
21069 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
21070 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
21071 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
21073 -- REASON ::= Reason => Static_String_Expression
21075 when Pragma_Warnings => Warnings : declare
21076 Reason : String_Id;
21080 Check_At_Least_N_Arguments (1);
21082 -- See if last argument is labeled Reason. If so, make sure we
21083 -- have a static string expression, and acquire the REASON string.
21084 -- Then remove the REASON argument by decreasing Num_Args by one;
21085 -- Remaining processing looks only at first Num_Args arguments).
21088 Last_Arg : constant Node_Id :=
21089 Last (Pragma_Argument_Associations (N));
21092 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21093 and then Chars (Last_Arg) = Name_Reason
21096 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21097 Reason := End_String;
21098 Arg_Count := Arg_Count - 1;
21100 -- Not allowed in compiler units (bootstrap issues)
21102 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21104 -- No REASON string, set null string as reason
21107 Reason := Null_String_Id;
21111 -- Now proceed with REASON taken care of and eliminated
21113 Check_No_Identifiers;
21115 -- If debug flag -gnatd.i is set, pragma is ignored
21117 if Debug_Flag_Dot_I then
21121 -- Process various forms of the pragma
21124 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21127 -- One argument case
21129 if Arg_Count = 1 then
21131 -- On/Off one argument case was processed by parser
21133 if Nkind (Argx) = N_Identifier
21134 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21138 -- One argument case must be ON/OFF or static string expr
21140 elsif not Is_Static_String_Expression (Arg1) then
21142 ("argument of pragma% must be On/Off or static string "
21143 & "expression", Arg1);
21145 -- One argument string expression case
21149 Lit : constant Node_Id := Expr_Value_S (Argx);
21150 Str : constant String_Id := Strval (Lit);
21151 Len : constant Nat := String_Length (Str);
21159 while J <= Len loop
21160 C := Get_String_Char (Str, J);
21161 OK := In_Character_Range (C);
21164 Chr := Get_Character (C);
21166 -- Dash case: only -Wxxx is accepted
21173 C := Get_String_Char (Str, J);
21174 Chr := Get_Character (C);
21175 exit when Chr = 'W
';
21180 elsif J < Len and then Chr = '.' then
21182 C := Get_String_Char (Str, J);
21183 Chr := Get_Character (C);
21185 if not Set_Dot_Warning_Switch (Chr) then
21187 ("invalid warning switch character "
21188 & '.' & Chr, Arg1);
21194 OK := Set_Warning_Switch (Chr);
21200 ("invalid warning switch character " & Chr,
21209 -- Two or more arguments (must be two)
21212 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21213 Check_Arg_Count (2);
21221 E_Id := Get_Pragma_Arg (Arg2);
21224 -- In the expansion of an inlined body, a reference to
21225 -- the formal may be wrapped in a conversion if the
21226 -- actual is a conversion. Retrieve the real entity name.
21228 if (In_Instance_Body or In_Inlined_Body)
21229 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21231 E_Id := Expression (E_Id);
21234 -- Entity name case
21236 if Is_Entity_Name (E_Id) then
21237 E := Entity (E_Id);
21244 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21247 -- For OFF case, make entry in warnings off
21248 -- pragma table for later processing. But we do
21249 -- not do that within an instance, since these
21250 -- warnings are about what is needed in the
21251 -- template, not an instance of it.
21253 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21254 and then Warn_On_Warnings_Off
21255 and then not In_Instance
21257 Warnings_Off_Pragmas.Append ((N, E, Reason));
21260 if Is_Enumeration_Type (E) then
21264 Lit := First_Literal (E);
21265 while Present (Lit) loop
21266 Set_Warnings_Off (Lit);
21267 Next_Literal (Lit);
21272 exit when No (Homonym (E));
21277 -- Error if not entity or static string expression case
21279 elsif not Is_Static_String_Expression (Arg2) then
21281 ("second argument of pragma% must be entity name "
21282 & "or static string expression", Arg2);
21284 -- Static string expression case
21287 Acquire_Warning_Match_String (Arg2);
21289 -- Note on configuration pragma case: If this is a
21290 -- configuration pragma, then for an OFF pragma, we
21291 -- just set Config True in the call, which is all
21292 -- that needs to be done. For the case of ON, this
21293 -- is normally an error, unless it is canceling the
21294 -- effect of a previous OFF pragma in the same file.
21295 -- In any other case, an error will be signalled (ON
21296 -- with no matching OFF).
21298 -- Note: We set Used if we are inside a generic to
21299 -- disable the test that the non-config case actually
21300 -- cancels a warning. That's because we can't be sure
21301 -- there isn't an instantiation in some other unit
21302 -- where a warning is suppressed.
21304 -- We could do a little better here by checking if the
21305 -- generic unit we are inside is public, but for now
21306 -- we don't bother with that refinement.
21308 if Chars (Argx) = Name_Off then
21309 Set_Specific_Warning_Off
21310 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21311 Config => Is_Configuration_Pragma,
21312 Used => Inside_A_Generic or else In_Instance);
21314 elsif Chars (Argx) = Name_On then
21315 Set_Specific_Warning_On
21316 (Loc, Name_Buffer (1 .. Name_Len), Err);
21320 ("??pragma Warnings On with no matching "
21321 & "Warnings Off", Loc);
21330 -------------------
21331 -- Weak_External --
21332 -------------------
21334 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21336 when Pragma_Weak_External => Weak_External : declare
21341 Check_Arg_Count (1);
21342 Check_Optional_Identifier (Arg1, Name_Entity);
21343 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21344 Ent := Entity (Get_Pragma_Arg (Arg1));
21346 if Rep_Item_Too_Early (Ent, N) then
21349 Ent := Underlying_Type (Ent);
21352 -- The only processing required is to link this item on to the
21353 -- list of rep items for the given entity. This is accomplished
21354 -- by the call to Rep_Item_Too_Late (when no error is detected
21355 -- and False is returned).
21357 if Rep_Item_Too_Late (Ent, N) then
21360 Set_Has_Gigi_Rep_Item (Ent);
21364 -----------------------------
21365 -- Wide_Character_Encoding --
21366 -----------------------------
21368 -- pragma Wide_Character_Encoding (IDENTIFIER);
21370 when Pragma_Wide_Character_Encoding =>
21373 -- Nothing to do, handled in parser. Note that we do not enforce
21374 -- configuration pragma placement, this pragma can appear at any
21375 -- place in the source, allowing mixed encodings within a single
21380 --------------------
21381 -- Unknown_Pragma --
21382 --------------------
21384 -- Should be impossible, since the case of an unknown pragma is
21385 -- separately processed before the case statement is entered.
21387 when Unknown_Pragma =>
21388 raise Program_Error;
21391 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21392 -- until AI is formally approved.
21394 -- Check_Order_Dependence;
21397 when Pragma_Exit => null;
21398 end Analyze_Pragma;
21400 ---------------------------------------------
21401 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21402 ---------------------------------------------
21404 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21406 Subp_Id : Entity_Id)
21408 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21409 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21412 Restore_Scope : Boolean := False;
21413 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21416 -- Ensure that the subprogram and its formals are visible when analyzing
21417 -- the expression of the pragma.
21419 if not In_Open_Scopes (Subp_Id) then
21420 Restore_Scope := True;
21421 Push_Scope (Subp_Id);
21422 Install_Formals (Subp_Id);
21425 -- Preanalyze the boolean expression, we treat this as a spec expression
21426 -- (i.e. similar to a default expression).
21428 Expr := Get_Pragma_Arg (Arg1);
21430 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21431 -- the original aspect expression, which is shared with the generated
21434 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21435 Expr := Expression (Corresponding_Aspect (Prag));
21438 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21440 -- For a class-wide condition, a reference to a controlling formal must
21441 -- be interpreted as having the class-wide type (or an access to such)
21442 -- so that the inherited condition can be properly applied to any
21443 -- overriding operation (see ARM12 6.6.1 (7)).
21445 if Class_Present (Prag) then
21446 Class_Wide_Condition : declare
21447 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21449 ACW : Entity_Id := Empty;
21450 -- Access to T'class, created if there is a controlling formal
21451 -- that is an access parameter.
21453 function Get_ACW return Entity_Id;
21454 -- If the expression has a reference to an controlling access
21455 -- parameter, create an access to T'class for the necessary
21456 -- conversions if one does not exist.
21458 function Process (N : Node_Id) return Traverse_Result;
21459 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21460 -- aspect for a primitive subprogram of a tagged type T, a name
21461 -- that denotes a formal parameter of type T is interpreted as
21462 -- having type T'Class. Similarly, a name that denotes a formal
21463 -- accessparameter of type access-to-T is interpreted as having
21464 -- type access-to-T'Class. This ensures the expression is well-
21465 -- defined for a primitive subprogram of a type descended from T.
21466 -- Note that this replacement is not done for selector names in
21467 -- parameter associations. These carry an entity for reference
21468 -- purposes, but semantically they are just identifiers.
21474 function Get_ACW return Entity_Id is
21475 Loc : constant Source_Ptr := Sloc (Prag);
21481 Make_Full_Type_Declaration (Loc,
21482 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21484 Make_Access_To_Object_Definition (Loc,
21485 Subtype_Indication =>
21486 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21487 All_Present => True));
21489 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21491 ACW := Defining_Identifier (Decl);
21492 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21502 function Process (N : Node_Id) return Traverse_Result is
21503 Loc : constant Source_Ptr := Sloc (N);
21507 if Is_Entity_Name (N)
21508 and then Present (Entity (N))
21509 and then Is_Formal (Entity (N))
21510 and then Nkind (Parent (N)) /= N_Type_Conversion
21512 (Nkind (Parent (N)) /= N_Parameter_Association
21513 or else N /= Selector_Name (Parent (N)))
21515 if Etype (Entity (N)) = T then
21516 Typ := Class_Wide_Type (T);
21518 elsif Is_Access_Type (Etype (Entity (N)))
21519 and then Designated_Type (Etype (Entity (N))) = T
21526 if Present (Typ) then
21528 Make_Type_Conversion (Loc,
21530 New_Occurrence_Of (Typ, Loc),
21531 Expression => New_Occurrence_Of (Entity (N), Loc)));
21532 Set_Etype (N, Typ);
21539 procedure Replace_Type is new Traverse_Proc (Process);
21541 -- Start of processing for Class_Wide_Condition
21544 if not Present (T) then
21546 -- Pre'Class/Post'Class aspect cases
21548 if From_Aspect_Specification (Prag) then
21549 if Nam = Name_uPre then
21550 Error_Msg_Name_1 := Name_Pre;
21552 Error_Msg_Name_1 := Name_Post;
21555 Error_Msg_Name_2 := Name_Class;
21558 ("aspect `%''%` can only be specified for a primitive "
21559 & "operation of a tagged type",
21560 Corresponding_Aspect (Prag));
21562 -- Pre_Class, Post_Class pragma cases
21565 if Nam = Name_uPre then
21566 Error_Msg_Name_1 := Name_Pre_Class;
21568 Error_Msg_Name_1 := Name_Post_Class;
21572 ("pragma% can only be specified for a primitive "
21573 & "operation of a tagged type",
21574 Corresponding_Aspect (Prag));
21578 Replace_Type (Get_Pragma_Arg (Arg1));
21579 end Class_Wide_Condition;
21582 -- Remove the subprogram from the scope stack now that the pre-analysis
21583 -- of the precondition/postcondition is done.
21585 if Restore_Scope then
21588 end Analyze_Pre_Post_Condition_In_Decl_Part;
21590 ------------------------------------------
21591 -- Analyze_Refined_Depends_In_Decl_Part --
21592 ------------------------------------------
21594 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21595 Dependencies : List_Id := No_List;
21597 -- The corresponding Depends pragma along with its clauses
21599 Matched_Items : Elist_Id := No_Elist;
21600 -- A list containing the entities of all successfully matched items
21601 -- found in pragma Depends.
21603 Refinements : List_Id := No_List;
21604 -- The clauses of pragma Refined_Depends
21606 Spec_Id : Entity_Id;
21607 -- The entity of the subprogram subject to pragma Refined_Depends
21609 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21610 -- Try to match a single dependency clause Dep_Clause against one or
21611 -- more refinement clauses found in list Refinements. Each successful
21612 -- match eliminates at least one refinement clause from Refinements.
21614 procedure Normalize_Clauses (Clauses : List_Id);
21615 -- Given a list of dependence or refinement clauses Clauses, normalize
21616 -- each clause by creating multiple dependencies with exactly one input
21619 procedure Report_Extra_Clauses;
21620 -- Emit an error for each extra clause found in list Refinements
21622 -----------------------------
21623 -- Check_Dependency_Clause --
21624 -----------------------------
21626 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21627 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21628 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21630 function Is_In_Out_State_Clause return Boolean;
21631 -- Determine whether dependence clause Dep_Clause denotes an abstract
21632 -- state that depends on itself (State => State).
21634 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21635 -- Determine whether item Item denotes an abstract state with visible
21636 -- null refinement.
21638 procedure Match_Items
21639 (Dep_Item : Node_Id;
21640 Ref_Item : Node_Id;
21641 Matched : out Boolean);
21642 -- Try to match dependence item Dep_Item against refinement item
21643 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21644 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21645 -- the following conformance scenarios is in effect:
21646 -- 1) Both items denote null
21647 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21648 -- 3) Both items denote attribute 'Result
21649 -- 4) Both items denote the same formal parameter
21650 -- 5) Both items denote the same variable
21651 -- 6) Dep_Item is an abstract state with visible null refinement
21652 -- and Ref_Item denotes null.
21653 -- 7) Dep_Item is an abstract state with visible null refinement
21654 -- and Ref_Item is Empty (special case).
21655 -- 8) Dep_Item is an abstract state with visible non-null
21656 -- refinement and Ref_Item denotes one of its constituents.
21657 -- 9) Dep_Item is an abstract state without a visible refinement
21658 -- and Ref_Item denotes the same state.
21659 -- When scenario 8 is in effect, the entity of the abstract state
21660 -- denoted by Dep_Item is added to list Refined_States.
21662 procedure Record_Item
(Item_Id
: Entity_Id
);
21663 -- Store the entity of an item denoted by Item_Id in Matched_Items
21665 ----------------------------
21666 -- Is_In_Out_State_Clause --
21667 ----------------------------
21669 function Is_In_Out_State_Clause
return Boolean is
21670 Dep_Input_Id
: Entity_Id
;
21671 Dep_Output_Id
: Entity_Id
;
21674 -- Detect the following clause:
21677 if Is_Entity_Name
(Dep_Input
)
21678 and then Is_Entity_Name
(Dep_Output
)
21680 -- Handle abstract views generated for limited with clauses
21682 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
21683 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
21686 Ekind
(Dep_Input_Id
) = E_Abstract_State
21687 and then Dep_Input_Id
= Dep_Output_Id
;
21691 end Is_In_Out_State_Clause
;
21693 ---------------------------
21694 -- Is_Null_Refined_State --
21695 ---------------------------
21697 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
21698 Item_Id
: Entity_Id
;
21701 if Is_Entity_Name
(Item
) then
21703 -- Handle abstract views generated for limited with clauses
21705 Item_Id
:= Available_View
(Entity_Of
(Item
));
21707 return Ekind
(Item_Id
) = E_Abstract_State
21708 and then Has_Null_Refinement
(Item_Id
);
21713 end Is_Null_Refined_State
;
21719 procedure Match_Items
21720 (Dep_Item
: Node_Id
;
21721 Ref_Item
: Node_Id
;
21722 Matched
: out Boolean)
21724 Dep_Item_Id
: Entity_Id
;
21725 Ref_Item_Id
: Entity_Id
;
21728 -- Assume that the two items do not match
21732 -- A null matches null or Empty (special case)
21734 if Nkind
(Dep_Item
) = N_Null
21735 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21739 -- Attribute 'Result matches attribute 'Result
21741 elsif Is_Attribute_Result
(Dep_Item
)
21742 and then Is_Attribute_Result
(Dep_Item
)
21746 -- Abstract states, formal parameters and variables
21748 elsif Is_Entity_Name
(Dep_Item
) then
21750 -- Handle abstract views generated for limited with clauses
21752 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
21754 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
21756 -- An abstract state with visible null refinement matches
21757 -- null or Empty (special case).
21759 if Has_Null_Refinement
(Dep_Item_Id
)
21760 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21762 Record_Item
(Dep_Item_Id
);
21765 -- An abstract state with visible non-null refinement
21766 -- matches one of its constituents.
21768 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
21769 if Is_Entity_Name
(Ref_Item
) then
21770 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
21772 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
, E_Variable
)
21773 and then Present
(Encapsulating_State
(Ref_Item_Id
))
21774 and then Encapsulating_State
(Ref_Item_Id
) =
21777 Record_Item
(Dep_Item_Id
);
21782 -- An abstract state without a visible refinement matches
21785 elsif Is_Entity_Name
(Ref_Item
)
21786 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
21788 Record_Item
(Dep_Item_Id
);
21792 -- A formal parameter or a variable matches itself
21794 elsif Is_Entity_Name
(Ref_Item
)
21795 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
21797 Record_Item
(Dep_Item_Id
);
21807 procedure Record_Item
(Item_Id
: Entity_Id
) is
21809 if not Contains
(Matched_Items
, Item_Id
) then
21810 Add_Item
(Item_Id
, Matched_Items
);
21816 Clause_Matched
: Boolean := False;
21817 Dummy
: Boolean := False;
21818 Inputs_Match
: Boolean;
21819 Next_Ref_Clause
: Node_Id
;
21820 Outputs_Match
: Boolean;
21821 Ref_Clause
: Node_Id
;
21822 Ref_Input
: Node_Id
;
21823 Ref_Output
: Node_Id
;
21825 -- Start of processing for Check_Dependency_Clause
21828 -- Examine all refinement clauses and compare them against the
21829 -- dependence clause.
21831 Ref_Clause
:= First
(Refinements
);
21832 while Present
(Ref_Clause
) loop
21833 Next_Ref_Clause
:= Next
(Ref_Clause
);
21835 -- Obtain the attributes of the current refinement clause
21837 Ref_Input
:= Expression
(Ref_Clause
);
21838 Ref_Output
:= First
(Choices
(Ref_Clause
));
21840 -- The current refinement clause matches the dependence clause
21841 -- when both outputs match and both inputs match. See routine
21842 -- Match_Items for all possible conformance scenarios.
21844 -- Depends Dep_Output => Dep_Input
21848 -- Refined_Depends Ref_Output => Ref_Input
21851 (Dep_Item
=> Dep_Input
,
21852 Ref_Item
=> Ref_Input
,
21853 Matched
=> Inputs_Match
);
21856 (Dep_Item
=> Dep_Output
,
21857 Ref_Item
=> Ref_Output
,
21858 Matched
=> Outputs_Match
);
21860 -- An In_Out state clause may be matched against a refinement with
21861 -- a null input or null output as long as the non-null side of the
21862 -- relation contains a valid constituent of the In_Out_State.
21864 if Is_In_Out_State_Clause
then
21866 -- Depends => (State => State)
21867 -- Refined_Depends => (null => Constit) -- OK
21870 and then not Outputs_Match
21871 and then Nkind
(Ref_Output
) = N_Null
21873 Outputs_Match
:= True;
21876 -- Depends => (State => State)
21877 -- Refined_Depends => (Constit => null) -- OK
21879 if not Inputs_Match
21880 and then Outputs_Match
21881 and then Nkind
(Ref_Input
) = N_Null
21883 Inputs_Match
:= True;
21887 -- The current refinement clause is legally constructed following
21888 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
21889 -- the pool of candidates. The seach continues because a single
21890 -- dependence clause may have multiple matching refinements.
21892 if Inputs_Match
and then Outputs_Match
then
21893 Clause_Matched
:= True;
21894 Remove
(Ref_Clause
);
21897 Ref_Clause
:= Next_Ref_Clause
;
21900 -- Depending on the order or composition of refinement clauses, an
21901 -- In_Out state clause may not be directly refinable.
21903 -- Depends => ((Output, State) => (Input, State))
21904 -- Refined_State => (State => (Constit_1, Constit_2))
21905 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
21907 -- Matching normalized clause (State => State) fails because there is
21908 -- no direct refinement capable of satisfying this relation. Another
21909 -- similar case arises when clauses (Constit_1 => Input) and (Output
21910 -- => Constit_2) are matched first, leaving no candidates for clause
21911 -- (State => State). Both scenarios are legal as long as one of the
21912 -- previous clauses mentioned a valid constituent of State.
21914 if not Clause_Matched
21915 and then Is_In_Out_State_Clause
21917 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
21919 Clause_Matched
:= True;
21922 -- A clause where the input is an abstract state with visible null
21923 -- refinement is implicitly matched when the output has already been
21924 -- matched in a previous clause.
21926 -- Depends => (Output => State) -- implicitly OK
21927 -- Refined_State => (State => null)
21928 -- Refined_Depends => (Output => ...)
21930 if not Clause_Matched
21931 and then Is_Null_Refined_State
(Dep_Input
)
21932 and then Is_Entity_Name
(Dep_Output
)
21934 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
21936 Clause_Matched
:= True;
21939 -- A clause where the output is an abstract state with visible null
21940 -- refinement is implicitly matched when the input has already been
21941 -- matched in a previous clause.
21943 -- Depends => (State => Input) -- implicitly OK
21944 -- Refined_State => (State => null)
21945 -- Refined_Depends => (... => Input)
21947 if not Clause_Matched
21948 and then Is_Null_Refined_State
(Dep_Output
)
21949 and then Is_Entity_Name
(Dep_Input
)
21951 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
21953 Clause_Matched
:= True;
21956 -- At this point either all refinement clauses have been examined or
21957 -- pragma Refined_Depends contains a solitary null. Only an abstract
21958 -- state with null refinement can possibly match these cases.
21960 -- Depends => (State => null)
21961 -- Refined_State => (State => null)
21962 -- Refined_Depends => null -- OK
21964 if not Clause_Matched
then
21966 (Dep_Item
=> Dep_Input
,
21968 Matched
=> Inputs_Match
);
21971 (Dep_Item
=> Dep_Output
,
21973 Matched
=> Outputs_Match
);
21975 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
21978 -- If the contents of Refined_Depends are legal, then the current
21979 -- dependence clause should be satisfied either by an explicit match
21980 -- or by one of the special cases.
21982 if not Clause_Matched
then
21984 ("dependence clause of subprogram & has no matching refinement "
21985 & "in body", Dep_Clause
, Spec_Id
);
21987 end Check_Dependency_Clause
;
21989 -----------------------
21990 -- Normalize_Clauses --
21991 -----------------------
21993 procedure Normalize_Clauses
(Clauses
: List_Id
) is
21994 procedure Normalize_Inputs
(Clause
: Node_Id
);
21995 -- Normalize clause Clause by creating multiple clauses for each
21996 -- input item of Clause. It is assumed that Clause has exactly one
21997 -- output. The transformation is as follows:
21999 -- Output => (Input_1, Input_2) -- original
22001 -- Output => Input_1 -- normalizations
22002 -- Output => Input_2
22004 ----------------------
22005 -- Normalize_Inputs --
22006 ----------------------
22008 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22009 Inputs
: constant Node_Id
:= Expression
(Clause
);
22010 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22011 Output
: constant List_Id
:= Choices
(Clause
);
22012 Last_Input
: Node_Id
;
22014 New_Clause
: Node_Id
;
22015 Next_Input
: Node_Id
;
22018 -- Normalization is performed only when the original clause has
22019 -- more than one input. Multiple inputs appear as an aggregate.
22021 if Nkind
(Inputs
) = N_Aggregate
then
22022 Last_Input
:= Last
(Expressions
(Inputs
));
22024 -- Create a new clause for each input
22026 Input
:= First
(Expressions
(Inputs
));
22027 while Present
(Input
) loop
22028 Next_Input
:= Next
(Input
);
22030 -- Unhook the current input from the original input list
22031 -- because it will be relocated to a new clause.
22035 -- Special processing for the last input. At this point the
22036 -- original aggregate has been stripped down to one element.
22037 -- Replace the aggregate by the element itself.
22039 if Input
= Last_Input
then
22040 Rewrite
(Inputs
, Input
);
22042 -- Generate a clause of the form:
22047 Make_Component_Association
(Loc
,
22048 Choices
=> New_Copy_List_Tree
(Output
),
22049 Expression
=> Input
);
22051 -- The new clause contains replicated content that has
22052 -- already been analyzed, mark the clause as analyzed.
22054 Set_Analyzed
(New_Clause
);
22055 Insert_After
(Clause
, New_Clause
);
22058 Input
:= Next_Input
;
22061 end Normalize_Inputs
;
22067 -- Start of processing for Normalize_Clauses
22070 Clause
:= First
(Clauses
);
22071 while Present
(Clause
) loop
22072 Normalize_Inputs
(Clause
);
22075 end Normalize_Clauses
;
22077 --------------------------
22078 -- Report_Extra_Clauses --
22079 --------------------------
22081 procedure Report_Extra_Clauses
is
22085 if Present
(Refinements
) then
22086 Clause
:= First
(Refinements
);
22087 while Present
(Clause
) loop
22089 -- Do not complain about a null input refinement, since a null
22090 -- input legitimately matches anything.
22092 if Nkind
(Clause
) /= N_Component_Association
22093 or else Nkind
(Expression
(Clause
)) /= N_Null
22096 ("unmatched or extra clause in dependence refinement",
22103 end Report_Extra_Clauses
;
22107 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22108 Errors
: constant Nat
:= Serious_Errors_Detected
;
22109 Refs
: constant Node_Id
:=
22110 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22114 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22117 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22118 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22120 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22123 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22125 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22126 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22128 if No
(Depends
) then
22130 ("useless refinement, declaration of subprogram & lacks aspect or "
22131 & "pragma Depends", N
, Spec_Id
);
22135 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
22137 -- A null dependency relation renders the refinement useless because it
22138 -- cannot possibly mention abstract states with visible refinement. Note
22139 -- that the inverse is not true as states may be refined to null
22140 -- (SPARK RM 7.2.5(2)).
22142 if Nkind
(Deps
) = N_Null
then
22144 ("useless refinement, subprogram & does not depend on abstract "
22145 & "state with visible refinement", N
, Spec_Id
);
22149 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22150 -- This ensures that the categorization of all refined dependency items
22151 -- is consistent with their role.
22153 Analyze_Depends_In_Decl_Part
(N
);
22155 -- Do not match dependencies against refinements if Refined_Depends is
22156 -- illegal to avoid emitting misleading error. Matching is disabled in
22157 -- ASIS because clauses are not normalized as this is a tree altering
22158 -- activity similar to expansion.
22160 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
22162 -- Multiple dependency clauses appear as component associations of an
22163 -- aggregate. Note that the clauses are copied because the algorithm
22164 -- modifies them and this should not be visible in Depends.
22166 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22167 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22168 Normalize_Clauses
(Dependencies
);
22170 if Nkind
(Refs
) = N_Null
then
22171 Refinements
:= No_List
;
22173 -- Multiple dependency clauses appear as component associations of an
22174 -- aggregate. Note that the clauses are copied because the algorithm
22175 -- modifies them and this should not be visible in Refined_Depends.
22177 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22178 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22179 Normalize_Clauses
(Refinements
);
22182 -- At this point the clauses of pragmas Depends and Refined_Depends
22183 -- have been normalized into simple dependencies between one output
22184 -- and one input. Examine all clauses of pragma Depends looking for
22185 -- matching clauses in pragma Refined_Depends.
22187 Clause
:= First
(Dependencies
);
22188 while Present
(Clause
) loop
22189 Check_Dependency_Clause
(Clause
);
22193 if Serious_Errors_Detected
= Errors
then
22194 Report_Extra_Clauses
;
22197 end Analyze_Refined_Depends_In_Decl_Part
;
22199 -----------------------------------------
22200 -- Analyze_Refined_Global_In_Decl_Part --
22201 -----------------------------------------
22203 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22205 -- The corresponding Global pragma
22207 Has_In_State
: Boolean := False;
22208 Has_In_Out_State
: Boolean := False;
22209 Has_Out_State
: Boolean := False;
22210 Has_Proof_In_State
: Boolean := False;
22211 -- These flags are set when the corresponding Global pragma has a state
22212 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22215 Has_Null_State
: Boolean := False;
22216 -- This flag is set when the corresponding Global pragma has at least
22217 -- one state with a null refinement.
22219 In_Constits
: Elist_Id
:= No_Elist
;
22220 In_Out_Constits
: Elist_Id
:= No_Elist
;
22221 Out_Constits
: Elist_Id
:= No_Elist
;
22222 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22223 -- These lists contain the entities of all Input, In_Out, Output and
22224 -- Proof_In constituents that appear in Refined_Global and participate
22225 -- in state refinement.
22227 In_Items
: Elist_Id
:= No_Elist
;
22228 In_Out_Items
: Elist_Id
:= No_Elist
;
22229 Out_Items
: Elist_Id
:= No_Elist
;
22230 Proof_In_Items
: Elist_Id
:= No_Elist
;
22231 -- These list contain the entities of all Input, In_Out, Output and
22232 -- Proof_In items defined in the corresponding Global pragma.
22234 procedure Check_In_Out_States
;
22235 -- Determine whether the corresponding Global pragma mentions In_Out
22236 -- states with visible refinement and if so, ensure that one of the
22237 -- following completions apply to the constituents of the state:
22238 -- 1) there is at least one constituent of mode In_Out
22239 -- 2) there is at least one Input and one Output constituent
22240 -- 3) not all constituents are present and one of them is of mode
22242 -- This routine may remove elements from In_Constits, In_Out_Constits,
22243 -- Out_Constits and Proof_In_Constits.
22245 procedure Check_Input_States
;
22246 -- Determine whether the corresponding Global pragma mentions Input
22247 -- states with visible refinement and if so, ensure that at least one of
22248 -- its constituents appears as an Input item in Refined_Global.
22249 -- This routine may remove elements from In_Constits, In_Out_Constits,
22250 -- Out_Constits and Proof_In_Constits.
22252 procedure Check_Output_States
;
22253 -- Determine whether the corresponding Global pragma mentions Output
22254 -- states with visible refinement and if so, ensure that all of its
22255 -- constituents appear as Output items in Refined_Global.
22256 -- This routine may remove elements from In_Constits, In_Out_Constits,
22257 -- Out_Constits and Proof_In_Constits.
22259 procedure Check_Proof_In_States
;
22260 -- Determine whether the corresponding Global pragma mentions Proof_In
22261 -- states with visible refinement and if so, ensure that at least one of
22262 -- its constituents appears as a Proof_In item in Refined_Global.
22263 -- This routine may remove elements from In_Constits, In_Out_Constits,
22264 -- Out_Constits and Proof_In_Constits.
22266 procedure Check_Refined_Global_List
22268 Global_Mode
: Name_Id
:= Name_Input
);
22269 -- Verify the legality of a single global list declaration. Global_Mode
22270 -- denotes the current mode in effect.
22272 function Present_Then_Remove
22274 Item
: Entity_Id
) return Boolean;
22275 -- Search List for a particular entity Item. If Item has been found,
22276 -- remove it from List. This routine is used to strip lists In_Constits,
22277 -- In_Out_Constits and Out_Constits of valid constituents.
22279 procedure Report_Extra_Constituents
;
22280 -- Emit an error for each constituent found in lists In_Constits,
22281 -- In_Out_Constits and Out_Constits.
22283 -------------------------
22284 -- Check_In_Out_States --
22285 -------------------------
22287 procedure Check_In_Out_States
is
22288 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22289 -- Determine whether one of the following coverage scenarios is in
22291 -- 1) there is at least one constituent of mode In_Out
22292 -- 2) there is at least one Input and one Output constituent
22293 -- 3) not all constituents are present and one of them is of mode
22295 -- If this is not the case, emit an error.
22297 -----------------------------
22298 -- Check_Constituent_Usage --
22299 -----------------------------
22301 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22302 Constit_Elmt
: Elmt_Id
;
22303 Constit_Id
: Entity_Id
;
22304 Has_Missing
: Boolean := False;
22305 In_Out_Seen
: Boolean := False;
22306 In_Seen
: Boolean := False;
22307 Out_Seen
: Boolean := False;
22310 -- Process all the constituents of the state and note their modes
22311 -- within the global refinement.
22313 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22314 while Present
(Constit_Elmt
) loop
22315 Constit_Id
:= Node
(Constit_Elmt
);
22317 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22320 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22321 In_Out_Seen
:= True;
22323 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22326 -- A Proof_In constituent cannot participate in the completion
22327 -- of an Output state (SPARK RM 7.2.4(5)).
22329 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22330 Error_Msg_Name_1
:= Chars
(State_Id
);
22332 ("constituent & of state % must have mode Input, In_Out "
22333 & "or Output in global refinement",
22337 Has_Missing
:= True;
22340 Next_Elmt
(Constit_Elmt
);
22343 -- A single In_Out constituent is a valid completion
22345 if In_Out_Seen
then
22348 -- A pair of one Input and one Output constituent is a valid
22351 elsif In_Seen
and then Out_Seen
then
22354 -- A single Output constituent is a valid completion only when
22355 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22357 elsif Has_Missing
and then Out_Seen
then
22362 ("global refinement of state & redefines the mode of its "
22363 & "constituents", N
, State_Id
);
22365 end Check_Constituent_Usage
;
22369 Item_Elmt
: Elmt_Id
;
22370 Item_Id
: Entity_Id
;
22372 -- Start of processing for Check_In_Out_States
22375 -- Inspect the In_Out items of the corresponding Global pragma
22376 -- looking for a state with a visible refinement.
22378 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22379 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22380 while Present
(Item_Elmt
) loop
22381 Item_Id
:= Node
(Item_Elmt
);
22383 -- Ensure that one of the three coverage variants is satisfied
22385 if Ekind
(Item_Id
) = E_Abstract_State
22386 and then Has_Non_Null_Refinement
(Item_Id
)
22388 Check_Constituent_Usage
(Item_Id
);
22391 Next_Elmt
(Item_Elmt
);
22394 end Check_In_Out_States
;
22396 ------------------------
22397 -- Check_Input_States --
22398 ------------------------
22400 procedure Check_Input_States
is
22401 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22402 -- Determine whether at least one constituent of state State_Id with
22403 -- visible refinement is used and has mode Input. Ensure that the
22404 -- remaining constituents do not have In_Out, Output or Proof_In
22407 -----------------------------
22408 -- Check_Constituent_Usage --
22409 -----------------------------
22411 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22412 Constit_Elmt
: Elmt_Id
;
22413 Constit_Id
: Entity_Id
;
22414 In_Seen
: Boolean := False;
22417 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22418 while Present
(Constit_Elmt
) loop
22419 Constit_Id
:= Node
(Constit_Elmt
);
22421 -- At least one of the constituents appears as an Input
22423 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22426 -- The constituent appears in the global refinement, but has
22427 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22429 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22430 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22431 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22433 Error_Msg_Name_1
:= Chars
(State_Id
);
22435 ("constituent & of state % must have mode Input in global "
22436 & "refinement", N
, Constit_Id
);
22439 Next_Elmt
(Constit_Elmt
);
22442 -- Not one of the constituents appeared as Input
22444 if not In_Seen
then
22446 ("global refinement of state & must include at least one "
22447 & "constituent of mode Input", N
, State_Id
);
22449 end Check_Constituent_Usage
;
22453 Item_Elmt
: Elmt_Id
;
22454 Item_Id
: Entity_Id
;
22456 -- Start of processing for Check_Input_States
22459 -- Inspect the Input items of the corresponding Global pragma
22460 -- looking for a state with a visible refinement.
22462 if Has_In_State
and then Present
(In_Items
) then
22463 Item_Elmt
:= First_Elmt
(In_Items
);
22464 while Present
(Item_Elmt
) loop
22465 Item_Id
:= Node
(Item_Elmt
);
22467 -- Ensure that at least one of the constituents is utilized and
22468 -- is of mode Input.
22470 if Ekind
(Item_Id
) = E_Abstract_State
22471 and then Has_Non_Null_Refinement
(Item_Id
)
22473 Check_Constituent_Usage
(Item_Id
);
22476 Next_Elmt
(Item_Elmt
);
22479 end Check_Input_States
;
22481 -------------------------
22482 -- Check_Output_States --
22483 -------------------------
22485 procedure Check_Output_States
is
22486 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22487 -- Determine whether all constituents of state State_Id with visible
22488 -- refinement are used and have mode Output. Emit an error if this is
22491 -----------------------------
22492 -- Check_Constituent_Usage --
22493 -----------------------------
22495 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22496 Constit_Elmt
: Elmt_Id
;
22497 Constit_Id
: Entity_Id
;
22498 Posted
: Boolean := False;
22501 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22502 while Present
(Constit_Elmt
) loop
22503 Constit_Id
:= Node
(Constit_Elmt
);
22505 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22508 -- The constituent appears in the global refinement, but has
22509 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22511 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22512 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22513 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22515 Error_Msg_Name_1
:= Chars
(State_Id
);
22517 ("constituent & of state % must have mode Output in "
22518 & "global refinement", N
, Constit_Id
);
22520 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22526 ("output state & must be replaced by all its "
22527 & "constituents in global refinement", N
, State_Id
);
22531 ("\constituent & is missing in output list",
22535 Next_Elmt
(Constit_Elmt
);
22537 end Check_Constituent_Usage
;
22541 Item_Elmt
: Elmt_Id
;
22542 Item_Id
: Entity_Id
;
22544 -- Start of processing for Check_Output_States
22547 -- Inspect the Output items of the corresponding Global pragma
22548 -- looking for a state with a visible refinement.
22550 if Has_Out_State
and then Present
(Out_Items
) then
22551 Item_Elmt
:= First_Elmt
(Out_Items
);
22552 while Present
(Item_Elmt
) loop
22553 Item_Id
:= Node
(Item_Elmt
);
22555 -- Ensure that all of the constituents are utilized and they
22556 -- have mode Output.
22558 if Ekind
(Item_Id
) = E_Abstract_State
22559 and then Has_Non_Null_Refinement
(Item_Id
)
22561 Check_Constituent_Usage
(Item_Id
);
22564 Next_Elmt
(Item_Elmt
);
22567 end Check_Output_States
;
22569 ---------------------------
22570 -- Check_Proof_In_States --
22571 ---------------------------
22573 procedure Check_Proof_In_States
is
22574 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22575 -- Determine whether at least one constituent of state State_Id with
22576 -- visible refinement is used and has mode Proof_In. Ensure that the
22577 -- remaining constituents do not have Input, In_Out or Output modes.
22579 -----------------------------
22580 -- Check_Constituent_Usage --
22581 -----------------------------
22583 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22584 Constit_Elmt
: Elmt_Id
;
22585 Constit_Id
: Entity_Id
;
22586 Proof_In_Seen
: Boolean := False;
22589 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22590 while Present
(Constit_Elmt
) loop
22591 Constit_Id
:= Node
(Constit_Elmt
);
22593 -- At least one of the constituents appears as Proof_In
22595 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22596 Proof_In_Seen
:= True;
22598 -- The constituent appears in the global refinement, but has
22599 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
22601 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22602 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22603 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22605 Error_Msg_Name_1
:= Chars
(State_Id
);
22607 ("constituent & of state % must have mode Proof_In in "
22608 & "global refinement", N
, Constit_Id
);
22611 Next_Elmt
(Constit_Elmt
);
22614 -- Not one of the constituents appeared as Proof_In
22616 if not Proof_In_Seen
then
22618 ("global refinement of state & must include at least one "
22619 & "constituent of mode Proof_In", N
, State_Id
);
22621 end Check_Constituent_Usage
;
22625 Item_Elmt
: Elmt_Id
;
22626 Item_Id
: Entity_Id
;
22628 -- Start of processing for Check_Proof_In_States
22631 -- Inspect the Proof_In items of the corresponding Global pragma
22632 -- looking for a state with a visible refinement.
22634 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
22635 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
22636 while Present
(Item_Elmt
) loop
22637 Item_Id
:= Node
(Item_Elmt
);
22639 -- Ensure that at least one of the constituents is utilized and
22640 -- is of mode Proof_In
22642 if Ekind
(Item_Id
) = E_Abstract_State
22643 and then Has_Non_Null_Refinement
(Item_Id
)
22645 Check_Constituent_Usage
(Item_Id
);
22648 Next_Elmt
(Item_Elmt
);
22651 end Check_Proof_In_States
;
22653 -------------------------------
22654 -- Check_Refined_Global_List --
22655 -------------------------------
22657 procedure Check_Refined_Global_List
22659 Global_Mode
: Name_Id
:= Name_Input
)
22661 procedure Check_Refined_Global_Item
22663 Global_Mode
: Name_Id
);
22664 -- Verify the legality of a single global item declaration. Parameter
22665 -- Global_Mode denotes the current mode in effect.
22667 -------------------------------
22668 -- Check_Refined_Global_Item --
22669 -------------------------------
22671 procedure Check_Refined_Global_Item
22673 Global_Mode
: Name_Id
)
22675 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
22677 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
22678 -- Issue a common error message for all mode mismatches. Expect
22679 -- denotes the expected mode.
22681 -----------------------------
22682 -- Inconsistent_Mode_Error --
22683 -----------------------------
22685 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
22688 ("global item & has inconsistent modes", Item
, Item_Id
);
22690 Error_Msg_Name_1
:= Global_Mode
;
22691 Error_Msg_Name_2
:= Expect
;
22692 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
22693 end Inconsistent_Mode_Error
;
22695 -- Start of processing for Check_Refined_Global_Item
22698 -- When the state or variable acts as a constituent of another
22699 -- state with a visible refinement, collect it for the state
22700 -- completeness checks performed later on.
22702 if Present
(Encapsulating_State
(Item_Id
))
22703 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
22705 if Global_Mode
= Name_Input
then
22706 Add_Item
(Item_Id
, In_Constits
);
22708 elsif Global_Mode
= Name_In_Out
then
22709 Add_Item
(Item_Id
, In_Out_Constits
);
22711 elsif Global_Mode
= Name_Output
then
22712 Add_Item
(Item_Id
, Out_Constits
);
22714 elsif Global_Mode
= Name_Proof_In
then
22715 Add_Item
(Item_Id
, Proof_In_Constits
);
22718 -- When not a constituent, ensure that both occurrences of the
22719 -- item in pragmas Global and Refined_Global match.
22721 elsif Contains
(In_Items
, Item_Id
) then
22722 if Global_Mode
/= Name_Input
then
22723 Inconsistent_Mode_Error
(Name_Input
);
22726 elsif Contains
(In_Out_Items
, Item_Id
) then
22727 if Global_Mode
/= Name_In_Out
then
22728 Inconsistent_Mode_Error
(Name_In_Out
);
22731 elsif Contains
(Out_Items
, Item_Id
) then
22732 if Global_Mode
/= Name_Output
then
22733 Inconsistent_Mode_Error
(Name_Output
);
22736 elsif Contains
(Proof_In_Items
, Item_Id
) then
22739 -- The item does not appear in the corresponding Global pragma,
22740 -- it must be an extra (SPARK RM 7.2.4(3)).
22743 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
22745 end Check_Refined_Global_Item
;
22751 -- Start of processing for Check_Refined_Global_List
22754 if Nkind
(List
) = N_Null
then
22757 -- Single global item declaration
22759 elsif Nkind_In
(List
, N_Expanded_Name
,
22761 N_Selected_Component
)
22763 Check_Refined_Global_Item
(List
, Global_Mode
);
22765 -- Simple global list or moded global list declaration
22767 elsif Nkind
(List
) = N_Aggregate
then
22769 -- The declaration of a simple global list appear as a collection
22772 if Present
(Expressions
(List
)) then
22773 Item
:= First
(Expressions
(List
));
22774 while Present
(Item
) loop
22775 Check_Refined_Global_Item
(Item
, Global_Mode
);
22780 -- The declaration of a moded global list appears as a collection
22781 -- of component associations where individual choices denote
22784 elsif Present
(Component_Associations
(List
)) then
22785 Item
:= First
(Component_Associations
(List
));
22786 while Present
(Item
) loop
22787 Check_Refined_Global_List
22788 (List
=> Expression
(Item
),
22789 Global_Mode
=> Chars
(First
(Choices
(Item
))));
22797 raise Program_Error
;
22803 raise Program_Error
;
22805 end Check_Refined_Global_List
;
22807 -------------------------
22808 -- Present_Then_Remove --
22809 -------------------------
22811 function Present_Then_Remove
22813 Item
: Entity_Id
) return Boolean
22818 if Present
(List
) then
22819 Elmt
:= First_Elmt
(List
);
22820 while Present
(Elmt
) loop
22821 if Node
(Elmt
) = Item
then
22822 Remove_Elmt
(List
, Elmt
);
22831 end Present_Then_Remove
;
22833 -------------------------------
22834 -- Report_Extra_Constituents --
22835 -------------------------------
22837 procedure Report_Extra_Constituents
is
22838 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
22839 -- Emit an error for every element of List
22841 ---------------------------------------
22842 -- Report_Extra_Constituents_In_List --
22843 ---------------------------------------
22845 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
22846 Constit_Elmt
: Elmt_Id
;
22849 if Present
(List
) then
22850 Constit_Elmt
:= First_Elmt
(List
);
22851 while Present
(Constit_Elmt
) loop
22852 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
22853 Next_Elmt
(Constit_Elmt
);
22856 end Report_Extra_Constituents_In_List
;
22858 -- Start of processing for Report_Extra_Constituents
22861 Report_Extra_Constituents_In_List
(In_Constits
);
22862 Report_Extra_Constituents_In_List
(In_Out_Constits
);
22863 Report_Extra_Constituents_In_List
(Out_Constits
);
22864 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
22865 end Report_Extra_Constituents
;
22869 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22870 Errors
: constant Nat
:= Serious_Errors_Detected
;
22871 Items
: constant Node_Id
:=
22872 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22873 Spec_Id
: Entity_Id
;
22875 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
22878 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22879 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22881 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22884 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
22886 -- The subprogram declaration lacks pragma Global. This renders
22887 -- Refined_Global useless as there is nothing to refine.
22889 if No
(Global
) then
22891 ("useless refinement, declaration of subprogram & lacks aspect or "
22892 & "pragma Global", N
, Spec_Id
);
22896 -- Extract all relevant items from the corresponding Global pragma
22898 Collect_Global_Items
22900 In_Items
=> In_Items
,
22901 In_Out_Items
=> In_Out_Items
,
22902 Out_Items
=> Out_Items
,
22903 Proof_In_Items
=> Proof_In_Items
,
22904 Has_In_State
=> Has_In_State
,
22905 Has_In_Out_State
=> Has_In_Out_State
,
22906 Has_Out_State
=> Has_Out_State
,
22907 Has_Proof_In_State
=> Has_Proof_In_State
,
22908 Has_Null_State
=> Has_Null_State
);
22910 -- Corresponding Global pragma must mention at least one state witha
22911 -- visible refinement at the point Refined_Global is processed. States
22912 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
22914 if not Has_In_State
22915 and then not Has_In_Out_State
22916 and then not Has_Out_State
22917 and then not Has_Proof_In_State
22918 and then not Has_Null_State
22921 ("useless refinement, subprogram & does not depend on abstract "
22922 & "state with visible refinement", N
, Spec_Id
);
22926 -- The global refinement of inputs and outputs cannot be null when the
22927 -- corresponding Global pragma contains at least one item except in the
22928 -- case where we have states with null refinements.
22930 if Nkind
(Items
) = N_Null
22932 (Present
(In_Items
)
22933 or else Present
(In_Out_Items
)
22934 or else Present
(Out_Items
)
22935 or else Present
(Proof_In_Items
))
22936 and then not Has_Null_State
22939 ("refinement cannot be null, subprogram & has global items",
22944 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
22945 -- This ensures that the categorization of all refined global items is
22946 -- consistent with their role.
22948 Analyze_Global_In_Decl_Part
(N
);
22950 -- Perform all refinement checks with respect to completeness and mode
22953 if Serious_Errors_Detected
= Errors
then
22954 Check_Refined_Global_List
(Items
);
22957 -- For Input states with visible refinement, at least one constituent
22958 -- must be used as an Input in the global refinement.
22960 if Serious_Errors_Detected
= Errors
then
22961 Check_Input_States
;
22964 -- Verify all possible completion variants for In_Out states with
22965 -- visible refinement.
22967 if Serious_Errors_Detected
= Errors
then
22968 Check_In_Out_States
;
22971 -- For Output states with visible refinement, all constituents must be
22972 -- used as Outputs in the global refinement.
22974 if Serious_Errors_Detected
= Errors
then
22975 Check_Output_States
;
22978 -- For Proof_In states with visible refinement, at least one constituent
22979 -- must be used as Proof_In in the global refinement.
22981 if Serious_Errors_Detected
= Errors
then
22982 Check_Proof_In_States
;
22985 -- Emit errors for all constituents that belong to other states with
22986 -- visible refinement that do not appear in Global.
22988 if Serious_Errors_Detected
= Errors
then
22989 Report_Extra_Constituents
;
22991 end Analyze_Refined_Global_In_Decl_Part
;
22993 ----------------------------------------
22994 -- Analyze_Refined_State_In_Decl_Part --
22995 ----------------------------------------
22997 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
22998 Available_States
: Elist_Id
:= No_Elist
;
22999 -- A list of all abstract states defined in the package declaration that
23000 -- are available for refinement. The list is used to report unrefined
23003 Body_Id
: Entity_Id
;
23004 -- The body entity of the package subject to pragma Refined_State
23006 Body_States
: Elist_Id
:= No_Elist
;
23007 -- A list of all hidden states that appear in the body of the related
23008 -- package. The list is used to report unused hidden states.
23010 Constituents_Seen
: Elist_Id
:= No_Elist
;
23011 -- A list that contains all constituents processed so far. The list is
23012 -- used to detect multiple uses of the same constituent.
23014 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23015 -- A list that contains all refined states processed so far. The list is
23016 -- used to detect duplicate refinements.
23018 Spec_Id
: Entity_Id
;
23019 -- The spec entity of the package subject to pragma Refined_State
23021 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23022 -- Perform full analysis of a single refinement clause
23024 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23025 -- Gather the entities of all abstract states and variables declared in
23026 -- the body state space of package Pack_Id.
23028 procedure Report_Unrefined_States
(States
: Elist_Id
);
23029 -- Emit errors for all unrefined abstract states found in list States
23031 procedure Report_Unused_States
(States
: Elist_Id
);
23032 -- Emit errors for all unused states found in list States
23034 -------------------------------
23035 -- Analyze_Refinement_Clause --
23036 -------------------------------
23038 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23039 AR_Constit
: Entity_Id
:= Empty
;
23040 AW_Constit
: Entity_Id
:= Empty
;
23041 ER_Constit
: Entity_Id
:= Empty
;
23042 EW_Constit
: Entity_Id
:= Empty
;
23043 -- The entities of external constituents that contain one of the
23044 -- following enabled properties: Async_Readers, Async_Writers,
23045 -- Effective_Reads and Effective_Writes.
23047 External_Constit_Seen
: Boolean := False;
23048 -- Flag used to mark when at least one external constituent is part
23049 -- of the state refinement.
23051 Non_Null_Seen
: Boolean := False;
23052 Null_Seen
: Boolean := False;
23053 -- Flags used to detect multiple uses of null in a single clause or a
23054 -- mixture of null and non-null constituents.
23056 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23057 -- A list of all candidate constituents subject to indicator Part_Of
23058 -- where the encapsulating state is the current state.
23061 State_Id
: Entity_Id
;
23062 -- The current state being refined
23064 procedure Analyze_Constituent
(Constit
: Node_Id
);
23065 -- Perform full analysis of a single constituent
23067 procedure Check_External_Property
23068 (Prop_Nam
: Name_Id
;
23070 Constit
: Entity_Id
);
23071 -- Determine whether a property denoted by name Prop_Nam is present
23072 -- in both the refined state and constituent Constit. Flag Enabled
23073 -- should be set when the property applies to the refined state. If
23074 -- this is not the case, emit an error message.
23076 procedure Check_Matching_State
;
23077 -- Determine whether the state being refined appears in list
23078 -- Available_States. Emit an error when attempting to re-refine the
23079 -- state or when the state is not defined in the package declaration,
23080 -- otherwise remove the state from Available_States.
23082 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23083 -- Emit errors for all unused Part_Of constituents in list Constits
23085 -------------------------
23086 -- Analyze_Constituent --
23087 -------------------------
23089 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23090 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23091 -- Determine whether constituent Constit denoted by its entity
23092 -- Constit_Id appears in Hidden_States. Emit an error when the
23093 -- constituent is not a valid hidden state of the related package
23094 -- or when it is used more than once. Otherwise remove the
23095 -- constituent from Hidden_States.
23097 --------------------------------
23098 -- Check_Matching_Constituent --
23099 --------------------------------
23101 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23102 procedure Collect_Constituent
;
23103 -- Add constituent Constit_Id to the refinements of State_Id
23105 -------------------------
23106 -- Collect_Constituent --
23107 -------------------------
23109 procedure Collect_Constituent
is
23111 -- Add the constituent to the list of processed items to aid
23112 -- with the detection of duplicates.
23114 Add_Item
(Constit_Id
, Constituents_Seen
);
23116 -- Collect the constituent in the list of refinement items
23117 -- and establish a relation between the refined state and
23120 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23121 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23123 -- The state has at least one legal constituent, mark the
23124 -- start of the refinement region. The region ends when the
23125 -- body declarations end (see routine Analyze_Declarations).
23127 Set_Has_Visible_Refinement
(State_Id
);
23129 -- When the constituent is external, save its relevant
23130 -- property for further checks.
23132 if Async_Readers_Enabled
(Constit_Id
) then
23133 AR_Constit
:= Constit_Id
;
23134 External_Constit_Seen
:= True;
23137 if Async_Writers_Enabled
(Constit_Id
) then
23138 AW_Constit
:= Constit_Id
;
23139 External_Constit_Seen
:= True;
23142 if Effective_Reads_Enabled
(Constit_Id
) then
23143 ER_Constit
:= Constit_Id
;
23144 External_Constit_Seen
:= True;
23147 if Effective_Writes_Enabled
(Constit_Id
) then
23148 EW_Constit
:= Constit_Id
;
23149 External_Constit_Seen
:= True;
23151 end Collect_Constituent
;
23155 State_Elmt
: Elmt_Id
;
23157 -- Start of processing for Check_Matching_Constituent
23160 -- Detect a duplicate use of a constituent
23162 if Contains
(Constituents_Seen
, Constit_Id
) then
23164 ("duplicate use of constituent &", Constit
, Constit_Id
);
23168 -- The constituent is subject to a Part_Of indicator
23170 if Present
(Encapsulating_State
(Constit_Id
)) then
23171 if Encapsulating_State
(Constit_Id
) = State_Id
then
23172 Remove
(Part_Of_Constits
, Constit_Id
);
23173 Collect_Constituent
;
23175 -- The constituent is part of another state and is used
23176 -- incorrectly in the refinement of the current state.
23179 Error_Msg_Name_1
:= Chars
(State_Id
);
23181 ("& cannot act as constituent of state %",
23182 Constit
, Constit_Id
);
23184 ("\Part_Of indicator specifies & as encapsulating "
23185 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23188 -- The only other source of legal constituents is the body
23189 -- state space of the related package.
23192 if Present
(Body_States
) then
23193 State_Elmt
:= First_Elmt
(Body_States
);
23194 while Present
(State_Elmt
) loop
23196 -- Consume a valid constituent to signal that it has
23197 -- been encountered.
23199 if Node
(State_Elmt
) = Constit_Id
then
23200 Remove_Elmt
(Body_States
, State_Elmt
);
23201 Collect_Constituent
;
23205 Next_Elmt
(State_Elmt
);
23209 -- If we get here, then the constituent is not a hidden
23210 -- state of the related package and may not be used in a
23211 -- refinement (SPARK RM 7.2.2(9)).
23213 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23215 ("cannot use & in refinement, constituent is not a hidden "
23216 & "state of package %", Constit
, Constit_Id
);
23218 end Check_Matching_Constituent
;
23222 Constit_Id
: Entity_Id
;
23224 -- Start of processing for Analyze_Constituent
23227 -- Detect multiple uses of null in a single refinement clause or a
23228 -- mixture of null and non-null constituents.
23230 if Nkind
(Constit
) = N_Null
then
23233 ("multiple null constituents not allowed", Constit
);
23235 elsif Non_Null_Seen
then
23237 ("cannot mix null and non-null constituents", Constit
);
23242 -- Collect the constituent in the list of refinement items
23244 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23246 -- The state has at least one legal constituent, mark the
23247 -- start of the refinement region. The region ends when the
23248 -- body declarations end (see Analyze_Declarations).
23250 Set_Has_Visible_Refinement
(State_Id
);
23253 -- Non-null constituents
23256 Non_Null_Seen
:= True;
23260 ("cannot mix null and non-null constituents", Constit
);
23264 Resolve_State
(Constit
);
23266 -- Ensure that the constituent denotes a valid state or a
23269 if Is_Entity_Name
(Constit
) then
23270 Constit_Id
:= Entity_Of
(Constit
);
23272 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
23273 Check_Matching_Constituent
(Constit_Id
);
23277 ("constituent & must denote a variable or state (SPARK "
23278 & "RM 7.2.2(5))", Constit
, Constit_Id
);
23281 -- The constituent is illegal
23284 SPARK_Msg_N
("malformed constituent", Constit
);
23287 end Analyze_Constituent
;
23289 -----------------------------
23290 -- Check_External_Property --
23291 -----------------------------
23293 procedure Check_External_Property
23294 (Prop_Nam
: Name_Id
;
23296 Constit
: Entity_Id
)
23299 Error_Msg_Name_1
:= Prop_Nam
;
23301 -- The property is enabled in the related Abstract_State pragma
23302 -- that defines the state (SPARK RM 7.2.8(3)).
23305 if No
(Constit
) then
23307 ("external state & requires at least one constituent with "
23308 & "property %", State
, State_Id
);
23311 -- The property is missing in the declaration of the state, but
23312 -- a constituent is introducing it in the state refinement
23313 -- (SPARK RM 7.2.8(3)).
23315 elsif Present
(Constit
) then
23316 Error_Msg_Name_2
:= Chars
(Constit
);
23318 ("external state & lacks property % set by constituent %",
23321 end Check_External_Property
;
23323 --------------------------
23324 -- Check_Matching_State --
23325 --------------------------
23327 procedure Check_Matching_State
is
23328 State_Elmt
: Elmt_Id
;
23331 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23333 if Contains
(Refined_States_Seen
, State_Id
) then
23335 ("duplicate refinement of state &", State
, State_Id
);
23339 -- Inspect the abstract states defined in the package declaration
23340 -- looking for a match.
23342 State_Elmt
:= First_Elmt
(Available_States
);
23343 while Present
(State_Elmt
) loop
23345 -- A valid abstract state is being refined in the body. Add
23346 -- the state to the list of processed refined states to aid
23347 -- with the detection of duplicate refinements. Remove the
23348 -- state from Available_States to signal that it has already
23351 if Node
(State_Elmt
) = State_Id
then
23352 Add_Item
(State_Id
, Refined_States_Seen
);
23353 Remove_Elmt
(Available_States
, State_Elmt
);
23357 Next_Elmt
(State_Elmt
);
23360 -- If we get here, we are refining a state that is not defined in
23361 -- the package declaration.
23363 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23365 ("cannot refine state, & is not defined in package %",
23367 end Check_Matching_State
;
23369 --------------------------------
23370 -- Report_Unused_Constituents --
23371 --------------------------------
23373 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
23374 Constit_Elmt
: Elmt_Id
;
23375 Constit_Id
: Entity_Id
;
23376 Posted
: Boolean := False;
23379 if Present
(Constits
) then
23380 Constit_Elmt
:= First_Elmt
(Constits
);
23381 while Present
(Constit_Elmt
) loop
23382 Constit_Id
:= Node
(Constit_Elmt
);
23384 -- Generate an error message of the form:
23386 -- state ... has unused Part_Of constituents
23387 -- abstract state ... defined at ...
23388 -- variable ... defined at ...
23393 ("state & has unused Part_Of constituents",
23397 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
23399 if Ekind
(Constit_Id
) = E_Abstract_State
then
23401 ("\abstract state & defined #", State
, Constit_Id
);
23404 ("\variable & defined #", State
, Constit_Id
);
23407 Next_Elmt
(Constit_Elmt
);
23410 end Report_Unused_Constituents
;
23412 -- Local declarations
23414 Body_Ref
: Node_Id
;
23415 Body_Ref_Elmt
: Elmt_Id
;
23417 Extra_State
: Node_Id
;
23419 -- Start of processing for Analyze_Refinement_Clause
23422 -- A refinement clause appears as a component association where the
23423 -- sole choice is the state and the expressions are the constituents.
23424 -- This is a syntax error, always report.
23426 if Nkind
(Clause
) /= N_Component_Association
then
23427 Error_Msg_N
("malformed state refinement clause", Clause
);
23431 -- Analyze the state name of a refinement clause
23433 State
:= First
(Choices
(Clause
));
23436 Resolve_State
(State
);
23438 -- Ensure that the state name denotes a valid abstract state that is
23439 -- defined in the spec of the related package.
23441 if Is_Entity_Name
(State
) then
23442 State_Id
:= Entity_Of
(State
);
23444 -- Catch any attempts to re-refine a state or refine a state that
23445 -- is not defined in the package declaration.
23447 if Ekind
(State_Id
) = E_Abstract_State
then
23448 Check_Matching_State
;
23451 ("& must denote an abstract state", State
, State_Id
);
23455 -- References to a state with visible refinement are illegal.
23456 -- When nested packages are involved, detecting such references is
23457 -- tricky because pragma Refined_State is analyzed later than the
23458 -- offending pragma Depends or Global. References that occur in
23459 -- such nested context are stored in a list. Emit errors for all
23460 -- references found in Body_References (SPARK RM 6.1.4(8)).
23462 if Present
(Body_References
(State_Id
)) then
23463 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
23464 while Present
(Body_Ref_Elmt
) loop
23465 Body_Ref
:= Node
(Body_Ref_Elmt
);
23467 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
23468 Error_Msg_Sloc
:= Sloc
(State
);
23469 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
23471 Next_Elmt
(Body_Ref_Elmt
);
23475 -- The state name is illegal. This is a syntax error, always report.
23478 Error_Msg_N
("malformed state name in refinement clause", State
);
23482 -- A refinement clause may only refine one state at a time
23484 Extra_State
:= Next
(State
);
23486 if Present
(Extra_State
) then
23488 ("refinement clause cannot cover multiple states", Extra_State
);
23491 -- Replicate the Part_Of constituents of the refined state because
23492 -- the algorithm will consume items.
23494 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
23496 -- Analyze all constituents of the refinement. Multiple constituents
23497 -- appear as an aggregate.
23499 Constit
:= Expression
(Clause
);
23501 if Nkind
(Constit
) = N_Aggregate
then
23502 if Present
(Component_Associations
(Constit
)) then
23504 ("constituents of refinement clause must appear in "
23505 & "positional form", Constit
);
23507 else pragma Assert
(Present
(Expressions
(Constit
)));
23508 Constit
:= First
(Expressions
(Constit
));
23509 while Present
(Constit
) loop
23510 Analyze_Constituent
(Constit
);
23516 -- Various forms of a single constituent. Note that these may include
23517 -- malformed constituents.
23520 Analyze_Constituent
(Constit
);
23523 -- A refined external state is subject to special rules with respect
23524 -- to its properties and constituents.
23526 if Is_External_State
(State_Id
) then
23528 -- The set of properties that all external constituents yield must
23529 -- match that of the refined state. There are two cases to detect:
23530 -- the refined state lacks a property or has an extra property.
23532 if External_Constit_Seen
then
23533 Check_External_Property
23534 (Prop_Nam
=> Name_Async_Readers
,
23535 Enabled
=> Async_Readers_Enabled
(State_Id
),
23536 Constit
=> AR_Constit
);
23538 Check_External_Property
23539 (Prop_Nam
=> Name_Async_Writers
,
23540 Enabled
=> Async_Writers_Enabled
(State_Id
),
23541 Constit
=> AW_Constit
);
23543 Check_External_Property
23544 (Prop_Nam
=> Name_Effective_Reads
,
23545 Enabled
=> Effective_Reads_Enabled
(State_Id
),
23546 Constit
=> ER_Constit
);
23548 Check_External_Property
23549 (Prop_Nam
=> Name_Effective_Writes
,
23550 Enabled
=> Effective_Writes_Enabled
(State_Id
),
23551 Constit
=> EW_Constit
);
23553 -- An external state may be refined to null (SPARK RM 7.2.8(2))
23555 elsif Null_Seen
then
23558 -- The external state has constituents, but none of them are
23559 -- external (SPARK RM 7.2.8(2)).
23563 ("external state & requires at least one external "
23564 & "constituent or null refinement", State
, State_Id
);
23567 -- When a refined state is not external, it should not have external
23568 -- constituents (SPARK RM 7.2.8(1)).
23570 elsif External_Constit_Seen
then
23572 ("non-external state & cannot contain external constituents in "
23573 & "refinement", State
, State_Id
);
23576 -- Ensure that all Part_Of candidate constituents have been mentioned
23577 -- in the refinement clause.
23579 Report_Unused_Constituents
(Part_Of_Constits
);
23580 end Analyze_Refinement_Clause
;
23582 -------------------------
23583 -- Collect_Body_States --
23584 -------------------------
23586 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
23587 Result
: Elist_Id
:= No_Elist
;
23588 -- A list containing all body states of Pack_Id
23590 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
23591 -- Gather the entities of all abstract states and variables declared
23592 -- in the visible state space of package Pack_Id.
23594 ----------------------------
23595 -- Collect_Visible_States --
23596 ----------------------------
23598 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
23599 Item_Id
: Entity_Id
;
23602 -- Traverse the entity chain of the package and inspect all
23605 Item_Id
:= First_Entity
(Pack_Id
);
23606 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
23608 -- Do not consider internally generated items as those cannot
23609 -- be named and participate in refinement.
23611 if not Comes_From_Source
(Item_Id
) then
23614 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
23615 Add_Item
(Item_Id
, Result
);
23617 -- Recursively gather the visible states of a nested package
23619 elsif Ekind
(Item_Id
) = E_Package
then
23620 Collect_Visible_States
(Item_Id
);
23623 Next_Entity
(Item_Id
);
23625 end Collect_Visible_States
;
23629 Pack_Body
: constant Node_Id
:=
23630 Declaration_Node
(Body_Entity
(Pack_Id
));
23632 Item_Id
: Entity_Id
;
23634 -- Start of processing for Collect_Body_States
23637 -- Inspect the declarations of the body looking for source variables,
23638 -- packages and package instantiations.
23640 Decl
:= First
(Declarations
(Pack_Body
));
23641 while Present
(Decl
) loop
23642 if Nkind
(Decl
) = N_Object_Declaration
then
23643 Item_Id
:= Defining_Entity
(Decl
);
23645 -- Capture source variables only as internally generated
23646 -- temporaries cannot be named and participate in refinement.
23648 if Ekind
(Item_Id
) = E_Variable
23649 and then Comes_From_Source
(Item_Id
)
23651 Add_Item
(Item_Id
, Result
);
23654 elsif Nkind
(Decl
) = N_Package_Declaration
then
23655 Item_Id
:= Defining_Entity
(Decl
);
23657 -- Capture the visible abstract states and variables of a
23658 -- source package [instantiation].
23660 if Comes_From_Source
(Item_Id
) then
23661 Collect_Visible_States
(Item_Id
);
23669 end Collect_Body_States
;
23671 -----------------------------
23672 -- Report_Unrefined_States --
23673 -----------------------------
23675 procedure Report_Unrefined_States
(States
: Elist_Id
) is
23676 State_Elmt
: Elmt_Id
;
23679 if Present
(States
) then
23680 State_Elmt
:= First_Elmt
(States
);
23681 while Present
(State_Elmt
) loop
23683 ("abstract state & must be refined", Node
(State_Elmt
));
23685 Next_Elmt
(State_Elmt
);
23688 end Report_Unrefined_States
;
23690 --------------------------
23691 -- Report_Unused_States --
23692 --------------------------
23694 procedure Report_Unused_States
(States
: Elist_Id
) is
23695 Posted
: Boolean := False;
23696 State_Elmt
: Elmt_Id
;
23697 State_Id
: Entity_Id
;
23700 if Present
(States
) then
23701 State_Elmt
:= First_Elmt
(States
);
23702 while Present
(State_Elmt
) loop
23703 State_Id
:= Node
(State_Elmt
);
23705 -- Generate an error message of the form:
23707 -- body of package ... has unused hidden states
23708 -- abstract state ... defined at ...
23709 -- variable ... defined at ...
23714 ("body of package & has unused hidden states", Body_Id
);
23717 Error_Msg_Sloc
:= Sloc
(State_Id
);
23719 if Ekind
(State_Id
) = E_Abstract_State
then
23721 ("\abstract state & defined #", Body_Id
, State_Id
);
23724 ("\variable & defined #", Body_Id
, State_Id
);
23727 Next_Elmt
(State_Elmt
);
23730 end Report_Unused_States
;
23732 -- Local declarations
23734 Body_Decl
: constant Node_Id
:= Parent
(N
);
23735 Clauses
: constant Node_Id
:=
23736 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23739 -- Start of processing for Analyze_Refined_State_In_Decl_Part
23744 Body_Id
:= Defining_Entity
(Body_Decl
);
23745 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23747 -- Replicate the abstract states declared by the package because the
23748 -- matching algorithm will consume states.
23750 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
23752 -- Gather all abstract states and variables declared in the visible
23753 -- state space of the package body. These items must be utilized as
23754 -- constituents in a state refinement.
23756 Body_States
:= Collect_Body_States
(Spec_Id
);
23758 -- Multiple non-null state refinements appear as an aggregate
23760 if Nkind
(Clauses
) = N_Aggregate
then
23761 if Present
(Expressions
(Clauses
)) then
23763 ("state refinements must appear as component associations",
23766 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
23767 Clause
:= First
(Component_Associations
(Clauses
));
23768 while Present
(Clause
) loop
23769 Analyze_Refinement_Clause
(Clause
);
23775 -- Various forms of a single state refinement. Note that these may
23776 -- include malformed refinements.
23779 Analyze_Refinement_Clause
(Clauses
);
23782 -- List all abstract states that were left unrefined
23784 Report_Unrefined_States
(Available_States
);
23786 -- Ensure that all abstract states and variables declared in the body
23787 -- state space of the related package are utilized as constituents.
23789 Report_Unused_States
(Body_States
);
23790 end Analyze_Refined_State_In_Decl_Part
;
23792 ------------------------------------
23793 -- Analyze_Test_Case_In_Decl_Part --
23794 ------------------------------------
23796 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
23798 -- Install formals and push subprogram spec onto scope stack so that we
23799 -- can see the formals from the pragma.
23802 Install_Formals
(S
);
23804 -- Preanalyze the boolean expressions, we treat these as spec
23805 -- expressions (i.e. similar to a default expression).
23807 if Pragma_Name
(N
) = Name_Test_Case
then
23808 Preanalyze_CTC_Args
23810 Get_Requires_From_CTC_Pragma
(N
),
23811 Get_Ensures_From_CTC_Pragma
(N
));
23814 -- Remove the subprogram from the scope stack now that the pre-analysis
23815 -- of the expressions in the contract case or test case is done.
23818 end Analyze_Test_Case_In_Decl_Part
;
23824 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
23829 if Present
(List
) then
23830 Elmt
:= First_Elmt
(List
);
23831 while Present
(Elmt
) loop
23832 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
23835 Id
:= Entity_Of
(Node
(Elmt
));
23838 if Id
= Item_Id
then
23849 -----------------------------
23850 -- Check_Applicable_Policy --
23851 -----------------------------
23853 procedure Check_Applicable_Policy
(N
: Node_Id
) is
23857 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
23860 -- No effect if not valid assertion kind name
23862 if not Is_Valid_Assertion_Kind
(Ename
) then
23866 -- Loop through entries in check policy list
23868 PP
:= Opt
.Check_Policy_List
;
23869 while Present
(PP
) loop
23871 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
23872 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
23876 or else Pnm
= Name_Assertion
23877 or else (Pnm
= Name_Statement_Assertions
23878 and then Nam_In
(Ename
, Name_Assert
,
23879 Name_Assert_And_Cut
,
23881 Name_Loop_Invariant
,
23882 Name_Loop_Variant
))
23884 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
23887 when Name_Off | Name_Ignore
=>
23888 Set_Is_Ignored
(N
, True);
23889 Set_Is_Checked
(N
, False);
23891 when Name_On | Name_Check
=>
23892 Set_Is_Checked
(N
, True);
23893 Set_Is_Ignored
(N
, False);
23895 when Name_Disable
=>
23896 Set_Is_Ignored
(N
, True);
23897 Set_Is_Checked
(N
, False);
23898 Set_Is_Disabled
(N
, True);
23900 -- That should be exhaustive, the null here is a defence
23901 -- against a malformed tree from previous errors.
23910 PP
:= Next_Pragma
(PP
);
23914 -- If there are no specific entries that matched, then we let the
23915 -- setting of assertions govern. Note that this provides the needed
23916 -- compatibility with the RM for the cases of assertion, invariant,
23917 -- precondition, predicate, and postcondition.
23919 if Assertions_Enabled
then
23920 Set_Is_Checked
(N
, True);
23921 Set_Is_Ignored
(N
, False);
23923 Set_Is_Checked
(N
, False);
23924 Set_Is_Ignored
(N
, True);
23926 end Check_Applicable_Policy
;
23928 -------------------------------
23929 -- Check_External_Properties --
23930 -------------------------------
23932 procedure Check_External_Properties
23940 -- All properties enabled
23942 if AR
and AW
and ER
and EW
then
23945 -- Async_Readers + Effective_Writes
23946 -- Async_Readers + Async_Writers + Effective_Writes
23948 elsif AR
and EW
and not ER
then
23951 -- Async_Writers + Effective_Reads
23952 -- Async_Readers + Async_Writers + Effective_Reads
23954 elsif AW
and ER
and not EW
then
23957 -- Async_Readers + Async_Writers
23959 elsif AR
and AW
and not ER
and not EW
then
23964 elsif AR
and not AW
and not ER
and not EW
then
23969 elsif AW
and not AR
and not ER
and not EW
then
23974 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
23977 end Check_External_Properties
;
23983 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
23987 -- Loop through entries in check policy list
23989 PP
:= Opt
.Check_Policy_List
;
23990 while Present
(PP
) loop
23992 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
23993 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
23997 or else (Pnm
= Name_Assertion
23998 and then Is_Valid_Assertion_Kind
(Nam
))
23999 or else (Pnm
= Name_Statement_Assertions
24000 and then Nam_In
(Nam
, Name_Assert
,
24001 Name_Assert_And_Cut
,
24003 Name_Loop_Invariant
,
24004 Name_Loop_Variant
))
24006 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24007 when Name_On | Name_Check
=>
24009 when Name_Off | Name_Ignore
=>
24010 return Name_Ignore
;
24011 when Name_Disable
=>
24012 return Name_Disable
;
24014 raise Program_Error
;
24018 PP
:= Next_Pragma
(PP
);
24023 -- If there are no specific entries that matched, then we let the
24024 -- setting of assertions govern. Note that this provides the needed
24025 -- compatibility with the RM for the cases of assertion, invariant,
24026 -- precondition, predicate, and postcondition.
24028 if Assertions_Enabled
then
24031 return Name_Ignore
;
24035 ---------------------------
24036 -- Check_Missing_Part_Of --
24037 ---------------------------
24039 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24040 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24041 -- Determine whether a package denoted by Pack_Id declares at least one
24044 -----------------------
24045 -- Has_Visible_State --
24046 -----------------------
24048 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24049 Item_Id
: Entity_Id
;
24052 -- Traverse the entity chain of the package trying to find at least
24053 -- one visible abstract state, variable or a package [instantiation]
24054 -- that declares a visible state.
24056 Item_Id
:= First_Entity
(Pack_Id
);
24057 while Present
(Item_Id
)
24058 and then not In_Private_Part
(Item_Id
)
24060 -- Do not consider internally generated items
24062 if not Comes_From_Source
(Item_Id
) then
24065 -- A visible state has been found
24067 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24070 -- Recursively peek into nested packages and instantiations
24072 elsif Ekind
(Item_Id
) = E_Package
24073 and then Has_Visible_State
(Item_Id
)
24078 Next_Entity
(Item_Id
);
24082 end Has_Visible_State
;
24086 Pack_Id
: Entity_Id
;
24087 Placement
: State_Space_Kind
;
24089 -- Start of processing for Check_Missing_Part_Of
24092 -- Do not consider abstract states, variables or package instantiations
24093 -- coming from an instance as those always inherit the Part_Of indicator
24094 -- of the instance itself.
24096 if In_Instance
then
24099 -- Do not consider internally generated entities as these can never
24100 -- have a Part_Of indicator.
24102 elsif not Comes_From_Source
(Item_Id
) then
24105 -- Perform these checks only when SPARK_Mode is enabled as they will
24106 -- interfere with standard Ada rules and produce false positives.
24108 elsif SPARK_Mode
/= On
then
24112 -- Find where the abstract state, variable or package instantiation
24113 -- lives with respect to the state space.
24115 Find_Placement_In_State_Space
24116 (Item_Id
=> Item_Id
,
24117 Placement
=> Placement
,
24118 Pack_Id
=> Pack_Id
);
24120 -- Items that appear in a non-package construct (subprogram, block, etc)
24121 -- do not require a Part_Of indicator because they can never act as a
24124 if Placement
= Not_In_Package
then
24127 -- An item declared in the body state space of a package always act as a
24128 -- constituent and does not need explicit Part_Of indicator.
24130 elsif Placement
= Body_State_Space
then
24133 -- In general an item declared in the visible state space of a package
24134 -- does not require a Part_Of indicator. The only exception is when the
24135 -- related package is a private child unit in which case Part_Of must
24136 -- denote a state in the parent unit or in one of its descendants.
24138 elsif Placement
= Visible_State_Space
then
24139 if Is_Child_Unit
(Pack_Id
)
24140 and then Is_Private_Descendant
(Pack_Id
)
24142 -- A package instantiation does not need a Part_Of indicator when
24143 -- the related generic template has no visible state.
24145 if Ekind
(Item_Id
) = E_Package
24146 and then Is_Generic_Instance
(Item_Id
)
24147 and then not Has_Visible_State
(Item_Id
)
24151 -- All other cases require Part_Of
24155 ("indicator Part_Of is required in this context "
24156 & "(SPARK RM 7.2.6(3))", Item_Id
);
24157 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24159 ("\& is declared in the visible part of private child "
24160 & "unit %", Item_Id
);
24164 -- When the item appears in the private state space of a packge, it must
24165 -- be a part of some state declared by the said package.
24167 else pragma Assert
(Placement
= Private_State_Space
);
24169 -- The related package does not declare a state, the item cannot act
24170 -- as a Part_Of constituent.
24172 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24175 -- A package instantiation does not need a Part_Of indicator when the
24176 -- related generic template has no visible state.
24178 elsif Ekind
(Pack_Id
) = E_Package
24179 and then Is_Generic_Instance
(Pack_Id
)
24180 and then not Has_Visible_State
(Pack_Id
)
24184 -- All other cases require Part_Of
24188 ("indicator Part_Of is required in this context "
24189 & "(SPARK RM 7.2.6(2))", Item_Id
);
24190 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24192 ("\& is declared in the private part of package %", Item_Id
);
24195 end Check_Missing_Part_Of
;
24197 ---------------------------------
24198 -- Check_SPARK_Aspect_For_ASIS --
24199 ---------------------------------
24201 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
24205 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
24206 Expr
:= Expression
(Corresponding_Aspect
(N
));
24207 if Nkind
(Expr
) /= N_Aggregate
then
24208 Preanalyze_And_Resolve
(Expr
);
24212 Comps
: constant List_Id
:= Component_Associations
(Expr
);
24213 Exprs
: constant List_Id
:= Expressions
(Expr
);
24218 E
:= First
(Exprs
);
24219 while Present
(E
) loop
24224 C
:= First
(Comps
);
24225 while Present
(C
) loop
24226 Analyze
(Expression
(C
));
24232 end Check_SPARK_Aspect_For_ASIS
;
24234 -------------------------------------
24235 -- Check_State_And_Constituent_Use --
24236 -------------------------------------
24238 procedure Check_State_And_Constituent_Use
24239 (States
: Elist_Id
;
24240 Constits
: Elist_Id
;
24243 function Find_Encapsulating_State
24244 (Constit_Id
: Entity_Id
) return Entity_Id
;
24245 -- Given the entity of a constituent, try to find a corresponding
24246 -- encapsulating state that appears in the same context. The routine
24247 -- returns Empty is no such state is found.
24249 ------------------------------
24250 -- Find_Encapsulating_State --
24251 ------------------------------
24253 function Find_Encapsulating_State
24254 (Constit_Id
: Entity_Id
) return Entity_Id
24256 State_Id
: Entity_Id
;
24259 -- Since a constituent may be part of a larger constituent set, climb
24260 -- the encapsulated state chain looking for a state that appears in
24261 -- the same context.
24263 State_Id
:= Encapsulating_State
(Constit_Id
);
24264 while Present
(State_Id
) loop
24265 if Contains
(States
, State_Id
) then
24269 State_Id
:= Encapsulating_State
(State_Id
);
24273 end Find_Encapsulating_State
;
24277 Constit_Elmt
: Elmt_Id
;
24278 Constit_Id
: Entity_Id
;
24279 State_Id
: Entity_Id
;
24281 -- Start of processing for Check_State_And_Constituent_Use
24284 -- Nothing to do if there are no states or constituents
24286 if No
(States
) or else No
(Constits
) then
24290 -- Inspect the list of constituents and try to determine whether its
24291 -- encapsulating state is in list States.
24293 Constit_Elmt
:= First_Elmt
(Constits
);
24294 while Present
(Constit_Elmt
) loop
24295 Constit_Id
:= Node
(Constit_Elmt
);
24297 -- Determine whether the constituent is part of an encapsulating
24298 -- state that appears in the same context and if this is the case,
24299 -- emit an error (SPARK RM 7.2.6(7)).
24301 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
24303 if Present
(State_Id
) then
24304 Error_Msg_Name_1
:= Chars
(Constit_Id
);
24306 ("cannot mention state & and its constituent % in the same "
24307 & "context", Context
, State_Id
);
24311 Next_Elmt
(Constit_Elmt
);
24313 end Check_State_And_Constituent_Use
;
24315 --------------------------
24316 -- Collect_Global_Items --
24317 --------------------------
24319 procedure Collect_Global_Items
24321 In_Items
: in out Elist_Id
;
24322 In_Out_Items
: in out Elist_Id
;
24323 Out_Items
: in out Elist_Id
;
24324 Proof_In_Items
: in out Elist_Id
;
24325 Has_In_State
: out Boolean;
24326 Has_In_Out_State
: out Boolean;
24327 Has_Out_State
: out Boolean;
24328 Has_Proof_In_State
: out Boolean;
24329 Has_Null_State
: out Boolean)
24331 procedure Process_Global_List
24333 Mode
: Name_Id
:= Name_Input
);
24334 -- Collect all items housed in a global list. Formal Mode denotes the
24335 -- current mode in effect.
24337 -------------------------
24338 -- Process_Global_List --
24339 -------------------------
24341 procedure Process_Global_List
24343 Mode
: Name_Id
:= Name_Input
)
24345 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24346 -- Add a single item to the appropriate list. Formal Mode denotes the
24347 -- current mode in effect.
24349 -------------------------
24350 -- Process_Global_Item --
24351 -------------------------
24353 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24354 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
24355 -- The above handles abstract views of variables and states built
24356 -- for limited with clauses.
24359 -- Signal that the global list contains at least one abstract
24360 -- state with a visible refinement. Note that the refinement may
24361 -- be null in which case there are no constituents.
24363 if Ekind
(Item_Id
) = E_Abstract_State
then
24364 if Has_Null_Refinement
(Item_Id
) then
24365 Has_Null_State
:= True;
24367 elsif Has_Non_Null_Refinement
(Item_Id
) then
24368 if Mode
= Name_Input
then
24369 Has_In_State
:= True;
24370 elsif Mode
= Name_In_Out
then
24371 Has_In_Out_State
:= True;
24372 elsif Mode
= Name_Output
then
24373 Has_Out_State
:= True;
24374 elsif Mode
= Name_Proof_In
then
24375 Has_Proof_In_State
:= True;
24380 -- Add the item to the proper list
24382 if Mode
= Name_Input
then
24383 Add_Item
(Item_Id
, In_Items
);
24384 elsif Mode
= Name_In_Out
then
24385 Add_Item
(Item_Id
, In_Out_Items
);
24386 elsif Mode
= Name_Output
then
24387 Add_Item
(Item_Id
, Out_Items
);
24388 elsif Mode
= Name_Proof_In
then
24389 Add_Item
(Item_Id
, Proof_In_Items
);
24391 end Process_Global_Item
;
24397 -- Start of processing for Process_Global_List
24400 if Nkind
(List
) = N_Null
then
24403 -- Single global item declaration
24405 elsif Nkind_In
(List
, N_Expanded_Name
,
24407 N_Selected_Component
)
24409 Process_Global_Item
(List
, Mode
);
24411 -- Single global list or moded global list declaration
24413 elsif Nkind
(List
) = N_Aggregate
then
24415 -- The declaration of a simple global list appear as a collection
24418 if Present
(Expressions
(List
)) then
24419 Item
:= First
(Expressions
(List
));
24420 while Present
(Item
) loop
24421 Process_Global_Item
(Item
, Mode
);
24426 -- The declaration of a moded global list appears as a collection
24427 -- of component associations where individual choices denote mode.
24429 elsif Present
(Component_Associations
(List
)) then
24430 Item
:= First
(Component_Associations
(List
));
24431 while Present
(Item
) loop
24432 Process_Global_List
24433 (List
=> Expression
(Item
),
24434 Mode
=> Chars
(First
(Choices
(Item
))));
24442 raise Program_Error
;
24445 -- To accomodate partial decoration of disabled SPARK features, this
24446 -- routine may be called with illegal input. If this is the case, do
24447 -- not raise Program_Error.
24452 end Process_Global_List
;
24456 Items
: constant Node_Id
:=
24457 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
)));
24459 -- Start of processing for Collect_Global_Items
24462 -- Assume that no states have been encountered
24464 Has_In_State
:= False;
24465 Has_In_Out_State
:= False;
24466 Has_Out_State
:= False;
24467 Has_Proof_In_State
:= False;
24468 Has_Null_State
:= False;
24470 Process_Global_List
(Items
);
24471 end Collect_Global_Items
;
24473 ---------------------------------------
24474 -- Collect_Subprogram_Inputs_Outputs --
24475 ---------------------------------------
24477 procedure Collect_Subprogram_Inputs_Outputs
24478 (Subp_Id
: Entity_Id
;
24479 Subp_Inputs
: in out Elist_Id
;
24480 Subp_Outputs
: in out Elist_Id
;
24481 Global_Seen
: out Boolean)
24483 procedure Collect_Global_List
24485 Mode
: Name_Id
:= Name_Input
);
24486 -- Collect all relevant items from a global list
24488 -------------------------
24489 -- Collect_Global_List --
24490 -------------------------
24492 procedure Collect_Global_List
24494 Mode
: Name_Id
:= Name_Input
)
24496 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24497 -- Add an item to the proper subprogram input or output collection
24499 -------------------------
24500 -- Collect_Global_Item --
24501 -------------------------
24503 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24505 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
24506 Add_Item
(Item
, Subp_Inputs
);
24509 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
24510 Add_Item
(Item
, Subp_Outputs
);
24512 end Collect_Global_Item
;
24519 -- Start of processing for Collect_Global_List
24522 if Nkind
(List
) = N_Null
then
24525 -- Single global item declaration
24527 elsif Nkind_In
(List
, N_Expanded_Name
,
24529 N_Selected_Component
)
24531 Collect_Global_Item
(List
, Mode
);
24533 -- Simple global list or moded global list declaration
24535 elsif Nkind
(List
) = N_Aggregate
then
24536 if Present
(Expressions
(List
)) then
24537 Item
:= First
(Expressions
(List
));
24538 while Present
(Item
) loop
24539 Collect_Global_Item
(Item
, Mode
);
24544 Assoc
:= First
(Component_Associations
(List
));
24545 while Present
(Assoc
) loop
24546 Collect_Global_List
24547 (List
=> Expression
(Assoc
),
24548 Mode
=> Chars
(First
(Choices
(Assoc
))));
24553 -- To accomodate partial decoration of disabled SPARK features, this
24554 -- routine may be called with illegal input. If this is the case, do
24555 -- not raise Program_Error.
24560 end Collect_Global_List
;
24564 Subp_Decl
: constant Node_Id
:= Parent
(Parent
(Subp_Id
));
24565 Formal
: Entity_Id
;
24568 Spec_Id
: Entity_Id
;
24570 -- Start of processing for Collect_Subprogram_Inputs_Outputs
24573 Global_Seen
:= False;
24575 -- Find the entity of the corresponding spec when processing a body
24577 if Nkind
(Subp_Decl
) = N_Subprogram_Body
24578 and then Present
(Corresponding_Spec
(Subp_Decl
))
24580 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
24582 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
24583 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
24585 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
24588 Spec_Id
:= Subp_Id
;
24591 -- Process all formal parameters
24593 Formal
:= First_Formal
(Spec_Id
);
24594 while Present
(Formal
) loop
24595 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
24596 Add_Item
(Formal
, Subp_Inputs
);
24599 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
24600 Add_Item
(Formal
, Subp_Outputs
);
24602 -- Out parameters can act as inputs when the related type is
24603 -- tagged, unconstrained array, unconstrained record or record
24604 -- with unconstrained components.
24606 if Ekind
(Formal
) = E_Out_Parameter
24607 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
24609 Add_Item
(Formal
, Subp_Inputs
);
24613 Next_Formal
(Formal
);
24616 -- When processing a subprogram body, look for pragma Refined_Global as
24617 -- it provides finer granularity of inputs and outputs.
24619 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
24620 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
24622 -- Subprogram declaration case, look for pragma Global
24625 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
24628 if Present
(Global
) then
24629 Global_Seen
:= True;
24630 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
24632 -- The pragma may not have been analyzed because of the arbitrary
24633 -- declaration order of aspects. Make sure that it is analyzed for
24634 -- the purposes of item extraction.
24636 if not Analyzed
(List
) then
24637 if Pragma_Name
(Global
) = Name_Refined_Global
then
24638 Analyze_Refined_Global_In_Decl_Part
(Global
);
24640 Analyze_Global_In_Decl_Part
(Global
);
24644 -- Nothing to be done for a null global list
24646 if Nkind
(List
) /= N_Null
then
24647 Collect_Global_List
(List
);
24650 end Collect_Subprogram_Inputs_Outputs
;
24652 ---------------------------------
24653 -- Delay_Config_Pragma_Analyze --
24654 ---------------------------------
24656 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
24658 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
24659 Name_Priority_Specific_Dispatching
);
24660 end Delay_Config_Pragma_Analyze
;
24662 -------------------------------------
24663 -- Find_Related_Subprogram_Or_Body --
24664 -------------------------------------
24666 function Find_Related_Subprogram_Or_Body
24668 Do_Checks
: Boolean := False) return Node_Id
24670 Context
: constant Node_Id
:= Parent
(Prag
);
24671 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
24674 Look_For_Body
: constant Boolean :=
24675 Nam_In
(Nam
, Name_Refined_Depends
,
24676 Name_Refined_Global
,
24677 Name_Refined_Post
);
24678 -- Refinement pragmas must be associated with a subprogram body [stub]
24681 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
24683 -- If the pragma is a byproduct of aspect expansion, return the related
24684 -- context of the original aspect.
24686 if Present
(Corresponding_Aspect
(Prag
)) then
24687 return Parent
(Corresponding_Aspect
(Prag
));
24690 -- Otherwise the pragma is a source construct, most likely part of a
24691 -- declarative list. Skip preceding declarations while looking for a
24692 -- proper subprogram declaration.
24694 pragma Assert
(Is_List_Member
(Prag
));
24696 Stmt
:= Prev
(Prag
);
24697 while Present
(Stmt
) loop
24699 -- Skip prior pragmas, but check for duplicates
24701 if Nkind
(Stmt
) = N_Pragma
then
24702 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
24703 Error_Msg_Name_1
:= Nam
;
24704 Error_Msg_Sloc
:= Sloc
(Stmt
);
24705 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
24708 -- Emit an error when a refinement pragma appears on an expression
24709 -- function without a completion.
24712 and then Look_For_Body
24713 and then Nkind
(Stmt
) = N_Subprogram_Declaration
24714 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
24715 and then not Has_Completion
(Defining_Entity
(Stmt
))
24717 Error_Msg_Name_1
:= Nam
;
24719 ("pragma % cannot apply to a stand alone expression function",
24724 -- The refinement pragma applies to a subprogram body stub
24726 elsif Look_For_Body
24727 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
24731 -- Skip internally generated code
24733 elsif not Comes_From_Source
(Stmt
) then
24736 -- Return the current construct which is either a subprogram body,
24737 -- a subprogram declaration or is illegal.
24746 -- If we fall through, then the pragma was either the first declaration
24747 -- or it was preceded by other pragmas and no source constructs.
24749 -- The pragma is associated with a library-level subprogram
24751 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
24752 return Unit
(Parent
(Context
));
24754 -- The pragma appears inside the declarative part of a subprogram body
24756 elsif Nkind
(Context
) = N_Subprogram_Body
then
24759 -- No candidate subprogram [body] found
24764 end Find_Related_Subprogram_Or_Body
;
24766 -------------------------
24767 -- Get_Base_Subprogram --
24768 -------------------------
24770 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
24771 Result
: Entity_Id
;
24774 -- Follow subprogram renaming chain
24778 if Is_Subprogram
(Result
)
24780 Nkind
(Parent
(Declaration_Node
(Result
))) =
24781 N_Subprogram_Renaming_Declaration
24782 and then Present
(Alias
(Result
))
24784 Result
:= Alias
(Result
);
24788 end Get_Base_Subprogram
;
24790 -----------------------
24791 -- Get_SPARK_Mode_Type --
24792 -----------------------
24794 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
24796 if N
= Name_On
then
24798 elsif N
= Name_Off
then
24801 -- Any other argument is illegal
24804 raise Program_Error
;
24806 end Get_SPARK_Mode_Type
;
24808 --------------------------------
24809 -- Get_SPARK_Mode_From_Pragma --
24810 --------------------------------
24812 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
24817 pragma Assert
(Nkind
(N
) = N_Pragma
);
24818 Args
:= Pragma_Argument_Associations
(N
);
24820 -- Extract the mode from the argument list
24822 if Present
(Args
) then
24823 Mode
:= First
(Pragma_Argument_Associations
(N
));
24824 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
24826 -- If SPARK_Mode pragma has no argument, default is ON
24831 end Get_SPARK_Mode_From_Pragma
;
24833 ---------------------------
24834 -- Has_Extra_Parentheses --
24835 ---------------------------
24837 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
24841 -- The aggregate should not have an expression list because a clause
24842 -- is always interpreted as a component association. The only way an
24843 -- expression list can sneak in is by adding extra parentheses around
24844 -- the individual clauses:
24846 -- Depends (Output => Input) -- proper form
24847 -- Depends ((Output => Input)) -- extra parentheses
24849 -- Since the extra parentheses are not allowed by the syntax of the
24850 -- pragma, flag them now to avoid emitting misleading errors down the
24853 if Nkind
(Clause
) = N_Aggregate
24854 and then Present
(Expressions
(Clause
))
24856 Expr
:= First
(Expressions
(Clause
));
24857 while Present
(Expr
) loop
24859 -- A dependency clause surrounded by extra parentheses appears
24860 -- as an aggregate of component associations with an optional
24861 -- Paren_Count set.
24863 if Nkind
(Expr
) = N_Aggregate
24864 and then Present
(Component_Associations
(Expr
))
24867 ("dependency clause contains extra parentheses", Expr
);
24869 -- Otherwise the expression is a malformed construct
24872 SPARK_Msg_N
("malformed dependency clause", Expr
);
24882 end Has_Extra_Parentheses
;
24888 procedure Initialize
is
24899 Dummy
:= Dummy
+ 1;
24902 -----------------------------
24903 -- Is_Config_Static_String --
24904 -----------------------------
24906 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
24908 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
24909 -- This is an internal recursive function that is just like the outer
24910 -- function except that it adds the string to the name buffer rather
24911 -- than placing the string in the name buffer.
24913 ------------------------------
24914 -- Add_Config_Static_String --
24915 ------------------------------
24917 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
24924 if Nkind
(N
) = N_Op_Concat
then
24925 if Add_Config_Static_String
(Left_Opnd
(N
)) then
24926 N
:= Right_Opnd
(N
);
24932 if Nkind
(N
) /= N_String_Literal
then
24933 Error_Msg_N
("string literal expected for pragma argument", N
);
24937 for J
in 1 .. String_Length
(Strval
(N
)) loop
24938 C
:= Get_String_Char
(Strval
(N
), J
);
24940 if not In_Character_Range
(C
) then
24942 ("string literal contains invalid wide character",
24943 Sloc
(N
) + 1 + Source_Ptr
(J
));
24947 Add_Char_To_Name_Buffer
(Get_Character
(C
));
24952 end Add_Config_Static_String
;
24954 -- Start of processing for Is_Config_Static_String
24959 return Add_Config_Static_String
(Arg
);
24960 end Is_Config_Static_String
;
24962 -------------------------------
24963 -- Is_Elaboration_SPARK_Mode --
24964 -------------------------------
24966 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
24969 (Nkind
(N
) = N_Pragma
24970 and then Pragma_Name
(N
) = Name_SPARK_Mode
24971 and then Is_List_Member
(N
));
24973 -- Pragma SPARK_Mode affects the elaboration of a package body when it
24974 -- appears in the statement part of the body.
24977 Present
(Parent
(N
))
24978 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
24979 and then List_Containing
(N
) = Statements
(Parent
(N
))
24980 and then Present
(Parent
(Parent
(N
)))
24981 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
24982 end Is_Elaboration_SPARK_Mode
;
24984 -----------------------------------------
24985 -- Is_Non_Significant_Pragma_Reference --
24986 -----------------------------------------
24988 -- This function makes use of the following static table which indicates
24989 -- whether appearance of some name in a given pragma is to be considered
24990 -- as a reference for the purposes of warnings about unreferenced objects.
24992 -- -1 indicates that appearence in any argument is significant
24993 -- 0 indicates that appearance in any argument is not significant
24994 -- +n indicates that appearance as argument n is significant, but all
24995 -- other arguments are not significant
24996 -- 9n arguments from n on are significant, before n inisignificant
24998 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
24999 (Pragma_Abort_Defer
=> -1,
25000 Pragma_Abstract_State
=> -1,
25001 Pragma_Ada_83
=> -1,
25002 Pragma_Ada_95
=> -1,
25003 Pragma_Ada_05
=> -1,
25004 Pragma_Ada_2005
=> -1,
25005 Pragma_Ada_12
=> -1,
25006 Pragma_Ada_2012
=> -1,
25007 Pragma_All_Calls_Remote
=> -1,
25008 Pragma_Allow_Integer_Address
=> -1,
25009 Pragma_Annotate
=> 93,
25010 Pragma_Assert
=> -1,
25011 Pragma_Assert_And_Cut
=> -1,
25012 Pragma_Assertion_Policy
=> 0,
25013 Pragma_Assume
=> -1,
25014 Pragma_Assume_No_Invalid_Values
=> 0,
25015 Pragma_Async_Readers
=> 0,
25016 Pragma_Async_Writers
=> 0,
25017 Pragma_Asynchronous
=> 0,
25018 Pragma_Atomic
=> 0,
25019 Pragma_Atomic_Components
=> 0,
25020 Pragma_Attach_Handler
=> -1,
25021 Pragma_Attribute_Definition
=> 92,
25022 Pragma_Check
=> -1,
25023 Pragma_Check_Float_Overflow
=> 0,
25024 Pragma_Check_Name
=> 0,
25025 Pragma_Check_Policy
=> 0,
25026 Pragma_CIL_Constructor
=> 0,
25027 Pragma_CPP_Class
=> 0,
25028 Pragma_CPP_Constructor
=> 0,
25029 Pragma_CPP_Virtual
=> 0,
25030 Pragma_CPP_Vtable
=> 0,
25032 Pragma_C_Pass_By_Copy
=> 0,
25033 Pragma_Comment
=> -1,
25034 Pragma_Common_Object
=> 0,
25035 Pragma_Compile_Time_Error
=> -1,
25036 Pragma_Compile_Time_Warning
=> -1,
25037 Pragma_Compiler_Unit
=> -1,
25038 Pragma_Compiler_Unit_Warning
=> -1,
25039 Pragma_Complete_Representation
=> 0,
25040 Pragma_Complex_Representation
=> 0,
25041 Pragma_Component_Alignment
=> 0,
25042 Pragma_Contract_Cases
=> -1,
25043 Pragma_Controlled
=> 0,
25044 Pragma_Convention
=> 0,
25045 Pragma_Convention_Identifier
=> 0,
25046 Pragma_Debug
=> -1,
25047 Pragma_Debug_Policy
=> 0,
25048 Pragma_Detect_Blocking
=> 0,
25049 Pragma_Default_Initial_Condition
=> -1,
25050 Pragma_Default_Scalar_Storage_Order
=> 0,
25051 Pragma_Default_Storage_Pool
=> 0,
25052 Pragma_Depends
=> -1,
25053 Pragma_Disable_Atomic_Synchronization
=> 0,
25054 Pragma_Discard_Names
=> 0,
25055 Pragma_Dispatching_Domain
=> -1,
25056 Pragma_Effective_Reads
=> 0,
25057 Pragma_Effective_Writes
=> 0,
25058 Pragma_Elaborate
=> 0,
25059 Pragma_Elaborate_All
=> 0,
25060 Pragma_Elaborate_Body
=> 0,
25061 Pragma_Elaboration_Checks
=> 0,
25062 Pragma_Eliminate
=> 0,
25063 Pragma_Enable_Atomic_Synchronization
=> 0,
25064 Pragma_Export
=> -1,
25065 Pragma_Export_Function
=> -1,
25066 Pragma_Export_Object
=> -1,
25067 Pragma_Export_Procedure
=> -1,
25068 Pragma_Export_Value
=> -1,
25069 Pragma_Export_Valued_Procedure
=> -1,
25070 Pragma_Extend_System
=> -1,
25071 Pragma_Extensions_Allowed
=> 0,
25072 Pragma_Extensions_Visible
=> 0,
25073 Pragma_External
=> -1,
25074 Pragma_Favor_Top_Level
=> 0,
25075 Pragma_External_Name_Casing
=> 0,
25076 Pragma_Fast_Math
=> 0,
25077 Pragma_Finalize_Storage_Only
=> 0,
25078 Pragma_Global
=> -1,
25079 Pragma_Ident
=> -1,
25080 Pragma_Implementation_Defined
=> -1,
25081 Pragma_Implemented
=> -1,
25082 Pragma_Implicit_Packing
=> 0,
25083 Pragma_Import
=> 93,
25084 Pragma_Import_Function
=> 0,
25085 Pragma_Import_Object
=> 0,
25086 Pragma_Import_Procedure
=> 0,
25087 Pragma_Import_Valued_Procedure
=> 0,
25088 Pragma_Independent
=> 0,
25089 Pragma_Independent_Components
=> 0,
25090 Pragma_Initial_Condition
=> -1,
25091 Pragma_Initialize_Scalars
=> 0,
25092 Pragma_Initializes
=> -1,
25093 Pragma_Inline
=> 0,
25094 Pragma_Inline_Always
=> 0,
25095 Pragma_Inline_Generic
=> 0,
25096 Pragma_Inspection_Point
=> -1,
25097 Pragma_Interface
=> 92,
25098 Pragma_Interface_Name
=> 0,
25099 Pragma_Interrupt_Handler
=> -1,
25100 Pragma_Interrupt_Priority
=> -1,
25101 Pragma_Interrupt_State
=> -1,
25102 Pragma_Invariant
=> -1,
25103 Pragma_Java_Constructor
=> -1,
25104 Pragma_Java_Interface
=> -1,
25105 Pragma_Keep_Names
=> 0,
25106 Pragma_License
=> 0,
25107 Pragma_Link_With
=> -1,
25108 Pragma_Linker_Alias
=> -1,
25109 Pragma_Linker_Constructor
=> -1,
25110 Pragma_Linker_Destructor
=> -1,
25111 Pragma_Linker_Options
=> -1,
25112 Pragma_Linker_Section
=> 0,
25114 Pragma_Lock_Free
=> 0,
25115 Pragma_Locking_Policy
=> 0,
25116 Pragma_Loop_Invariant
=> -1,
25117 Pragma_Loop_Optimize
=> 0,
25118 Pragma_Loop_Variant
=> -1,
25119 Pragma_Machine_Attribute
=> -1,
25121 Pragma_Main_Storage
=> -1,
25122 Pragma_Memory_Size
=> 0,
25123 Pragma_No_Return
=> 0,
25124 Pragma_No_Body
=> 0,
25125 Pragma_No_Elaboration_Code_All
=> 0,
25126 Pragma_No_Inline
=> 0,
25127 Pragma_No_Run_Time
=> -1,
25128 Pragma_No_Strict_Aliasing
=> -1,
25129 Pragma_No_Tagged_Streams
=> 0,
25130 Pragma_Normalize_Scalars
=> 0,
25131 Pragma_Obsolescent
=> 0,
25132 Pragma_Optimize
=> 0,
25133 Pragma_Optimize_Alignment
=> 0,
25134 Pragma_Overflow_Mode
=> 0,
25135 Pragma_Overriding_Renamings
=> 0,
25136 Pragma_Ordered
=> 0,
25139 Pragma_Part_Of
=> 0,
25140 Pragma_Partition_Elaboration_Policy
=> 0,
25141 Pragma_Passive
=> 0,
25142 Pragma_Persistent_BSS
=> 0,
25143 Pragma_Polling
=> 0,
25144 Pragma_Prefix_Exception_Messages
=> 0,
25146 Pragma_Postcondition
=> -1,
25147 Pragma_Post_Class
=> -1,
25149 Pragma_Precondition
=> -1,
25150 Pragma_Predicate
=> -1,
25151 Pragma_Preelaborable_Initialization
=> -1,
25152 Pragma_Preelaborate
=> 0,
25153 Pragma_Pre_Class
=> -1,
25154 Pragma_Priority
=> -1,
25155 Pragma_Priority_Specific_Dispatching
=> 0,
25156 Pragma_Profile
=> 0,
25157 Pragma_Profile_Warnings
=> 0,
25158 Pragma_Propagate_Exceptions
=> 0,
25159 Pragma_Provide_Shift_Operators
=> 0,
25160 Pragma_Psect_Object
=> 0,
25162 Pragma_Pure_Function
=> 0,
25163 Pragma_Queuing_Policy
=> 0,
25164 Pragma_Rational
=> 0,
25165 Pragma_Ravenscar
=> 0,
25166 Pragma_Refined_Depends
=> -1,
25167 Pragma_Refined_Global
=> -1,
25168 Pragma_Refined_Post
=> -1,
25169 Pragma_Refined_State
=> -1,
25170 Pragma_Relative_Deadline
=> 0,
25171 Pragma_Remote_Access_Type
=> -1,
25172 Pragma_Remote_Call_Interface
=> -1,
25173 Pragma_Remote_Types
=> -1,
25174 Pragma_Restricted_Run_Time
=> 0,
25175 Pragma_Restriction_Warnings
=> 0,
25176 Pragma_Restrictions
=> 0,
25177 Pragma_Reviewable
=> -1,
25178 Pragma_Short_Circuit_And_Or
=> 0,
25179 Pragma_Share_Generic
=> 0,
25180 Pragma_Shared
=> 0,
25181 Pragma_Shared_Passive
=> 0,
25182 Pragma_Short_Descriptors
=> 0,
25183 Pragma_Simple_Storage_Pool_Type
=> 0,
25184 Pragma_Source_File_Name
=> 0,
25185 Pragma_Source_File_Name_Project
=> 0,
25186 Pragma_Source_Reference
=> 0,
25187 Pragma_SPARK_Mode
=> 0,
25188 Pragma_Storage_Size
=> -1,
25189 Pragma_Storage_Unit
=> 0,
25190 Pragma_Static_Elaboration_Desired
=> 0,
25191 Pragma_Stream_Convert
=> 0,
25192 Pragma_Style_Checks
=> 0,
25193 Pragma_Subtitle
=> 0,
25194 Pragma_Suppress
=> 0,
25195 Pragma_Suppress_Exception_Locations
=> 0,
25196 Pragma_Suppress_All
=> 0,
25197 Pragma_Suppress_Debug_Info
=> 0,
25198 Pragma_Suppress_Initialization
=> 0,
25199 Pragma_System_Name
=> 0,
25200 Pragma_Task_Dispatching_Policy
=> 0,
25201 Pragma_Task_Info
=> -1,
25202 Pragma_Task_Name
=> -1,
25203 Pragma_Task_Storage
=> -1,
25204 Pragma_Test_Case
=> -1,
25205 Pragma_Thread_Local_Storage
=> -1,
25206 Pragma_Time_Slice
=> -1,
25208 Pragma_Type_Invariant
=> -1,
25209 Pragma_Type_Invariant_Class
=> -1,
25210 Pragma_Unchecked_Union
=> 0,
25211 Pragma_Unimplemented_Unit
=> 0,
25212 Pragma_Universal_Aliasing
=> 0,
25213 Pragma_Universal_Data
=> 0,
25214 Pragma_Unmodified
=> 0,
25215 Pragma_Unreferenced
=> 0,
25216 Pragma_Unreferenced_Objects
=> 0,
25217 Pragma_Unreserve_All_Interrupts
=> 0,
25218 Pragma_Unsuppress
=> 0,
25219 Pragma_Unevaluated_Use_Of_Old
=> 0,
25220 Pragma_Use_VADS_Size
=> 0,
25221 Pragma_Validity_Checks
=> 0,
25222 Pragma_Volatile
=> 0,
25223 Pragma_Volatile_Components
=> 0,
25224 Pragma_Warning_As_Error
=> 0,
25225 Pragma_Warnings
=> 0,
25226 Pragma_Weak_External
=> 0,
25227 Pragma_Wide_Character_Encoding
=> 0,
25228 Unknown_Pragma
=> 0);
25230 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25236 function Arg_No
return Nat
;
25237 -- Returns an integer showing what argument we are in. A value of
25238 -- zero means we are not in any of the arguments.
25244 function Arg_No
return Nat
is
25249 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25263 -- Start of processing for Non_Significant_Pragma_Reference
25268 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25272 Id
:= Get_Pragma_Id
(Parent
(P
));
25273 C
:= Sig_Flags
(Id
);
25288 return AN
< (C
- 90);
25294 end Is_Non_Significant_Pragma_Reference
;
25296 ------------------------------
25297 -- Is_Pragma_String_Literal --
25298 ------------------------------
25300 -- This function returns true if the corresponding pragma argument is a
25301 -- static string expression. These are the only cases in which string
25302 -- literals can appear as pragma arguments. We also allow a string literal
25303 -- as the first argument to pragma Assert (although it will of course
25304 -- always generate a type error).
25306 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
25307 Pragn
: constant Node_Id
:= Parent
(Par
);
25308 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
25309 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
25315 N
:= First
(Assoc
);
25322 if Pname
= Name_Assert
then
25325 elsif Pname
= Name_Export
then
25328 elsif Pname
= Name_Ident
then
25331 elsif Pname
= Name_Import
then
25334 elsif Pname
= Name_Interface_Name
then
25337 elsif Pname
= Name_Linker_Alias
then
25340 elsif Pname
= Name_Linker_Section
then
25343 elsif Pname
= Name_Machine_Attribute
then
25346 elsif Pname
= Name_Source_File_Name
then
25349 elsif Pname
= Name_Source_Reference
then
25352 elsif Pname
= Name_Title
then
25355 elsif Pname
= Name_Subtitle
then
25361 end Is_Pragma_String_Literal
;
25363 ---------------------------
25364 -- Is_Private_SPARK_Mode --
25365 ---------------------------
25367 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
25370 (Nkind
(N
) = N_Pragma
25371 and then Pragma_Name
(N
) = Name_SPARK_Mode
25372 and then Is_List_Member
(N
));
25374 -- For pragma SPARK_Mode to be private, it has to appear in the private
25375 -- declarations of a package.
25378 Present
(Parent
(N
))
25379 and then Nkind
(Parent
(N
)) = N_Package_Specification
25380 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
25381 end Is_Private_SPARK_Mode
;
25383 -------------------------------------
25384 -- Is_Unconstrained_Or_Tagged_Item --
25385 -------------------------------------
25387 function Is_Unconstrained_Or_Tagged_Item
25388 (Item
: Entity_Id
) return Boolean
25390 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
25391 -- Determine whether record type Typ has at least one unconstrained
25394 ---------------------------------
25395 -- Has_Unconstrained_Component --
25396 ---------------------------------
25398 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
25402 Comp
:= First_Component
(Typ
);
25403 while Present
(Comp
) loop
25404 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
25408 Next_Component
(Comp
);
25412 end Has_Unconstrained_Component
;
25416 Typ
: constant Entity_Id
:= Etype
(Item
);
25418 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
25421 if Is_Tagged_Type
(Typ
) then
25424 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
25427 elsif Is_Record_Type
(Typ
) then
25428 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
25431 return Has_Unconstrained_Component
(Typ
);
25434 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
25440 end Is_Unconstrained_Or_Tagged_Item
;
25442 -----------------------------
25443 -- Is_Valid_Assertion_Kind --
25444 -----------------------------
25446 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
25453 Name_Static_Predicate |
25454 Name_Dynamic_Predicate |
25459 Name_Type_Invariant |
25460 Name_uType_Invariant |
25464 Name_Assert_And_Cut |
25466 Name_Contract_Cases |
25468 Name_Default_Initial_Condition |
25469 Name_Initial_Condition |
25472 Name_Loop_Invariant |
25473 Name_Loop_Variant |
25474 Name_Postcondition |
25475 Name_Precondition |
25477 Name_Refined_Post |
25478 Name_Statement_Assertions
=> return True;
25480 when others => return False;
25482 end Is_Valid_Assertion_Kind
;
25484 -----------------------------------------
25485 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
25486 -----------------------------------------
25488 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
25489 Aspects
: constant List_Id
:= New_List
;
25490 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
25491 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
25493 Original_Aspects
: List_Id
;
25494 -- To capture global references, a copy of the created aspects must be
25495 -- inserted in the original tree.
25498 Prag_Arg_Ass
: Node_Id
;
25499 Prag_Id
: Pragma_Id
;
25502 -- Check for any PPC pragmas that appear within Decl
25504 Prag
:= Next
(Decl
);
25505 while Nkind
(Prag
) = N_Pragma
loop
25506 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
25509 when Pragma_Postcondition | Pragma_Precondition
=>
25510 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
25512 -- Make an aspect from any PPC pragma
25514 Append_To
(Aspects
,
25515 Make_Aspect_Specification
(Loc
,
25517 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
25519 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
25521 -- Generate the analysis information in the pragma expression
25522 -- and then set the pragma node analyzed to avoid any further
25525 Analyze
(Expression
(Prag_Arg_Ass
));
25526 Set_Analyzed
(Prag
, True);
25528 when others => null;
25534 -- Set all new aspects into the generic declaration node
25536 if Is_Non_Empty_List
(Aspects
) then
25538 -- Create the list of aspects to be inserted in the original tree
25540 Original_Aspects
:= Copy_Separate_List
(Aspects
);
25542 -- Check if Decl already has aspects
25544 -- Attach the new lists of aspects to both the generic copy and the
25547 if Has_Aspects
(Decl
) then
25548 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
25549 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
25552 Set_Parent
(Aspects
, Decl
);
25553 Set_Aspect_Specifications
(Decl
, Aspects
);
25554 Set_Parent
(Original_Aspects
, Or_Decl
);
25555 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
25558 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
25560 -------------------------
25561 -- Preanalyze_CTC_Args --
25562 -------------------------
25564 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
25566 -- Preanalyze the boolean expressions, we treat these as spec
25567 -- expressions (i.e. similar to a default expression).
25569 if Present
(Arg_Req
) then
25570 Preanalyze_Assert_Expression
25571 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
25573 -- In ASIS mode, for a pragma generated from a source aspect, also
25574 -- analyze the original aspect expression.
25576 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
25577 Preanalyze_Assert_Expression
25578 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
25582 if Present
(Arg_Ens
) then
25583 Preanalyze_Assert_Expression
25584 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
25586 -- In ASIS mode, for a pragma generated from a source aspect, also
25587 -- analyze the original aspect expression.
25589 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
25590 Preanalyze_Assert_Expression
25591 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
25594 end Preanalyze_CTC_Args
;
25596 --------------------------------------
25597 -- Process_Compilation_Unit_Pragmas --
25598 --------------------------------------
25600 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
25602 -- A special check for pragma Suppress_All, a very strange DEC pragma,
25603 -- strange because it comes at the end of the unit. Rational has the
25604 -- same name for a pragma, but treats it as a program unit pragma, In
25605 -- GNAT we just decide to allow it anywhere at all. If it appeared then
25606 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
25607 -- node, and we insert a pragma Suppress (All_Checks) at the start of
25608 -- the context clause to ensure the correct processing.
25610 if Has_Pragma_Suppress_All
(N
) then
25611 Prepend_To
(Context_Items
(N
),
25612 Make_Pragma
(Sloc
(N
),
25613 Chars
=> Name_Suppress
,
25614 Pragma_Argument_Associations
=> New_List
(
25615 Make_Pragma_Argument_Association
(Sloc
(N
),
25616 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
25619 -- Nothing else to do at the current time
25621 end Process_Compilation_Unit_Pragmas
;
25623 ------------------------------------
25624 -- Record_Possible_Body_Reference --
25625 ------------------------------------
25627 procedure Record_Possible_Body_Reference
25628 (State_Id
: Entity_Id
;
25632 Spec_Id
: Entity_Id
;
25635 -- Ensure that we are dealing with a reference to a state
25637 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
25639 -- Climb the tree starting from the reference looking for a package body
25640 -- whose spec declares the referenced state. This criteria automatically
25641 -- excludes references in package specs which are legal. Note that it is
25642 -- not wise to emit an error now as the package body may lack pragma
25643 -- Refined_State or the referenced state may not be mentioned in the
25644 -- refinement. This approach avoids the generation of misleading errors.
25647 while Present
(Context
) loop
25648 if Nkind
(Context
) = N_Package_Body
then
25649 Spec_Id
:= Corresponding_Spec
(Context
);
25651 if Present
(Abstract_States
(Spec_Id
))
25652 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
25654 if No
(Body_References
(State_Id
)) then
25655 Set_Body_References
(State_Id
, New_Elmt_List
);
25658 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
25663 Context
:= Parent
(Context
);
25665 end Record_Possible_Body_Reference
;
25667 ------------------------------
25668 -- Relocate_Pragmas_To_Body --
25669 ------------------------------
25671 procedure Relocate_Pragmas_To_Body
25672 (Subp_Body
: Node_Id
;
25673 Target_Body
: Node_Id
:= Empty
)
25675 procedure Relocate_Pragma
(Prag
: Node_Id
);
25676 -- Remove a single pragma from its current list and add it to the
25677 -- declarations of the proper body (either Subp_Body or Target_Body).
25679 ---------------------
25680 -- Relocate_Pragma --
25681 ---------------------
25683 procedure Relocate_Pragma
(Prag
: Node_Id
) is
25688 -- When subprogram stubs or expression functions are involves, the
25689 -- destination declaration list belongs to the proper body.
25691 if Present
(Target_Body
) then
25692 Target
:= Target_Body
;
25694 Target
:= Subp_Body
;
25697 Decls
:= Declarations
(Target
);
25701 Set_Declarations
(Target
, Decls
);
25704 -- Unhook the pragma from its current list
25707 Prepend
(Prag
, Decls
);
25708 end Relocate_Pragma
;
25712 Body_Id
: constant Entity_Id
:=
25713 Defining_Unit_Name
(Specification
(Subp_Body
));
25714 Next_Stmt
: Node_Id
;
25717 -- Start of processing for Relocate_Pragmas_To_Body
25720 -- Do not process a body that comes from a separate unit as no construct
25721 -- can possibly follow it.
25723 if not Is_List_Member
(Subp_Body
) then
25726 -- Do not relocate pragmas that follow a stub if the stub does not have
25729 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
25730 and then No
(Target_Body
)
25734 -- Do not process internally generated routine _Postconditions
25736 elsif Ekind
(Body_Id
) = E_Procedure
25737 and then Chars
(Body_Id
) = Name_uPostconditions
25742 -- Look at what is following the body. We are interested in certain kind
25743 -- of pragmas (either from source or byproducts of expansion) that can
25744 -- apply to a body [stub].
25746 Stmt
:= Next
(Subp_Body
);
25747 while Present
(Stmt
) loop
25749 -- Preserve the following statement for iteration purposes due to a
25750 -- possible relocation of a pragma.
25752 Next_Stmt
:= Next
(Stmt
);
25754 -- Move a candidate pragma following the body to the declarations of
25757 if Nkind
(Stmt
) = N_Pragma
25758 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
25760 Relocate_Pragma
(Stmt
);
25762 -- Skip internally generated code
25764 elsif not Comes_From_Source
(Stmt
) then
25767 -- No candidate pragmas are available for relocation
25775 end Relocate_Pragmas_To_Body
;
25777 -------------------
25778 -- Resolve_State --
25779 -------------------
25781 procedure Resolve_State
(N
: Node_Id
) is
25786 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
25787 Func
:= Entity
(N
);
25789 -- Handle overloading of state names by functions. Traverse the
25790 -- homonym chain looking for an abstract state.
25792 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
25793 State
:= Homonym
(Func
);
25794 while Present
(State
) loop
25796 -- Resolve the overloading by setting the proper entity of the
25797 -- reference to that of the state.
25799 if Ekind
(State
) = E_Abstract_State
then
25800 Set_Etype
(N
, Standard_Void_Type
);
25801 Set_Entity
(N
, State
);
25802 Set_Associated_Node
(N
, State
);
25806 State
:= Homonym
(State
);
25809 -- A function can never act as a state. If the homonym chain does
25810 -- not contain a corresponding state, then something went wrong in
25811 -- the overloading mechanism.
25813 raise Program_Error
;
25818 ----------------------------
25819 -- Rewrite_Assertion_Kind --
25820 ----------------------------
25822 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
25826 if Nkind
(N
) = N_Attribute_Reference
25827 and then Attribute_Name
(N
) = Name_Class
25828 and then Nkind
(Prefix
(N
)) = N_Identifier
25830 case Chars
(Prefix
(N
)) is
25835 when Name_Type_Invariant
=>
25836 Nam
:= Name_uType_Invariant
;
25837 when Name_Invariant
=>
25838 Nam
:= Name_uInvariant
;
25843 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
25845 end Rewrite_Assertion_Kind
;
25853 Dummy
:= Dummy
+ 1;
25856 --------------------------------
25857 -- Set_Encoded_Interface_Name --
25858 --------------------------------
25860 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
25861 Str
: constant String_Id
:= Strval
(S
);
25862 Len
: constant Int
:= String_Length
(Str
);
25867 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
25870 -- Stores encoded value of character code CC. The encoding we use an
25871 -- underscore followed by four lower case hex digits.
25877 procedure Encode
is
25879 Store_String_Char
(Get_Char_Code
('_'));
25881 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
25883 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
25885 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
25887 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
25890 -- Start of processing for Set_Encoded_Interface_Name
25893 -- If first character is asterisk, this is a link name, and we leave it
25894 -- completely unmodified. We also ignore null strings (the latter case
25895 -- happens only in error cases) and no encoding should occur for Java or
25896 -- AAMP interface names.
25899 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
25900 or else VM_Target
/= No_VM
25901 or else AAMP_On_Target
25903 Set_Interface_Name
(E
, S
);
25908 CC
:= Get_String_Char
(Str
, J
);
25910 exit when not In_Character_Range
(CC
);
25912 C
:= Get_Character
(CC
);
25914 exit when C
/= '_' and then C
/= '$'
25915 and then C
not in '0' .. '9'
25916 and then C
not in 'a' .. 'z'
25917 and then C
not in 'A' .. 'Z';
25920 Set_Interface_Name
(E
, S
);
25928 -- Here we need to encode. The encoding we use as follows:
25929 -- three underscores + four hex digits (lower case)
25933 for J
in 1 .. String_Length
(Str
) loop
25934 CC
:= Get_String_Char
(Str
, J
);
25936 if not In_Character_Range
(CC
) then
25939 C
:= Get_Character
(CC
);
25941 if C
= '_' or else C
= '$'
25942 or else C
in '0' .. '9'
25943 or else C
in 'a' .. 'z'
25944 or else C
in 'A' .. 'Z'
25946 Store_String_Char
(CC
);
25953 Set_Interface_Name
(E
,
25954 Make_String_Literal
(Sloc
(S
),
25955 Strval
=> End_String
));
25957 end Set_Encoded_Interface_Name
;
25959 -------------------
25960 -- Set_Unit_Name --
25961 -------------------
25963 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
25968 if Nkind
(N
) = N_Identifier
25969 and then Nkind
(With_Item
) = N_Identifier
25971 Set_Entity
(N
, Entity
(With_Item
));
25973 elsif Nkind
(N
) = N_Selected_Component
then
25974 Change_Selected_Component_To_Expanded_Name
(N
);
25975 Set_Entity
(N
, Entity
(With_Item
));
25976 Set_Entity
(Selector_Name
(N
), Entity
(N
));
25978 Pref
:= Prefix
(N
);
25979 Scop
:= Scope
(Entity
(N
));
25980 while Nkind
(Pref
) = N_Selected_Component
loop
25981 Change_Selected_Component_To_Expanded_Name
(Pref
);
25982 Set_Entity
(Selector_Name
(Pref
), Scop
);
25983 Set_Entity
(Pref
, Scop
);
25984 Pref
:= Prefix
(Pref
);
25985 Scop
:= Scope
(Scop
);
25988 Set_Entity
(Pref
, Scop
);