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.
3205 procedure Pragma_Misplaced
;
3206 pragma No_Return
(Pragma_Misplaced
);
3207 -- Issue fatal error message for misplaced pragma
3209 procedure Process_Atomic_Shared_Volatile
;
3210 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3211 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3212 -- in effect to pragma Atomic.
3214 procedure Process_Compile_Time_Warning_Or_Error
;
3215 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3217 procedure Process_Convention
3218 (C
: out Convention_Id
;
3219 Ent
: out Entity_Id
);
3220 -- Common processing for Convention, Interface, Import and Export.
3221 -- Checks first two arguments of pragma, and sets the appropriate
3222 -- convention value in the specified entity or entities. On return
3223 -- C is the convention, Ent is the referenced entity.
3225 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3226 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3227 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3229 procedure Process_Extended_Import_Export_Object_Pragma
3230 (Arg_Internal
: Node_Id
;
3231 Arg_External
: Node_Id
;
3232 Arg_Size
: Node_Id
);
3233 -- Common processing for the pragmas Import/Export_Object. The three
3234 -- arguments correspond to the three named parameters of the pragmas. An
3235 -- argument is empty if the corresponding parameter is not present in
3238 procedure Process_Extended_Import_Export_Internal_Arg
3239 (Arg_Internal
: Node_Id
:= Empty
);
3240 -- Common processing for all extended Import and Export pragmas. The
3241 -- argument is the pragma parameter for the Internal argument. If
3242 -- Arg_Internal is empty or inappropriate, an error message is posted.
3243 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3244 -- set to identify the referenced entity.
3246 procedure Process_Extended_Import_Export_Subprogram_Pragma
3247 (Arg_Internal
: Node_Id
;
3248 Arg_External
: Node_Id
;
3249 Arg_Parameter_Types
: Node_Id
;
3250 Arg_Result_Type
: Node_Id
:= Empty
;
3251 Arg_Mechanism
: Node_Id
;
3252 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3253 -- Common processing for all extended Import and Export pragmas applying
3254 -- to subprograms. The caller omits any arguments that do not apply to
3255 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3256 -- only in the Import_Function and Export_Function cases). The argument
3257 -- names correspond to the allowed pragma association identifiers.
3259 procedure Process_Generic_List
;
3260 -- Common processing for Share_Generic and Inline_Generic
3262 procedure Process_Import_Or_Interface
;
3263 -- Common processing for Import of Interface
3265 procedure Process_Import_Predefined_Type
;
3266 -- Processing for completing a type with pragma Import. This is used
3267 -- to declare types that match predefined C types, especially for cases
3268 -- without corresponding Ada predefined type.
3270 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3271 -- Inline status of a subprogram, indicated as follows:
3272 -- Suppressed: inlining is suppressed for the subprogram
3273 -- Disabled: no inlining is requested for the subprogram
3274 -- Enabled: inlining is requested/required for the subprogram
3276 procedure Process_Inline
(Status
: Inline_Status
);
3277 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3278 -- indicates the inline status specified by the pragma.
3280 procedure Process_Interface_Name
3281 (Subprogram_Def
: Entity_Id
;
3283 Link_Arg
: Node_Id
);
3284 -- Given the last two arguments of pragma Import, pragma Export, or
3285 -- pragma Interface_Name, performs validity checks and sets the
3286 -- Interface_Name field of the given subprogram entity to the
3287 -- appropriate external or link name, depending on the arguments given.
3288 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3289 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3290 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3291 -- nor Link_Arg is present, the interface name is set to the default
3292 -- from the subprogram name.
3294 procedure Process_Interrupt_Or_Attach_Handler
;
3295 -- Common processing for Interrupt and Attach_Handler pragmas
3297 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3298 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3299 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3300 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3301 -- is not set in the Restrictions case.
3303 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3304 -- Common processing for Suppress and Unsuppress. The boolean parameter
3305 -- Suppress_Case is True for the Suppress case, and False for the
3308 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3309 -- This procedure sets the Is_Exported flag for the given entity,
3310 -- checking that the entity was not previously imported. Arg is
3311 -- the argument that specified the entity. A check is also made
3312 -- for exporting inappropriate entities.
3314 procedure Set_Extended_Import_Export_External_Name
3315 (Internal_Ent
: Entity_Id
;
3316 Arg_External
: Node_Id
);
3317 -- Common processing for all extended import export pragmas. The first
3318 -- argument, Internal_Ent, is the internal entity, which has already
3319 -- been checked for validity by the caller. Arg_External is from the
3320 -- Import or Export pragma, and may be null if no External parameter
3321 -- was present. If Arg_External is present and is a non-null string
3322 -- (a null string is treated as the default), then the Interface_Name
3323 -- field of Internal_Ent is set appropriately.
3325 procedure Set_Imported
(E
: Entity_Id
);
3326 -- This procedure sets the Is_Imported flag for the given entity,
3327 -- checking that it is not previously exported or imported.
3329 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3330 -- Mech is a parameter passing mechanism (see Import_Function syntax
3331 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3332 -- has the right form, and if not issues an error message. If the
3333 -- argument has the right form then the Mechanism field of Ent is
3334 -- set appropriately.
3336 procedure Set_Rational_Profile
;
3337 -- Activate the set of configuration pragmas and permissions that make
3338 -- up the Rational profile.
3340 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3341 -- Activate the set of configuration pragmas and restrictions that make
3342 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3343 -- is used for error messages on any constructs violating the profile.
3345 ----------------------------------
3346 -- Acquire_Warning_Match_String --
3347 ----------------------------------
3349 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3351 String_To_Name_Buffer
3352 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3354 -- Add asterisk at start if not already there
3356 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3357 Name_Buffer
(2 .. Name_Len
+ 1) :=
3358 Name_Buffer
(1 .. Name_Len
);
3359 Name_Buffer
(1) := '*';
3360 Name_Len
:= Name_Len
+ 1;
3363 -- Add asterisk at end if not already there
3365 if Name_Buffer
(Name_Len
) /= '*' then
3366 Name_Len
:= Name_Len
+ 1;
3367 Name_Buffer
(Name_Len
) := '*';
3369 end Acquire_Warning_Match_String
;
3371 ---------------------
3372 -- Ada_2005_Pragma --
3373 ---------------------
3375 procedure Ada_2005_Pragma
is
3377 if Ada_Version
<= Ada_95
then
3378 Check_Restriction
(No_Implementation_Pragmas
, N
);
3380 end Ada_2005_Pragma
;
3382 ---------------------
3383 -- Ada_2012_Pragma --
3384 ---------------------
3386 procedure Ada_2012_Pragma
is
3388 if Ada_Version
<= Ada_2005
then
3389 Check_Restriction
(No_Implementation_Pragmas
, N
);
3391 end Ada_2012_Pragma
;
3393 ---------------------
3394 -- Analyze_Part_Of --
3395 ---------------------
3397 procedure Analyze_Part_Of
3398 (Item_Id
: Entity_Id
;
3401 Legal
: out Boolean)
3403 Pack_Id
: Entity_Id
;
3404 Placement
: State_Space_Kind
;
3405 Parent_Unit
: Entity_Id
;
3406 State_Id
: Entity_Id
;
3409 -- Assume that the pragma/option is illegal
3413 if Nkind_In
(State
, N_Expanded_Name
,
3415 N_Selected_Component
)
3418 Resolve_State
(State
);
3420 if Is_Entity_Name
(State
)
3421 and then Ekind
(Entity
(State
)) = E_Abstract_State
3423 State_Id
:= Entity
(State
);
3427 ("indicator Part_Of must denote an abstract state", State
);
3431 -- This is a syntax error, always report
3435 ("indicator Part_Of must denote an abstract state", State
);
3439 -- Determine where the state, variable or the package instantiation
3440 -- lives with respect to the enclosing packages or package bodies (if
3441 -- any). This placement dictates the legality of the encapsulating
3444 Find_Placement_In_State_Space
3445 (Item_Id
=> Item_Id
,
3446 Placement
=> Placement
,
3447 Pack_Id
=> Pack_Id
);
3449 -- The item appears in a non-package construct with a declarative
3450 -- part (subprogram, block, etc). As such, the item is not allowed
3451 -- to be a part of an encapsulating state because the item is not
3454 if Placement
= Not_In_Package
then
3456 ("indicator Part_Of cannot appear in this context "
3457 & "(SPARK RM 7.2.6(5))", Indic
);
3458 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3460 ("\& is not part of the hidden state of package %",
3463 -- The item appears in the visible state space of some package. In
3464 -- general this scenario does not warrant Part_Of except when the
3465 -- package is a private child unit and the encapsulating state is
3466 -- declared in a parent unit or a public descendant of that parent
3469 elsif Placement
= Visible_State_Space
then
3470 if Is_Child_Unit
(Pack_Id
)
3471 and then Is_Private_Descendant
(Pack_Id
)
3473 -- A variable or state abstraction which is part of the
3474 -- visible state of a private child unit (or one of its public
3475 -- descendants) must have its Part_Of indicator specified. The
3476 -- Part_Of indicator must denote a state abstraction declared
3477 -- by either the parent unit of the private unit or by a public
3478 -- descendant of that parent unit.
3480 -- Find nearest private ancestor (which can be the current unit
3483 Parent_Unit
:= Pack_Id
;
3484 while Present
(Parent_Unit
) loop
3485 exit when Private_Present
3486 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3487 Parent_Unit
:= Scope
(Parent_Unit
);
3490 Parent_Unit
:= Scope
(Parent_Unit
);
3492 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3494 ("indicator Part_Of must denote an abstract state of& "
3495 & "or public descendant (SPARK RM 7.2.6(3))",
3496 Indic
, Parent_Unit
);
3498 elsif Scope
(State_Id
) = Parent_Unit
3499 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3501 not Is_Private_Descendant
(Scope
(State_Id
)))
3507 ("indicator Part_Of must denote an abstract state of& "
3508 & "or public descendant (SPARK RM 7.2.6(3))",
3509 Indic
, Parent_Unit
);
3512 -- Indicator Part_Of is not needed when the related package is not
3513 -- a private child unit or a public descendant thereof.
3517 ("indicator Part_Of cannot appear in this context "
3518 & "(SPARK RM 7.2.6(5))", Indic
);
3519 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3521 ("\& is declared in the visible part of package %",
3525 -- When the item appears in the private state space of a package, the
3526 -- encapsulating state must be declared in the same package.
3528 elsif Placement
= Private_State_Space
then
3529 if Scope
(State_Id
) /= Pack_Id
then
3531 ("indicator Part_Of must designate an abstract state of "
3532 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3533 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3535 ("\& is declared in the private part of package %",
3539 -- Items declared in the body state space of a package do not need
3540 -- Part_Of indicators as the refinement has already been seen.
3544 ("indicator Part_Of cannot appear in this context "
3545 & "(SPARK RM 7.2.6(5))", Indic
);
3547 if Scope
(State_Id
) = Pack_Id
then
3548 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3550 ("\& is declared in the body of package %", Indic
, Item_Id
);
3555 end Analyze_Part_Of
;
3557 ----------------------------
3558 -- Analyze_Refined_Pragma --
3559 ----------------------------
3561 procedure Analyze_Refined_Pragma
3562 (Spec_Id
: out Entity_Id
;
3563 Body_Id
: out Entity_Id
;
3564 Legal
: out Boolean)
3566 Body_Decl
: Node_Id
;
3567 Spec_Decl
: Node_Id
;
3570 -- Assume that the pragma is illegal
3577 Check_Arg_Count
(1);
3578 Check_No_Identifiers
;
3580 if Nam_In
(Pname
, Name_Refined_Depends
,
3581 Name_Refined_Global
,
3584 Ensure_Aggregate_Form
(Arg1
);
3587 -- Verify the placement of the pragma and check for duplicates. The
3588 -- pragma must apply to a subprogram body [stub].
3590 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3592 -- Extract the entities of the spec and body
3594 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3595 Body_Id
:= Defining_Entity
(Body_Decl
);
3596 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3598 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3599 Body_Id
:= Defining_Entity
(Body_Decl
);
3600 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3607 -- The pragma must apply to the second declaration of a subprogram.
3608 -- In other words, the body [stub] cannot acts as a spec.
3610 if No
(Spec_Id
) then
3611 Error_Pragma
("pragma % cannot apply to a stand alone body");
3614 -- Catch the case where the subprogram body is a subunit and acts as
3615 -- the third declaration of the subprogram.
3617 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3618 Error_Pragma
("pragma % cannot apply to a subunit");
3622 -- The pragma can only apply to the body [stub] of a subprogram
3623 -- declared in the visible part of a package. Retrieve the context of
3624 -- the subprogram declaration.
3626 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3628 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3630 ("pragma % must apply to the body of a subprogram declared in a "
3631 & "package specification");
3635 -- If we get here, then the pragma is legal
3638 end Analyze_Refined_Pragma
;
3640 --------------------------
3641 -- Check_Ada_83_Warning --
3642 --------------------------
3644 procedure Check_Ada_83_Warning
is
3646 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3647 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3649 end Check_Ada_83_Warning
;
3651 ---------------------
3652 -- Check_Arg_Count --
3653 ---------------------
3655 procedure Check_Arg_Count
(Required
: Nat
) is
3657 if Arg_Count
/= Required
then
3658 Error_Pragma
("wrong number of arguments for pragma%");
3660 end Check_Arg_Count
;
3662 --------------------------------
3663 -- Check_Arg_Is_External_Name --
3664 --------------------------------
3666 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3667 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3670 if Nkind
(Argx
) = N_Identifier
then
3674 Analyze_And_Resolve
(Argx
, Standard_String
);
3676 if Is_OK_Static_Expression
(Argx
) then
3679 elsif Etype
(Argx
) = Any_Type
then
3682 -- An interesting special case, if we have a string literal and
3683 -- we are in Ada 83 mode, then we allow it even though it will
3684 -- not be flagged as static. This allows expected Ada 83 mode
3685 -- use of external names which are string literals, even though
3686 -- technically these are not static in Ada 83.
3688 elsif Ada_Version
= Ada_83
3689 and then Nkind
(Argx
) = N_String_Literal
3693 -- Static expression that raises Constraint_Error. This has
3694 -- already been flagged, so just exit from pragma processing.
3696 elsif Is_OK_Static_Expression
(Argx
) then
3699 -- Here we have a real error (non-static expression)
3702 Error_Msg_Name_1
:= Pname
;
3705 Msg
: constant String :=
3706 "argument for pragma% must be a identifier or "
3707 & "static string expression!";
3709 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3714 end Check_Arg_Is_External_Name
;
3716 -----------------------------
3717 -- Check_Arg_Is_Identifier --
3718 -----------------------------
3720 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3721 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3723 if Nkind
(Argx
) /= N_Identifier
then
3725 ("argument for pragma% must be identifier", Argx
);
3727 end Check_Arg_Is_Identifier
;
3729 ----------------------------------
3730 -- Check_Arg_Is_Integer_Literal --
3731 ----------------------------------
3733 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3734 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3736 if Nkind
(Argx
) /= N_Integer_Literal
then
3738 ("argument for pragma% must be integer literal", Argx
);
3740 end Check_Arg_Is_Integer_Literal
;
3742 -------------------------------------------
3743 -- Check_Arg_Is_Library_Level_Local_Name --
3744 -------------------------------------------
3748 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3749 -- | library_unit_NAME
3751 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3753 Check_Arg_Is_Local_Name
(Arg
);
3755 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3756 and then Comes_From_Source
(N
)
3759 ("argument for pragma% must be library level entity", Arg
);
3761 end Check_Arg_Is_Library_Level_Local_Name
;
3763 -----------------------------
3764 -- Check_Arg_Is_Local_Name --
3765 -----------------------------
3769 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3770 -- | library_unit_NAME
3772 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3773 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3778 if Nkind
(Argx
) not in N_Direct_Name
3779 and then (Nkind
(Argx
) /= N_Attribute_Reference
3780 or else Present
(Expressions
(Argx
))
3781 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3782 and then (not Is_Entity_Name
(Argx
)
3783 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3785 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3788 -- No further check required if not an entity name
3790 if not Is_Entity_Name
(Argx
) then
3796 Ent
: constant Entity_Id
:= Entity
(Argx
);
3797 Scop
: constant Entity_Id
:= Scope
(Ent
);
3800 -- Case of a pragma applied to a compilation unit: pragma must
3801 -- occur immediately after the program unit in the compilation.
3803 if Is_Compilation_Unit
(Ent
) then
3805 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3808 -- Case of pragma placed immediately after spec
3810 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3813 -- Case of pragma placed immediately after body
3815 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3816 and then Present
(Corresponding_Body
(Decl
))
3820 (Parent
(Unit_Declaration_Node
3821 (Corresponding_Body
(Decl
))));
3823 -- All other cases are illegal
3830 -- Special restricted placement rule from 10.2.1(11.8/2)
3832 elsif Is_Generic_Formal
(Ent
)
3833 and then Prag_Id
= Pragma_Preelaborable_Initialization
3835 OK
:= List_Containing
(N
) =
3836 Generic_Formal_Declarations
3837 (Unit_Declaration_Node
(Scop
));
3839 -- If this is an aspect applied to a subprogram body, the
3840 -- pragma is inserted in its declarative part.
3842 elsif From_Aspect_Specification
(N
)
3844 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3845 and then Ent
= Current_Scope
3849 -- If the aspect is a predicate (possibly others ???) and the
3850 -- context is a record type, this is a discriminant expression
3851 -- within a type declaration, that freezes the predicated
3854 elsif From_Aspect_Specification
(N
)
3855 and then Prag_Id
= Pragma_Predicate
3856 and then Ekind
(Current_Scope
) = E_Record_Type
3857 and then Scop
= Scope
(Current_Scope
)
3861 -- Default case, just check that the pragma occurs in the scope
3862 -- of the entity denoted by the name.
3865 OK
:= Current_Scope
= Scop
;
3870 ("pragma% argument must be in same declarative part", Arg
);
3874 end Check_Arg_Is_Local_Name
;
3876 ---------------------------------
3877 -- Check_Arg_Is_Locking_Policy --
3878 ---------------------------------
3880 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3881 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3884 Check_Arg_Is_Identifier
(Argx
);
3886 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3887 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3889 end Check_Arg_Is_Locking_Policy
;
3891 -----------------------------------------------
3892 -- Check_Arg_Is_Partition_Elaboration_Policy --
3893 -----------------------------------------------
3895 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3896 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3899 Check_Arg_Is_Identifier
(Argx
);
3901 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3903 ("& is not a valid partition elaboration policy name", Argx
);
3905 end Check_Arg_Is_Partition_Elaboration_Policy
;
3907 -------------------------
3908 -- Check_Arg_Is_One_Of --
3909 -------------------------
3911 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3912 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3915 Check_Arg_Is_Identifier
(Argx
);
3917 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3918 Error_Msg_Name_2
:= N1
;
3919 Error_Msg_Name_3
:= N2
;
3920 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3922 end Check_Arg_Is_One_Of
;
3924 procedure Check_Arg_Is_One_Of
3926 N1
, N2
, N3
: Name_Id
)
3928 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3931 Check_Arg_Is_Identifier
(Argx
);
3933 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3934 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3936 end Check_Arg_Is_One_Of
;
3938 procedure Check_Arg_Is_One_Of
3940 N1
, N2
, N3
, N4
: Name_Id
)
3942 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3945 Check_Arg_Is_Identifier
(Argx
);
3947 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3948 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3950 end Check_Arg_Is_One_Of
;
3952 procedure Check_Arg_Is_One_Of
3954 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3956 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3959 Check_Arg_Is_Identifier
(Argx
);
3961 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3962 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3964 end Check_Arg_Is_One_Of
;
3966 ---------------------------------
3967 -- Check_Arg_Is_Queuing_Policy --
3968 ---------------------------------
3970 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3971 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3974 Check_Arg_Is_Identifier
(Argx
);
3976 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3977 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3979 end Check_Arg_Is_Queuing_Policy
;
3981 ---------------------------------------
3982 -- Check_Arg_Is_OK_Static_Expression --
3983 ---------------------------------------
3985 procedure Check_Arg_Is_OK_Static_Expression
3987 Typ
: Entity_Id
:= Empty
)
3990 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
3991 end Check_Arg_Is_OK_Static_Expression
;
3993 ------------------------------------------
3994 -- Check_Arg_Is_Task_Dispatching_Policy --
3995 ------------------------------------------
3997 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
3998 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4001 Check_Arg_Is_Identifier
(Argx
);
4003 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4005 ("& is not an allowed task dispatching policy name", Argx
);
4007 end Check_Arg_Is_Task_Dispatching_Policy
;
4009 ---------------------
4010 -- Check_Arg_Order --
4011 ---------------------
4013 procedure Check_Arg_Order
(Names
: Name_List
) is
4016 Highest_So_Far
: Natural := 0;
4017 -- Highest index in Names seen do far
4021 for J
in 1 .. Arg_Count
loop
4022 if Chars
(Arg
) /= No_Name
then
4023 for K
in Names
'Range loop
4024 if Chars
(Arg
) = Names
(K
) then
4025 if K
< Highest_So_Far
then
4026 Error_Msg_Name_1
:= Pname
;
4028 ("parameters out of order for pragma%", Arg
);
4029 Error_Msg_Name_1
:= Names
(K
);
4030 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4031 Error_Msg_N
("\% must appear before %", Arg
);
4035 Highest_So_Far
:= K
;
4043 end Check_Arg_Order
;
4045 --------------------------------
4046 -- Check_At_Least_N_Arguments --
4047 --------------------------------
4049 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4051 if Arg_Count
< N
then
4052 Error_Pragma
("too few arguments for pragma%");
4054 end Check_At_Least_N_Arguments
;
4056 -------------------------------
4057 -- Check_At_Most_N_Arguments --
4058 -------------------------------
4060 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4063 if Arg_Count
> N
then
4065 for J
in 1 .. N
loop
4067 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4070 end Check_At_Most_N_Arguments
;
4072 ---------------------
4073 -- Check_Component --
4074 ---------------------
4076 procedure Check_Component
4079 In_Variant_Part
: Boolean := False)
4081 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4082 Sindic
: constant Node_Id
:=
4083 Subtype_Indication
(Component_Definition
(Comp
));
4084 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4087 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4088 -- object constraint, then the component type shall be an Unchecked_
4091 if Nkind
(Sindic
) = N_Subtype_Indication
4092 and then Has_Per_Object_Constraint
(Comp_Id
)
4093 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4096 ("component subtype subject to per-object constraint "
4097 & "must be an Unchecked_Union", Comp
);
4099 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4100 -- the body of a generic unit, or within the body of any of its
4101 -- descendant library units, no part of the type of a component
4102 -- declared in a variant_part of the unchecked union type shall be of
4103 -- a formal private type or formal private extension declared within
4104 -- the formal part of the generic unit.
4106 elsif Ada_Version
>= Ada_2012
4107 and then In_Generic_Body
(UU_Typ
)
4108 and then In_Variant_Part
4109 and then Is_Private_Type
(Typ
)
4110 and then Is_Generic_Type
(Typ
)
4113 ("component of unchecked union cannot be of generic type", Comp
);
4115 elsif Needs_Finalization
(Typ
) then
4117 ("component of unchecked union cannot be controlled", Comp
);
4119 elsif Has_Task
(Typ
) then
4121 ("component of unchecked union cannot have tasks", Comp
);
4123 end Check_Component
;
4125 -----------------------------
4126 -- Check_Declaration_Order --
4127 -----------------------------
4129 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4130 procedure Check_Aspect_Specification_Order
;
4131 -- Inspect the aspect specifications of the context to determine the
4134 --------------------------------------
4135 -- Check_Aspect_Specification_Order --
4136 --------------------------------------
4138 procedure Check_Aspect_Specification_Order
is
4139 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4140 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4144 -- Both aspects must be part of the same aspect specification list
4147 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4149 -- Try to reach Second starting from First in a left to right
4150 -- traversal of the aspect specifications.
4152 Asp
:= Next
(Asp_First
);
4153 while Present
(Asp
) loop
4155 -- The order is ok, First is followed by Second
4157 if Asp
= Asp_Second
then
4164 -- If we get here, then the aspects are out of order
4166 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4167 end Check_Aspect_Specification_Order
;
4173 -- Start of processing for Check_Declaration_Order
4176 -- Cannot check the order if one of the pragmas is missing
4178 if No
(First
) or else No
(Second
) then
4182 -- Set up the error names in case the order is incorrect
4184 Error_Msg_Name_1
:= Pragma_Name
(First
);
4185 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4187 if From_Aspect_Specification
(First
) then
4189 -- Both pragmas are actually aspects, check their declaration
4190 -- order in the associated aspect specification list. Otherwise
4191 -- First is an aspect and Second a source pragma.
4193 if From_Aspect_Specification
(Second
) then
4194 Check_Aspect_Specification_Order
;
4197 -- Abstract_States is a source pragma
4200 if From_Aspect_Specification
(Second
) then
4201 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4203 -- Both pragmas are source constructs. Try to reach First from
4204 -- Second by traversing the declarations backwards.
4207 Stmt
:= Prev
(Second
);
4208 while Present
(Stmt
) loop
4210 -- The order is ok, First is followed by Second
4212 if Stmt
= First
then
4219 -- If we get here, then the pragmas are out of order
4221 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4224 end Check_Declaration_Order
;
4226 ----------------------------
4227 -- Check_Duplicate_Pragma --
4228 ----------------------------
4230 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4231 Id
: Entity_Id
:= E
;
4235 -- Nothing to do if this pragma comes from an aspect specification,
4236 -- since we could not be duplicating a pragma, and we dealt with the
4237 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4239 if From_Aspect_Specification
(N
) then
4243 -- Otherwise current pragma may duplicate previous pragma or a
4244 -- previously given aspect specification or attribute definition
4245 -- clause for the same pragma.
4247 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4251 -- If the entity is a type, then we have to make sure that the
4252 -- ostensible duplicate is not for a parent type from which this
4256 if Nkind
(P
) = N_Pragma
then
4258 Args
: constant List_Id
:=
4259 Pragma_Argument_Associations
(P
);
4262 and then Is_Entity_Name
(Expression
(First
(Args
)))
4263 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4264 and then Entity
(Expression
(First
(Args
))) /= E
4270 elsif Nkind
(P
) = N_Aspect_Specification
4271 and then Is_Type
(Entity
(P
))
4272 and then Entity
(P
) /= E
4278 -- Here we have a definite duplicate
4280 Error_Msg_Name_1
:= Pragma_Name
(N
);
4281 Error_Msg_Sloc
:= Sloc
(P
);
4283 -- For a single protected or a single task object, the error is
4284 -- issued on the original entity.
4286 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4287 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4290 if Nkind
(P
) = N_Aspect_Specification
4291 or else From_Aspect_Specification
(P
)
4293 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4295 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4300 end Check_Duplicate_Pragma
;
4302 ----------------------------------
4303 -- Check_Duplicated_Export_Name --
4304 ----------------------------------
4306 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4307 String_Val
: constant String_Id
:= Strval
(Nam
);
4310 -- We are only interested in the export case, and in the case of
4311 -- generics, it is the instance, not the template, that is the
4312 -- problem (the template will generate a warning in any case).
4314 if not Inside_A_Generic
4315 and then (Prag_Id
= Pragma_Export
4317 Prag_Id
= Pragma_Export_Procedure
4319 Prag_Id
= Pragma_Export_Valued_Procedure
4321 Prag_Id
= Pragma_Export_Function
)
4323 for J
in Externals
.First
.. Externals
.Last
loop
4324 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4325 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4326 Error_Msg_N
("external name duplicates name given#", Nam
);
4331 Externals
.Append
(Nam
);
4333 end Check_Duplicated_Export_Name
;
4335 ----------------------------------------
4336 -- Check_Expr_Is_OK_Static_Expression --
4337 ----------------------------------------
4339 procedure Check_Expr_Is_OK_Static_Expression
4341 Typ
: Entity_Id
:= Empty
)
4344 if Present
(Typ
) then
4345 Analyze_And_Resolve
(Expr
, Typ
);
4347 Analyze_And_Resolve
(Expr
);
4350 if Is_OK_Static_Expression
(Expr
) then
4353 elsif Etype
(Expr
) = Any_Type
then
4356 -- An interesting special case, if we have a string literal and we
4357 -- are in Ada 83 mode, then we allow it even though it will not be
4358 -- flagged as static. This allows the use of Ada 95 pragmas like
4359 -- Import in Ada 83 mode. They will of course be flagged with
4360 -- warnings as usual, but will not cause errors.
4362 elsif Ada_Version
= Ada_83
4363 and then Nkind
(Expr
) = N_String_Literal
4367 -- Static expression that raises Constraint_Error. This has already
4368 -- been flagged, so just exit from pragma processing.
4370 elsif Is_OK_Static_Expression
(Expr
) then
4373 -- Finally, we have a real error
4376 Error_Msg_Name_1
:= Pname
;
4377 Flag_Non_Static_Expr
4378 (Fix_Error
("argument for pragma% must be a static expression!"),
4382 end Check_Expr_Is_OK_Static_Expression
;
4384 -------------------------
4385 -- Check_First_Subtype --
4386 -------------------------
4388 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4389 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4390 Ent
: constant Entity_Id
:= Entity
(Argx
);
4393 if Is_First_Subtype
(Ent
) then
4396 elsif Is_Type
(Ent
) then
4398 ("pragma% cannot apply to subtype", Argx
);
4400 elsif Is_Object
(Ent
) then
4402 ("pragma% cannot apply to object, requires a type", Argx
);
4406 ("pragma% cannot apply to&, requires a type", Argx
);
4408 end Check_First_Subtype
;
4410 ----------------------
4411 -- Check_Identifier --
4412 ----------------------
4414 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4417 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4419 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4420 Error_Msg_Name_1
:= Pname
;
4421 Error_Msg_Name_2
:= Id
;
4422 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4426 end Check_Identifier
;
4428 --------------------------------
4429 -- Check_Identifier_Is_One_Of --
4430 --------------------------------
4432 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4435 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4437 if Chars
(Arg
) = No_Name
then
4438 Error_Msg_Name_1
:= Pname
;
4439 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4442 elsif Chars
(Arg
) /= N1
4443 and then Chars
(Arg
) /= N2
4445 Error_Msg_Name_1
:= Pname
;
4446 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4450 end Check_Identifier_Is_One_Of
;
4452 ---------------------------
4453 -- Check_In_Main_Program --
4454 ---------------------------
4456 procedure Check_In_Main_Program
is
4457 P
: constant Node_Id
:= Parent
(N
);
4460 -- Must be at in subprogram body
4462 if Nkind
(P
) /= N_Subprogram_Body
then
4463 Error_Pragma
("% pragma allowed only in subprogram");
4465 -- Otherwise warn if obviously not main program
4467 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4468 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4470 Error_Msg_Name_1
:= Pname
;
4472 ("??pragma% is only effective in main program", N
);
4474 end Check_In_Main_Program
;
4476 ---------------------------------------
4477 -- Check_Interrupt_Or_Attach_Handler --
4478 ---------------------------------------
4480 procedure Check_Interrupt_Or_Attach_Handler
is
4481 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4482 Handler_Proc
, Proc_Scope
: Entity_Id
;
4487 if Prag_Id
= Pragma_Interrupt_Handler
then
4488 Check_Restriction
(No_Dynamic_Attachment
, N
);
4491 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4492 Proc_Scope
:= Scope
(Handler_Proc
);
4494 -- On AAMP only, a pragma Interrupt_Handler is supported for
4495 -- nonprotected parameterless procedures.
4497 if not AAMP_On_Target
4498 or else Prag_Id
= Pragma_Attach_Handler
4500 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4502 ("argument of pragma% must be protected procedure", Arg1
);
4505 -- For pragma case (as opposed to access case), check placement.
4506 -- We don't need to do that for aspects, because we have the
4507 -- check that they aspect applies an appropriate procedure.
4509 if not From_Aspect_Specification
(N
)
4510 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4512 Error_Pragma
("pragma% must be in protected definition");
4516 if not Is_Library_Level_Entity
(Proc_Scope
)
4517 or else (AAMP_On_Target
4518 and then not Is_Library_Level_Entity
(Handler_Proc
))
4521 ("argument for pragma% must be library level entity", Arg1
);
4524 -- AI05-0033: A pragma cannot appear within a generic body, because
4525 -- instance can be in a nested scope. The check that protected type
4526 -- is itself a library-level declaration is done elsewhere.
4528 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4529 -- handle code prior to AI-0033. Analysis tools typically are not
4530 -- interested in this pragma in any case, so no need to worry too
4531 -- much about its placement.
4533 if Inside_A_Generic
then
4534 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4535 and then In_Package_Body
(Scope
(Current_Scope
))
4536 and then not Relaxed_RM_Semantics
4538 Error_Pragma
("pragma% cannot be used inside a generic");
4541 end Check_Interrupt_Or_Attach_Handler
;
4543 ---------------------------------
4544 -- Check_Loop_Pragma_Placement --
4545 ---------------------------------
4547 procedure Check_Loop_Pragma_Placement
is
4548 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4549 -- Verify whether the current pragma is properly grouped with other
4550 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4551 -- related loop where the pragma appears.
4553 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4554 -- Determine whether an arbitrary statement Stmt denotes pragma
4555 -- Loop_Invariant or Loop_Variant.
4557 procedure Placement_Error
(Constr
: Node_Id
);
4558 pragma No_Return
(Placement_Error
);
4559 -- Node Constr denotes the last loop restricted construct before we
4560 -- encountered an illegal relation between enclosing constructs. Emit
4561 -- an error depending on what Constr was.
4563 --------------------------------
4564 -- Check_Loop_Pragma_Grouping --
4565 --------------------------------
4567 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4568 Stop_Search
: exception;
4569 -- This exception is used to terminate the recursive descent of
4570 -- routine Check_Grouping.
4572 procedure Check_Grouping
(L
: List_Id
);
4573 -- Find the first group of pragmas in list L and if successful,
4574 -- ensure that the current pragma is part of that group. The
4575 -- routine raises Stop_Search once such a check is performed to
4576 -- halt the recursive descent.
4578 procedure Grouping_Error
(Prag
: Node_Id
);
4579 pragma No_Return
(Grouping_Error
);
4580 -- Emit an error concerning the current pragma indicating that it
4581 -- should be placed after pragma Prag.
4583 --------------------
4584 -- Check_Grouping --
4585 --------------------
4587 procedure Check_Grouping
(L
: List_Id
) is
4593 -- Inspect the list of declarations or statements looking for
4594 -- the first grouping of pragmas:
4597 -- pragma Loop_Invariant ...;
4598 -- pragma Loop_Variant ...;
4600 -- pragma Loop_Variant ...; -- current pragma
4602 -- If the current pragma is not in the grouping, then it must
4603 -- either appear in a different declarative or statement list
4604 -- or the construct at (1) is separating the pragma from the
4608 while Present
(Stmt
) loop
4610 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4611 -- inside a loop or a block housed inside a loop. Inspect
4612 -- the declarations and statements of the block as they may
4613 -- contain the first grouping.
4615 if Nkind
(Stmt
) = N_Block_Statement
then
4616 HSS
:= Handled_Statement_Sequence
(Stmt
);
4618 Check_Grouping
(Declarations
(Stmt
));
4620 if Present
(HSS
) then
4621 Check_Grouping
(Statements
(HSS
));
4624 -- First pragma of the first topmost grouping has been found
4626 elsif Is_Loop_Pragma
(Stmt
) then
4628 -- The group and the current pragma are not in the same
4629 -- declarative or statement list.
4631 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4632 Grouping_Error
(Stmt
);
4634 -- Try to reach the current pragma from the first pragma
4635 -- of the grouping while skipping other members:
4637 -- pragma Loop_Invariant ...; -- first pragma
4638 -- pragma Loop_Variant ...; -- member
4640 -- pragma Loop_Variant ...; -- current pragma
4643 while Present
(Stmt
) loop
4645 -- The current pragma is either the first pragma
4646 -- of the group or is a member of the group. Stop
4647 -- the search as the placement is legal.
4652 -- Skip group members, but keep track of the last
4653 -- pragma in the group.
4655 elsif Is_Loop_Pragma
(Stmt
) then
4658 -- A non-pragma is separating the group from the
4659 -- current pragma, the placement is illegal.
4662 Grouping_Error
(Prag
);
4668 -- If the traversal did not reach the current pragma,
4669 -- then the list must be malformed.
4671 raise Program_Error
;
4679 --------------------
4680 -- Grouping_Error --
4681 --------------------
4683 procedure Grouping_Error
(Prag
: Node_Id
) is
4685 Error_Msg_Sloc
:= Sloc
(Prag
);
4686 Error_Pragma
("pragma% must appear next to pragma#");
4689 -- Start of processing for Check_Loop_Pragma_Grouping
4692 -- Inspect the statements of the loop or nested blocks housed
4693 -- within to determine whether the current pragma is part of the
4694 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4696 Check_Grouping
(Statements
(Loop_Stmt
));
4699 when Stop_Search
=> null;
4700 end Check_Loop_Pragma_Grouping
;
4702 --------------------
4703 -- Is_Loop_Pragma --
4704 --------------------
4706 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4708 -- Inspect the original node as Loop_Invariant and Loop_Variant
4709 -- pragmas are rewritten to null when assertions are disabled.
4711 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4713 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4714 Name_Loop_Invariant
,
4721 ---------------------
4722 -- Placement_Error --
4723 ---------------------
4725 procedure Placement_Error
(Constr
: Node_Id
) is
4726 LA
: constant String := " with Loop_Entry";
4729 if Prag_Id
= Pragma_Assert
then
4730 Error_Msg_String
(1 .. LA
'Length) := LA
;
4731 Error_Msg_Strlen
:= LA
'Length;
4733 Error_Msg_Strlen
:= 0;
4736 if Nkind
(Constr
) = N_Pragma
then
4738 ("pragma %~ must appear immediately within the statements "
4742 ("block containing pragma %~ must appear immediately within "
4743 & "the statements of a loop", Constr
);
4745 end Placement_Error
;
4747 -- Local declarations
4752 -- Start of processing for Check_Loop_Pragma_Placement
4755 -- Check that pragma appears immediately within a loop statement,
4756 -- ignoring intervening block statements.
4760 while Present
(Stmt
) loop
4762 -- The pragma or previous block must appear immediately within the
4763 -- current block's declarative or statement part.
4765 if Nkind
(Stmt
) = N_Block_Statement
then
4766 if (No
(Declarations
(Stmt
))
4767 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4769 List_Containing
(Prev
) /=
4770 Statements
(Handled_Statement_Sequence
(Stmt
))
4772 Placement_Error
(Prev
);
4775 -- Keep inspecting the parents because we are now within a
4776 -- chain of nested blocks.
4780 Stmt
:= Parent
(Stmt
);
4783 -- The pragma or previous block must appear immediately within the
4784 -- statements of the loop.
4786 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4787 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4788 Placement_Error
(Prev
);
4791 -- Stop the traversal because we reached the innermost loop
4792 -- regardless of whether we encountered an error or not.
4796 -- Ignore a handled statement sequence. Note that this node may
4797 -- be related to a subprogram body in which case we will emit an
4798 -- error on the next iteration of the search.
4800 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4801 Stmt
:= Parent
(Stmt
);
4803 -- Any other statement breaks the chain from the pragma to the
4807 Placement_Error
(Prev
);
4812 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4813 -- grouped together with other such pragmas.
4815 if Is_Loop_Pragma
(N
) then
4817 -- The previous check should have located the related loop
4819 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4820 Check_Loop_Pragma_Grouping
(Stmt
);
4822 end Check_Loop_Pragma_Placement
;
4824 -------------------------------------------
4825 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4826 -------------------------------------------
4828 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4837 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4840 elsif Nkind_In
(P
, N_Package_Specification
,
4845 -- Note: the following tests seem a little peculiar, because
4846 -- they test for bodies, but if we were in the statement part
4847 -- of the body, we would already have hit the handled statement
4848 -- sequence, so the only way we get here is by being in the
4849 -- declarative part of the body.
4851 elsif Nkind_In
(P
, N_Subprogram_Body
,
4862 Error_Pragma
("pragma% is not in declarative part or package spec");
4863 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4865 -------------------------
4866 -- Check_No_Identifier --
4867 -------------------------
4869 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4871 if Nkind
(Arg
) = N_Pragma_Argument_Association
4872 and then Chars
(Arg
) /= No_Name
4874 Error_Pragma_Arg_Ident
4875 ("pragma% does not permit identifier& here", Arg
);
4877 end Check_No_Identifier
;
4879 --------------------------
4880 -- Check_No_Identifiers --
4881 --------------------------
4883 procedure Check_No_Identifiers
is
4887 for J
in 1 .. Arg_Count
loop
4888 Check_No_Identifier
(Arg_Node
);
4891 end Check_No_Identifiers
;
4893 ------------------------
4894 -- Check_No_Link_Name --
4895 ------------------------
4897 procedure Check_No_Link_Name
is
4899 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4903 if Present
(Arg4
) then
4905 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4907 end Check_No_Link_Name
;
4909 -------------------------------
4910 -- Check_Optional_Identifier --
4911 -------------------------------
4913 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4916 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4917 and then Chars
(Arg
) /= No_Name
4919 if Chars
(Arg
) /= Id
then
4920 Error_Msg_Name_1
:= Pname
;
4921 Error_Msg_Name_2
:= Id
;
4922 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4926 end Check_Optional_Identifier
;
4928 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4930 Name_Buffer
(1 .. Id
'Length) := Id
;
4931 Name_Len
:= Id
'Length;
4932 Check_Optional_Identifier
(Arg
, Name_Find
);
4933 end Check_Optional_Identifier
;
4935 --------------------
4936 -- Check_Pre_Post --
4937 --------------------
4939 procedure Check_Pre_Post
is
4944 if not Is_List_Member
(N
) then
4948 -- If we are within an inlined body, the legality of the pragma
4949 -- has been checked already.
4951 if In_Inlined_Body
then
4955 -- Search prior declarations
4958 while Present
(Prev
(P
)) loop
4961 -- If the previous node is a generic subprogram, do not go to to
4962 -- the original node, which is the unanalyzed tree: we need to
4963 -- attach the pre/postconditions to the analyzed version at this
4964 -- point. They get propagated to the original tree when analyzing
4965 -- the corresponding body.
4967 if Nkind
(P
) not in N_Generic_Declaration
then
4968 PO
:= Original_Node
(P
);
4973 -- Skip past prior pragma
4975 if Nkind
(PO
) = N_Pragma
then
4978 -- Skip stuff not coming from source
4980 elsif not Comes_From_Source
(PO
) then
4982 -- The condition may apply to a subprogram instantiation
4984 if Nkind
(PO
) = N_Subprogram_Declaration
4985 and then Present
(Generic_Parent
(Specification
(PO
)))
4989 elsif Nkind
(PO
) = N_Subprogram_Declaration
4990 and then In_Instance
4994 -- For all other cases of non source code, do nothing
5000 -- Only remaining possibility is subprogram declaration
5007 -- If we fall through loop, pragma is at start of list, so see if it
5008 -- is at the start of declarations of a subprogram body.
5012 if Nkind
(PO
) = N_Subprogram_Body
5013 and then List_Containing
(N
) = Declarations
(PO
)
5015 -- This is only allowed if there is no separate specification
5017 if Present
(Corresponding_Spec
(PO
)) then
5019 ("pragma% must apply to subprogram specification");
5026 --------------------------------------
5027 -- Check_Precondition_Postcondition --
5028 --------------------------------------
5030 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
5034 procedure Chain_PPC
(PO
: Node_Id
);
5035 -- If PO is an entry or a [generic] subprogram declaration node, then
5036 -- the precondition/postcondition applies to this subprogram and the
5037 -- processing for the pragma is completed. Otherwise the pragma is
5044 procedure Chain_PPC
(PO
: Node_Id
) is
5048 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5049 if not From_Aspect_Specification
(N
) then
5051 ("pragma% cannot be applied to abstract subprogram");
5053 elsif Class_Present
(N
) then
5058 ("aspect % requires ''Class for abstract subprogram");
5061 -- AI05-0230: The same restriction applies to null procedures. For
5062 -- compatibility with earlier uses of the Ada pragma, apply this
5063 -- rule only to aspect specifications.
5065 -- The above discrepency needs documentation. Robert is dubious
5066 -- about whether it is a good idea ???
5068 elsif Nkind
(PO
) = N_Subprogram_Declaration
5069 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
5070 and then Null_Present
(Specification
(PO
))
5071 and then From_Aspect_Specification
(N
)
5072 and then not Class_Present
(N
)
5075 ("aspect % requires ''Class for null procedure");
5077 -- Pre/postconditions are legal on a subprogram body if it is not
5078 -- a completion of a declaration. They are also legal on a stub
5079 -- with no previous declarations (this is checked when processing
5080 -- the corresponding aspects).
5082 elsif Nkind
(PO
) = N_Subprogram_Body
5083 and then Acts_As_Spec
(PO
)
5087 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
5090 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5091 N_Expression_Function
,
5092 N_Generic_Subprogram_Declaration
,
5093 N_Entry_Declaration
)
5098 -- Here if we have [generic] subprogram or entry declaration
5100 if Nkind
(PO
) = N_Entry_Declaration
then
5101 S
:= Defining_Entity
(PO
);
5103 S
:= Defining_Unit_Name
(Specification
(PO
));
5105 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5106 S
:= Defining_Identifier
(S
);
5110 -- Note: we do not analyze the pragma at this point. Instead we
5111 -- delay this analysis until the end of the declarative part in
5112 -- which the pragma appears. This implements the required delay
5113 -- in this analysis, allowing forward references. The analysis
5114 -- happens at the end of Analyze_Declarations.
5116 -- Chain spec PPC pragma to list for subprogram
5118 Add_Contract_Item
(N
, S
);
5120 -- Return indicating spec case
5126 -- Start of processing for Check_Precondition_Postcondition
5129 if not Is_List_Member
(N
) then
5133 -- Preanalyze message argument if present. Visibility in this
5134 -- argument is established at the point of pragma occurrence.
5136 if Arg_Count
= 2 then
5137 Check_Optional_Identifier
(Arg2
, Name_Message
);
5138 Preanalyze_Spec_Expression
5139 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5142 -- For a pragma PPC in the extended main source unit, record enabled
5145 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5146 Set_SCO_Pragma_Enabled
(Loc
);
5149 -- If we are within an inlined body, the legality of the pragma
5150 -- has been checked already.
5152 if In_Inlined_Body
then
5157 -- Search prior declarations
5160 while Present
(Prev
(P
)) loop
5163 -- If the previous node is a generic subprogram, do not go to to
5164 -- the original node, which is the unanalyzed tree: we need to
5165 -- attach the pre/postconditions to the analyzed version at this
5166 -- point. They get propagated to the original tree when analyzing
5167 -- the corresponding body.
5169 if Nkind
(P
) not in N_Generic_Declaration
then
5170 PO
:= Original_Node
(P
);
5175 -- Skip past prior pragma
5177 if Nkind
(PO
) = N_Pragma
then
5180 -- Skip stuff not coming from source
5182 elsif not Comes_From_Source
(PO
) then
5184 -- The condition may apply to a subprogram instantiation
5186 if Nkind
(PO
) = N_Subprogram_Declaration
5187 and then Present
(Generic_Parent
(Specification
(PO
)))
5192 elsif Nkind
(PO
) = N_Subprogram_Declaration
5193 and then In_Instance
5198 -- For all other cases of non source code, do nothing
5204 -- Only remaining possibility is subprogram declaration
5212 -- If we fall through loop, pragma is at start of list, so see if it
5213 -- is at the start of declarations of a subprogram body.
5217 if Nkind
(PO
) = N_Subprogram_Body
5218 and then List_Containing
(N
) = Declarations
(PO
)
5220 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5222 -- Analyze pragma expression for correctness and for ASIS use
5224 Preanalyze_Assert_Expression
5225 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5227 -- In ASIS mode, for a pragma generated from a source aspect,
5228 -- also analyze the original aspect expression.
5230 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5231 Preanalyze_Assert_Expression
5232 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5236 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5237 -- The copy is needed because the pragma is expanded into other
5238 -- constructs which are not acceptable in the N_Contract node.
5240 if Acts_As_Spec
(PO
) and then GNATprove_Mode
then
5242 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5245 -- Preanalyze the pragma
5247 Preanalyze_Assert_Expression
5249 (First
(Pragma_Argument_Associations
(Prag
))),
5252 -- Preanalyze the corresponding aspect (if any)
5254 if Present
(Corresponding_Aspect
(Prag
)) then
5255 Preanalyze_Assert_Expression
5256 (Expression
(Corresponding_Aspect
(Prag
)),
5260 -- Chain the copy on the contract of the body
5263 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5270 -- See if it is in the pragmas after a library level subprogram
5272 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5274 -- In GNATprove mode, analyze pragma expression for correctness,
5275 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5276 -- no later point at which the aspect will be analyzed.
5278 if GNATprove_Mode
or ASIS_Mode
then
5279 Analyze_Pre_Post_Condition_In_Decl_Part
5280 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5283 Chain_PPC
(Unit
(Parent
(PO
)));
5287 -- If we fall through, pragma was misplaced
5290 end Check_Precondition_Postcondition
;
5292 -----------------------------
5293 -- Check_Static_Constraint --
5294 -----------------------------
5296 -- Note: for convenience in writing this procedure, in addition to
5297 -- the officially (i.e. by spec) allowed argument which is always a
5298 -- constraint, it also allows ranges and discriminant associations.
5299 -- Above is not clear ???
5301 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5303 procedure Require_Static
(E
: Node_Id
);
5304 -- Require given expression to be static expression
5306 --------------------
5307 -- Require_Static --
5308 --------------------
5310 procedure Require_Static
(E
: Node_Id
) is
5312 if not Is_OK_Static_Expression
(E
) then
5313 Flag_Non_Static_Expr
5314 ("non-static constraint not allowed in Unchecked_Union!", E
);
5319 -- Start of processing for Check_Static_Constraint
5322 case Nkind
(Constr
) is
5323 when N_Discriminant_Association
=>
5324 Require_Static
(Expression
(Constr
));
5327 Require_Static
(Low_Bound
(Constr
));
5328 Require_Static
(High_Bound
(Constr
));
5330 when N_Attribute_Reference
=>
5331 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5332 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5334 when N_Range_Constraint
=>
5335 Check_Static_Constraint
(Range_Expression
(Constr
));
5337 when N_Index_Or_Discriminant_Constraint
=>
5341 IDC
:= First
(Constraints
(Constr
));
5342 while Present
(IDC
) loop
5343 Check_Static_Constraint
(IDC
);
5351 end Check_Static_Constraint
;
5353 ---------------------
5354 -- Check_Test_Case --
5355 ---------------------
5357 procedure Check_Test_Case
is
5361 procedure Chain_CTC
(PO
: Node_Id
);
5362 -- If PO is a [generic] subprogram declaration node, then the
5363 -- test-case applies to this subprogram and the processing for
5364 -- the pragma is completed. Otherwise the pragma is misplaced.
5370 procedure Chain_CTC
(PO
: Node_Id
) is
5374 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5376 ("pragma% cannot be applied to abstract subprogram");
5378 elsif Nkind
(PO
) = N_Entry_Declaration
then
5379 Error_Pragma
("pragma% cannot be applied to entry");
5381 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5382 N_Generic_Subprogram_Declaration
)
5387 -- Here if we have [generic] subprogram declaration
5389 S
:= Defining_Unit_Name
(Specification
(PO
));
5391 -- Note: we do not analyze the pragma at this point. Instead we
5392 -- delay this analysis until the end of the declarative part in
5393 -- which the pragma appears. This implements the required delay
5394 -- in this analysis, allowing forward references. The analysis
5395 -- happens at the end of Analyze_Declarations.
5397 -- There should not be another test-case with the same name
5398 -- associated to this subprogram.
5401 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5405 CTC
:= Contract_Test_Cases
(Contract
(S
));
5406 while Present
(CTC
) loop
5408 -- Omit pragma Contract_Cases because it does not introduce
5409 -- a unique case name and it does not follow the syntax of
5412 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5416 (Name
, Get_Name_From_CTC_Pragma
(CTC
))
5418 Error_Msg_Sloc
:= Sloc
(CTC
);
5419 Error_Pragma
("name for pragma% is already used#");
5422 CTC
:= Next_Pragma
(CTC
);
5426 -- Chain spec CTC pragma to list for subprogram
5428 Add_Contract_Item
(N
, S
);
5431 -- Start of processing for Check_Test_Case
5434 -- First check pragma arguments
5436 Check_At_Least_N_Arguments
(2);
5437 Check_At_Most_N_Arguments
(4);
5439 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5441 Check_Optional_Identifier
(Arg1
, Name_Name
);
5442 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
5444 -- In ASIS mode, for a pragma generated from a source aspect, also
5445 -- analyze the original aspect expression.
5447 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5448 Check_Expr_Is_OK_Static_Expression
5449 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5452 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5453 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5455 if Arg_Count
= 4 then
5456 Check_Identifier
(Arg3
, Name_Requires
);
5457 Check_Identifier
(Arg4
, Name_Ensures
);
5459 elsif Arg_Count
= 3 then
5460 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5463 -- Check pragma placement
5465 if not Is_List_Member
(N
) then
5469 -- Test-case should only appear in package spec unit
5471 if Get_Source_Unit
(N
) = No_Unit
5472 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Current_Sem_Unit
)),
5473 N_Package_Declaration
,
5474 N_Generic_Package_Declaration
)
5479 -- Search prior declarations
5482 while Present
(Prev
(P
)) loop
5485 -- If the previous node is a generic subprogram, do not go to to
5486 -- the original node, which is the unanalyzed tree: we need to
5487 -- attach the test-case to the analyzed version at this point.
5488 -- They get propagated to the original tree when analyzing the
5489 -- corresponding body.
5491 if Nkind
(P
) not in N_Generic_Declaration
then
5492 PO
:= Original_Node
(P
);
5497 -- Skip past prior pragma
5499 if Nkind
(PO
) = N_Pragma
then
5502 -- Skip stuff not coming from source
5504 elsif not Comes_From_Source
(PO
) then
5507 -- Only remaining possibility is subprogram declaration. First
5508 -- check that it is declared directly in a package declaration.
5509 -- This may be either the package declaration for the current unit
5510 -- being defined or a local package declaration.
5512 elsif not Present
(Parent
(Parent
(PO
)))
5513 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5514 or else not Nkind_In
(Parent
(Parent
(PO
)),
5515 N_Package_Declaration
,
5516 N_Generic_Package_Declaration
)
5526 -- If we fall through, pragma was misplaced
5529 end Check_Test_Case
;
5531 --------------------------------------
5532 -- Check_Valid_Configuration_Pragma --
5533 --------------------------------------
5535 -- A configuration pragma must appear in the context clause of a
5536 -- compilation unit, and only other pragmas may precede it. Note that
5537 -- the test also allows use in a configuration pragma file.
5539 procedure Check_Valid_Configuration_Pragma
is
5541 if not Is_Configuration_Pragma
then
5542 Error_Pragma
("incorrect placement for configuration pragma%");
5544 end Check_Valid_Configuration_Pragma
;
5546 -------------------------------------
5547 -- Check_Valid_Library_Unit_Pragma --
5548 -------------------------------------
5550 procedure Check_Valid_Library_Unit_Pragma
is
5552 Parent_Node
: Node_Id
;
5553 Unit_Name
: Entity_Id
;
5554 Unit_Kind
: Node_Kind
;
5555 Unit_Node
: Node_Id
;
5556 Sindex
: Source_File_Index
;
5559 if not Is_List_Member
(N
) then
5563 Plist
:= List_Containing
(N
);
5564 Parent_Node
:= Parent
(Plist
);
5566 if Parent_Node
= Empty
then
5569 -- Case of pragma appearing after a compilation unit. In this case
5570 -- it must have an argument with the corresponding name and must
5571 -- be part of the following pragmas of its parent.
5573 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5574 if Plist
/= Pragmas_After
(Parent_Node
) then
5577 elsif Arg_Count
= 0 then
5579 ("argument required if outside compilation unit");
5582 Check_No_Identifiers
;
5583 Check_Arg_Count
(1);
5584 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5585 Unit_Kind
:= Nkind
(Unit_Node
);
5587 Analyze
(Get_Pragma_Arg
(Arg1
));
5589 if Unit_Kind
= N_Generic_Subprogram_Declaration
5590 or else Unit_Kind
= N_Subprogram_Declaration
5592 Unit_Name
:= Defining_Entity
(Unit_Node
);
5594 elsif Unit_Kind
in N_Generic_Instantiation
then
5595 Unit_Name
:= Defining_Entity
(Unit_Node
);
5598 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5601 if Chars
(Unit_Name
) /=
5602 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5605 ("pragma% argument is not current unit name", Arg1
);
5608 if Ekind
(Unit_Name
) = E_Package
5609 and then Present
(Renamed_Entity
(Unit_Name
))
5611 Error_Pragma
("pragma% not allowed for renamed package");
5615 -- Pragma appears other than after a compilation unit
5618 -- Here we check for the generic instantiation case and also
5619 -- for the case of processing a generic formal package. We
5620 -- detect these cases by noting that the Sloc on the node
5621 -- does not belong to the current compilation unit.
5623 Sindex
:= Source_Index
(Current_Sem_Unit
);
5625 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5626 Rewrite
(N
, Make_Null_Statement
(Loc
));
5629 -- If before first declaration, the pragma applies to the
5630 -- enclosing unit, and the name if present must be this name.
5632 elsif Is_Before_First_Decl
(N
, Plist
) then
5633 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5634 Unit_Kind
:= Nkind
(Unit_Node
);
5636 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5639 elsif Unit_Kind
= N_Subprogram_Body
5640 and then not Acts_As_Spec
(Unit_Node
)
5644 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5647 elsif Nkind
(Parent_Node
) = N_Package_Specification
5648 and then Plist
= Private_Declarations
(Parent_Node
)
5652 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5653 or else Nkind
(Parent_Node
) =
5654 N_Generic_Subprogram_Declaration
)
5655 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5659 elsif Arg_Count
> 0 then
5660 Analyze
(Get_Pragma_Arg
(Arg1
));
5662 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5664 ("name in pragma% must be enclosing unit", Arg1
);
5667 -- It is legal to have no argument in this context
5673 -- Error if not before first declaration. This is because a
5674 -- library unit pragma argument must be the name of a library
5675 -- unit (RM 10.1.5(7)), but the only names permitted in this
5676 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5677 -- generic subprogram declarations or generic instantiations.
5681 ("pragma% misplaced, must be before first declaration");
5685 end Check_Valid_Library_Unit_Pragma
;
5691 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5692 Clist
: constant Node_Id
:= Component_List
(Variant
);
5696 Comp
:= First
(Component_Items
(Clist
));
5697 while Present
(Comp
) loop
5698 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5703 ---------------------------
5704 -- Ensure_Aggregate_Form --
5705 ---------------------------
5707 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5708 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5709 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5710 Nam
: constant Name_Id
:= Chars
(Arg
);
5711 Comps
: List_Id
:= No_List
;
5712 Exprs
: List_Id
:= No_List
;
5714 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5715 -- Used to restore Comes_From_Source_Default
5718 -- The argument is already in aggregate form, but the presence of a
5719 -- name causes this to be interpreted as a named association which in
5720 -- turn must be converted into an aggregate.
5722 -- pragma Global (In_Out => (A, B, C))
5726 -- pragma Global ((In_Out => (A, B, C)))
5728 -- aggregate aggregate
5730 if Nkind
(Expr
) = N_Aggregate
then
5731 if Nam
= No_Name
then
5735 -- Do not transform a null argument into an aggregate as N_Null has
5736 -- special meaning in formal verification pragmas.
5738 elsif Nkind
(Expr
) = N_Null
then
5742 -- Everything comes from source if the original comes from source
5744 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5746 -- Positional argument is transformed into an aggregate with an
5747 -- Expressions list.
5749 if Nam
= No_Name
then
5750 Exprs
:= New_List
(Relocate_Node
(Expr
));
5752 -- An associative argument is transformed into an aggregate with
5753 -- Component_Associations.
5757 Make_Component_Association
(Loc
,
5758 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5759 Expression
=> Relocate_Node
(Expr
)));
5762 -- Remove the pragma argument name as this information has been
5763 -- captured in the aggregate.
5765 Set_Chars
(Arg
, No_Name
);
5767 Set_Expression
(Arg
,
5768 Make_Aggregate
(Loc
,
5769 Component_Associations
=> Comps
,
5770 Expressions
=> Exprs
));
5772 -- Restore Comes_From_Source default
5774 Set_Comes_From_Source_Default
(CFSD
);
5775 end Ensure_Aggregate_Form
;
5781 procedure Error_Pragma
(Msg
: String) is
5783 Error_Msg_Name_1
:= Pname
;
5784 Error_Msg_N
(Fix_Error
(Msg
), N
);
5788 ----------------------
5789 -- Error_Pragma_Arg --
5790 ----------------------
5792 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5794 Error_Msg_Name_1
:= Pname
;
5795 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5797 end Error_Pragma_Arg
;
5799 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5801 Error_Msg_Name_1
:= Pname
;
5802 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5803 Error_Pragma_Arg
(Msg2
, Arg
);
5804 end Error_Pragma_Arg
;
5806 ----------------------------
5807 -- Error_Pragma_Arg_Ident --
5808 ----------------------------
5810 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5812 Error_Msg_Name_1
:= Pname
;
5813 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5815 end Error_Pragma_Arg_Ident
;
5817 ----------------------
5818 -- Error_Pragma_Ref --
5819 ----------------------
5821 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5823 Error_Msg_Name_1
:= Pname
;
5824 Error_Msg_Sloc
:= Sloc
(Ref
);
5825 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5827 end Error_Pragma_Ref
;
5829 ------------------------
5830 -- Find_Lib_Unit_Name --
5831 ------------------------
5833 function Find_Lib_Unit_Name
return Entity_Id
is
5835 -- Return inner compilation unit entity, for case of nested
5836 -- categorization pragmas. This happens in generic unit.
5838 if Nkind
(Parent
(N
)) = N_Package_Specification
5839 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5841 return Defining_Entity
(Parent
(N
));
5843 return Current_Scope
;
5845 end Find_Lib_Unit_Name
;
5847 ----------------------------
5848 -- Find_Program_Unit_Name --
5849 ----------------------------
5851 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5852 Unit_Name
: Entity_Id
;
5853 Unit_Kind
: Node_Kind
;
5854 P
: constant Node_Id
:= Parent
(N
);
5857 if Nkind
(P
) = N_Compilation_Unit
then
5858 Unit_Kind
:= Nkind
(Unit
(P
));
5860 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5861 N_Package_Declaration
)
5862 or else Unit_Kind
in N_Generic_Declaration
5864 Unit_Name
:= Defining_Entity
(Unit
(P
));
5866 if Chars
(Id
) = Chars
(Unit_Name
) then
5867 Set_Entity
(Id
, Unit_Name
);
5868 Set_Etype
(Id
, Etype
(Unit_Name
));
5870 Set_Etype
(Id
, Any_Type
);
5872 ("cannot find program unit referenced by pragma%");
5876 Set_Etype
(Id
, Any_Type
);
5877 Error_Pragma
("pragma% inapplicable to this unit");
5883 end Find_Program_Unit_Name
;
5885 -----------------------------------------
5886 -- Find_Unique_Parameterless_Procedure --
5887 -----------------------------------------
5889 function Find_Unique_Parameterless_Procedure
5891 Arg
: Node_Id
) return Entity_Id
5893 Proc
: Entity_Id
:= Empty
;
5896 -- The body of this procedure needs some comments ???
5898 if not Is_Entity_Name
(Name
) then
5900 ("argument of pragma% must be entity name", Arg
);
5902 elsif not Is_Overloaded
(Name
) then
5903 Proc
:= Entity
(Name
);
5905 if Ekind
(Proc
) /= E_Procedure
5906 or else Present
(First_Formal
(Proc
))
5909 ("argument of pragma% must be parameterless procedure", Arg
);
5914 Found
: Boolean := False;
5916 Index
: Interp_Index
;
5919 Get_First_Interp
(Name
, Index
, It
);
5920 while Present
(It
.Nam
) loop
5923 if Ekind
(Proc
) = E_Procedure
5924 and then No
(First_Formal
(Proc
))
5928 Set_Entity
(Name
, Proc
);
5929 Set_Is_Overloaded
(Name
, False);
5932 ("ambiguous handler name for pragma% ", Arg
);
5936 Get_Next_Interp
(Index
, It
);
5941 ("argument of pragma% must be parameterless procedure",
5944 Proc
:= Entity
(Name
);
5950 end Find_Unique_Parameterless_Procedure
;
5956 function Fix_Error
(Msg
: String) return String is
5957 Res
: String (Msg
'Range) := Msg
;
5958 Res_Last
: Natural := Msg
'Last;
5962 -- If we have a rewriting of another pragma, go to that pragma
5964 if Is_Rewrite_Substitution
(N
)
5965 and then Nkind
(Original_Node
(N
)) = N_Pragma
5967 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5970 -- Case where pragma comes from an aspect specification
5972 if From_Aspect_Specification
(N
) then
5974 -- Change appearence of "pragma" in message to "aspect"
5977 while J
<= Res_Last
- 5 loop
5978 if Res
(J
.. J
+ 5) = "pragma" then
5979 Res
(J
.. J
+ 5) := "aspect";
5987 -- Change "argument of" at start of message to "entity for"
5990 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5992 Res
(Res
'First .. Res
'First + 9) := "entity for";
5993 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5994 Res
(Res
'First + 11 .. Res_Last
);
5995 Res_Last
:= Res_Last
- 1;
5998 -- Change "argument" at start of message to "entity"
6001 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6003 Res
(Res
'First .. Res
'First + 5) := "entity";
6004 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6005 Res
(Res
'First + 8 .. Res_Last
);
6006 Res_Last
:= Res_Last
- 2;
6009 -- Get name from corresponding aspect
6011 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
6014 -- Return possibly modified message
6016 return Res
(Res
'First .. Res_Last
);
6019 -------------------------
6020 -- Gather_Associations --
6021 -------------------------
6023 procedure Gather_Associations
6025 Args
: out Args_List
)
6030 -- Initialize all parameters to Empty
6032 for J
in Args
'Range loop
6036 -- That's all we have to do if there are no argument associations
6038 if No
(Pragma_Argument_Associations
(N
)) then
6042 -- Otherwise first deal with any positional parameters present
6044 Arg
:= First
(Pragma_Argument_Associations
(N
));
6045 for Index
in Args
'Range loop
6046 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6047 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6051 -- Positional parameters all processed, if any left, then we
6052 -- have too many positional parameters.
6054 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6056 ("too many positional associations for pragma%", Arg
);
6059 -- Process named parameters if any are present
6061 while Present
(Arg
) loop
6062 if Chars
(Arg
) = No_Name
then
6064 ("positional association cannot follow named association",
6068 for Index
in Names
'Range loop
6069 if Names
(Index
) = Chars
(Arg
) then
6070 if Present
(Args
(Index
)) then
6072 ("duplicate argument association for pragma%", Arg
);
6074 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6079 if Index
= Names
'Last then
6080 Error_Msg_Name_1
:= Pname
;
6081 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6083 -- Check for possible misspelling
6085 for Index1
in Names
'Range loop
6086 if Is_Bad_Spelling_Of
6087 (Chars
(Arg
), Names
(Index1
))
6089 Error_Msg_Name_1
:= Names
(Index1
);
6090 Error_Msg_N
-- CODEFIX
6091 ("\possible misspelling of%", Arg
);
6103 end Gather_Associations
;
6109 procedure GNAT_Pragma
is
6111 -- We need to check the No_Implementation_Pragmas restriction for
6112 -- the case of a pragma from source. Note that the case of aspects
6113 -- generating corresponding pragmas marks these pragmas as not being
6114 -- from source, so this test also catches that case.
6116 if Comes_From_Source
(N
) then
6117 Check_Restriction
(No_Implementation_Pragmas
, N
);
6121 --------------------------
6122 -- Is_Before_First_Decl --
6123 --------------------------
6125 function Is_Before_First_Decl
6126 (Pragma_Node
: Node_Id
;
6127 Decls
: List_Id
) return Boolean
6129 Item
: Node_Id
:= First
(Decls
);
6132 -- Only other pragmas can come before this pragma
6135 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6138 elsif Item
= Pragma_Node
then
6144 end Is_Before_First_Decl
;
6146 -----------------------------
6147 -- Is_Configuration_Pragma --
6148 -----------------------------
6150 -- A configuration pragma must appear in the context clause of a
6151 -- compilation unit, and only other pragmas may precede it. Note that
6152 -- the test below also permits use in a configuration pragma file.
6154 function Is_Configuration_Pragma
return Boolean is
6155 Lis
: constant List_Id
:= List_Containing
(N
);
6156 Par
: constant Node_Id
:= Parent
(N
);
6160 -- If no parent, then we are in the configuration pragma file,
6161 -- so the placement is definitely appropriate.
6166 -- Otherwise we must be in the context clause of a compilation unit
6167 -- and the only thing allowed before us in the context list is more
6168 -- configuration pragmas.
6170 elsif Nkind
(Par
) = N_Compilation_Unit
6171 and then Context_Items
(Par
) = Lis
6178 elsif Nkind
(Prg
) /= N_Pragma
then
6188 end Is_Configuration_Pragma
;
6190 --------------------------
6191 -- Is_In_Context_Clause --
6192 --------------------------
6194 function Is_In_Context_Clause
return Boolean is
6196 Parent_Node
: Node_Id
;
6199 if not Is_List_Member
(N
) then
6203 Plist
:= List_Containing
(N
);
6204 Parent_Node
:= Parent
(Plist
);
6206 if Parent_Node
= Empty
6207 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6208 or else Context_Items
(Parent_Node
) /= Plist
6215 end Is_In_Context_Clause
;
6217 ---------------------------------
6218 -- Is_Static_String_Expression --
6219 ---------------------------------
6221 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6222 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6225 Analyze_And_Resolve
(Argx
);
6226 return Is_OK_Static_Expression
(Argx
)
6227 and then Nkind
(Argx
) = N_String_Literal
;
6228 end Is_Static_String_Expression
;
6230 ----------------------
6231 -- Pragma_Misplaced --
6232 ----------------------
6234 procedure Pragma_Misplaced
is
6236 Error_Pragma
("incorrect placement of pragma%");
6237 end Pragma_Misplaced
;
6239 ------------------------------------
6240 -- Process_Atomic_Shared_Volatile --
6241 ------------------------------------
6243 procedure Process_Atomic_Shared_Volatile
is
6250 procedure Set_Atomic
(E
: Entity_Id
);
6251 -- Set given type as atomic, and if no explicit alignment was given,
6252 -- set alignment to unknown, since back end knows what the alignment
6253 -- requirements are for atomic arrays. Note: this step is necessary
6254 -- for derived types.
6260 procedure Set_Atomic
(E
: Entity_Id
) is
6264 if not Has_Alignment_Clause
(E
) then
6265 Set_Alignment
(E
, Uint_0
);
6269 -- Start of processing for Process_Atomic_Shared_Volatile
6272 Check_Ada_83_Warning
;
6273 Check_No_Identifiers
;
6274 Check_Arg_Count
(1);
6275 Check_Arg_Is_Local_Name
(Arg1
);
6276 E_Id
:= Get_Pragma_Arg
(Arg1
);
6278 if Etype
(E_Id
) = Any_Type
then
6283 D
:= Declaration_Node
(E
);
6286 -- Check duplicate before we chain ourselves
6288 Check_Duplicate_Pragma
(E
);
6290 -- Now check appropriateness of the entity
6293 if Rep_Item_Too_Early
(E
, N
)
6295 Rep_Item_Too_Late
(E
, N
)
6299 Check_First_Subtype
(Arg1
);
6302 if Prag_Id
/= Pragma_Volatile
then
6304 Set_Atomic
(Underlying_Type
(E
));
6305 Set_Atomic
(Base_Type
(E
));
6308 -- Attribute belongs on the base type. If the view of the type is
6309 -- currently private, it also belongs on the underlying type.
6311 Set_Is_Volatile
(Base_Type
(E
));
6312 Set_Is_Volatile
(Underlying_Type
(E
));
6314 Set_Treat_As_Volatile
(E
);
6315 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6317 elsif K
= N_Object_Declaration
6318 or else (K
= N_Component_Declaration
6319 and then Original_Record_Component
(E
) = E
)
6321 if Rep_Item_Too_Late
(E
, N
) then
6325 if Prag_Id
/= Pragma_Volatile
then
6328 -- If the object declaration has an explicit initialization, a
6329 -- temporary may have to be created to hold the expression, to
6330 -- ensure that access to the object remain atomic.
6332 if Nkind
(Parent
(E
)) = N_Object_Declaration
6333 and then Present
(Expression
(Parent
(E
)))
6335 Set_Has_Delayed_Freeze
(E
);
6338 -- An interesting improvement here. If an object of composite
6339 -- type X is declared atomic, and the type X isn't, that's a
6340 -- pity, since it may not have appropriate alignment etc. We
6341 -- can rescue this in the special case where the object and
6342 -- type are in the same unit by just setting the type as
6343 -- atomic, so that the back end will process it as atomic.
6345 -- Note: we used to do this for elementary types as well,
6346 -- but that turns out to be a bad idea and can have unwanted
6347 -- effects, most notably if the type is elementary, the object
6348 -- a simple component within a record, and both are in a spec:
6349 -- every object of this type in the entire program will be
6350 -- treated as atomic, thus incurring a potentially costly
6351 -- synchronization operation for every access.
6353 -- Of course it would be best if the back end could just adjust
6354 -- the alignment etc for the specific object, but that's not
6355 -- something we are capable of doing at this point.
6357 Utyp
:= Underlying_Type
(Etype
(E
));
6360 and then Is_Composite_Type
(Utyp
)
6361 and then Sloc
(E
) > No_Location
6362 and then Sloc
(Utyp
) > No_Location
6364 Get_Source_File_Index
(Sloc
(E
)) =
6365 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6367 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6371 Set_Is_Volatile
(E
);
6372 Set_Treat_As_Volatile
(E
);
6375 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6378 -- The following check is only relevant when SPARK_Mode is on as
6379 -- this is not a standard Ada legality rule. Pragma Volatile can
6380 -- only apply to a full type declaration or an object declaration
6381 -- (SPARK RM C.6(1)).
6384 and then Prag_Id
= Pragma_Volatile
6385 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6386 N_Object_Declaration
)
6389 ("argument of pragma % must denote a full type or object "
6390 & "declaration", Arg1
);
6392 end Process_Atomic_Shared_Volatile
;
6394 -------------------------------------------
6395 -- Process_Compile_Time_Warning_Or_Error --
6396 -------------------------------------------
6398 procedure Process_Compile_Time_Warning_Or_Error
is
6399 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6402 Check_Arg_Count
(2);
6403 Check_No_Identifiers
;
6404 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6405 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6407 if Compile_Time_Known_Value
(Arg1x
) then
6408 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6410 Str
: constant String_Id
:=
6411 Strval
(Get_Pragma_Arg
(Arg2
));
6412 Len
: constant Int
:= String_Length
(Str
);
6417 Cent
: constant Entity_Id
:=
6418 Cunit_Entity
(Current_Sem_Unit
);
6420 Force
: constant Boolean :=
6421 Prag_Id
= Pragma_Compile_Time_Warning
6423 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6424 and then (Ekind
(Cent
) /= E_Package
6425 or else not In_Private_Part
(Cent
));
6426 -- Set True if this is the warning case, and we are in the
6427 -- visible part of a package spec, or in a subprogram spec,
6428 -- in which case we want to force the client to see the
6429 -- warning, even though it is not in the main unit.
6432 -- Loop through segments of message separated by line feeds.
6433 -- We output these segments as separate messages with
6434 -- continuation marks for all but the first.
6439 Error_Msg_Strlen
:= 0;
6441 -- Loop to copy characters from argument to error message
6445 exit when Ptr
> Len
;
6446 CC
:= Get_String_Char
(Str
, Ptr
);
6449 -- Ignore wide chars ??? else store character
6451 if In_Character_Range
(CC
) then
6452 C
:= Get_Character
(CC
);
6453 exit when C
= ASCII
.LF
;
6454 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6455 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6459 -- Here with one line ready to go
6461 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6463 -- If this is a warning in a spec, then we want clients
6464 -- to see the warning, so mark the message with the
6465 -- special sequence !! to force the warning. In the case
6466 -- of a package spec, we do not force this if we are in
6467 -- the private part of the spec.
6470 if Cont
= False then
6471 Error_Msg_N
("<<~!!", Arg1
);
6474 Error_Msg_N
("\<<~!!", Arg1
);
6477 -- Error, rather than warning, or in a body, so we do not
6478 -- need to force visibility for client (error will be
6479 -- output in any case, and this is the situation in which
6480 -- we do not want a client to get a warning, since the
6481 -- warning is in the body or the spec private part).
6484 if Cont
= False then
6485 Error_Msg_N
("<<~", Arg1
);
6488 Error_Msg_N
("\<<~", Arg1
);
6492 exit when Ptr
> Len
;
6497 end Process_Compile_Time_Warning_Or_Error
;
6499 ------------------------
6500 -- Process_Convention --
6501 ------------------------
6503 procedure Process_Convention
6504 (C
: out Convention_Id
;
6505 Ent
: out Entity_Id
)
6511 Comp_Unit
: Unit_Number_Type
;
6513 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6514 -- Called if we have more than one Export/Import/Convention pragma.
6515 -- This is generally illegal, but we have a special case of allowing
6516 -- Import and Interface to coexist if they specify the convention in
6517 -- a consistent manner. We are allowed to do this, since Interface is
6518 -- an implementation defined pragma, and we choose to do it since we
6519 -- know Rational allows this combination. S is the entity id of the
6520 -- subprogram in question. This procedure also sets the special flag
6521 -- Import_Interface_Present in both pragmas in the case where we do
6522 -- have matching Import and Interface pragmas.
6524 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6525 -- Set convention in entity E, and also flag that the entity has a
6526 -- convention pragma. If entity is for a private or incomplete type,
6527 -- also set convention and flag on underlying type. This procedure
6528 -- also deals with the special case of C_Pass_By_Copy convention,
6529 -- and error checks for inappropriate convention specification.
6531 -------------------------------
6532 -- Diagnose_Multiple_Pragmas --
6533 -------------------------------
6535 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6536 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6540 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6541 -- Decl is a pragma node. This function returns True if this
6542 -- pragma has a first argument that is an identifier with a
6543 -- Chars field corresponding to the Convention_Id C.
6545 function Same_Name
(Decl
: Node_Id
) return Boolean;
6546 -- Decl is a pragma node. This function returns True if this
6547 -- pragma has a second argument that is an identifier with a
6548 -- Chars field that matches the Chars of the current subprogram.
6550 ---------------------
6551 -- Same_Convention --
6552 ---------------------
6554 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6555 Arg1
: constant Node_Id
:=
6556 First
(Pragma_Argument_Associations
(Decl
));
6559 if Present
(Arg1
) then
6561 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6563 if Nkind
(Arg
) = N_Identifier
6564 and then Is_Convention_Name
(Chars
(Arg
))
6565 and then Get_Convention_Id
(Chars
(Arg
)) = C
6573 end Same_Convention
;
6579 function Same_Name
(Decl
: Node_Id
) return Boolean is
6580 Arg1
: constant Node_Id
:=
6581 First
(Pragma_Argument_Associations
(Decl
));
6589 Arg2
:= Next
(Arg1
);
6596 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6598 if Nkind
(Arg
) = N_Identifier
6599 and then Chars
(Arg
) = Chars
(S
)
6608 -- Start of processing for Diagnose_Multiple_Pragmas
6613 -- Definitely give message if we have Convention/Export here
6615 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6618 -- If we have an Import or Export, scan back from pragma to
6619 -- find any previous pragma applying to the same procedure.
6620 -- The scan will be terminated by the start of the list, or
6621 -- hitting the subprogram declaration. This won't allow one
6622 -- pragma to appear in the public part and one in the private
6623 -- part, but that seems very unlikely in practice.
6627 while Present
(Decl
) and then Decl
/= Pdec
loop
6629 -- Look for pragma with same name as us
6631 if Nkind
(Decl
) = N_Pragma
6632 and then Same_Name
(Decl
)
6634 -- Give error if same as our pragma or Export/Convention
6636 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6642 -- Case of Import/Interface or the other way round
6644 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6647 -- Here we know that we have Import and Interface. It
6648 -- doesn't matter which way round they are. See if
6649 -- they specify the same convention. If so, all OK,
6650 -- and set special flags to stop other messages
6652 if Same_Convention
(Decl
) then
6653 Set_Import_Interface_Present
(N
);
6654 Set_Import_Interface_Present
(Decl
);
6657 -- If different conventions, special message
6660 Error_Msg_Sloc
:= Sloc
(Decl
);
6662 ("convention differs from that given#", Arg1
);
6672 -- Give message if needed if we fall through those tests
6673 -- except on Relaxed_RM_Semantics where we let go: either this
6674 -- is a case accepted/ignored by other Ada compilers (e.g.
6675 -- a mix of Convention and Import), or another error will be
6676 -- generated later (e.g. using both Import and Export).
6678 if Err
and not Relaxed_RM_Semantics
then
6680 ("at most one Convention/Export/Import pragma is allowed",
6683 end Diagnose_Multiple_Pragmas
;
6685 --------------------------------
6686 -- Set_Convention_From_Pragma --
6687 --------------------------------
6689 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6691 -- Ghost convention is allowed only for functions
6693 if Ekind
(E
) /= E_Function
and then C
= Convention_Ghost
then
6695 ("& may not have Ghost convention", E
);
6697 ("\only functions are permitted to have Ghost convention",
6702 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6703 -- for an overridden dispatching operation. Technically this is
6704 -- an amendment and should only be done in Ada 2005 mode. However,
6705 -- this is clearly a mistake, since the problem that is addressed
6706 -- by this AI is that there is a clear gap in the RM.
6708 if Is_Dispatching_Operation
(E
)
6709 and then Present
(Overridden_Operation
(E
))
6710 and then C
/= Convention
(Overridden_Operation
(E
))
6712 -- An attempt to override a function with a ghost function
6713 -- appears as a mismatch in conventions.
6715 if C
= Convention_Ghost
then
6716 Error_Msg_N
("ghost function & cannot be overriding", E
);
6719 ("cannot change convention for overridden dispatching "
6720 & "operation", Arg1
);
6724 -- Special checks for Convention_Stdcall
6726 if C
= Convention_Stdcall
then
6728 -- A dispatching call is not allowed. A dispatching subprogram
6729 -- cannot be used to interface to the Win32 API, so in fact
6730 -- this check does not impose any effective restriction.
6732 if Is_Dispatching_Operation
(E
) then
6733 Error_Msg_Sloc
:= Sloc
(E
);
6735 -- Note: make this unconditional so that if there is more
6736 -- than one call to which the pragma applies, we get a
6737 -- message for each call. Also don't use Error_Pragma,
6738 -- so that we get multiple messages.
6741 ("dispatching subprogram# cannot use Stdcall convention!",
6744 -- Subprograms are not allowed
6746 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6750 and then Ekind
(E
) /= E_Variable
6752 -- An access to subprogram is also allowed
6756 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6758 -- Allow internal call to set convention of subprogram type
6760 and then not (Ekind
(E
) = E_Subprogram_Type
)
6763 ("second argument of pragma% must be subprogram (type)",
6768 -- Set the convention
6770 Set_Convention
(E
, C
);
6771 Set_Has_Convention_Pragma
(E
);
6773 -- For the case of a record base type, also set the convention of
6774 -- any anonymous access types declared in the record which do not
6775 -- currently have a specified convention.
6777 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6782 Comp
:= First_Component
(E
);
6783 while Present
(Comp
) loop
6784 if Present
(Etype
(Comp
))
6785 and then Ekind_In
(Etype
(Comp
),
6786 E_Anonymous_Access_Type
,
6787 E_Anonymous_Access_Subprogram_Type
)
6788 and then not Has_Convention_Pragma
(Comp
)
6790 Set_Convention
(Comp
, C
);
6793 Next_Component
(Comp
);
6798 -- Deal with incomplete/private type case, where underlying type
6799 -- is available, so set convention of that underlying type.
6801 if Is_Incomplete_Or_Private_Type
(E
)
6802 and then Present
(Underlying_Type
(E
))
6804 Set_Convention
(Underlying_Type
(E
), C
);
6805 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6808 -- A class-wide type should inherit the convention of the specific
6809 -- root type (although this isn't specified clearly by the RM).
6811 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6812 Set_Convention
(Class_Wide_Type
(E
), C
);
6815 -- If the entity is a record type, then check for special case of
6816 -- C_Pass_By_Copy, which is treated the same as C except that the
6817 -- special record flag is set. This convention is only permitted
6818 -- on record types (see AI95-00131).
6820 if Cname
= Name_C_Pass_By_Copy
then
6821 if Is_Record_Type
(E
) then
6822 Set_C_Pass_By_Copy
(Base_Type
(E
));
6823 elsif Is_Incomplete_Or_Private_Type
(E
)
6824 and then Is_Record_Type
(Underlying_Type
(E
))
6826 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6829 ("C_Pass_By_Copy convention allowed only for record type",
6834 -- If the entity is a derived boolean type, check for the special
6835 -- case of convention C, C++, or Fortran, where we consider any
6836 -- nonzero value to represent true.
6838 if Is_Discrete_Type
(E
)
6839 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6845 C
= Convention_Fortran
)
6847 Set_Nonzero_Is_True
(Base_Type
(E
));
6849 end Set_Convention_From_Pragma
;
6851 -- Start of processing for Process_Convention
6854 Check_At_Least_N_Arguments
(2);
6855 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6856 Check_Arg_Is_Identifier
(Arg1
);
6857 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6859 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6860 -- tested again below to set the critical flag).
6862 if Cname
= Name_C_Pass_By_Copy
then
6865 -- Otherwise we must have something in the standard convention list
6867 elsif Is_Convention_Name
(Cname
) then
6868 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6870 -- Otherwise warn on unrecognized convention
6873 if Warn_On_Export_Import
then
6875 ("??unrecognized convention name, C assumed",
6876 Get_Pragma_Arg
(Arg1
));
6882 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6883 Check_Arg_Is_Local_Name
(Arg2
);
6885 Id
:= Get_Pragma_Arg
(Arg2
);
6888 if not Is_Entity_Name
(Id
) then
6889 Error_Pragma_Arg
("entity name required", Arg2
);
6894 -- Set entity to return
6898 -- Ada_Pass_By_Copy special checking
6900 if C
= Convention_Ada_Pass_By_Copy
then
6901 if not Is_First_Subtype
(E
) then
6903 ("convention `Ada_Pass_By_Copy` only allowed for types",
6907 if Is_By_Reference_Type
(E
) then
6909 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6914 -- Ada_Pass_By_Reference special checking
6916 if C
= Convention_Ada_Pass_By_Reference
then
6917 if not Is_First_Subtype
(E
) then
6919 ("convention `Ada_Pass_By_Reference` only allowed for types",
6923 if Is_By_Copy_Type
(E
) then
6925 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6930 -- Ghost special checking
6932 if Is_Ghost_Subprogram
(E
)
6933 and then Present
(Overridden_Operation
(E
))
6935 Error_Msg_N
("ghost function & cannot be overriding", E
);
6938 -- Go to renamed subprogram if present, since convention applies to
6939 -- the actual renamed entity, not to the renaming entity. If the
6940 -- subprogram is inherited, go to parent subprogram.
6942 if Is_Subprogram
(E
)
6943 and then Present
(Alias
(E
))
6945 if Nkind
(Parent
(Declaration_Node
(E
))) =
6946 N_Subprogram_Renaming_Declaration
6948 if Scope
(E
) /= Scope
(Alias
(E
)) then
6950 ("cannot apply pragma% to non-local entity&#", E
);
6955 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6956 N_Private_Extension_Declaration
)
6957 and then Scope
(E
) = Scope
(Alias
(E
))
6961 -- Return the parent subprogram the entity was inherited from
6967 -- Check that we are not applying this to a specless body
6968 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
6971 if Is_Subprogram
(E
)
6972 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6973 and then not Relaxed_RM_Semantics
6976 ("pragma% requires separate spec and must come before body");
6979 -- Check that we are not applying this to a named constant
6981 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6982 Error_Msg_Name_1
:= Pname
;
6984 ("cannot apply pragma% to named constant!",
6985 Get_Pragma_Arg
(Arg2
));
6987 ("\supply appropriate type for&!", Arg2
);
6990 if Ekind
(E
) = E_Enumeration_Literal
then
6991 Error_Pragma
("enumeration literal not allowed for pragma%");
6994 -- Check for rep item appearing too early or too late
6996 if Etype
(E
) = Any_Type
6997 or else Rep_Item_Too_Early
(E
, N
)
7001 elsif Present
(Underlying_Type
(E
)) then
7002 E
:= Underlying_Type
(E
);
7005 if Rep_Item_Too_Late
(E
, N
) then
7009 if Has_Convention_Pragma
(E
) then
7010 Diagnose_Multiple_Pragmas
(E
);
7012 elsif Convention
(E
) = Convention_Protected
7013 or else Ekind
(Scope
(E
)) = E_Protected_Type
7016 ("a protected operation cannot be given a different convention",
7020 -- For Intrinsic, a subprogram is required
7022 if C
= Convention_Intrinsic
7023 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7026 ("second argument of pragma% must be a subprogram", Arg2
);
7029 -- Deal with non-subprogram cases
7031 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7032 Set_Convention_From_Pragma
(E
);
7035 Check_First_Subtype
(Arg2
);
7036 Set_Convention_From_Pragma
(Base_Type
(E
));
7038 -- For access subprograms, we must set the convention on the
7039 -- internally generated directly designated type as well.
7041 if Ekind
(E
) = E_Access_Subprogram_Type
then
7042 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7046 -- For the subprogram case, set proper convention for all homonyms
7047 -- in same scope and the same declarative part, i.e. the same
7048 -- compilation unit.
7051 Comp_Unit
:= Get_Source_Unit
(E
);
7052 Set_Convention_From_Pragma
(E
);
7054 -- Treat a pragma Import as an implicit body, and pragma import
7055 -- as implicit reference (for navigation in GPS).
7057 if Prag_Id
= Pragma_Import
then
7058 Generate_Reference
(E
, Id
, 'b');
7060 -- For exported entities we restrict the generation of references
7061 -- to entities exported to foreign languages since entities
7062 -- exported to Ada do not provide further information to GPS and
7063 -- add undesired references to the output of the gnatxref tool.
7065 elsif Prag_Id
= Pragma_Export
7066 and then Convention
(E
) /= Convention_Ada
7068 Generate_Reference
(E
, Id
, 'i');
7071 -- If the pragma comes from from an aspect, it only applies to the
7072 -- given entity, not its homonyms.
7074 if From_Aspect_Specification
(N
) then
7078 -- Otherwise Loop through the homonyms of the pragma argument's
7079 -- entity, an apply convention to those in the current scope.
7085 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7087 -- Ignore entry for which convention is already set
7089 if Has_Convention_Pragma
(E1
) then
7093 -- Do not set the pragma on inherited operations or on formal
7096 if Comes_From_Source
(E1
)
7097 and then Comp_Unit
= Get_Source_Unit
(E1
)
7098 and then not Is_Formal_Subprogram
(E1
)
7099 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7100 N_Full_Type_Declaration
7102 if Present
(Alias
(E1
))
7103 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7106 ("cannot apply pragma% to non-local entity& declared#",
7110 Set_Convention_From_Pragma
(E1
);
7112 if Prag_Id
= Pragma_Import
then
7113 Generate_Reference
(E1
, Id
, 'b');
7121 end Process_Convention
;
7123 ----------------------------------------
7124 -- Process_Disable_Enable_Atomic_Sync --
7125 ----------------------------------------
7127 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7129 Check_No_Identifiers
;
7130 Check_At_Most_N_Arguments
(1);
7132 -- Modeled internally as
7133 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7137 Pragma_Identifier
=>
7138 Make_Identifier
(Loc
, Nam
),
7139 Pragma_Argument_Associations
=> New_List
(
7140 Make_Pragma_Argument_Association
(Loc
,
7142 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7144 if Present
(Arg1
) then
7145 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7149 end Process_Disable_Enable_Atomic_Sync
;
7151 -------------------------------------------------
7152 -- Process_Extended_Import_Export_Internal_Arg --
7153 -------------------------------------------------
7155 procedure Process_Extended_Import_Export_Internal_Arg
7156 (Arg_Internal
: Node_Id
:= Empty
)
7159 if No
(Arg_Internal
) then
7160 Error_Pragma
("Internal parameter required for pragma%");
7163 if Nkind
(Arg_Internal
) = N_Identifier
then
7166 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7167 and then (Prag_Id
= Pragma_Import_Function
7169 Prag_Id
= Pragma_Export_Function
)
7175 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7178 Check_Arg_Is_Local_Name
(Arg_Internal
);
7179 end Process_Extended_Import_Export_Internal_Arg
;
7181 --------------------------------------------------
7182 -- Process_Extended_Import_Export_Object_Pragma --
7183 --------------------------------------------------
7185 procedure Process_Extended_Import_Export_Object_Pragma
7186 (Arg_Internal
: Node_Id
;
7187 Arg_External
: Node_Id
;
7193 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7194 Def_Id
:= Entity
(Arg_Internal
);
7196 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7198 ("pragma% must designate an object", Arg_Internal
);
7201 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7203 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7206 ("previous Common/Psect_Object applies, pragma % not permitted",
7210 if Rep_Item_Too_Late
(Def_Id
, N
) then
7214 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7216 if Present
(Arg_Size
) then
7217 Check_Arg_Is_External_Name
(Arg_Size
);
7220 -- Export_Object case
7222 if Prag_Id
= Pragma_Export_Object
then
7223 if not Is_Library_Level_Entity
(Def_Id
) then
7225 ("argument for pragma% must be library level entity",
7229 if Ekind
(Current_Scope
) = E_Generic_Package
then
7230 Error_Pragma
("pragma& cannot appear in a generic unit");
7233 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7235 ("exported object must have compile time known size",
7239 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7240 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7242 Set_Exported
(Def_Id
, Arg_Internal
);
7245 -- Import_Object case
7248 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7250 ("cannot use pragma% for task/protected object",
7254 if Ekind
(Def_Id
) = E_Constant
then
7256 ("cannot import a constant", Arg_Internal
);
7259 if Warn_On_Export_Import
7260 and then Has_Discriminants
(Etype
(Def_Id
))
7263 ("imported value must be initialized??", Arg_Internal
);
7266 if Warn_On_Export_Import
7267 and then Is_Access_Type
(Etype
(Def_Id
))
7270 ("cannot import object of an access type??", Arg_Internal
);
7273 if Warn_On_Export_Import
7274 and then Is_Imported
(Def_Id
)
7276 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7278 -- Check for explicit initialization present. Note that an
7279 -- initialization generated by the code generator, e.g. for an
7280 -- access type, does not count here.
7282 elsif Present
(Expression
(Parent
(Def_Id
)))
7285 (Original_Node
(Expression
(Parent
(Def_Id
))))
7287 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7289 ("imported entities cannot be initialized (RM B.1(24))",
7290 "\no initialization allowed for & declared#", Arg1
);
7292 Set_Imported
(Def_Id
);
7293 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7296 end Process_Extended_Import_Export_Object_Pragma
;
7298 ------------------------------------------------------
7299 -- Process_Extended_Import_Export_Subprogram_Pragma --
7300 ------------------------------------------------------
7302 procedure Process_Extended_Import_Export_Subprogram_Pragma
7303 (Arg_Internal
: Node_Id
;
7304 Arg_External
: Node_Id
;
7305 Arg_Parameter_Types
: Node_Id
;
7306 Arg_Result_Type
: Node_Id
:= Empty
;
7307 Arg_Mechanism
: Node_Id
;
7308 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7314 Ambiguous
: Boolean;
7317 function Same_Base_Type
7319 Formal
: Entity_Id
) return Boolean;
7320 -- Determines if Ptype references the type of Formal. Note that only
7321 -- the base types need to match according to the spec. Ptype here is
7322 -- the argument from the pragma, which is either a type name, or an
7323 -- access attribute.
7325 --------------------
7326 -- Same_Base_Type --
7327 --------------------
7329 function Same_Base_Type
7331 Formal
: Entity_Id
) return Boolean
7333 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7337 -- Case where pragma argument is typ'Access
7339 if Nkind
(Ptype
) = N_Attribute_Reference
7340 and then Attribute_Name
(Ptype
) = Name_Access
7342 Pref
:= Prefix
(Ptype
);
7345 if not Is_Entity_Name
(Pref
)
7346 or else Entity
(Pref
) = Any_Type
7351 -- We have a match if the corresponding argument is of an
7352 -- anonymous access type, and its designated type matches the
7353 -- type of the prefix of the access attribute
7355 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7356 and then Base_Type
(Entity
(Pref
)) =
7357 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7359 -- Case where pragma argument is a type name
7364 if not Is_Entity_Name
(Ptype
)
7365 or else Entity
(Ptype
) = Any_Type
7370 -- We have a match if the corresponding argument is of the type
7371 -- given in the pragma (comparing base types)
7373 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7377 -- Start of processing for
7378 -- Process_Extended_Import_Export_Subprogram_Pragma
7381 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7385 -- Loop through homonyms (overloadings) of the entity
7387 Hom_Id
:= Entity
(Arg_Internal
);
7388 while Present
(Hom_Id
) loop
7389 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7391 -- We need a subprogram in the current scope
7393 if not Is_Subprogram
(Def_Id
)
7394 or else Scope
(Def_Id
) /= Current_Scope
7401 -- Pragma cannot apply to subprogram body
7403 if Is_Subprogram
(Def_Id
)
7404 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7408 ("pragma% requires separate spec"
7409 & " and must come before body");
7412 -- Test result type if given, note that the result type
7413 -- parameter can only be present for the function cases.
7415 if Present
(Arg_Result_Type
)
7416 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7420 elsif Etype
(Def_Id
) /= Standard_Void_Type
7422 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7426 -- Test parameter types if given. Note that this parameter
7427 -- has not been analyzed (and must not be, since it is
7428 -- semantic nonsense), so we get it as the parser left it.
7430 elsif Present
(Arg_Parameter_Types
) then
7431 Check_Matching_Types
: declare
7436 Formal
:= First_Formal
(Def_Id
);
7438 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7439 if Present
(Formal
) then
7443 -- A list of one type, e.g. (List) is parsed as
7444 -- a parenthesized expression.
7446 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7447 and then Paren_Count
(Arg_Parameter_Types
) = 1
7450 or else Present
(Next_Formal
(Formal
))
7455 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7458 -- A list of more than one type is parsed as a aggregate
7460 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7461 and then Paren_Count
(Arg_Parameter_Types
) = 0
7463 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7464 while Present
(Ptype
) or else Present
(Formal
) loop
7467 or else not Same_Base_Type
(Ptype
, Formal
)
7472 Next_Formal
(Formal
);
7477 -- Anything else is of the wrong form
7481 ("wrong form for Parameter_Types parameter",
7482 Arg_Parameter_Types
);
7484 end Check_Matching_Types
;
7487 -- Match is now False if the entry we found did not match
7488 -- either a supplied Parameter_Types or Result_Types argument
7494 -- Ambiguous case, the flag Ambiguous shows if we already
7495 -- detected this and output the initial messages.
7498 if not Ambiguous
then
7500 Error_Msg_Name_1
:= Pname
;
7502 ("pragma% does not uniquely identify subprogram!",
7504 Error_Msg_Sloc
:= Sloc
(Ent
);
7505 Error_Msg_N
("matching subprogram #!", N
);
7509 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7510 Error_Msg_N
("matching subprogram #!", N
);
7515 Hom_Id
:= Homonym
(Hom_Id
);
7518 -- See if we found an entry
7521 if not Ambiguous
then
7522 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7524 ("pragma% cannot be given for generic subprogram");
7527 ("pragma% does not identify local subprogram");
7534 -- Import pragmas must be for imported entities
7536 if Prag_Id
= Pragma_Import_Function
7538 Prag_Id
= Pragma_Import_Procedure
7540 Prag_Id
= Pragma_Import_Valued_Procedure
7542 if not Is_Imported
(Ent
) then
7544 ("pragma Import or Interface must precede pragma%");
7547 -- Here we have the Export case which can set the entity as exported
7549 -- But does not do so if the specified external name is null, since
7550 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7551 -- compatible) to request no external name.
7553 elsif Nkind
(Arg_External
) = N_String_Literal
7554 and then String_Length
(Strval
(Arg_External
)) = 0
7558 -- In all other cases, set entity as exported
7561 Set_Exported
(Ent
, Arg_Internal
);
7564 -- Special processing for Valued_Procedure cases
7566 if Prag_Id
= Pragma_Import_Valued_Procedure
7568 Prag_Id
= Pragma_Export_Valued_Procedure
7570 Formal
:= First_Formal
(Ent
);
7573 Error_Pragma
("at least one parameter required for pragma%");
7575 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7576 Error_Pragma
("first parameter must have mode out for pragma%");
7579 Set_Is_Valued_Procedure
(Ent
);
7583 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7585 -- Process Result_Mechanism argument if present. We have already
7586 -- checked that this is only allowed for the function case.
7588 if Present
(Arg_Result_Mechanism
) then
7589 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7592 -- Process Mechanism parameter if present. Note that this parameter
7593 -- is not analyzed, and must not be analyzed since it is semantic
7594 -- nonsense, so we get it in exactly as the parser left it.
7596 if Present
(Arg_Mechanism
) then
7604 -- A single mechanism association without a formal parameter
7605 -- name is parsed as a parenthesized expression. All other
7606 -- cases are parsed as aggregates, so we rewrite the single
7607 -- parameter case as an aggregate for consistency.
7609 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7610 and then Paren_Count
(Arg_Mechanism
) = 1
7612 Rewrite
(Arg_Mechanism
,
7613 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7614 Expressions
=> New_List
(
7615 Relocate_Node
(Arg_Mechanism
))));
7618 -- Case of only mechanism name given, applies to all formals
7620 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7621 Formal
:= First_Formal
(Ent
);
7622 while Present
(Formal
) loop
7623 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7624 Next_Formal
(Formal
);
7627 -- Case of list of mechanism associations given
7630 if Null_Record_Present
(Arg_Mechanism
) then
7632 ("inappropriate form for Mechanism parameter",
7636 -- Deal with positional ones first
7638 Formal
:= First_Formal
(Ent
);
7640 if Present
(Expressions
(Arg_Mechanism
)) then
7641 Mname
:= First
(Expressions
(Arg_Mechanism
));
7642 while Present
(Mname
) loop
7645 ("too many mechanism associations", Mname
);
7648 Set_Mechanism_Value
(Formal
, Mname
);
7649 Next_Formal
(Formal
);
7654 -- Deal with named entries
7656 if Present
(Component_Associations
(Arg_Mechanism
)) then
7657 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7658 while Present
(Massoc
) loop
7659 Choice
:= First
(Choices
(Massoc
));
7661 if Nkind
(Choice
) /= N_Identifier
7662 or else Present
(Next
(Choice
))
7665 ("incorrect form for mechanism association",
7669 Formal
:= First_Formal
(Ent
);
7673 ("parameter name & not present", Choice
);
7676 if Chars
(Choice
) = Chars
(Formal
) then
7678 (Formal
, Expression
(Massoc
));
7680 -- Set entity on identifier (needed by ASIS)
7682 Set_Entity
(Choice
, Formal
);
7687 Next_Formal
(Formal
);
7696 end Process_Extended_Import_Export_Subprogram_Pragma
;
7698 --------------------------
7699 -- Process_Generic_List --
7700 --------------------------
7702 procedure Process_Generic_List
is
7707 Check_No_Identifiers
;
7708 Check_At_Least_N_Arguments
(1);
7710 -- Check all arguments are names of generic units or instances
7713 while Present
(Arg
) loop
7714 Exp
:= Get_Pragma_Arg
(Arg
);
7717 if not Is_Entity_Name
(Exp
)
7719 (not Is_Generic_Instance
(Entity
(Exp
))
7721 not Is_Generic_Unit
(Entity
(Exp
)))
7724 ("pragma% argument must be name of generic unit/instance",
7730 end Process_Generic_List
;
7732 ------------------------------------
7733 -- Process_Import_Predefined_Type --
7734 ------------------------------------
7736 procedure Process_Import_Predefined_Type
is
7737 Loc
: constant Source_Ptr
:= Sloc
(N
);
7739 Ftyp
: Node_Id
:= Empty
;
7745 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7748 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7749 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7753 Ftyp
:= Node
(Elmt
);
7755 if Present
(Ftyp
) then
7757 -- Don't build a derived type declaration, because predefined C
7758 -- types have no declaration anywhere, so cannot really be named.
7759 -- Instead build a full type declaration, starting with an
7760 -- appropriate type definition is built
7762 if Is_Floating_Point_Type
(Ftyp
) then
7763 Def
:= Make_Floating_Point_Definition
(Loc
,
7764 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7765 Make_Real_Range_Specification
(Loc
,
7766 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7767 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7769 -- Should never have a predefined type we cannot handle
7772 raise Program_Error
;
7775 -- Build and insert a Full_Type_Declaration, which will be
7776 -- analyzed as soon as this list entry has been analyzed.
7778 Decl
:= Make_Full_Type_Declaration
(Loc
,
7779 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7780 Type_Definition
=> Def
);
7782 Insert_After
(N
, Decl
);
7783 Mark_Rewrite_Insertion
(Decl
);
7786 Error_Pragma_Arg
("no matching type found for pragma%",
7789 end Process_Import_Predefined_Type
;
7791 ---------------------------------
7792 -- Process_Import_Or_Interface --
7793 ---------------------------------
7795 procedure Process_Import_Or_Interface
is
7801 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7802 -- pragma Import (Entity, "external name");
7804 if Relaxed_RM_Semantics
7805 and then Arg_Count
= 2
7806 and then Prag_Id
= Pragma_Import
7807 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7810 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7813 if not Is_Entity_Name
(Def_Id
) then
7814 Error_Pragma_Arg
("entity name required", Arg1
);
7817 Def_Id
:= Entity
(Def_Id
);
7818 Kill_Size_Check_Code
(Def_Id
);
7819 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7822 Process_Convention
(C
, Def_Id
);
7823 Kill_Size_Check_Code
(Def_Id
);
7824 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7827 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7829 -- We do not permit Import to apply to a renaming declaration
7831 if Present
(Renamed_Object
(Def_Id
)) then
7833 ("pragma% not allowed for object renaming", Arg2
);
7835 -- User initialization is not allowed for imported object, but
7836 -- the object declaration may contain a default initialization,
7837 -- that will be discarded. Note that an explicit initialization
7838 -- only counts if it comes from source, otherwise it is simply
7839 -- the code generator making an implicit initialization explicit.
7841 elsif Present
(Expression
(Parent
(Def_Id
)))
7842 and then Comes_From_Source
7843 (Original_Node
(Expression
(Parent
(Def_Id
))))
7845 -- Set imported flag to prevent cascaded errors
7847 Set_Is_Imported
(Def_Id
);
7849 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7851 ("no initialization allowed for declaration of& #",
7852 "\imported entities cannot be initialized (RM B.1(24))",
7856 -- If the pragma comes from an aspect specification the
7857 -- Is_Imported flag has already been set.
7859 if not From_Aspect_Specification
(N
) then
7860 Set_Imported
(Def_Id
);
7863 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7865 -- Note that we do not set Is_Public here. That's because we
7866 -- only want to set it if there is no address clause, and we
7867 -- don't know that yet, so we delay that processing till
7870 -- pragma Import completes deferred constants
7872 if Ekind
(Def_Id
) = E_Constant
then
7873 Set_Has_Completion
(Def_Id
);
7876 -- It is not possible to import a constant of an unconstrained
7877 -- array type (e.g. string) because there is no simple way to
7878 -- write a meaningful subtype for it.
7880 if Is_Array_Type
(Etype
(Def_Id
))
7881 and then not Is_Constrained
(Etype
(Def_Id
))
7884 ("imported constant& must have a constrained subtype",
7889 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7891 -- If the name is overloaded, pragma applies to all of the denoted
7892 -- entities in the same declarative part, unless the pragma comes
7893 -- from an aspect specification or was generated by the compiler
7894 -- (such as for pragma Provide_Shift_Operators).
7897 while Present
(Hom_Id
) loop
7899 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7901 -- Ignore inherited subprograms because the pragma will apply
7902 -- to the parent operation, which is the one called.
7904 if Is_Overloadable
(Def_Id
)
7905 and then Present
(Alias
(Def_Id
))
7909 -- If it is not a subprogram, it must be in an outer scope and
7910 -- pragma does not apply.
7912 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7915 -- The pragma does not apply to primitives of interfaces
7917 elsif Is_Dispatching_Operation
(Def_Id
)
7918 and then Present
(Find_Dispatching_Type
(Def_Id
))
7919 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7923 -- Verify that the homonym is in the same declarative part (not
7924 -- just the same scope). If the pragma comes from an aspect
7925 -- specification we know that it is part of the declaration.
7927 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7928 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7929 and then not From_Aspect_Specification
(N
)
7934 -- If the pragma comes from an aspect specification the
7935 -- Is_Imported flag has already been set.
7937 if not From_Aspect_Specification
(N
) then
7938 Set_Imported
(Def_Id
);
7941 -- Reject an Import applied to an abstract subprogram
7943 if Is_Subprogram
(Def_Id
)
7944 and then Is_Abstract_Subprogram
(Def_Id
)
7946 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7948 ("cannot import abstract subprogram& declared#",
7952 -- Special processing for Convention_Intrinsic
7954 if C
= Convention_Intrinsic
then
7956 -- Link_Name argument not allowed for intrinsic
7960 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7962 -- If no external name is present, then check that this
7963 -- is a valid intrinsic subprogram. If an external name
7964 -- is present, then this is handled by the back end.
7967 Check_Intrinsic_Subprogram
7968 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7972 -- Verify that the subprogram does not have a completion
7973 -- through a renaming declaration. For other completions the
7974 -- pragma appears as a too late representation.
7977 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7981 and then Nkind
(Decl
) = N_Subprogram_Declaration
7982 and then Present
(Corresponding_Body
(Decl
))
7983 and then Nkind
(Unit_Declaration_Node
7984 (Corresponding_Body
(Decl
))) =
7985 N_Subprogram_Renaming_Declaration
7987 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7989 ("cannot import&, renaming already provided for "
7990 & "declaration #", N
, Def_Id
);
7994 -- If the pragma comes from an aspect specification, there
7995 -- must be an Import aspect specified as well. In the rare
7996 -- case where Import is set to False, the suprogram needs to
7997 -- have a local completion.
8000 Imp_Aspect
: constant Node_Id
:=
8001 Find_Aspect
(Def_Id
, Aspect_Import
);
8005 if Present
(Imp_Aspect
)
8006 and then Present
(Expression
(Imp_Aspect
))
8008 Expr
:= Expression
(Imp_Aspect
);
8009 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8011 if Is_Entity_Name
(Expr
)
8012 and then Entity
(Expr
) = Standard_True
8014 Set_Has_Completion
(Def_Id
);
8017 -- If there is no expression, the default is True, as for
8018 -- all boolean aspects. Same for the older pragma.
8021 Set_Has_Completion
(Def_Id
);
8025 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8028 if Is_Compilation_Unit
(Hom_Id
) then
8030 -- Its possible homonyms are not affected by the pragma.
8031 -- Such homonyms might be present in the context of other
8032 -- units being compiled.
8036 elsif From_Aspect_Specification
(N
) then
8039 -- If the pragma was created by the compiler, then we don't
8040 -- want it to apply to other homonyms. This kind of case can
8041 -- occur when using pragma Provide_Shift_Operators, which
8042 -- generates implicit shift and rotate operators with Import
8043 -- pragmas that might apply to earlier explicit or implicit
8044 -- declarations marked with Import (for example, coming from
8045 -- an earlier pragma Provide_Shift_Operators for another type),
8046 -- and we don't generally want other homonyms being treated
8047 -- as imported or the pragma flagged as an illegal duplicate.
8049 elsif not Comes_From_Source
(N
) then
8053 Hom_Id
:= Homonym
(Hom_Id
);
8057 -- When the convention is Java or CIL, we also allow Import to
8058 -- be given for packages, generic packages, exceptions, record
8059 -- components, and access to subprograms.
8061 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
8063 (Is_Package_Or_Generic_Package
(Def_Id
)
8064 or else Ekind
(Def_Id
) = E_Exception
8065 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
8066 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
8068 Set_Imported
(Def_Id
);
8069 Set_Is_Public
(Def_Id
);
8070 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8072 -- Import a CPP class
8074 elsif C
= Convention_CPP
8075 and then (Is_Record_Type
(Def_Id
)
8076 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8078 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8079 if Present
(Full_View
(Def_Id
)) then
8080 Def_Id
:= Full_View
(Def_Id
);
8084 ("cannot import 'C'P'P type before full declaration seen",
8085 Get_Pragma_Arg
(Arg2
));
8087 -- Although we have reported the error we decorate it as
8088 -- CPP_Class to avoid reporting spurious errors
8090 Set_Is_CPP_Class
(Def_Id
);
8095 -- Types treated as CPP classes must be declared limited (note:
8096 -- this used to be a warning but there is no real benefit to it
8097 -- since we did effectively intend to treat the type as limited
8100 if not Is_Limited_Type
(Def_Id
) then
8102 ("imported 'C'P'P type must be limited",
8103 Get_Pragma_Arg
(Arg2
));
8106 if Etype
(Def_Id
) /= Def_Id
8107 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8109 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8112 Set_Is_CPP_Class
(Def_Id
);
8114 -- Imported CPP types must not have discriminants (because C++
8115 -- classes do not have discriminants).
8117 if Has_Discriminants
(Def_Id
) then
8119 ("imported 'C'P'P type cannot have discriminants",
8120 First
(Discriminant_Specifications
8121 (Declaration_Node
(Def_Id
))));
8124 -- Check that components of imported CPP types do not have default
8125 -- expressions. For private types this check is performed when the
8126 -- full view is analyzed (see Process_Full_View).
8128 if not Is_Private_Type
(Def_Id
) then
8129 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8132 -- Import a CPP exception
8134 elsif C
= Convention_CPP
8135 and then Ekind
(Def_Id
) = E_Exception
8139 ("'External_'Name arguments is required for 'Cpp exception",
8142 -- As only a string is allowed, Check_Arg_Is_External_Name
8145 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8148 if Present
(Arg4
) then
8150 ("Link_Name argument not allowed for imported Cpp exception",
8154 -- Do not call Set_Interface_Name as the name of the exception
8155 -- shouldn't be modified (and in particular it shouldn't be
8156 -- the External_Name). For exceptions, the External_Name is the
8157 -- name of the RTTI structure.
8159 -- ??? Emit an error if pragma Import/Export_Exception is present
8161 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8163 Check_Arg_Count
(3);
8164 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8166 Process_Import_Predefined_Type
;
8170 ("second argument of pragma% must be object, subprogram "
8171 & "or incomplete type",
8175 -- If this pragma applies to a compilation unit, then the unit, which
8176 -- is a subprogram, does not require (or allow) a body. We also do
8177 -- not need to elaborate imported procedures.
8179 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8181 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8183 Set_Body_Required
(Cunit
, False);
8186 end Process_Import_Or_Interface
;
8188 --------------------
8189 -- Process_Inline --
8190 --------------------
8192 procedure Process_Inline
(Status
: Inline_Status
) is
8199 Effective
: Boolean := False;
8200 -- Set True if inline has some effect, i.e. if there is at least one
8201 -- subprogram set as inlined as a result of the use of the pragma.
8203 procedure Make_Inline
(Subp
: Entity_Id
);
8204 -- Subp is the defining unit name of the subprogram declaration. Set
8205 -- the flag, as well as the flag in the corresponding body, if there
8208 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8209 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8210 -- Has_Pragma_Inline_Always for the Inline_Always case.
8212 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8213 -- Returns True if it can be determined at this stage that inlining
8214 -- is not possible, for example if the body is available and contains
8215 -- exception handlers, we prevent inlining, since otherwise we can
8216 -- get undefined symbols at link time. This function also emits a
8217 -- warning if front-end inlining is enabled and the pragma appears
8220 -- ??? is business with link symbols still valid, or does it relate
8221 -- to front end ZCX which is being phased out ???
8223 ---------------------------
8224 -- Inlining_Not_Possible --
8225 ---------------------------
8227 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8228 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8232 if Nkind
(Decl
) = N_Subprogram_Body
then
8233 Stats
:= Handled_Statement_Sequence
(Decl
);
8234 return Present
(Exception_Handlers
(Stats
))
8235 or else Present
(At_End_Proc
(Stats
));
8237 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8238 and then Present
(Corresponding_Body
(Decl
))
8240 if Front_End_Inlining
8241 and then Analyzed
(Corresponding_Body
(Decl
))
8243 Error_Msg_N
("pragma appears too late, ignored??", N
);
8246 -- If the subprogram is a renaming as body, the body is just a
8247 -- call to the renamed subprogram, and inlining is trivially
8251 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8252 N_Subprogram_Renaming_Declaration
8258 Handled_Statement_Sequence
8259 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8262 Present
(Exception_Handlers
(Stats
))
8263 or else Present
(At_End_Proc
(Stats
));
8267 -- If body is not available, assume the best, the check is
8268 -- performed again when compiling enclosing package bodies.
8272 end Inlining_Not_Possible
;
8278 procedure Make_Inline
(Subp
: Entity_Id
) is
8279 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8280 Inner_Subp
: Entity_Id
:= Subp
;
8283 -- Ignore if bad type, avoid cascaded error
8285 if Etype
(Subp
) = Any_Type
then
8289 -- Ignore if all inlining is suppressed
8291 elsif Suppress_All_Inlining
then
8295 -- If inlining is not possible, for now do not treat as an error
8297 elsif Status
/= Suppressed
8298 and then Inlining_Not_Possible
(Subp
)
8303 -- Here we have a candidate for inlining, but we must exclude
8304 -- derived operations. Otherwise we would end up trying to inline
8305 -- a phantom declaration, and the result would be to drag in a
8306 -- body which has no direct inlining associated with it. That
8307 -- would not only be inefficient but would also result in the
8308 -- backend doing cross-unit inlining in cases where it was
8309 -- definitely inappropriate to do so.
8311 -- However, a simple Comes_From_Source test is insufficient, since
8312 -- we do want to allow inlining of generic instances which also do
8313 -- not come from source. We also need to recognize specs generated
8314 -- by the front-end for bodies that carry the pragma. Finally,
8315 -- predefined operators do not come from source but are not
8316 -- inlineable either.
8318 elsif Is_Generic_Instance
(Subp
)
8319 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8323 elsif not Comes_From_Source
(Subp
)
8324 and then Scope
(Subp
) /= Standard_Standard
8330 -- The referenced entity must either be the enclosing entity, or
8331 -- an entity declared within the current open scope.
8333 if Present
(Scope
(Subp
))
8334 and then Scope
(Subp
) /= Current_Scope
8335 and then Subp
/= Current_Scope
8338 ("argument of% must be entity in current scope", Assoc
);
8342 -- Processing for procedure, operator or function. If subprogram
8343 -- is aliased (as for an instance) indicate that the renamed
8344 -- entity (if declared in the same unit) is inlined.
8346 if Is_Subprogram
(Subp
) then
8347 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8349 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8350 Set_Inline_Flags
(Inner_Subp
);
8352 Decl
:= Parent
(Parent
(Inner_Subp
));
8354 if Nkind
(Decl
) = N_Subprogram_Declaration
8355 and then Present
(Corresponding_Body
(Decl
))
8357 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8359 elsif Is_Generic_Instance
(Subp
) then
8361 -- Indicate that the body needs to be created for
8362 -- inlining subsequent calls. The instantiation node
8363 -- follows the declaration of the wrapper package
8366 if Scope
(Subp
) /= Standard_Standard
8368 Need_Subprogram_Instance_Body
8369 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8375 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8376 -- appear in a formal part to apply to a formal subprogram.
8377 -- Do not apply check within an instance or a formal package
8378 -- the test will have been applied to the original generic.
8380 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8381 and then List_Containing
(Decl
) = List_Containing
(N
)
8382 and then not In_Instance
8385 ("Inline cannot apply to a formal subprogram", N
);
8387 -- If Subp is a renaming, it is the renamed entity that
8388 -- will appear in any call, and be inlined. However, for
8389 -- ASIS uses it is convenient to indicate that the renaming
8390 -- itself is an inlined subprogram, so that some gnatcheck
8391 -- rules can be applied in the absence of expansion.
8393 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8394 Set_Inline_Flags
(Subp
);
8400 -- For a generic subprogram set flag as well, for use at the point
8401 -- of instantiation, to determine whether the body should be
8404 elsif Is_Generic_Subprogram
(Subp
) then
8405 Set_Inline_Flags
(Subp
);
8408 -- Literals are by definition inlined
8410 elsif Kind
= E_Enumeration_Literal
then
8413 -- Anything else is an error
8417 ("expect subprogram name for pragma%", Assoc
);
8421 ----------------------
8422 -- Set_Inline_Flags --
8423 ----------------------
8425 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8427 -- First set the Has_Pragma_XXX flags and issue the appropriate
8428 -- errors and warnings for suspicious combinations.
8430 if Prag_Id
= Pragma_No_Inline
then
8431 if Has_Pragma_Inline_Always
(Subp
) then
8433 ("Inline_Always and No_Inline are mutually exclusive", N
);
8434 elsif Has_Pragma_Inline
(Subp
) then
8436 ("Inline and No_Inline both specified for& ??",
8437 N
, Entity
(Subp_Id
));
8440 Set_Has_Pragma_No_Inline
(Subp
);
8442 if Prag_Id
= Pragma_Inline_Always
then
8443 if Has_Pragma_No_Inline
(Subp
) then
8445 ("Inline_Always and No_Inline are mutually exclusive",
8449 Set_Has_Pragma_Inline_Always
(Subp
);
8451 if Has_Pragma_No_Inline
(Subp
) then
8453 ("Inline and No_Inline both specified for& ??",
8454 N
, Entity
(Subp_Id
));
8458 if not Has_Pragma_Inline
(Subp
) then
8459 Set_Has_Pragma_Inline
(Subp
);
8464 -- Then adjust the Is_Inlined flag. It can never be set if the
8465 -- subprogram is subject to pragma No_Inline.
8469 Set_Is_Inlined
(Subp
, False);
8473 if not Has_Pragma_No_Inline
(Subp
) then
8474 Set_Is_Inlined
(Subp
, True);
8477 end Set_Inline_Flags
;
8479 -- Start of processing for Process_Inline
8482 Check_No_Identifiers
;
8483 Check_At_Least_N_Arguments
(1);
8485 if Status
= Enabled
then
8486 Inline_Processing_Required
:= True;
8490 while Present
(Assoc
) loop
8491 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8495 if Is_Entity_Name
(Subp_Id
) then
8496 Subp
:= Entity
(Subp_Id
);
8498 if Subp
= Any_Id
then
8500 -- If previous error, avoid cascaded errors
8502 Check_Error_Detected
;
8509 -- For the pragma case, climb homonym chain. This is
8510 -- what implements allowing the pragma in the renaming
8511 -- case, with the result applying to the ancestors, and
8512 -- also allows Inline to apply to all previous homonyms.
8514 if not From_Aspect_Specification
(N
) then
8515 while Present
(Homonym
(Subp
))
8516 and then Scope
(Homonym
(Subp
)) = Current_Scope
8518 Make_Inline
(Homonym
(Subp
));
8519 Subp
:= Homonym
(Subp
);
8527 ("inappropriate argument for pragma%", Assoc
);
8530 and then Warn_On_Redundant_Constructs
8531 and then not (Status
= Suppressed
or else Suppress_All_Inlining
)
8533 if Inlining_Not_Possible
(Subp
) then
8535 ("pragma Inline for& is ignored?r?",
8536 N
, Entity
(Subp_Id
));
8539 ("pragma Inline for& is redundant?r?",
8540 N
, Entity
(Subp_Id
));
8548 ----------------------------
8549 -- Process_Interface_Name --
8550 ----------------------------
8552 procedure Process_Interface_Name
8553 (Subprogram_Def
: Entity_Id
;
8559 String_Val
: String_Id
;
8561 procedure Check_Form_Of_Interface_Name
8563 Ext_Name_Case
: Boolean);
8564 -- SN is a string literal node for an interface name. This routine
8565 -- performs some minimal checks that the name is reasonable. In
8566 -- particular that no spaces or other obviously incorrect characters
8567 -- appear. This is only a warning, since any characters are allowed.
8568 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8570 ----------------------------------
8571 -- Check_Form_Of_Interface_Name --
8572 ----------------------------------
8574 procedure Check_Form_Of_Interface_Name
8576 Ext_Name_Case
: Boolean)
8578 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8579 SL
: constant Nat
:= String_Length
(S
);
8584 Error_Msg_N
("interface name cannot be null string", SN
);
8587 for J
in 1 .. SL
loop
8588 C
:= Get_String_Char
(S
, J
);
8590 -- Look for dubious character and issue unconditional warning.
8591 -- Definitely dubious if not in character range.
8593 if not In_Character_Range
(C
)
8595 -- For all cases except CLI target,
8596 -- commas, spaces and slashes are dubious (in CLI, we use
8597 -- commas and backslashes in external names to specify
8598 -- assembly version and public key, while slashes and spaces
8599 -- can be used in names to mark nested classes and
8602 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8603 and then (Get_Character
(C
) = ','
8605 Get_Character
(C
) = '\'))
8606 or else (VM_Target
/= CLI_Target
8607 and then (Get_Character
(C
) = ' '
8609 Get_Character
(C
) = '/'))
8612 ("??interface name contains illegal character",
8613 Sloc
(SN
) + Source_Ptr
(J
));
8616 end Check_Form_Of_Interface_Name
;
8618 -- Start of processing for Process_Interface_Name
8621 if No
(Link_Arg
) then
8622 if No
(Ext_Arg
) then
8623 if VM_Target
= CLI_Target
8624 and then Ekind
(Subprogram_Def
) = E_Package
8625 and then Nkind
(Parent
(Subprogram_Def
)) =
8626 N_Package_Specification
8627 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8632 (Generic_Parent
(Parent
(Subprogram_Def
))));
8637 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8639 Link_Nam
:= Expression
(Ext_Arg
);
8642 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8643 Ext_Nam
:= Expression
(Ext_Arg
);
8648 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8649 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8650 Ext_Nam
:= Expression
(Ext_Arg
);
8651 Link_Nam
:= Expression
(Link_Arg
);
8654 -- Check expressions for external name and link name are static
8656 if Present
(Ext_Nam
) then
8657 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8658 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8660 -- Verify that external name is not the name of a local entity,
8661 -- which would hide the imported one and could lead to run-time
8662 -- surprises. The problem can only arise for entities declared in
8663 -- a package body (otherwise the external name is fully qualified
8664 -- and will not conflict).
8672 if Prag_Id
= Pragma_Import
then
8673 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8675 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
8677 if Nam
/= Chars
(Subprogram_Def
)
8678 and then Present
(E
)
8679 and then not Is_Overloadable
(E
)
8680 and then Is_Immediately_Visible
(E
)
8681 and then not Is_Imported
(E
)
8682 and then Ekind
(Scope
(E
)) = E_Package
8685 while Present
(Par
) loop
8686 if Nkind
(Par
) = N_Package_Body
then
8687 Error_Msg_Sloc
:= Sloc
(E
);
8689 ("imported entity is hidden by & declared#",
8694 Par
:= Parent
(Par
);
8701 if Present
(Link_Nam
) then
8702 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8703 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8706 -- If there is no link name, just set the external name
8708 if No
(Link_Nam
) then
8709 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8711 -- For the Link_Name case, the given literal is preceded by an
8712 -- asterisk, which indicates to GCC that the given name should be
8713 -- taken literally, and in particular that no prepending of
8714 -- underlines should occur, even in systems where this is the
8720 if VM_Target
= No_VM
then
8721 Store_String_Char
(Get_Char_Code
('*'));
8724 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8725 Store_String_Chars
(String_Val
);
8727 Make_String_Literal
(Sloc
(Link_Nam
),
8728 Strval
=> End_String
);
8731 -- Set the interface name. If the entity is a generic instance, use
8732 -- its alias, which is the callable entity.
8734 if Is_Generic_Instance
(Subprogram_Def
) then
8735 Set_Encoded_Interface_Name
8736 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8738 Set_Encoded_Interface_Name
8739 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8742 -- We allow duplicated export names in CIL/Java, as they are always
8743 -- enclosed in a namespace that differentiates them, and overloaded
8744 -- entities are supported by the VM.
8746 if Convention
(Subprogram_Def
) /= Convention_CIL
8748 Convention
(Subprogram_Def
) /= Convention_Java
8750 Check_Duplicated_Export_Name
(Link_Nam
);
8752 end Process_Interface_Name
;
8754 -----------------------------------------
8755 -- Process_Interrupt_Or_Attach_Handler --
8756 -----------------------------------------
8758 procedure Process_Interrupt_Or_Attach_Handler
is
8759 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8760 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8761 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8764 Set_Is_Interrupt_Handler
(Handler_Proc
);
8766 -- If the pragma is not associated with a handler procedure within a
8767 -- protected type, then it must be for a nonprotected procedure for
8768 -- the AAMP target, in which case we don't associate a representation
8769 -- item with the procedure's scope.
8771 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8772 if Prag_Id
= Pragma_Interrupt_Handler
8774 Prag_Id
= Pragma_Attach_Handler
8776 Record_Rep_Item
(Proc_Scope
, N
);
8779 end Process_Interrupt_Or_Attach_Handler
;
8781 --------------------------------------------------
8782 -- Process_Restrictions_Or_Restriction_Warnings --
8783 --------------------------------------------------
8785 -- Note: some of the simple identifier cases were handled in par-prag,
8786 -- but it is harmless (and more straightforward) to simply handle all
8787 -- cases here, even if it means we repeat a bit of work in some cases.
8789 procedure Process_Restrictions_Or_Restriction_Warnings
8793 R_Id
: Restriction_Id
;
8799 -- Ignore all Restrictions pragmas in CodePeer mode
8801 if CodePeer_Mode
then
8805 Check_Ada_83_Warning
;
8806 Check_At_Least_N_Arguments
(1);
8807 Check_Valid_Configuration_Pragma
;
8810 while Present
(Arg
) loop
8812 Expr
:= Get_Pragma_Arg
(Arg
);
8814 -- Case of no restriction identifier present
8816 if Id
= No_Name
then
8817 if Nkind
(Expr
) /= N_Identifier
then
8819 ("invalid form for restriction", Arg
);
8824 (Process_Restriction_Synonyms
(Expr
));
8826 if R_Id
not in All_Boolean_Restrictions
then
8827 Error_Msg_Name_1
:= Pname
;
8829 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8831 -- Check for possible misspelling
8833 for J
in Restriction_Id
loop
8835 Rnm
: constant String := Restriction_Id
'Image (J
);
8838 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8839 Name_Len
:= Rnm
'Length;
8840 Set_Casing
(All_Lower_Case
);
8842 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8844 (Identifier_Casing
(Current_Source_File
));
8845 Error_Msg_String
(1 .. Rnm
'Length) :=
8846 Name_Buffer
(1 .. Name_Len
);
8847 Error_Msg_Strlen
:= Rnm
'Length;
8848 Error_Msg_N
-- CODEFIX
8849 ("\possible misspelling of ""~""",
8850 Get_Pragma_Arg
(Arg
));
8859 if Implementation_Restriction
(R_Id
) then
8860 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8863 -- Special processing for No_Elaboration_Code restriction
8865 if R_Id
= No_Elaboration_Code
then
8867 -- Restriction is only recognized within a configuration
8868 -- pragma file, or within a unit of the main extended
8869 -- program. Note: the test for Main_Unit is needed to
8870 -- properly include the case of configuration pragma files.
8872 if not (Current_Sem_Unit
= Main_Unit
8873 or else In_Extended_Main_Source_Unit
(N
))
8877 -- Don't allow in a subunit unless already specified in
8880 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8881 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8882 and then not Restriction_Active
(No_Elaboration_Code
)
8885 ("invalid specification of ""No_Elaboration_Code""",
8888 ("\restriction cannot be specified in a subunit", N
);
8890 ("\unless also specified in body or spec", N
);
8893 -- If we accept a No_Elaboration_Code restriction, then it
8894 -- needs to be added to the configuration restriction set so
8895 -- that we get proper application to other units in the main
8896 -- extended source as required.
8899 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8903 -- If this is a warning, then set the warning unless we already
8904 -- have a real restriction active (we never want a warning to
8905 -- override a real restriction).
8908 if not Restriction_Active
(R_Id
) then
8909 Set_Restriction
(R_Id
, N
);
8910 Restriction_Warnings
(R_Id
) := True;
8913 -- If real restriction case, then set it and make sure that the
8914 -- restriction warning flag is off, since a real restriction
8915 -- always overrides a warning.
8918 Set_Restriction
(R_Id
, N
);
8919 Restriction_Warnings
(R_Id
) := False;
8922 -- Check for obsolescent restrictions in Ada 2005 mode
8925 and then Ada_Version
>= Ada_2005
8926 and then (R_Id
= No_Asynchronous_Control
8928 R_Id
= No_Unchecked_Deallocation
8930 R_Id
= No_Unchecked_Conversion
)
8932 Check_Restriction
(No_Obsolescent_Features
, N
);
8935 -- A very special case that must be processed here: pragma
8936 -- Restrictions (No_Exceptions) turns off all run-time
8937 -- checking. This is a bit dubious in terms of the formal
8938 -- language definition, but it is what is intended by RM
8939 -- H.4(12). Restriction_Warnings never affects generated code
8940 -- so this is done only in the real restriction case.
8942 -- Atomic_Synchronization is not a real check, so it is not
8943 -- affected by this processing).
8945 if R_Id
= No_Exceptions
and then not Warn
then
8946 for J
in Scope_Suppress
.Suppress
'Range loop
8947 if J
/= Atomic_Synchronization
then
8948 Scope_Suppress
.Suppress
(J
) := True;
8953 -- Case of No_Dependence => unit-name. Note that the parser
8954 -- already made the necessary entry in the No_Dependence table.
8956 elsif Id
= Name_No_Dependence
then
8957 if not OK_No_Dependence_Unit_Name
(Expr
) then
8961 -- Case of No_Specification_Of_Aspect => Identifier.
8963 elsif Id
= Name_No_Specification_Of_Aspect
then
8968 if Nkind
(Expr
) /= N_Identifier
then
8971 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8974 if A_Id
= No_Aspect
then
8975 Error_Pragma_Arg
("invalid restriction name", Arg
);
8977 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8981 elsif Id
= Name_No_Use_Of_Attribute
then
8982 if Nkind
(Expr
) /= N_Identifier
8983 or else not Is_Attribute_Name
(Chars
(Expr
))
8985 Error_Msg_N
("unknown attribute name??", Expr
);
8988 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8991 elsif Id
= Name_No_Use_Of_Pragma
then
8992 if Nkind
(Expr
) /= N_Identifier
8993 or else not Is_Pragma_Name
(Chars
(Expr
))
8995 Error_Msg_N
("unknown pragma name??", Expr
);
8998 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9001 -- All other cases of restriction identifier present
9004 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9005 Analyze_And_Resolve
(Expr
, Any_Integer
);
9007 if R_Id
not in All_Parameter_Restrictions
then
9009 ("invalid restriction parameter identifier", Arg
);
9011 elsif not Is_OK_Static_Expression
(Expr
) then
9012 Flag_Non_Static_Expr
9013 ("value must be static expression!", Expr
);
9016 elsif not Is_Integer_Type
(Etype
(Expr
))
9017 or else Expr_Value
(Expr
) < 0
9020 ("value must be non-negative integer", Arg
);
9023 -- Restriction pragma is active
9025 Val
:= Expr_Value
(Expr
);
9027 if not UI_Is_In_Int_Range
(Val
) then
9029 ("pragma ignored, value too large??", Arg
);
9032 -- Warning case. If the real restriction is active, then we
9033 -- ignore the request, since warning never overrides a real
9034 -- restriction. Otherwise we set the proper warning. Note that
9035 -- this circuit sets the warning again if it is already set,
9036 -- which is what we want, since the constant may have changed.
9039 if not Restriction_Active
(R_Id
) then
9041 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9042 Restriction_Warnings
(R_Id
) := True;
9045 -- Real restriction case, set restriction and make sure warning
9046 -- flag is off since real restriction always overrides warning.
9049 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9050 Restriction_Warnings
(R_Id
) := False;
9056 end Process_Restrictions_Or_Restriction_Warnings
;
9058 ---------------------------------
9059 -- Process_Suppress_Unsuppress --
9060 ---------------------------------
9062 -- Note: this procedure makes entries in the check suppress data
9063 -- structures managed by Sem. See spec of package Sem for full
9064 -- details on how we handle recording of check suppression.
9066 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9071 In_Package_Spec
: constant Boolean :=
9072 Is_Package_Or_Generic_Package
(Current_Scope
)
9073 and then not In_Package_Body
(Current_Scope
);
9075 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9076 -- Used to suppress a single check on the given entity
9078 --------------------------------
9079 -- Suppress_Unsuppress_Echeck --
9080 --------------------------------
9082 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9084 -- Check for error of trying to set atomic synchronization for
9085 -- a non-atomic variable.
9087 if C
= Atomic_Synchronization
9088 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9091 ("pragma & requires atomic type or variable",
9092 Pragma_Identifier
(Original_Node
(N
)));
9095 Set_Checks_May_Be_Suppressed
(E
);
9097 if In_Package_Spec
then
9098 Push_Global_Suppress_Stack_Entry
9101 Suppress
=> Suppress_Case
);
9103 Push_Local_Suppress_Stack_Entry
9106 Suppress
=> Suppress_Case
);
9109 -- If this is a first subtype, and the base type is distinct,
9110 -- then also set the suppress flags on the base type.
9112 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9113 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9115 end Suppress_Unsuppress_Echeck
;
9117 -- Start of processing for Process_Suppress_Unsuppress
9120 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9121 -- on user code: we want to generate checks for analysis purposes, as
9122 -- set respectively by -gnatC and -gnatd.F
9124 if (CodePeer_Mode
or GNATprove_Mode
)
9125 and then Comes_From_Source
(N
)
9130 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9131 -- declarative part or a package spec (RM 11.5(5)).
9133 if not Is_Configuration_Pragma
then
9134 Check_Is_In_Decl_Part_Or_Package_Spec
;
9137 Check_At_Least_N_Arguments
(1);
9138 Check_At_Most_N_Arguments
(2);
9139 Check_No_Identifier
(Arg1
);
9140 Check_Arg_Is_Identifier
(Arg1
);
9142 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9144 if C
= No_Check_Id
then
9146 ("argument of pragma% is not valid check name", Arg1
);
9149 if Arg_Count
= 1 then
9151 -- Make an entry in the local scope suppress table. This is the
9152 -- table that directly shows the current value of the scope
9153 -- suppress check for any check id value.
9155 if C
= All_Checks
then
9157 -- For All_Checks, we set all specific predefined checks with
9158 -- the exception of Elaboration_Check, which is handled
9159 -- specially because of not wanting All_Checks to have the
9160 -- effect of deactivating static elaboration order processing.
9161 -- Atomic_Synchronization is also not affected, since this is
9162 -- not a real check.
9164 for J
in Scope_Suppress
.Suppress
'Range loop
9165 if J
/= Elaboration_Check
9167 J
/= Atomic_Synchronization
9169 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9173 -- If not All_Checks, and predefined check, then set appropriate
9174 -- scope entry. Note that we will set Elaboration_Check if this
9175 -- is explicitly specified. Atomic_Synchronization is allowed
9176 -- only if internally generated and entity is atomic.
9178 elsif C
in Predefined_Check_Id
9179 and then (not Comes_From_Source
(N
)
9180 or else C
/= Atomic_Synchronization
)
9182 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9185 -- Also make an entry in the Local_Entity_Suppress table
9187 Push_Local_Suppress_Stack_Entry
9190 Suppress
=> Suppress_Case
);
9192 -- Case of two arguments present, where the check is suppressed for
9193 -- a specified entity (given as the second argument of the pragma)
9196 -- This is obsolescent in Ada 2005 mode
9198 if Ada_Version
>= Ada_2005
then
9199 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9202 Check_Optional_Identifier
(Arg2
, Name_On
);
9203 E_Id
:= Get_Pragma_Arg
(Arg2
);
9206 if not Is_Entity_Name
(E_Id
) then
9208 ("second argument of pragma% must be entity name", Arg2
);
9217 -- Enforce RM 11.5(7) which requires that for a pragma that
9218 -- appears within a package spec, the named entity must be
9219 -- within the package spec. We allow the package name itself
9220 -- to be mentioned since that makes sense, although it is not
9221 -- strictly allowed by 11.5(7).
9224 and then E
/= Current_Scope
9225 and then Scope
(E
) /= Current_Scope
9228 ("entity in pragma% is not in package spec (RM 11.5(7))",
9232 -- Loop through homonyms. As noted below, in the case of a package
9233 -- spec, only homonyms within the package spec are considered.
9236 Suppress_Unsuppress_Echeck
(E
, C
);
9238 if Is_Generic_Instance
(E
)
9239 and then Is_Subprogram
(E
)
9240 and then Present
(Alias
(E
))
9242 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9245 -- Move to next homonym if not aspect spec case
9247 exit when From_Aspect_Specification
(N
);
9251 -- If we are within a package specification, the pragma only
9252 -- applies to homonyms in the same scope.
9254 exit when In_Package_Spec
9255 and then Scope
(E
) /= Current_Scope
;
9258 end Process_Suppress_Unsuppress
;
9264 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9266 if Is_Imported
(E
) then
9268 ("cannot export entity& that was previously imported", Arg
);
9270 elsif Present
(Address_Clause
(E
))
9271 and then not Relaxed_RM_Semantics
9274 ("cannot export entity& that has an address clause", Arg
);
9277 Set_Is_Exported
(E
);
9279 -- Generate a reference for entity explicitly, because the
9280 -- identifier may be overloaded and name resolution will not
9283 Generate_Reference
(E
, Arg
);
9285 -- Deal with exporting non-library level entity
9287 if not Is_Library_Level_Entity
(E
) then
9289 -- Not allowed at all for subprograms
9291 if Is_Subprogram
(E
) then
9292 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9294 -- Otherwise set public and statically allocated
9298 Set_Is_Statically_Allocated
(E
);
9300 -- Warn if the corresponding W flag is set
9302 if Warn_On_Export_Import
9304 -- Only do this for something that was in the source. Not
9305 -- clear if this can be False now (there used for sure to be
9306 -- cases on some systems where it was False), but anyway the
9307 -- test is harmless if not needed, so it is retained.
9309 and then Comes_From_Source
(Arg
)
9312 ("?x?& has been made static as a result of Export",
9315 ("\?x?this usage is non-standard and non-portable",
9321 if Warn_On_Export_Import
and then Is_Type
(E
) then
9322 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9325 if Warn_On_Export_Import
and Inside_A_Generic
then
9327 ("all instances of& will have the same external name?x?",
9332 ----------------------------------------------
9333 -- Set_Extended_Import_Export_External_Name --
9334 ----------------------------------------------
9336 procedure Set_Extended_Import_Export_External_Name
9337 (Internal_Ent
: Entity_Id
;
9338 Arg_External
: Node_Id
)
9340 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9344 if No
(Arg_External
) then
9348 Check_Arg_Is_External_Name
(Arg_External
);
9350 if Nkind
(Arg_External
) = N_String_Literal
then
9351 if String_Length
(Strval
(Arg_External
)) = 0 then
9354 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9357 elsif Nkind
(Arg_External
) = N_Identifier
then
9358 New_Name
:= Get_Default_External_Name
(Arg_External
);
9360 -- Check_Arg_Is_External_Name should let through only identifiers and
9361 -- string literals or static string expressions (which are folded to
9362 -- string literals).
9365 raise Program_Error
;
9368 -- If we already have an external name set (by a prior normal Import
9369 -- or Export pragma), then the external names must match
9371 if Present
(Interface_Name
(Internal_Ent
)) then
9373 -- Ignore mismatching names in CodePeer mode, to support some
9374 -- old compilers which would export the same procedure under
9375 -- different names, e.g:
9377 -- pragma Export_Procedure (P, "a");
9378 -- pragma Export_Procedure (P, "b");
9380 if CodePeer_Mode
then
9384 Check_Matching_Internal_Names
: declare
9385 S1
: constant String_Id
:= Strval
(Old_Name
);
9386 S2
: constant String_Id
:= Strval
(New_Name
);
9389 pragma No_Return
(Mismatch
);
9390 -- Called if names do not match
9396 procedure Mismatch
is
9398 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9400 ("external name does not match that given #",
9404 -- Start of processing for Check_Matching_Internal_Names
9407 if String_Length
(S1
) /= String_Length
(S2
) then
9411 for J
in 1 .. String_Length
(S1
) loop
9412 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9417 end Check_Matching_Internal_Names
;
9419 -- Otherwise set the given name
9422 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9423 Check_Duplicated_Export_Name
(New_Name
);
9425 end Set_Extended_Import_Export_External_Name
;
9431 procedure Set_Imported
(E
: Entity_Id
) is
9433 -- Error message if already imported or exported
9435 if Is_Exported
(E
) or else Is_Imported
(E
) then
9437 -- Error if being set Exported twice
9439 if Is_Exported
(E
) then
9440 Error_Msg_NE
("entity& was previously exported", N
, E
);
9442 -- Ignore error in CodePeer mode where we treat all imported
9443 -- subprograms as unknown.
9445 elsif CodePeer_Mode
then
9448 -- OK if Import/Interface case
9450 elsif Import_Interface_Present
(N
) then
9453 -- Error if being set Imported twice
9456 Error_Msg_NE
("entity& was previously imported", N
, E
);
9459 Error_Msg_Name_1
:= Pname
;
9461 ("\(pragma% applies to all previous entities)", N
);
9463 Error_Msg_Sloc
:= Sloc
(E
);
9464 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9466 -- Here if not previously imported or exported, OK to import
9469 Set_Is_Imported
(E
);
9471 -- For subprogram, set Import_Pragma field
9473 if Is_Subprogram
(E
) then
9474 Set_Import_Pragma
(E
, N
);
9477 -- If the entity is an object that is not at the library level,
9478 -- then it is statically allocated. We do not worry about objects
9479 -- with address clauses in this context since they are not really
9480 -- imported in the linker sense.
9483 and then not Is_Library_Level_Entity
(E
)
9484 and then No
(Address_Clause
(E
))
9486 Set_Is_Statically_Allocated
(E
);
9493 -------------------------
9494 -- Set_Mechanism_Value --
9495 -------------------------
9497 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9498 -- analyzed, since it is semantic nonsense), so we get it in the exact
9499 -- form created by the parser.
9501 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9502 procedure Bad_Mechanism
;
9503 pragma No_Return
(Bad_Mechanism
);
9504 -- Signal bad mechanism name
9506 -------------------------
9507 -- Bad_Mechanism_Value --
9508 -------------------------
9510 procedure Bad_Mechanism
is
9512 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9515 -- Start of processing for Set_Mechanism_Value
9518 if Mechanism
(Ent
) /= Default_Mechanism
then
9520 ("mechanism for & has already been set", Mech_Name
, Ent
);
9523 -- MECHANISM_NAME ::= value | reference
9525 if Nkind
(Mech_Name
) = N_Identifier
then
9526 if Chars
(Mech_Name
) = Name_Value
then
9527 Set_Mechanism
(Ent
, By_Copy
);
9530 elsif Chars
(Mech_Name
) = Name_Reference
then
9531 Set_Mechanism
(Ent
, By_Reference
);
9534 elsif Chars
(Mech_Name
) = Name_Copy
then
9536 ("bad mechanism name, Value assumed", Mech_Name
);
9545 end Set_Mechanism_Value
;
9547 --------------------------
9548 -- Set_Rational_Profile --
9549 --------------------------
9551 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9552 -- and extension to the semantics of renaming declarations.
9554 procedure Set_Rational_Profile
is
9556 Implicit_Packing
:= True;
9557 Overriding_Renamings
:= True;
9558 Use_VADS_Size
:= True;
9559 end Set_Rational_Profile
;
9561 ---------------------------
9562 -- Set_Ravenscar_Profile --
9563 ---------------------------
9565 -- The tasks to be done here are
9567 -- Set required policies
9569 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9570 -- pragma Locking_Policy (Ceiling_Locking)
9572 -- Set Detect_Blocking mode
9574 -- Set required restrictions (see System.Rident for detailed list)
9576 -- Set the No_Dependence rules
9577 -- No_Dependence => Ada.Asynchronous_Task_Control
9578 -- No_Dependence => Ada.Calendar
9579 -- No_Dependence => Ada.Execution_Time.Group_Budget
9580 -- No_Dependence => Ada.Execution_Time.Timers
9581 -- No_Dependence => Ada.Task_Attributes
9582 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9584 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9585 Prefix_Entity
: Entity_Id
;
9586 Selector_Entity
: Entity_Id
;
9587 Prefix_Node
: Node_Id
;
9591 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9593 if Task_Dispatching_Policy
/= ' '
9594 and then Task_Dispatching_Policy
/= 'F'
9596 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9597 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9599 -- Set the FIFO_Within_Priorities policy, but always preserve
9600 -- System_Location since we like the error message with the run time
9604 Task_Dispatching_Policy
:= 'F';
9606 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9607 Task_Dispatching_Policy_Sloc
:= Loc
;
9611 -- pragma Locking_Policy (Ceiling_Locking)
9613 if Locking_Policy
/= ' '
9614 and then Locking_Policy
/= 'C'
9616 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9617 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9619 -- Set the Ceiling_Locking policy, but preserve System_Location since
9620 -- we like the error message with the run time name.
9623 Locking_Policy
:= 'C';
9625 if Locking_Policy_Sloc
/= System_Location
then
9626 Locking_Policy_Sloc
:= Loc
;
9630 -- pragma Detect_Blocking
9632 Detect_Blocking
:= True;
9634 -- Set the corresponding restrictions
9636 Set_Profile_Restrictions
9637 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9639 -- Set the No_Dependence restrictions
9641 -- The following No_Dependence restrictions:
9642 -- No_Dependence => Ada.Asynchronous_Task_Control
9643 -- No_Dependence => Ada.Calendar
9644 -- No_Dependence => Ada.Task_Attributes
9645 -- are already set by previous call to Set_Profile_Restrictions.
9647 -- Set the following restrictions which were added to Ada 2005:
9648 -- No_Dependence => Ada.Execution_Time.Group_Budget
9649 -- No_Dependence => Ada.Execution_Time.Timers
9651 if Ada_Version
>= Ada_2005
then
9652 Name_Buffer
(1 .. 3) := "ada";
9655 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9657 Name_Buffer
(1 .. 14) := "execution_time";
9660 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9663 Make_Selected_Component
9665 Prefix
=> Prefix_Entity
,
9666 Selector_Name
=> Selector_Entity
);
9668 Name_Buffer
(1 .. 13) := "group_budgets";
9671 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9674 Make_Selected_Component
9676 Prefix
=> Prefix_Node
,
9677 Selector_Name
=> Selector_Entity
);
9679 Set_Restriction_No_Dependence
9681 Warn
=> Treat_Restrictions_As_Warnings
,
9682 Profile
=> Ravenscar
);
9684 Name_Buffer
(1 .. 6) := "timers";
9687 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9690 Make_Selected_Component
9692 Prefix
=> Prefix_Node
,
9693 Selector_Name
=> Selector_Entity
);
9695 Set_Restriction_No_Dependence
9697 Warn
=> Treat_Restrictions_As_Warnings
,
9698 Profile
=> Ravenscar
);
9701 -- Set the following restrictions which was added to Ada 2012 (see
9703 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9705 if Ada_Version
>= Ada_2012
then
9706 Name_Buffer
(1 .. 6) := "system";
9709 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9711 Name_Buffer
(1 .. 15) := "multiprocessors";
9714 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9717 Make_Selected_Component
9719 Prefix
=> Prefix_Entity
,
9720 Selector_Name
=> Selector_Entity
);
9722 Name_Buffer
(1 .. 19) := "dispatching_domains";
9725 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9728 Make_Selected_Component
9730 Prefix
=> Prefix_Node
,
9731 Selector_Name
=> Selector_Entity
);
9733 Set_Restriction_No_Dependence
9735 Warn
=> Treat_Restrictions_As_Warnings
,
9736 Profile
=> Ravenscar
);
9738 end Set_Ravenscar_Profile
;
9740 -- Start of processing for Analyze_Pragma
9743 -- The following code is a defense against recursion. Not clear that
9744 -- this can happen legitimately, but perhaps some error situations
9745 -- can cause it, and we did see this recursion during testing.
9747 if Analyzed
(N
) then
9750 Set_Analyzed
(N
, True);
9753 -- Deal with unrecognized pragma
9755 Pname
:= Pragma_Name
(N
);
9757 if not Is_Pragma_Name
(Pname
) then
9758 if Warn_On_Unrecognized_Pragma
then
9759 Error_Msg_Name_1
:= Pname
;
9760 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9762 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9763 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9764 Error_Msg_Name_1
:= PN
;
9765 Error_Msg_N
-- CODEFIX
9766 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9775 -- Here to start processing for recognized pragma
9777 Prag_Id
:= Get_Pragma_Id
(Pname
);
9778 Pname
:= Original_Aspect_Name
(N
);
9780 -- Capture setting of Opt.Uneval_Old
9782 case Opt
.Uneval_Old
is
9784 Set_Uneval_Old_Accept
(N
);
9788 Set_Uneval_Old_Warn
(N
);
9790 raise Program_Error
;
9793 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9794 -- is already set, indicating that we have already checked the policy
9795 -- at the right point. This happens for example in the case of a pragma
9796 -- that is derived from an Aspect.
9798 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9801 -- For a pragma that is a rewriting of another pragma, copy the
9802 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9804 elsif Is_Rewrite_Substitution
(N
)
9805 and then Nkind
(Original_Node
(N
)) = N_Pragma
9806 and then Original_Node
(N
) /= N
9808 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9809 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9811 -- Otherwise query the applicable policy at this point
9814 Check_Applicable_Policy
(N
);
9816 -- If pragma is disabled, rewrite as NULL and skip analysis
9818 if Is_Disabled
(N
) then
9819 Rewrite
(N
, Make_Null_Statement
(Loc
));
9833 if Present
(Pragma_Argument_Associations
(N
)) then
9834 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9835 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9837 if Present
(Arg1
) then
9838 Arg2
:= Next
(Arg1
);
9840 if Present
(Arg2
) then
9841 Arg3
:= Next
(Arg2
);
9843 if Present
(Arg3
) then
9844 Arg4
:= Next
(Arg3
);
9850 Check_Restriction_No_Use_Of_Pragma
(N
);
9852 -- An enumeration type defines the pragmas that are supported by the
9853 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9854 -- into the corresponding enumeration value for the following case.
9862 -- pragma Abort_Defer;
9864 when Pragma_Abort_Defer
=>
9866 Check_Arg_Count
(0);
9868 -- The only required semantic processing is to check the
9869 -- placement. This pragma must appear at the start of the
9870 -- statement sequence of a handled sequence of statements.
9872 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9873 or else N
/= First
(Statements
(Parent
(N
)))
9878 --------------------
9879 -- Abstract_State --
9880 --------------------
9882 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9884 -- ABSTRACT_STATE_LIST ::=
9886 -- | STATE_NAME_WITH_OPTIONS
9887 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9889 -- STATE_NAME_WITH_OPTIONS ::=
9891 -- | (STATE_NAME with OPTION_LIST)
9893 -- OPTION_LIST ::= OPTION {, OPTION}
9897 -- | NAME_VALUE_OPTION
9899 -- SIMPLE_OPTION ::= identifier
9901 -- NAME_VALUE_OPTION ::=
9902 -- Part_Of => ABSTRACT_STATE
9903 -- | External [=> EXTERNAL_PROPERTY_LIST]
9905 -- EXTERNAL_PROPERTY_LIST ::=
9906 -- EXTERNAL_PROPERTY
9907 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9909 -- EXTERNAL_PROPERTY ::=
9910 -- Async_Readers [=> boolean_EXPRESSION]
9911 -- | Async_Writers [=> boolean_EXPRESSION]
9912 -- | Effective_Reads [=> boolean_EXPRESSION]
9913 -- | Effective_Writes [=> boolean_EXPRESSION]
9914 -- others => boolean_EXPRESSION
9916 -- STATE_NAME ::= defining_identifier
9918 -- ABSTRACT_STATE ::= name
9920 when Pragma_Abstract_State
=> Abstract_State
: declare
9921 Missing_Parentheses
: Boolean := False;
9922 -- Flag set when a state declaration with options is not properly
9925 -- Flags used to verify the consistency of states
9927 Non_Null_Seen
: Boolean := False;
9928 Null_Seen
: Boolean := False;
9930 Pack_Id
: Entity_Id
;
9931 -- Entity of related package when pragma Abstract_State appears
9933 procedure Analyze_Abstract_State
(State
: Node_Id
);
9934 -- Verify the legality of a single state declaration. Create and
9935 -- decorate a state abstraction entity and introduce it into the
9936 -- visibility chain.
9938 ----------------------------
9939 -- Analyze_Abstract_State --
9940 ----------------------------
9942 procedure Analyze_Abstract_State
(State
: Node_Id
) is
9944 -- Flags used to verify the consistency of options
9946 AR_Seen
: Boolean := False;
9947 AW_Seen
: Boolean := False;
9948 ER_Seen
: Boolean := False;
9949 EW_Seen
: Boolean := False;
9950 External_Seen
: Boolean := False;
9951 Others_Seen
: Boolean := False;
9952 Part_Of_Seen
: Boolean := False;
9954 -- Flags used to store the static value of all external states'
9957 AR_Val
: Boolean := False;
9958 AW_Val
: Boolean := False;
9959 ER_Val
: Boolean := False;
9960 EW_Val
: Boolean := False;
9962 State_Id
: Entity_Id
:= Empty
;
9963 -- The entity to be generated for the current state declaration
9965 procedure Analyze_External_Option
(Opt
: Node_Id
);
9966 -- Verify the legality of option External
9968 procedure Analyze_External_Property
9970 Expr
: Node_Id
:= Empty
);
9971 -- Verify the legailty of a single external property. Prop
9972 -- denotes the external property. Expr is the expression used
9973 -- to set the property.
9975 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9976 -- Verify the legality of option Part_Of
9978 procedure Check_Duplicate_Option
9980 Status
: in out Boolean);
9981 -- Flag Status denotes whether a particular option has been
9982 -- seen while processing a state. This routine verifies that
9983 -- Opt is not a duplicate option and sets the flag Status
9984 -- (SPARK RM 7.1.4(1)).
9986 procedure Check_Duplicate_Property
9988 Status
: in out Boolean);
9989 -- Flag Status denotes whether a particular property has been
9990 -- seen while processing option External. This routine verifies
9991 -- that Prop is not a duplicate property and sets flag Status.
9992 -- Opt is not a duplicate property and sets the flag Status.
9993 -- (SPARK RM 7.1.4(2))
9995 procedure Create_Abstract_State
10000 -- Generate an abstract state entity with name Nam and enter it
10001 -- into visibility. Decl is the "declaration" of the state as
10002 -- it appears in pragma Abstract_State. Loc is the location of
10003 -- the related state "declaration". Flag Is_Null should be set
10004 -- when the associated Abstract_State pragma defines a null
10007 -----------------------------
10008 -- Analyze_External_Option --
10009 -----------------------------
10011 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10012 Errors
: constant Nat
:= Serious_Errors_Detected
;
10014 Props
: Node_Id
:= Empty
;
10017 Check_Duplicate_Option
(Opt
, External_Seen
);
10019 if Nkind
(Opt
) = N_Component_Association
then
10020 Props
:= Expression
(Opt
);
10023 -- External state with properties
10025 if Present
(Props
) then
10027 -- Multiple properties appear as an aggregate
10029 if Nkind
(Props
) = N_Aggregate
then
10031 -- Simple property form
10033 Prop
:= First
(Expressions
(Props
));
10034 while Present
(Prop
) loop
10035 Analyze_External_Property
(Prop
);
10039 -- Property with expression form
10041 Prop
:= First
(Component_Associations
(Props
));
10042 while Present
(Prop
) loop
10043 Analyze_External_Property
10044 (Prop
=> First
(Choices
(Prop
)),
10045 Expr
=> Expression
(Prop
));
10053 Analyze_External_Property
(Props
);
10056 -- An external state defined without any properties defaults
10057 -- all properties to True.
10066 -- Once all external properties have been processed, verify
10067 -- their mutual interaction. Do not perform the check when
10068 -- at least one of the properties is illegal as this will
10069 -- produce a bogus error.
10071 if Errors
= Serious_Errors_Detected
then
10072 Check_External_Properties
10073 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10075 end Analyze_External_Option
;
10077 -------------------------------
10078 -- Analyze_External_Property --
10079 -------------------------------
10081 procedure Analyze_External_Property
10083 Expr
: Node_Id
:= Empty
)
10085 Expr_Val
: Boolean;
10088 -- Check the placement of "others" (if available)
10090 if Nkind
(Prop
) = N_Others_Choice
then
10091 if Others_Seen
then
10093 ("only one others choice allowed in option External",
10096 Others_Seen
:= True;
10099 elsif Others_Seen
then
10101 ("others must be the last property in option External",
10104 -- The only remaining legal options are the four predefined
10105 -- external properties.
10107 elsif Nkind
(Prop
) = N_Identifier
10108 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10109 Name_Async_Writers
,
10110 Name_Effective_Reads
,
10111 Name_Effective_Writes
)
10115 -- Otherwise the construct is not a valid property
10118 SPARK_Msg_N
("invalid external state property", Prop
);
10122 -- Ensure that the expression of the external state property
10123 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10125 if Present
(Expr
) then
10126 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10128 if Is_OK_Static_Expression
(Expr
) then
10129 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10132 ("expression of external state property must be "
10136 -- The lack of expression defaults the property to True
10142 -- Named properties
10144 if Nkind
(Prop
) = N_Identifier
then
10145 if Chars
(Prop
) = Name_Async_Readers
then
10146 Check_Duplicate_Property
(Prop
, AR_Seen
);
10147 AR_Val
:= Expr_Val
;
10149 elsif Chars
(Prop
) = Name_Async_Writers
then
10150 Check_Duplicate_Property
(Prop
, AW_Seen
);
10151 AW_Val
:= Expr_Val
;
10153 elsif Chars
(Prop
) = Name_Effective_Reads
then
10154 Check_Duplicate_Property
(Prop
, ER_Seen
);
10155 ER_Val
:= Expr_Val
;
10158 Check_Duplicate_Property
(Prop
, EW_Seen
);
10159 EW_Val
:= Expr_Val
;
10162 -- The handling of property "others" must take into account
10163 -- all other named properties that have been encountered so
10164 -- far. Only those that have not been seen are affected by
10168 if not AR_Seen
then
10169 AR_Val
:= Expr_Val
;
10172 if not AW_Seen
then
10173 AW_Val
:= Expr_Val
;
10176 if not ER_Seen
then
10177 ER_Val
:= Expr_Val
;
10180 if not EW_Seen
then
10181 EW_Val
:= Expr_Val
;
10184 end Analyze_External_Property
;
10186 ----------------------------
10187 -- Analyze_Part_Of_Option --
10188 ----------------------------
10190 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10191 Encaps
: constant Node_Id
:= Expression
(Opt
);
10192 Encaps_Id
: Entity_Id
;
10196 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10199 (Item_Id
=> State_Id
,
10201 Indic
=> First
(Choices
(Opt
)),
10204 -- The Part_Of indicator turns an abstract state into a
10205 -- constituent of the encapsulating state.
10208 Encaps_Id
:= Entity
(Encaps
);
10210 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10211 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10213 end Analyze_Part_Of_Option
;
10215 ----------------------------
10216 -- Check_Duplicate_Option --
10217 ----------------------------
10219 procedure Check_Duplicate_Option
10221 Status
: in out Boolean)
10225 SPARK_Msg_N
("duplicate state option", Opt
);
10229 end Check_Duplicate_Option
;
10231 ------------------------------
10232 -- Check_Duplicate_Property --
10233 ------------------------------
10235 procedure Check_Duplicate_Property
10237 Status
: in out Boolean)
10241 SPARK_Msg_N
("duplicate external property", Prop
);
10245 end Check_Duplicate_Property
;
10247 ---------------------------
10248 -- Create_Abstract_State --
10249 ---------------------------
10251 procedure Create_Abstract_State
10258 -- The abstract state may be semi-declared when the related
10259 -- package was withed through a limited with clause. In that
10260 -- case reuse the entity to fully declare the state.
10262 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10263 State_Id
:= Entity
(Decl
);
10265 -- Otherwise the elaboration of pragma Abstract_State
10266 -- declares the state.
10269 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10271 if Present
(Decl
) then
10272 Set_Entity
(Decl
, State_Id
);
10276 -- Null states never come from source
10278 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10279 Set_Parent
(State_Id
, State
);
10280 Set_Ekind
(State_Id
, E_Abstract_State
);
10281 Set_Etype
(State_Id
, Standard_Void_Type
);
10282 Set_Encapsulating_State
(State_Id
, Empty
);
10283 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10284 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10286 -- Establish a link between the state declaration and the
10287 -- abstract state entity. Note that a null state remains as
10288 -- N_Null and does not carry any linkages.
10290 if not Is_Null
then
10291 if Present
(Decl
) then
10292 Set_Entity
(Decl
, State_Id
);
10293 Set_Etype
(Decl
, Standard_Void_Type
);
10296 -- Every non-null state must be defined, nameable and
10299 Push_Scope
(Pack_Id
);
10300 Generate_Definition
(State_Id
);
10301 Enter_Name
(State_Id
);
10304 end Create_Abstract_State
;
10311 -- Start of processing for Analyze_Abstract_State
10314 -- A package with a null abstract state is not allowed to
10315 -- declare additional states.
10319 ("package & has null abstract state", State
, Pack_Id
);
10321 -- Null states appear as internally generated entities
10323 elsif Nkind
(State
) = N_Null
then
10324 Create_Abstract_State
10325 (Nam
=> New_Internal_Name
('S'),
10327 Loc
=> Sloc
(State
),
10331 -- Catch a case where a null state appears in a list of
10332 -- non-null states.
10334 if Non_Null_Seen
then
10336 ("package & has non-null abstract state",
10340 -- Simple state declaration
10342 elsif Nkind
(State
) = N_Identifier
then
10343 Create_Abstract_State
10344 (Nam
=> Chars
(State
),
10346 Loc
=> Sloc
(State
),
10348 Non_Null_Seen
:= True;
10350 -- State declaration with various options. This construct
10351 -- appears as an extension aggregate in the tree.
10353 elsif Nkind
(State
) = N_Extension_Aggregate
then
10354 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10355 Create_Abstract_State
10356 (Nam
=> Chars
(Ancestor_Part
(State
)),
10357 Decl
=> Ancestor_Part
(State
),
10358 Loc
=> Sloc
(Ancestor_Part
(State
)),
10360 Non_Null_Seen
:= True;
10363 ("state name must be an identifier",
10364 Ancestor_Part
(State
));
10367 -- Catch an attempt to introduce a simple option which is
10368 -- currently not allowed. An exception to this is External
10369 -- defined without any properties.
10371 Opt
:= First
(Expressions
(State
));
10372 while Present
(Opt
) loop
10373 if Nkind
(Opt
) = N_Identifier
then
10374 if Chars
(Opt
) = Name_External
then
10375 Analyze_External_Option
(Opt
);
10377 -- Option Part_Of without an encapsulating state is
10378 -- illegal. (SPARK RM 7.1.4(9)).
10380 elsif Chars
(Opt
) = Name_Part_Of
then
10382 ("indicator Part_Of must denote an abstract "
10385 -- Do not emit an error message when a previous state
10386 -- declaration with options was not parenthesized as
10387 -- the option is actually another state declaration.
10389 -- with Abstract_State
10390 -- (State_1 with ..., -- missing parentheses
10391 -- (State_2 with ...),
10392 -- State_3) -- ok state declaration
10394 elsif Missing_Parentheses
then
10397 -- Otherwise the option is not allowed. Note that it
10398 -- is not possible to distinguish between an option
10399 -- and a state declaration when a previous state with
10400 -- options not properly parentheses.
10402 -- with Abstract_State
10403 -- (State_1 with ..., -- missing parentheses
10404 -- State_2); -- could be an option
10408 ("simple option not allowed in state declaration",
10412 -- Catch a case where missing parentheses around a state
10413 -- declaration with options cause a subsequent state
10414 -- declaration with options to be treated as an option.
10416 -- with Abstract_State
10417 -- (State_1 with ..., -- missing parentheses
10418 -- (State_2 with ...))
10420 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10421 Missing_Parentheses
:= True;
10423 ("state declaration must be parenthesized",
10424 Ancestor_Part
(State
));
10426 -- Otherwise the option is malformed
10429 SPARK_Msg_N
("malformed option", Opt
);
10435 -- Options External and Part_Of appear as component
10438 Opt
:= First
(Component_Associations
(State
));
10439 while Present
(Opt
) loop
10440 Opt_Nam
:= First
(Choices
(Opt
));
10442 if Nkind
(Opt_Nam
) = N_Identifier
then
10443 if Chars
(Opt_Nam
) = Name_External
then
10444 Analyze_External_Option
(Opt
);
10446 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10447 Analyze_Part_Of_Option
(Opt
);
10450 SPARK_Msg_N
("invalid state option", Opt
);
10453 SPARK_Msg_N
("invalid state option", Opt
);
10459 -- Any other attempt to declare a state is illegal. This is a
10460 -- syntax error, always report.
10463 Error_Msg_N
("malformed abstract state declaration", State
);
10467 -- Guard against a junk state. In such cases no entity is
10468 -- generated and the subsequent checks cannot be applied.
10470 if Present
(State_Id
) then
10472 -- Verify whether the state does not introduce an illegal
10473 -- hidden state within a package subject to a null abstract
10476 Check_No_Hidden_State
(State_Id
);
10478 -- Check whether the lack of option Part_Of agrees with the
10479 -- placement of the abstract state with respect to the state
10482 if not Part_Of_Seen
then
10483 Check_Missing_Part_Of
(State_Id
);
10486 -- Associate the state with its related package
10488 if No
(Abstract_States
(Pack_Id
)) then
10489 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10492 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10494 end Analyze_Abstract_State
;
10498 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10501 -- Start of processing for Abstract_State
10505 Check_Arg_Count
(1);
10506 Ensure_Aggregate_Form
(Arg1
);
10508 -- Ensure the proper placement of the pragma. Abstract states must
10509 -- be associated with a package declaration.
10511 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10512 N_Package_Declaration
)
10518 State
:= Expression
(Arg1
);
10519 Pack_Id
:= Defining_Entity
(Context
);
10521 -- Multiple non-null abstract states appear as an aggregate
10523 if Nkind
(State
) = N_Aggregate
then
10524 State
:= First
(Expressions
(State
));
10525 while Present
(State
) loop
10526 Analyze_Abstract_State
(State
);
10530 -- Various forms of a single abstract state. Note that these may
10531 -- include malformed state declarations.
10534 Analyze_Abstract_State
(State
);
10537 -- Save the pragma for retrieval by other tools
10539 Add_Contract_Item
(N
, Pack_Id
);
10541 -- Verify the declaration order of pragmas Abstract_State and
10544 Check_Declaration_Order
10546 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10547 end Abstract_State
;
10555 -- Note: this pragma also has some specific processing in Par.Prag
10556 -- because we want to set the Ada version mode during parsing.
10558 when Pragma_Ada_83
=>
10560 Check_Arg_Count
(0);
10562 -- We really should check unconditionally for proper configuration
10563 -- pragma placement, since we really don't want mixed Ada modes
10564 -- within a single unit, and the GNAT reference manual has always
10565 -- said this was a configuration pragma, but we did not check and
10566 -- are hesitant to add the check now.
10568 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10569 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10570 -- or Ada 2012 mode.
10572 if Ada_Version
>= Ada_2005
then
10573 Check_Valid_Configuration_Pragma
;
10576 -- Now set Ada 83 mode
10578 Ada_Version
:= Ada_83
;
10579 Ada_Version_Explicit
:= Ada_83
;
10580 Ada_Version_Pragma
:= N
;
10588 -- Note: this pragma also has some specific processing in Par.Prag
10589 -- because we want to set the Ada 83 version mode during parsing.
10591 when Pragma_Ada_95
=>
10593 Check_Arg_Count
(0);
10595 -- We really should check unconditionally for proper configuration
10596 -- pragma placement, since we really don't want mixed Ada modes
10597 -- within a single unit, and the GNAT reference manual has always
10598 -- said this was a configuration pragma, but we did not check and
10599 -- are hesitant to add the check now.
10601 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10602 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10604 if Ada_Version
>= Ada_2005
then
10605 Check_Valid_Configuration_Pragma
;
10608 -- Now set Ada 95 mode
10610 Ada_Version
:= Ada_95
;
10611 Ada_Version_Explicit
:= Ada_95
;
10612 Ada_Version_Pragma
:= N
;
10614 ---------------------
10615 -- Ada_05/Ada_2005 --
10616 ---------------------
10619 -- pragma Ada_05 (LOCAL_NAME);
10621 -- pragma Ada_2005;
10622 -- pragma Ada_2005 (LOCAL_NAME):
10624 -- Note: these pragmas also have some specific processing in Par.Prag
10625 -- because we want to set the Ada 2005 version mode during parsing.
10627 -- The one argument form is used for managing the transition from
10628 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10629 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10630 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10631 -- mode, a preference rule is established which does not choose
10632 -- such an entity unless it is unambiguously specified. This avoids
10633 -- extra subprograms marked this way from generating ambiguities in
10634 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10635 -- intended for exclusive use in the GNAT run-time library.
10637 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10643 if Arg_Count
= 1 then
10644 Check_Arg_Is_Local_Name
(Arg1
);
10645 E_Id
:= Get_Pragma_Arg
(Arg1
);
10647 if Etype
(E_Id
) = Any_Type
then
10651 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10652 Record_Rep_Item
(Entity
(E_Id
), N
);
10655 Check_Arg_Count
(0);
10657 -- For Ada_2005 we unconditionally enforce the documented
10658 -- configuration pragma placement, since we do not want to
10659 -- tolerate mixed modes in a unit involving Ada 2005. That
10660 -- would cause real difficulties for those cases where there
10661 -- are incompatibilities between Ada 95 and Ada 2005.
10663 Check_Valid_Configuration_Pragma
;
10665 -- Now set appropriate Ada mode
10667 Ada_Version
:= Ada_2005
;
10668 Ada_Version_Explicit
:= Ada_2005
;
10669 Ada_Version_Pragma
:= N
;
10673 ---------------------
10674 -- Ada_12/Ada_2012 --
10675 ---------------------
10678 -- pragma Ada_12 (LOCAL_NAME);
10680 -- pragma Ada_2012;
10681 -- pragma Ada_2012 (LOCAL_NAME):
10683 -- Note: these pragmas also have some specific processing in Par.Prag
10684 -- because we want to set the Ada 2012 version mode during parsing.
10686 -- The one argument form is used for managing the transition from Ada
10687 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10688 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10689 -- mode will generate a warning. In addition, in any pre-Ada_2012
10690 -- mode, a preference rule is established which does not choose
10691 -- such an entity unless it is unambiguously specified. This avoids
10692 -- extra subprograms marked this way from generating ambiguities in
10693 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10694 -- intended for exclusive use in the GNAT run-time library.
10696 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10702 if Arg_Count
= 1 then
10703 Check_Arg_Is_Local_Name
(Arg1
);
10704 E_Id
:= Get_Pragma_Arg
(Arg1
);
10706 if Etype
(E_Id
) = Any_Type
then
10710 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10711 Record_Rep_Item
(Entity
(E_Id
), N
);
10714 Check_Arg_Count
(0);
10716 -- For Ada_2012 we unconditionally enforce the documented
10717 -- configuration pragma placement, since we do not want to
10718 -- tolerate mixed modes in a unit involving Ada 2012. That
10719 -- would cause real difficulties for those cases where there
10720 -- are incompatibilities between Ada 95 and Ada 2012. We could
10721 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10723 Check_Valid_Configuration_Pragma
;
10725 -- Now set appropriate Ada mode
10727 Ada_Version
:= Ada_2012
;
10728 Ada_Version_Explicit
:= Ada_2012
;
10729 Ada_Version_Pragma
:= N
;
10733 ----------------------
10734 -- All_Calls_Remote --
10735 ----------------------
10737 -- pragma All_Calls_Remote [(library_package_NAME)];
10739 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10740 Lib_Entity
: Entity_Id
;
10743 Check_Ada_83_Warning
;
10744 Check_Valid_Library_Unit_Pragma
;
10746 if Nkind
(N
) = N_Null_Statement
then
10750 Lib_Entity
:= Find_Lib_Unit_Name
;
10752 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10754 if Present
(Lib_Entity
)
10755 and then not Debug_Flag_U
10757 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10758 Error_Pragma
("pragma% only apply to rci unit");
10760 -- Set flag for entity of the library unit
10763 Set_Has_All_Calls_Remote
(Lib_Entity
);
10767 end All_Calls_Remote
;
10769 ---------------------------
10770 -- Allow_Integer_Address --
10771 ---------------------------
10773 -- pragma Allow_Integer_Address;
10775 when Pragma_Allow_Integer_Address
=>
10777 Check_Valid_Configuration_Pragma
;
10778 Check_Arg_Count
(0);
10780 -- If Address is a private type, then set the flag to allow
10781 -- integer address values. If Address is not private, then this
10782 -- pragma has no purpose, so it is simply ignored. Not clear if
10783 -- there are any such targets now.
10785 if Opt
.Address_Is_Private
then
10786 Opt
.Allow_Integer_Address
:= True;
10794 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10795 -- ARG ::= NAME | EXPRESSION
10797 -- The first two arguments are by convention intended to refer to an
10798 -- external tool and a tool-specific function. These arguments are
10801 when Pragma_Annotate
=> Annotate
: declare
10807 Check_At_Least_N_Arguments
(1);
10809 -- See if last argument is Entity => local_Name, and if so process
10810 -- and then remove it for remaining processing.
10813 Last_Arg
: constant Node_Id
:=
10814 Last
(Pragma_Argument_Associations
(N
));
10817 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10818 and then Chars
(Last_Arg
) = Name_Entity
10820 Check_Arg_Is_Local_Name
(Last_Arg
);
10821 Arg_Count
:= Arg_Count
- 1;
10823 -- Not allowed in compiler units (bootstrap issues)
10825 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10829 -- Continue processing with last argument removed for now
10831 Check_Arg_Is_Identifier
(Arg1
);
10832 Check_No_Identifiers
;
10835 -- Second parameter is optional, it is never analyzed
10840 -- Here if we have a second parameter
10843 -- Second parameter must be identifier
10845 Check_Arg_Is_Identifier
(Arg2
);
10847 -- Process remaining parameters if any
10849 Arg
:= Next
(Arg2
);
10850 while Present
(Arg
) loop
10851 Exp
:= Get_Pragma_Arg
(Arg
);
10854 if Is_Entity_Name
(Exp
) then
10857 -- For string literals, we assume Standard_String as the
10858 -- type, unless the string contains wide or wide_wide
10861 elsif Nkind
(Exp
) = N_String_Literal
then
10862 if Has_Wide_Wide_Character
(Exp
) then
10863 Resolve
(Exp
, Standard_Wide_Wide_String
);
10864 elsif Has_Wide_Character
(Exp
) then
10865 Resolve
(Exp
, Standard_Wide_String
);
10867 Resolve
(Exp
, Standard_String
);
10870 elsif Is_Overloaded
(Exp
) then
10872 ("ambiguous argument for pragma%", Exp
);
10883 -------------------------------------------------
10884 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10885 -------------------------------------------------
10888 -- ( [Check => ] Boolean_EXPRESSION
10889 -- [, [Message =>] Static_String_EXPRESSION]);
10891 -- pragma Assert_And_Cut
10892 -- ( [Check => ] Boolean_EXPRESSION
10893 -- [, [Message =>] Static_String_EXPRESSION]);
10896 -- ( [Check => ] Boolean_EXPRESSION
10897 -- [, [Message =>] Static_String_EXPRESSION]);
10899 -- pragma Loop_Invariant
10900 -- ( [Check => ] Boolean_EXPRESSION
10901 -- [, [Message =>] Static_String_EXPRESSION]);
10903 when Pragma_Assert |
10904 Pragma_Assert_And_Cut |
10906 Pragma_Loop_Invariant
=>
10908 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10909 -- Determine whether expression Expr contains a Loop_Entry
10910 -- attribute reference.
10912 -------------------------
10913 -- Contains_Loop_Entry --
10914 -------------------------
10916 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10917 Has_Loop_Entry
: Boolean := False;
10919 function Process
(N
: Node_Id
) return Traverse_Result
;
10920 -- Process function for traversal to look for Loop_Entry
10926 function Process
(N
: Node_Id
) return Traverse_Result
is
10928 if Nkind
(N
) = N_Attribute_Reference
10929 and then Attribute_Name
(N
) = Name_Loop_Entry
10931 Has_Loop_Entry
:= True;
10938 procedure Traverse
is new Traverse_Proc
(Process
);
10940 -- Start of processing for Contains_Loop_Entry
10944 return Has_Loop_Entry
;
10945 end Contains_Loop_Entry
;
10952 -- Start of processing for Assert
10955 -- Assert is an Ada 2005 RM-defined pragma
10957 if Prag_Id
= Pragma_Assert
then
10960 -- The remaining ones are GNAT pragmas
10966 Check_At_Least_N_Arguments
(1);
10967 Check_At_Most_N_Arguments
(2);
10968 Check_Arg_Order
((Name_Check
, Name_Message
));
10969 Check_Optional_Identifier
(Arg1
, Name_Check
);
10970 Expr
:= Get_Pragma_Arg
(Arg1
);
10972 -- Special processing for Loop_Invariant, Loop_Variant or for
10973 -- other cases where a Loop_Entry attribute is present. If the
10974 -- assertion pragma contains attribute Loop_Entry, ensure that
10975 -- the related pragma is within a loop.
10977 if Prag_Id
= Pragma_Loop_Invariant
10978 or else Prag_Id
= Pragma_Loop_Variant
10979 or else Contains_Loop_Entry
(Expr
)
10981 Check_Loop_Pragma_Placement
;
10983 -- Perform preanalysis to deal with embedded Loop_Entry
10986 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10989 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10990 -- a corresponding Check pragma:
10992 -- pragma Check (name, condition [, msg]);
10994 -- Where name is the identifier matching the pragma name. So
10995 -- rewrite pragma in this manner, transfer the message argument
10996 -- if present, and analyze the result
10998 -- Note: When dealing with a semantically analyzed tree, the
10999 -- information that a Check node N corresponds to a source Assert,
11000 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11001 -- pragma kind of Original_Node(N).
11004 Make_Pragma_Argument_Association
(Loc
,
11005 Expression
=> Make_Identifier
(Loc
, Pname
)),
11006 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11007 Expression
=> Expr
));
11009 if Arg_Count
> 1 then
11010 Check_Optional_Identifier
(Arg2
, Name_Message
);
11012 -- Provide semantic annnotations for optional argument, for
11013 -- ASIS use, before rewriting.
11015 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11016 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
11019 -- Rewrite as Check pragma
11023 Chars
=> Name_Check
,
11024 Pragma_Argument_Associations
=> Newa
));
11028 ----------------------
11029 -- Assertion_Policy --
11030 ----------------------
11032 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11034 -- The following form is Ada 2012 only, but we allow it in all modes
11036 -- Pragma Assertion_Policy (
11037 -- ASSERTION_KIND => POLICY_IDENTIFIER
11038 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11040 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11042 -- RM_ASSERTION_KIND ::= Assert |
11043 -- Static_Predicate |
11044 -- Dynamic_Predicate |
11049 -- Type_Invariant |
11050 -- Type_Invariant'Class
11052 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11054 -- Contract_Cases |
11056 -- Default_Initial_Condition |
11057 -- Initial_Condition |
11058 -- Loop_Invariant |
11064 -- Statement_Assertions
11066 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11067 -- ID_ASSERTION_KIND list contains implementation-defined additions
11068 -- recognized by GNAT. The effect is to control the behavior of
11069 -- identically named aspects and pragmas, depending on the specified
11070 -- policy identifier:
11072 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11074 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11075 -- implementation defined addition that results in totally ignoring
11076 -- the corresponding assertion. If Disable is specified, then the
11077 -- argument of the assertion is not even analyzed. This is useful
11078 -- when the aspect/pragma argument references entities in a with'ed
11079 -- package that is replaced by a dummy package in the final build.
11081 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11082 -- and Type_Invariant'Class were recognized by the parser and
11083 -- transformed into references to the special internal identifiers
11084 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11085 -- processing is required here.
11087 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11096 -- This can always appear as a configuration pragma
11098 if Is_Configuration_Pragma
then
11101 -- It can also appear in a declarative part or package spec in Ada
11102 -- 2012 mode. We allow this in other modes, but in that case we
11103 -- consider that we have an Ada 2012 pragma on our hands.
11106 Check_Is_In_Decl_Part_Or_Package_Spec
;
11110 -- One argument case with no identifier (first form above)
11113 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11114 or else Chars
(Arg1
) = No_Name
)
11116 Check_Arg_Is_One_Of
11117 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11119 -- Treat one argument Assertion_Policy as equivalent to:
11121 -- pragma Check_Policy (Assertion, policy)
11123 -- So rewrite pragma in that manner and link on to the chain
11124 -- of Check_Policy pragmas, marking the pragma as analyzed.
11126 Policy
:= Get_Pragma_Arg
(Arg1
);
11130 Chars
=> Name_Check_Policy
,
11131 Pragma_Argument_Associations
=> New_List
(
11132 Make_Pragma_Argument_Association
(Loc
,
11133 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11135 Make_Pragma_Argument_Association
(Loc
,
11137 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11140 -- Here if we have two or more arguments
11143 Check_At_Least_N_Arguments
(1);
11146 -- Loop through arguments
11149 while Present
(Arg
) loop
11150 LocP
:= Sloc
(Arg
);
11152 -- Kind must be specified
11154 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11155 or else Chars
(Arg
) = No_Name
11158 ("missing assertion kind for pragma%", Arg
);
11161 -- Check Kind and Policy have allowed forms
11163 Kind
:= Chars
(Arg
);
11165 if not Is_Valid_Assertion_Kind
(Kind
) then
11167 ("invalid assertion kind for pragma%", Arg
);
11170 Check_Arg_Is_One_Of
11171 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11173 -- We rewrite the Assertion_Policy pragma as a series of
11174 -- Check_Policy pragmas:
11176 -- Check_Policy (Kind, Policy);
11180 Chars
=> Name_Check_Policy
,
11181 Pragma_Argument_Associations
=> New_List
(
11182 Make_Pragma_Argument_Association
(LocP
,
11183 Expression
=> Make_Identifier
(LocP
, Kind
)),
11184 Make_Pragma_Argument_Association
(LocP
,
11185 Expression
=> Get_Pragma_Arg
(Arg
)))));
11190 -- Rewrite the Assertion_Policy pragma as null since we have
11191 -- now inserted all the equivalent Check pragmas.
11193 Rewrite
(N
, Make_Null_Statement
(Loc
));
11196 end Assertion_Policy
;
11198 ------------------------------
11199 -- Assume_No_Invalid_Values --
11200 ------------------------------
11202 -- pragma Assume_No_Invalid_Values (On | Off);
11204 when Pragma_Assume_No_Invalid_Values
=>
11206 Check_Valid_Configuration_Pragma
;
11207 Check_Arg_Count
(1);
11208 Check_No_Identifiers
;
11209 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11211 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11212 Assume_No_Invalid_Values
:= True;
11214 Assume_No_Invalid_Values
:= False;
11217 --------------------------
11218 -- Attribute_Definition --
11219 --------------------------
11221 -- pragma Attribute_Definition
11222 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11223 -- [Entity =>] LOCAL_NAME,
11224 -- [Expression =>] EXPRESSION | NAME);
11226 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11227 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11232 Check_Arg_Count
(3);
11233 Check_Optional_Identifier
(Arg1
, "attribute");
11234 Check_Optional_Identifier
(Arg2
, "entity");
11235 Check_Optional_Identifier
(Arg3
, "expression");
11237 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11238 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11242 Check_Arg_Is_Local_Name
(Arg2
);
11244 -- If the attribute is not recognized, then issue a warning (not
11245 -- an error), and ignore the pragma.
11247 Aname
:= Chars
(Attribute_Designator
);
11249 if not Is_Attribute_Name
(Aname
) then
11250 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11254 -- Otherwise, rewrite the pragma as an attribute definition clause
11257 Make_Attribute_Definition_Clause
(Loc
,
11258 Name
=> Get_Pragma_Arg
(Arg2
),
11260 Expression
=> Get_Pragma_Arg
(Arg3
)));
11262 end Attribute_Definition
;
11264 ------------------------------------------------------------------
11265 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11266 ------------------------------------------------------------------
11268 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11269 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11270 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11271 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11273 -- FLAG ::= boolean_EXPRESSION
11275 when Pragma_Async_Readers |
11276 Pragma_Async_Writers |
11277 Pragma_Effective_Reads |
11278 Pragma_Effective_Writes
=>
11279 Async_Effective
: declare
11283 Obj_Id
: Entity_Id
;
11287 Check_No_Identifiers
;
11288 Check_At_Least_N_Arguments
(1);
11289 Check_At_Most_N_Arguments
(2);
11290 Check_Arg_Is_Local_Name
(Arg1
);
11291 Error_Msg_Name_1
:= Pname
;
11293 Obj
:= Get_Pragma_Arg
(Arg1
);
11294 Expr
:= Get_Pragma_Arg
(Arg2
);
11296 -- Perform minimal verification to ensure that the argument is at
11297 -- least a variable. Subsequent finer grained checks will be done
11298 -- at the end of the declarative region the contains the pragma.
11300 if Is_Entity_Name
(Obj
)
11301 and then Present
(Entity
(Obj
))
11302 and then Ekind
(Entity
(Obj
)) = E_Variable
11304 Obj_Id
:= Entity
(Obj
);
11306 -- Detect a duplicate pragma. Note that it is not efficient to
11307 -- examine preceding statements as Boolean aspects may appear
11308 -- anywhere between the related object declaration and its
11309 -- freeze point. As an alternative, inspect the contents of the
11310 -- variable contract.
11312 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11314 if Present
(Duplic
) then
11315 Error_Msg_Sloc
:= Sloc
(Duplic
);
11316 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11318 -- No duplicate detected
11321 if Present
(Expr
) then
11322 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11325 -- Chain the pragma on the contract for further processing
11327 Add_Contract_Item
(N
, Obj_Id
);
11330 Error_Pragma
("pragma % must apply to a volatile object");
11332 end Async_Effective
;
11338 -- pragma Asynchronous (LOCAL_NAME);
11340 when Pragma_Asynchronous
=> Asynchronous
: declare
11346 Formal
: Entity_Id
;
11348 procedure Process_Async_Pragma
;
11349 -- Common processing for procedure and access-to-procedure case
11351 --------------------------
11352 -- Process_Async_Pragma --
11353 --------------------------
11355 procedure Process_Async_Pragma
is
11358 Set_Is_Asynchronous
(Nm
);
11362 -- The formals should be of mode IN (RM E.4.1(6))
11365 while Present
(S
) loop
11366 Formal
:= Defining_Identifier
(S
);
11368 if Nkind
(Formal
) = N_Defining_Identifier
11369 and then Ekind
(Formal
) /= E_In_Parameter
11372 ("pragma% procedure can only have IN parameter",
11379 Set_Is_Asynchronous
(Nm
);
11380 end Process_Async_Pragma
;
11382 -- Start of processing for pragma Asynchronous
11385 Check_Ada_83_Warning
;
11386 Check_No_Identifiers
;
11387 Check_Arg_Count
(1);
11388 Check_Arg_Is_Local_Name
(Arg1
);
11390 if Debug_Flag_U
then
11394 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11395 Analyze
(Get_Pragma_Arg
(Arg1
));
11396 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11398 if not Is_Remote_Call_Interface
(C_Ent
)
11399 and then not Is_Remote_Types
(C_Ent
)
11401 -- This pragma should only appear in an RCI or Remote Types
11402 -- unit (RM E.4.1(4)).
11405 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11408 if Ekind
(Nm
) = E_Procedure
11409 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11411 if not Is_Remote_Call_Interface
(Nm
) then
11413 ("pragma% cannot be applied on non-remote procedure",
11417 L
:= Parameter_Specifications
(Parent
(Nm
));
11418 Process_Async_Pragma
;
11421 elsif Ekind
(Nm
) = E_Function
then
11423 ("pragma% cannot be applied to function", Arg1
);
11425 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11426 if Is_Record_Type
(Nm
) then
11428 -- A record type that is the Equivalent_Type for a remote
11429 -- access-to-subprogram type.
11431 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11434 -- A non-expanded RAS type (distribution is not enabled)
11436 N
:= Declaration_Node
(Nm
);
11439 if Nkind
(N
) = N_Full_Type_Declaration
11440 and then Nkind
(Type_Definition
(N
)) =
11441 N_Access_Procedure_Definition
11443 L
:= Parameter_Specifications
(Type_Definition
(N
));
11444 Process_Async_Pragma
;
11446 if Is_Asynchronous
(Nm
)
11447 and then Expander_Active
11448 and then Get_PCS_Name
/= Name_No_DSA
11450 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11455 ("pragma% cannot reference access-to-function type",
11459 -- Only other possibility is Access-to-class-wide type
11461 elsif Is_Access_Type
(Nm
)
11462 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11464 Check_First_Subtype
(Arg1
);
11465 Set_Is_Asynchronous
(Nm
);
11466 if Expander_Active
then
11467 RACW_Type_Is_Asynchronous
(Nm
);
11471 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11479 -- pragma Atomic (LOCAL_NAME);
11481 when Pragma_Atomic
=>
11482 Process_Atomic_Shared_Volatile
;
11484 -----------------------
11485 -- Atomic_Components --
11486 -----------------------
11488 -- pragma Atomic_Components (array_LOCAL_NAME);
11490 -- This processing is shared by Volatile_Components
11492 when Pragma_Atomic_Components |
11493 Pragma_Volatile_Components
=>
11495 Atomic_Components
: declare
11502 Check_Ada_83_Warning
;
11503 Check_No_Identifiers
;
11504 Check_Arg_Count
(1);
11505 Check_Arg_Is_Local_Name
(Arg1
);
11506 E_Id
:= Get_Pragma_Arg
(Arg1
);
11508 if Etype
(E_Id
) = Any_Type
then
11512 E
:= Entity
(E_Id
);
11514 Check_Duplicate_Pragma
(E
);
11516 if Rep_Item_Too_Early
(E
, N
)
11518 Rep_Item_Too_Late
(E
, N
)
11523 D
:= Declaration_Node
(E
);
11526 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11528 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11529 and then Nkind
(D
) = N_Object_Declaration
11530 and then Nkind
(Object_Definition
(D
)) =
11531 N_Constrained_Array_Definition
)
11533 -- The flag is set on the object, or on the base type
11535 if Nkind
(D
) /= N_Object_Declaration
then
11536 E
:= Base_Type
(E
);
11539 Set_Has_Volatile_Components
(E
);
11541 if Prag_Id
= Pragma_Atomic_Components
then
11542 Set_Has_Atomic_Components
(E
);
11546 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11548 end Atomic_Components
;
11550 --------------------
11551 -- Attach_Handler --
11552 --------------------
11554 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11556 when Pragma_Attach_Handler
=>
11557 Check_Ada_83_Warning
;
11558 Check_No_Identifiers
;
11559 Check_Arg_Count
(2);
11561 if No_Run_Time_Mode
then
11562 Error_Msg_CRT
("Attach_Handler pragma", N
);
11564 Check_Interrupt_Or_Attach_Handler
;
11566 -- The expression that designates the attribute may depend on a
11567 -- discriminant, and is therefore a per-object expression, to
11568 -- be expanded in the init proc. If expansion is enabled, then
11569 -- perform semantic checks on a copy only.
11574 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11577 -- In Relaxed_RM_Semantics mode, we allow any static
11578 -- integer value, for compatibility with other compilers.
11580 if Relaxed_RM_Semantics
11581 and then Nkind
(Parg2
) = N_Integer_Literal
11583 Typ
:= Standard_Integer
;
11585 Typ
:= RTE
(RE_Interrupt_ID
);
11588 if Expander_Active
then
11589 Temp
:= New_Copy_Tree
(Parg2
);
11590 Set_Parent
(Temp
, N
);
11591 Preanalyze_And_Resolve
(Temp
, Typ
);
11594 Resolve
(Parg2
, Typ
);
11598 Process_Interrupt_Or_Attach_Handler
;
11601 --------------------
11602 -- C_Pass_By_Copy --
11603 --------------------
11605 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11607 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11613 Check_Valid_Configuration_Pragma
;
11614 Check_Arg_Count
(1);
11615 Check_Optional_Identifier
(Arg1
, "max_size");
11617 Arg
:= Get_Pragma_Arg
(Arg1
);
11618 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11620 Val
:= Expr_Value
(Arg
);
11624 ("maximum size for pragma% must be positive", Arg1
);
11626 elsif UI_Is_In_Int_Range
(Val
) then
11627 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11629 -- If a giant value is given, Int'Last will do well enough.
11630 -- If sometime someone complains that a record larger than
11631 -- two gigabytes is not copied, we will worry about it then.
11634 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11636 end C_Pass_By_Copy
;
11642 -- pragma Check ([Name =>] CHECK_KIND,
11643 -- [Check =>] Boolean_EXPRESSION
11644 -- [,[Message =>] String_EXPRESSION]);
11646 -- CHECK_KIND ::= IDENTIFIER |
11649 -- Invariant'Class |
11650 -- Type_Invariant'Class
11652 -- The identifiers Assertions and Statement_Assertions are not
11653 -- allowed, since they have special meaning for Check_Policy.
11655 when Pragma_Check
=> Check
: declare
11663 Check_At_Least_N_Arguments
(2);
11664 Check_At_Most_N_Arguments
(3);
11665 Check_Optional_Identifier
(Arg1
, Name_Name
);
11666 Check_Optional_Identifier
(Arg2
, Name_Check
);
11668 if Arg_Count
= 3 then
11669 Check_Optional_Identifier
(Arg3
, Name_Message
);
11670 Str
:= Get_Pragma_Arg
(Arg3
);
11673 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11674 Check_Arg_Is_Identifier
(Arg1
);
11675 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11677 -- Check forbidden name Assertions or Statement_Assertions
11680 when Name_Assertions
=>
11682 ("""Assertions"" is not allowed as a check kind "
11683 & "for pragma%", Arg1
);
11685 when Name_Statement_Assertions
=>
11687 ("""Statement_Assertions"" is not allowed as a check kind "
11688 & "for pragma%", Arg1
);
11694 -- Check applicable policy. We skip this if Checked/Ignored status
11695 -- is already set (e.g. in the casse of a pragma from an aspect).
11697 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11700 -- For a non-source pragma that is a rewriting of another pragma,
11701 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11703 elsif Is_Rewrite_Substitution
(N
)
11704 and then Nkind
(Original_Node
(N
)) = N_Pragma
11705 and then Original_Node
(N
) /= N
11707 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11708 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11710 -- Otherwise query the applicable policy at this point
11713 case Check_Kind
(Cname
) is
11714 when Name_Ignore
=>
11715 Set_Is_Ignored
(N
, True);
11716 Set_Is_Checked
(N
, False);
11719 Set_Is_Ignored
(N
, False);
11720 Set_Is_Checked
(N
, True);
11722 -- For disable, rewrite pragma as null statement and skip
11723 -- rest of the analysis of the pragma.
11725 when Name_Disable
=>
11726 Rewrite
(N
, Make_Null_Statement
(Loc
));
11730 -- No other possibilities
11733 raise Program_Error
;
11737 -- If check kind was not Disable, then continue pragma analysis
11739 Expr
:= Get_Pragma_Arg
(Arg2
);
11741 -- Deal with SCO generation
11744 when Name_Predicate |
11747 -- Nothing to do: since checks occur in client units,
11748 -- the SCO for the aspect in the declaration unit is
11749 -- conservatively always enabled.
11755 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11757 -- Mark aspect/pragma SCO as enabled
11759 Set_SCO_Pragma_Enabled
(Loc
);
11763 -- Deal with analyzing the string argument.
11765 if Arg_Count
= 3 then
11767 -- If checks are not on we don't want any expansion (since
11768 -- such expansion would not get properly deleted) but
11769 -- we do want to analyze (to get proper references).
11770 -- The Preanalyze_And_Resolve routine does just what we want
11772 if Is_Ignored
(N
) then
11773 Preanalyze_And_Resolve
(Str
, Standard_String
);
11775 -- Otherwise we need a proper analysis and expansion
11778 Analyze_And_Resolve
(Str
, Standard_String
);
11782 -- Now you might think we could just do the same with the Boolean
11783 -- expression if checks are off (and expansion is on) and then
11784 -- rewrite the check as a null statement. This would work but we
11785 -- would lose the useful warnings about an assertion being bound
11786 -- to fail even if assertions are turned off.
11788 -- So instead we wrap the boolean expression in an if statement
11789 -- that looks like:
11791 -- if False and then condition then
11795 -- The reason we do this rewriting during semantic analysis rather
11796 -- than as part of normal expansion is that we cannot analyze and
11797 -- expand the code for the boolean expression directly, or it may
11798 -- cause insertion of actions that would escape the attempt to
11799 -- suppress the check code.
11801 -- Note that the Sloc for the if statement corresponds to the
11802 -- argument condition, not the pragma itself. The reason for
11803 -- this is that we may generate a warning if the condition is
11804 -- False at compile time, and we do not want to delete this
11805 -- warning when we delete the if statement.
11807 if Expander_Active
and Is_Ignored
(N
) then
11808 Eloc
:= Sloc
(Expr
);
11811 Make_If_Statement
(Eloc
,
11813 Make_And_Then
(Eloc
,
11814 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
11815 Right_Opnd
=> Expr
),
11816 Then_Statements
=> New_List
(
11817 Make_Null_Statement
(Eloc
))));
11819 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11821 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11823 -- Check is active or expansion not active. In these cases we can
11824 -- just go ahead and analyze the boolean with no worries.
11827 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11828 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11829 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11833 --------------------------
11834 -- Check_Float_Overflow --
11835 --------------------------
11837 -- pragma Check_Float_Overflow;
11839 when Pragma_Check_Float_Overflow
=>
11841 Check_Valid_Configuration_Pragma
;
11842 Check_Arg_Count
(0);
11843 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11849 -- pragma Check_Name (check_IDENTIFIER);
11851 when Pragma_Check_Name
=>
11853 Check_No_Identifiers
;
11854 Check_Valid_Configuration_Pragma
;
11855 Check_Arg_Count
(1);
11856 Check_Arg_Is_Identifier
(Arg1
);
11859 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11862 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11863 if Check_Names
.Table
(J
) = Nam
then
11868 Check_Names
.Append
(Nam
);
11875 -- This is the old style syntax, which is still allowed in all modes:
11877 -- pragma Check_Policy ([Name =>] CHECK_KIND
11878 -- [Policy =>] POLICY_IDENTIFIER);
11880 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11882 -- CHECK_KIND ::= IDENTIFIER |
11885 -- Type_Invariant'Class |
11888 -- This is the new style syntax, compatible with Assertion_Policy
11889 -- and also allowed in all modes.
11891 -- Pragma Check_Policy (
11892 -- CHECK_KIND => POLICY_IDENTIFIER
11893 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11895 -- Note: the identifiers Name and Policy are not allowed as
11896 -- Check_Kind values. This avoids ambiguities between the old and
11897 -- new form syntax.
11899 when Pragma_Check_Policy
=> Check_Policy
: declare
11904 Check_At_Least_N_Arguments
(1);
11906 -- A Check_Policy pragma can appear either as a configuration
11907 -- pragma, or in a declarative part or a package spec (see RM
11908 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11909 -- followed for Check_Policy).
11911 if not Is_Configuration_Pragma
then
11912 Check_Is_In_Decl_Part_Or_Package_Spec
;
11915 -- Figure out if we have the old or new syntax. We have the
11916 -- old syntax if the first argument has no identifier, or the
11917 -- identifier is Name.
11919 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11920 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11924 Check_Arg_Count
(2);
11925 Check_Optional_Identifier
(Arg1
, Name_Name
);
11926 Kind
:= Get_Pragma_Arg
(Arg1
);
11927 Rewrite_Assertion_Kind
(Kind
);
11928 Check_Arg_Is_Identifier
(Arg1
);
11930 -- Check forbidden check kind
11932 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11933 Error_Msg_Name_2
:= Chars
(Kind
);
11935 ("pragma% does not allow% as check name", Arg1
);
11940 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11941 Check_Arg_Is_One_Of
11943 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11945 -- And chain pragma on the Check_Policy_List for search
11947 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11948 Opt
.Check_Policy_List
:= N
;
11950 -- For the new syntax, what we do is to convert each argument to
11951 -- an old syntax equivalent. We do that because we want to chain
11952 -- old style Check_Policy pragmas for the search (we don't want
11953 -- to have to deal with multiple arguments in the search).
11963 while Present
(Arg
) loop
11964 LocP
:= Sloc
(Arg
);
11965 Argx
:= Get_Pragma_Arg
(Arg
);
11967 -- Kind must be specified
11969 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11970 or else Chars
(Arg
) = No_Name
11973 ("missing assertion kind for pragma%", Arg
);
11976 -- Construct equivalent old form syntax Check_Policy
11977 -- pragma and insert it to get remaining checks.
11981 Chars
=> Name_Check_Policy
,
11982 Pragma_Argument_Associations
=> New_List
(
11983 Make_Pragma_Argument_Association
(LocP
,
11985 Make_Identifier
(LocP
, Chars
(Arg
))),
11986 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11987 Expression
=> Argx
))));
11992 -- Rewrite original Check_Policy pragma to null, since we
11993 -- have converted it into a series of old syntax pragmas.
11995 Rewrite
(N
, Make_Null_Statement
(Loc
));
12001 ---------------------
12002 -- CIL_Constructor --
12003 ---------------------
12005 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12007 -- Processing for this pragma is shared with Java_Constructor
12013 -- pragma Comment (static_string_EXPRESSION)
12015 -- Processing for pragma Comment shares the circuitry for pragma
12016 -- Ident. The only differences are that Ident enforces a limit of 31
12017 -- characters on its argument, and also enforces limitations on
12018 -- placement for DEC compatibility. Pragma Comment shares neither of
12019 -- these restrictions.
12021 -------------------
12022 -- Common_Object --
12023 -------------------
12025 -- pragma Common_Object (
12026 -- [Internal =>] LOCAL_NAME
12027 -- [, [External =>] EXTERNAL_SYMBOL]
12028 -- [, [Size =>] EXTERNAL_SYMBOL]);
12030 -- Processing for this pragma is shared with Psect_Object
12032 ------------------------
12033 -- Compile_Time_Error --
12034 ------------------------
12036 -- pragma Compile_Time_Error
12037 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12039 when Pragma_Compile_Time_Error
=>
12041 Process_Compile_Time_Warning_Or_Error
;
12043 --------------------------
12044 -- Compile_Time_Warning --
12045 --------------------------
12047 -- pragma Compile_Time_Warning
12048 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12050 when Pragma_Compile_Time_Warning
=>
12052 Process_Compile_Time_Warning_Or_Error
;
12054 ---------------------------
12055 -- Compiler_Unit_Warning --
12056 ---------------------------
12058 -- pragma Compiler_Unit_Warning;
12062 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12063 -- errors not warnings. This means that we had introduced a big extra
12064 -- inertia to compiler changes, since even if we implemented a new
12065 -- feature, and even if all versions to be used for bootstrapping
12066 -- implemented this new feature, we could not use it, since old
12067 -- compilers would give errors for using this feature in units
12068 -- having Compiler_Unit pragmas.
12070 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12071 -- problem. We no longer have any units mentioning Compiler_Unit,
12072 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12073 -- and thus generates a warning which can be ignored. So that deals
12074 -- with the problem of old compilers not implementing the newer form
12077 -- Newer compilers recognize the new pragma, but generate warning
12078 -- messages instead of errors, which again can be ignored in the
12079 -- case of an old compiler which implements a wanted new feature
12080 -- but at the time felt like warning about it for older compilers.
12082 -- We retain Compiler_Unit so that new compilers can be used to build
12083 -- older run-times that use this pragma. That's an unusual case, but
12084 -- it's easy enough to handle, so why not?
12086 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12088 Check_Arg_Count
(0);
12090 -- Only recognized in main unit
12092 if Current_Sem_Unit
= Main_Unit
then
12093 Compiler_Unit
:= True;
12096 -----------------------------
12097 -- Complete_Representation --
12098 -----------------------------
12100 -- pragma Complete_Representation;
12102 when Pragma_Complete_Representation
=>
12104 Check_Arg_Count
(0);
12106 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12108 ("pragma & must appear within record representation clause");
12111 ----------------------------
12112 -- Complex_Representation --
12113 ----------------------------
12115 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12117 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12124 Check_Arg_Count
(1);
12125 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12126 Check_Arg_Is_Local_Name
(Arg1
);
12127 E_Id
:= Get_Pragma_Arg
(Arg1
);
12129 if Etype
(E_Id
) = Any_Type
then
12133 E
:= Entity
(E_Id
);
12135 if not Is_Record_Type
(E
) then
12137 ("argument for pragma% must be record type", Arg1
);
12140 Ent
:= First_Entity
(E
);
12143 or else No
(Next_Entity
(Ent
))
12144 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12145 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12146 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12149 ("record for pragma% must have two fields of the same "
12150 & "floating-point type", Arg1
);
12153 Set_Has_Complex_Representation
(Base_Type
(E
));
12155 -- We need to treat the type has having a non-standard
12156 -- representation, for back-end purposes, even though in
12157 -- general a complex will have the default representation
12158 -- of a record with two real components.
12160 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12162 end Complex_Representation
;
12164 -------------------------
12165 -- Component_Alignment --
12166 -------------------------
12168 -- pragma Component_Alignment (
12169 -- [Form =>] ALIGNMENT_CHOICE
12170 -- [, [Name =>] type_LOCAL_NAME]);
12172 -- ALIGNMENT_CHOICE ::=
12174 -- | Component_Size_4
12178 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12179 Args
: Args_List
(1 .. 2);
12180 Names
: constant Name_List
(1 .. 2) := (
12184 Form
: Node_Id
renames Args
(1);
12185 Name
: Node_Id
renames Args
(2);
12187 Atype
: Component_Alignment_Kind
;
12192 Gather_Associations
(Names
, Args
);
12195 Error_Pragma
("missing Form argument for pragma%");
12198 Check_Arg_Is_Identifier
(Form
);
12200 -- Get proper alignment, note that Default = Component_Size on all
12201 -- machines we have so far, and we want to set this value rather
12202 -- than the default value to indicate that it has been explicitly
12203 -- set (and thus will not get overridden by the default component
12204 -- alignment for the current scope)
12206 if Chars
(Form
) = Name_Component_Size
then
12207 Atype
:= Calign_Component_Size
;
12209 elsif Chars
(Form
) = Name_Component_Size_4
then
12210 Atype
:= Calign_Component_Size_4
;
12212 elsif Chars
(Form
) = Name_Default
then
12213 Atype
:= Calign_Component_Size
;
12215 elsif Chars
(Form
) = Name_Storage_Unit
then
12216 Atype
:= Calign_Storage_Unit
;
12220 ("invalid Form parameter for pragma%", Form
);
12223 -- Case with no name, supplied, affects scope table entry
12227 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12229 -- Case of name supplied
12232 Check_Arg_Is_Local_Name
(Name
);
12234 Typ
:= Entity
(Name
);
12237 or else Rep_Item_Too_Early
(Typ
, N
)
12241 Typ
:= Underlying_Type
(Typ
);
12244 if not Is_Record_Type
(Typ
)
12245 and then not Is_Array_Type
(Typ
)
12248 ("Name parameter of pragma% must identify record or "
12249 & "array type", Name
);
12252 -- An explicit Component_Alignment pragma overrides an
12253 -- implicit pragma Pack, but not an explicit one.
12255 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12256 Set_Is_Packed
(Base_Type
(Typ
), False);
12257 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12260 end Component_AlignmentP
;
12262 --------------------
12263 -- Contract_Cases --
12264 --------------------
12266 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12268 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12270 -- CASE_GUARD ::= boolean_EXPRESSION | others
12272 -- CONSEQUENCE ::= boolean_EXPRESSION
12274 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12275 Subp_Decl
: Node_Id
;
12279 Check_Arg_Count
(1);
12280 Ensure_Aggregate_Form
(Arg1
);
12282 -- The pragma is analyzed at the end of the declarative part which
12283 -- contains the related subprogram. Reset the analyzed flag.
12285 Set_Analyzed
(N
, False);
12287 -- Ensure the proper placement of the pragma. Contract_Cases must
12288 -- be associated with a subprogram declaration or a body that acts
12292 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12294 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12297 -- Body acts as spec
12299 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12300 and then No
(Corresponding_Spec
(Subp_Decl
))
12304 -- Body stub acts as spec
12306 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12307 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12316 -- When the pragma appears on a subprogram body, perform the full
12319 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12320 Analyze_Contract_Cases_In_Decl_Part
(N
);
12322 -- When Contract_Cases applies to a subprogram compilation unit,
12323 -- the corresponding pragma is placed after the unit's declaration
12324 -- node and needs to be analyzed immediately.
12326 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12327 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12329 Analyze_Contract_Cases_In_Decl_Part
(N
);
12332 -- Chain the pragma on the contract for further processing
12334 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12335 end Contract_Cases
;
12341 -- pragma Controlled (first_subtype_LOCAL_NAME);
12343 when Pragma_Controlled
=> Controlled
: declare
12347 Check_No_Identifiers
;
12348 Check_Arg_Count
(1);
12349 Check_Arg_Is_Local_Name
(Arg1
);
12350 Arg
:= Get_Pragma_Arg
(Arg1
);
12352 if not Is_Entity_Name
(Arg
)
12353 or else not Is_Access_Type
(Entity
(Arg
))
12355 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12357 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12365 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12366 -- [Entity =>] LOCAL_NAME);
12368 when Pragma_Convention
=> Convention
: declare
12371 pragma Warnings
(Off
, C
);
12372 pragma Warnings
(Off
, E
);
12374 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12375 Check_Ada_83_Warning
;
12376 Check_Arg_Count
(2);
12377 Process_Convention
(C
, E
);
12380 ---------------------------
12381 -- Convention_Identifier --
12382 ---------------------------
12384 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12385 -- [Convention =>] convention_IDENTIFIER);
12387 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12393 Check_Arg_Order
((Name_Name
, Name_Convention
));
12394 Check_Arg_Count
(2);
12395 Check_Optional_Identifier
(Arg1
, Name_Name
);
12396 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12397 Check_Arg_Is_Identifier
(Arg1
);
12398 Check_Arg_Is_Identifier
(Arg2
);
12399 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12400 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12402 if Is_Convention_Name
(Cname
) then
12403 Record_Convention_Identifier
12404 (Idnam
, Get_Convention_Id
(Cname
));
12407 ("second arg for % pragma must be convention", Arg2
);
12409 end Convention_Identifier
;
12415 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12417 when Pragma_CPP_Class
=> CPP_Class
: declare
12421 if Warn_On_Obsolescent_Feature
then
12423 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12424 & "effect; replace it by pragma import?j?", N
);
12427 Check_Arg_Count
(1);
12431 Chars
=> Name_Import
,
12432 Pragma_Argument_Associations
=> New_List
(
12433 Make_Pragma_Argument_Association
(Loc
,
12434 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12435 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12439 ---------------------
12440 -- CPP_Constructor --
12441 ---------------------
12443 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12444 -- [, [External_Name =>] static_string_EXPRESSION ]
12445 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12447 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12450 Def_Id
: Entity_Id
;
12451 Tag_Typ
: Entity_Id
;
12455 Check_At_Least_N_Arguments
(1);
12456 Check_At_Most_N_Arguments
(3);
12457 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12458 Check_Arg_Is_Local_Name
(Arg1
);
12460 Id
:= Get_Pragma_Arg
(Arg1
);
12461 Find_Program_Unit_Name
(Id
);
12463 -- If we did not find the name, we are done
12465 if Etype
(Id
) = Any_Type
then
12469 Def_Id
:= Entity
(Id
);
12471 -- Check if already defined as constructor
12473 if Is_Constructor
(Def_Id
) then
12475 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12479 if Ekind
(Def_Id
) = E_Function
12480 and then (Is_CPP_Class
(Etype
(Def_Id
))
12481 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12483 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12485 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12487 ("'C'P'P constructor must be defined in the scope of "
12488 & "its returned type", Arg1
);
12491 if Arg_Count
>= 2 then
12492 Set_Imported
(Def_Id
);
12493 Set_Is_Public
(Def_Id
);
12494 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12497 Set_Has_Completion
(Def_Id
);
12498 Set_Is_Constructor
(Def_Id
);
12499 Set_Convention
(Def_Id
, Convention_CPP
);
12501 -- Imported C++ constructors are not dispatching primitives
12502 -- because in C++ they don't have a dispatch table slot.
12503 -- However, in Ada the constructor has the profile of a
12504 -- function that returns a tagged type and therefore it has
12505 -- been treated as a primitive operation during semantic
12506 -- analysis. We now remove it from the list of primitive
12507 -- operations of the type.
12509 if Is_Tagged_Type
(Etype
(Def_Id
))
12510 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12511 and then Is_Dispatching_Operation
(Def_Id
)
12513 Tag_Typ
:= Etype
(Def_Id
);
12515 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12516 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12520 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12521 Set_Is_Dispatching_Operation
(Def_Id
, False);
12524 -- For backward compatibility, if the constructor returns a
12525 -- class wide type, and we internally change the return type to
12526 -- the corresponding root type.
12528 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12529 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12533 ("pragma% requires function returning a 'C'P'P_Class type",
12536 end CPP_Constructor
;
12542 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12546 if Warn_On_Obsolescent_Feature
then
12548 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12557 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12561 if Warn_On_Obsolescent_Feature
then
12563 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12572 -- pragma CPU (EXPRESSION);
12574 when Pragma_CPU
=> CPU
: declare
12575 P
: constant Node_Id
:= Parent
(N
);
12581 Check_No_Identifiers
;
12582 Check_Arg_Count
(1);
12586 if Nkind
(P
) = N_Subprogram_Body
then
12587 Check_In_Main_Program
;
12589 Arg
:= Get_Pragma_Arg
(Arg1
);
12590 Analyze_And_Resolve
(Arg
, Any_Integer
);
12592 Ent
:= Defining_Unit_Name
(Specification
(P
));
12594 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12595 Ent
:= Defining_Identifier
(Ent
);
12600 if not Is_OK_Static_Expression
(Arg
) then
12601 Flag_Non_Static_Expr
12602 ("main subprogram affinity is not static!", Arg
);
12605 -- If constraint error, then we already signalled an error
12607 elsif Raises_Constraint_Error
(Arg
) then
12610 -- Otherwise check in range
12614 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12615 -- This is the entity System.Multiprocessors.CPU_Range;
12617 Val
: constant Uint
:= Expr_Value
(Arg
);
12620 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12622 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12625 ("main subprogram CPU is out of range", Arg1
);
12631 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12635 elsif Nkind
(P
) = N_Task_Definition
then
12636 Arg
:= Get_Pragma_Arg
(Arg1
);
12637 Ent
:= Defining_Identifier
(Parent
(P
));
12639 -- The expression must be analyzed in the special manner
12640 -- described in "Handling of Default and Per-Object
12641 -- Expressions" in sem.ads.
12643 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12645 -- Anything else is incorrect
12651 -- Check duplicate pragma before we chain the pragma in the Rep
12652 -- Item chain of Ent.
12654 Check_Duplicate_Pragma
(Ent
);
12655 Record_Rep_Item
(Ent
, N
);
12662 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12664 when Pragma_Debug
=> Debug
: declare
12671 -- The condition for executing the call is that the expander
12672 -- is active and that we are not ignoring this debug pragma.
12677 (Expander_Active
and then not Is_Ignored
(N
)),
12680 if not Is_Ignored
(N
) then
12681 Set_SCO_Pragma_Enabled
(Loc
);
12684 if Arg_Count
= 2 then
12686 Make_And_Then
(Loc
,
12687 Left_Opnd
=> Relocate_Node
(Cond
),
12688 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12689 Call
:= Get_Pragma_Arg
(Arg2
);
12691 Call
:= Get_Pragma_Arg
(Arg1
);
12695 N_Indexed_Component
,
12699 N_Selected_Component
)
12701 -- If this pragma Debug comes from source, its argument was
12702 -- parsed as a name form (which is syntactically identical).
12703 -- In a generic context a parameterless call will be left as
12704 -- an expanded name (if global) or selected_component if local.
12705 -- Change it to a procedure call statement now.
12707 Change_Name_To_Procedure_Call_Statement
(Call
);
12709 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12711 -- Already in the form of a procedure call statement: nothing
12712 -- to do (could happen in case of an internally generated
12718 -- All other cases: diagnose error
12721 ("argument of pragma ""Debug"" is not procedure call",
12726 -- Rewrite into a conditional with an appropriate condition. We
12727 -- wrap the procedure call in a block so that overhead from e.g.
12728 -- use of the secondary stack does not generate execution overhead
12729 -- for suppressed conditions.
12731 -- Normally the analysis that follows will freeze the subprogram
12732 -- being called. However, if the call is to a null procedure,
12733 -- we want to freeze it before creating the block, because the
12734 -- analysis that follows may be done with expansion disabled, in
12735 -- which case the body will not be generated, leading to spurious
12738 if Nkind
(Call
) = N_Procedure_Call_Statement
12739 and then Is_Entity_Name
(Name
(Call
))
12741 Analyze
(Name
(Call
));
12742 Freeze_Before
(N
, Entity
(Name
(Call
)));
12746 Make_Implicit_If_Statement
(N
,
12748 Then_Statements
=> New_List
(
12749 Make_Block_Statement
(Loc
,
12750 Handled_Statement_Sequence
=>
12751 Make_Handled_Sequence_Of_Statements
(Loc
,
12752 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12755 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12756 -- after analysis of the normally rewritten node, to capture all
12757 -- references to entities, which avoids issuing wrong warnings
12758 -- about unused entities.
12760 if GNATprove_Mode
then
12761 Rewrite
(N
, Make_Null_Statement
(Loc
));
12769 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12771 when Pragma_Debug_Policy
=>
12773 Check_Arg_Count
(1);
12774 Check_No_Identifiers
;
12775 Check_Arg_Is_Identifier
(Arg1
);
12777 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12778 -- rewrite it that way, and let the rest of the checking come
12779 -- from analyzing the rewritten pragma.
12783 Chars
=> Name_Check_Policy
,
12784 Pragma_Argument_Associations
=> New_List
(
12785 Make_Pragma_Argument_Association
(Loc
,
12786 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12788 Make_Pragma_Argument_Association
(Loc
,
12789 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12792 --------------------------------------
12793 -- Pragma_Default_Initial_Condition --
12794 --------------------------------------
12796 -- pragma Pragma_Default_Initial_Condition
12797 -- [ (null | boolean_EXPRESSION) ];
12799 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12806 Check_At_Most_N_Arguments
(1);
12809 while Present
(Stmt
) loop
12811 -- Skip prior pragmas, but check for duplicates
12813 if Nkind
(Stmt
) = N_Pragma
then
12814 if Pragma_Name
(Stmt
) = Pname
then
12815 Error_Msg_Name_1
:= Pname
;
12816 Error_Msg_Sloc
:= Sloc
(Stmt
);
12817 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12820 -- Skip internally generated code
12822 elsif not Comes_From_Source
(Stmt
) then
12825 -- The associated private type [extension] has been found, stop
12828 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12829 N_Private_Type_Declaration
)
12831 Typ
:= Defining_Entity
(Stmt
);
12834 -- The pragma does not apply to a legal construct, issue an
12835 -- error and stop the analysis.
12842 Stmt
:= Prev
(Stmt
);
12845 Set_Has_Default_Init_Cond
(Typ
);
12846 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12848 -- Chain the pragma on the rep item chain for further processing
12850 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12851 end Default_Init_Cond
;
12853 ----------------------------------
12854 -- Default_Scalar_Storage_Order --
12855 ----------------------------------
12857 -- pragma Default_Scalar_Storage_Order
12858 -- (High_Order_First | Low_Order_First);
12860 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12861 Default
: Character;
12865 Check_Arg_Count
(1);
12867 -- Default_Scalar_Storage_Order can appear as a configuration
12868 -- pragma, or in a declarative part of a package spec.
12870 if not Is_Configuration_Pragma
then
12871 Check_Is_In_Decl_Part_Or_Package_Spec
;
12874 Check_No_Identifiers
;
12875 Check_Arg_Is_One_Of
12876 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12877 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12878 Default
:= Fold_Upper
(Name_Buffer
(1));
12880 if not Support_Nondefault_SSO_On_Target
12881 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12883 if Warn_On_Unrecognized_Pragma
then
12885 ("non-default Scalar_Storage_Order not supported "
12886 & "on target?g?", N
);
12888 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12891 -- Here set the specified default
12894 Opt
.Default_SSO
:= Default
;
12898 --------------------------
12899 -- Default_Storage_Pool --
12900 --------------------------
12902 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12904 when Pragma_Default_Storage_Pool
=>
12906 Check_Arg_Count
(1);
12908 -- Default_Storage_Pool can appear as a configuration pragma, or
12909 -- in a declarative part of a package spec.
12911 if not Is_Configuration_Pragma
then
12912 Check_Is_In_Decl_Part_Or_Package_Spec
;
12915 -- Case of Default_Storage_Pool (null);
12917 if Nkind
(Expression
(Arg1
)) = N_Null
then
12918 Analyze
(Expression
(Arg1
));
12920 -- This is an odd case, this is not really an expression, so
12921 -- we don't have a type for it. So just set the type to Empty.
12923 Set_Etype
(Expression
(Arg1
), Empty
);
12925 -- Case of Default_Storage_Pool (storage_pool_NAME);
12928 -- If it's a configuration pragma, then the only allowed
12929 -- argument is "null".
12931 if Is_Configuration_Pragma
then
12932 Error_Pragma_Arg
("NULL expected", Arg1
);
12935 -- The expected type for a non-"null" argument is
12936 -- Root_Storage_Pool'Class.
12938 Analyze_And_Resolve
12939 (Get_Pragma_Arg
(Arg1
),
12940 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12943 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12944 -- for an access type will use this information to set the
12945 -- appropriate attributes of the access type.
12947 Default_Pool
:= Expression
(Arg1
);
12953 -- pragma Depends (DEPENDENCY_RELATION);
12955 -- DEPENDENCY_RELATION ::=
12957 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12959 -- DEPENDENCY_CLAUSE ::=
12960 -- OUTPUT_LIST =>[+] INPUT_LIST
12961 -- | NULL_DEPENDENCY_CLAUSE
12963 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12965 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12967 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12969 -- OUTPUT ::= NAME | FUNCTION_RESULT
12972 -- where FUNCTION_RESULT is a function Result attribute_reference
12974 when Pragma_Depends
=> Depends
: declare
12975 Subp_Decl
: Node_Id
;
12979 Check_Arg_Count
(1);
12980 Ensure_Aggregate_Form
(Arg1
);
12982 -- Ensure the proper placement of the pragma. Depends must be
12983 -- associated with a subprogram declaration or a body that acts
12987 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12989 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12992 -- Body acts as spec
12994 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12995 and then No
(Corresponding_Spec
(Subp_Decl
))
12999 -- Body stub acts as spec
13001 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13002 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13011 -- When the pragma appears on a subprogram body, perform the full
13014 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
13015 Analyze_Depends_In_Decl_Part
(N
);
13017 -- When Depends applies to a subprogram compilation unit, the
13018 -- corresponding pragma is placed after the unit's declaration
13019 -- node and needs to be analyzed immediately.
13021 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13022 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
13024 Analyze_Depends_In_Decl_Part
(N
);
13027 -- Chain the pragma on the contract for further processing
13029 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13032 ---------------------
13033 -- Detect_Blocking --
13034 ---------------------
13036 -- pragma Detect_Blocking;
13038 when Pragma_Detect_Blocking
=>
13040 Check_Arg_Count
(0);
13041 Check_Valid_Configuration_Pragma
;
13042 Detect_Blocking
:= True;
13044 ------------------------------------
13045 -- Disable_Atomic_Synchronization --
13046 ------------------------------------
13048 -- pragma Disable_Atomic_Synchronization [(Entity)];
13050 when Pragma_Disable_Atomic_Synchronization
=>
13052 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13054 -------------------
13055 -- Discard_Names --
13056 -------------------
13058 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13060 when Pragma_Discard_Names
=> Discard_Names
: declare
13065 Check_Ada_83_Warning
;
13067 -- Deal with configuration pragma case
13069 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13070 Global_Discard_Names
:= True;
13073 -- Otherwise, check correct appropriate context
13076 Check_Is_In_Decl_Part_Or_Package_Spec
;
13078 if Arg_Count
= 0 then
13080 -- If there is no parameter, then from now on this pragma
13081 -- applies to any enumeration, exception or tagged type
13082 -- defined in the current declarative part, and recursively
13083 -- to any nested scope.
13085 Set_Discard_Names
(Current_Scope
);
13089 Check_Arg_Count
(1);
13090 Check_Optional_Identifier
(Arg1
, Name_On
);
13091 Check_Arg_Is_Local_Name
(Arg1
);
13093 E_Id
:= Get_Pragma_Arg
(Arg1
);
13095 if Etype
(E_Id
) = Any_Type
then
13098 E
:= Entity
(E_Id
);
13101 if (Is_First_Subtype
(E
)
13103 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13104 or else Ekind
(E
) = E_Exception
13106 Set_Discard_Names
(E
);
13107 Record_Rep_Item
(E
, N
);
13111 ("inappropriate entity for pragma%", Arg1
);
13118 ------------------------
13119 -- Dispatching_Domain --
13120 ------------------------
13122 -- pragma Dispatching_Domain (EXPRESSION);
13124 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13125 P
: constant Node_Id
:= Parent
(N
);
13131 Check_No_Identifiers
;
13132 Check_Arg_Count
(1);
13134 -- This pragma is born obsolete, but not the aspect
13136 if not From_Aspect_Specification
(N
) then
13138 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13141 if Nkind
(P
) = N_Task_Definition
then
13142 Arg
:= Get_Pragma_Arg
(Arg1
);
13143 Ent
:= Defining_Identifier
(Parent
(P
));
13145 -- The expression must be analyzed in the special manner
13146 -- described in "Handling of Default and Per-Object
13147 -- Expressions" in sem.ads.
13149 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13151 -- Check duplicate pragma before we chain the pragma in the Rep
13152 -- Item chain of Ent.
13154 Check_Duplicate_Pragma
(Ent
);
13155 Record_Rep_Item
(Ent
, N
);
13157 -- Anything else is incorrect
13162 end Dispatching_Domain
;
13168 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13170 when Pragma_Elaborate
=> Elaborate
: declare
13175 -- Pragma must be in context items list of a compilation unit
13177 if not Is_In_Context_Clause
then
13181 -- Must be at least one argument
13183 if Arg_Count
= 0 then
13184 Error_Pragma
("pragma% requires at least one argument");
13187 -- In Ada 83 mode, there can be no items following it in the
13188 -- context list except other pragmas and implicit with clauses
13189 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13190 -- placement rule does not apply.
13192 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13194 while Present
(Citem
) loop
13195 if Nkind
(Citem
) = N_Pragma
13196 or else (Nkind
(Citem
) = N_With_Clause
13197 and then Implicit_With
(Citem
))
13202 ("(Ada 83) pragma% must be at end of context clause");
13209 -- Finally, the arguments must all be units mentioned in a with
13210 -- clause in the same context clause. Note we already checked (in
13211 -- Par.Prag) that the arguments are all identifiers or selected
13215 Outer
: while Present
(Arg
) loop
13216 Citem
:= First
(List_Containing
(N
));
13217 Inner
: while Citem
/= N
loop
13218 if Nkind
(Citem
) = N_With_Clause
13219 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13221 Set_Elaborate_Present
(Citem
, True);
13222 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13223 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
13225 -- With the pragma present, elaboration calls on
13226 -- subprograms from the named unit need no further
13227 -- checks, as long as the pragma appears in the current
13228 -- compilation unit. If the pragma appears in some unit
13229 -- in the context, there might still be a need for an
13230 -- Elaborate_All_Desirable from the current compilation
13231 -- to the named unit, so we keep the check enabled.
13233 if In_Extended_Main_Source_Unit
(N
) then
13234 Set_Suppress_Elaboration_Warnings
13235 (Entity
(Name
(Citem
)));
13246 ("argument of pragma% is not withed unit", Arg
);
13252 -- Give a warning if operating in static mode with one of the
13253 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13255 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
13257 ("?l?use of pragma Elaborate may not be safe", N
);
13259 ("?l?use pragma Elaborate_All instead if possible", N
);
13263 -------------------
13264 -- Elaborate_All --
13265 -------------------
13267 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13269 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13274 Check_Ada_83_Warning
;
13276 -- Pragma must be in context items list of a compilation unit
13278 if not Is_In_Context_Clause
then
13282 -- Must be at least one argument
13284 if Arg_Count
= 0 then
13285 Error_Pragma
("pragma% requires at least one argument");
13288 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13289 -- have to appear at the end of the context clause, but may
13290 -- appear mixed in with other items, even in Ada 83 mode.
13292 -- Final check: the arguments must all be units mentioned in
13293 -- a with clause in the same context clause. Note that we
13294 -- already checked (in Par.Prag) that all the arguments are
13295 -- either identifiers or selected components.
13298 Outr
: while Present
(Arg
) loop
13299 Citem
:= First
(List_Containing
(N
));
13300 Innr
: while Citem
/= N
loop
13301 if Nkind
(Citem
) = N_With_Clause
13302 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13304 Set_Elaborate_All_Present
(Citem
, True);
13305 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13307 -- Suppress warnings and elaboration checks on the named
13308 -- unit if the pragma is in the current compilation, as
13309 -- for pragma Elaborate.
13311 if In_Extended_Main_Source_Unit
(N
) then
13312 Set_Suppress_Elaboration_Warnings
13313 (Entity
(Name
(Citem
)));
13322 Set_Error_Posted
(N
);
13324 ("argument of pragma% is not withed unit", Arg
);
13331 --------------------
13332 -- Elaborate_Body --
13333 --------------------
13335 -- pragma Elaborate_Body [( library_unit_NAME )];
13337 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13338 Cunit_Node
: Node_Id
;
13339 Cunit_Ent
: Entity_Id
;
13342 Check_Ada_83_Warning
;
13343 Check_Valid_Library_Unit_Pragma
;
13345 if Nkind
(N
) = N_Null_Statement
then
13349 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13350 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13352 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13355 Error_Pragma
("pragma% must refer to a spec, not a body");
13357 Set_Body_Required
(Cunit_Node
, True);
13358 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13360 -- If we are in dynamic elaboration mode, then we suppress
13361 -- elaboration warnings for the unit, since it is definitely
13362 -- fine NOT to do dynamic checks at the first level (and such
13363 -- checks will be suppressed because no elaboration boolean
13364 -- is created for Elaborate_Body packages).
13366 -- But in the static model of elaboration, Elaborate_Body is
13367 -- definitely NOT good enough to ensure elaboration safety on
13368 -- its own, since the body may WITH other units that are not
13369 -- safe from an elaboration point of view, so a client must
13370 -- still do an Elaborate_All on such units.
13372 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13373 -- Elaborate_Body always suppressed elab warnings.
13375 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13376 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13379 end Elaborate_Body
;
13381 ------------------------
13382 -- Elaboration_Checks --
13383 ------------------------
13385 -- pragma Elaboration_Checks (Static | Dynamic);
13387 when Pragma_Elaboration_Checks
=>
13389 Check_Arg_Count
(1);
13390 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13391 Dynamic_Elaboration_Checks
:=
13392 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
13398 -- pragma Eliminate (
13399 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13400 -- [,[Entity =>] IDENTIFIER |
13401 -- SELECTED_COMPONENT |
13403 -- [, OVERLOADING_RESOLUTION]);
13405 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13408 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13409 -- FUNCTION_PROFILE
13411 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13413 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13414 -- Result_Type => result_SUBTYPE_NAME]
13416 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13417 -- SUBTYPE_NAME ::= STRING_LITERAL
13419 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13420 -- SOURCE_TRACE ::= STRING_LITERAL
13422 when Pragma_Eliminate
=> Eliminate
: declare
13423 Args
: Args_List
(1 .. 5);
13424 Names
: constant Name_List
(1 .. 5) := (
13427 Name_Parameter_Types
,
13429 Name_Source_Location
);
13431 Unit_Name
: Node_Id
renames Args
(1);
13432 Entity
: Node_Id
renames Args
(2);
13433 Parameter_Types
: Node_Id
renames Args
(3);
13434 Result_Type
: Node_Id
renames Args
(4);
13435 Source_Location
: Node_Id
renames Args
(5);
13439 Check_Valid_Configuration_Pragma
;
13440 Gather_Associations
(Names
, Args
);
13442 if No
(Unit_Name
) then
13443 Error_Pragma
("missing Unit_Name argument for pragma%");
13447 and then (Present
(Parameter_Types
)
13449 Present
(Result_Type
)
13451 Present
(Source_Location
))
13453 Error_Pragma
("missing Entity argument for pragma%");
13456 if (Present
(Parameter_Types
)
13458 Present
(Result_Type
))
13460 Present
(Source_Location
)
13463 ("parameter profile and source location cannot be used "
13464 & "together in pragma%");
13467 Process_Eliminate_Pragma
13476 -----------------------------------
13477 -- Enable_Atomic_Synchronization --
13478 -----------------------------------
13480 -- pragma Enable_Atomic_Synchronization [(Entity)];
13482 when Pragma_Enable_Atomic_Synchronization
=>
13484 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13491 -- [ Convention =>] convention_IDENTIFIER,
13492 -- [ Entity =>] LOCAL_NAME
13493 -- [, [External_Name =>] static_string_EXPRESSION ]
13494 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13496 when Pragma_Export
=> Export
: declare
13498 Def_Id
: Entity_Id
;
13500 pragma Warnings
(Off
, C
);
13503 Check_Ada_83_Warning
;
13507 Name_External_Name
,
13510 Check_At_Least_N_Arguments
(2);
13511 Check_At_Most_N_Arguments
(4);
13513 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13514 -- pragma Export (Entity, "external name");
13516 if Relaxed_RM_Semantics
13517 and then Arg_Count
= 2
13518 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13521 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13524 if not Is_Entity_Name
(Def_Id
) then
13525 Error_Pragma_Arg
("entity name required", Arg1
);
13528 Def_Id
:= Entity
(Def_Id
);
13529 Set_Exported
(Def_Id
, Arg1
);
13532 Process_Convention
(C
, Def_Id
);
13534 if Ekind
(Def_Id
) /= E_Constant
then
13535 Note_Possible_Modification
13536 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13539 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13540 Set_Exported
(Def_Id
, Arg2
);
13543 -- If the entity is a deferred constant, propagate the information
13544 -- to the full view, because gigi elaborates the full view only.
13546 if Ekind
(Def_Id
) = E_Constant
13547 and then Present
(Full_View
(Def_Id
))
13550 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13552 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13553 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13554 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13559 ---------------------
13560 -- Export_Function --
13561 ---------------------
13563 -- pragma Export_Function (
13564 -- [Internal =>] LOCAL_NAME
13565 -- [, [External =>] EXTERNAL_SYMBOL]
13566 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13567 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13568 -- [, [Mechanism =>] MECHANISM]
13569 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13571 -- EXTERNAL_SYMBOL ::=
13573 -- | static_string_EXPRESSION
13575 -- PARAMETER_TYPES ::=
13577 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13579 -- TYPE_DESIGNATOR ::=
13581 -- | subtype_Name ' Access
13585 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13587 -- MECHANISM_ASSOCIATION ::=
13588 -- [formal_parameter_NAME =>] MECHANISM_NAME
13590 -- MECHANISM_NAME ::=
13594 when Pragma_Export_Function
=> Export_Function
: declare
13595 Args
: Args_List
(1 .. 6);
13596 Names
: constant Name_List
(1 .. 6) := (
13599 Name_Parameter_Types
,
13602 Name_Result_Mechanism
);
13604 Internal
: Node_Id
renames Args
(1);
13605 External
: Node_Id
renames Args
(2);
13606 Parameter_Types
: Node_Id
renames Args
(3);
13607 Result_Type
: Node_Id
renames Args
(4);
13608 Mechanism
: Node_Id
renames Args
(5);
13609 Result_Mechanism
: Node_Id
renames Args
(6);
13613 Gather_Associations
(Names
, Args
);
13614 Process_Extended_Import_Export_Subprogram_Pragma
(
13615 Arg_Internal
=> Internal
,
13616 Arg_External
=> External
,
13617 Arg_Parameter_Types
=> Parameter_Types
,
13618 Arg_Result_Type
=> Result_Type
,
13619 Arg_Mechanism
=> Mechanism
,
13620 Arg_Result_Mechanism
=> Result_Mechanism
);
13621 end Export_Function
;
13623 -------------------
13624 -- Export_Object --
13625 -------------------
13627 -- pragma Export_Object (
13628 -- [Internal =>] LOCAL_NAME
13629 -- [, [External =>] EXTERNAL_SYMBOL]
13630 -- [, [Size =>] EXTERNAL_SYMBOL]);
13632 -- EXTERNAL_SYMBOL ::=
13634 -- | static_string_EXPRESSION
13636 -- PARAMETER_TYPES ::=
13638 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13640 -- TYPE_DESIGNATOR ::=
13642 -- | subtype_Name ' Access
13646 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13648 -- MECHANISM_ASSOCIATION ::=
13649 -- [formal_parameter_NAME =>] MECHANISM_NAME
13651 -- MECHANISM_NAME ::=
13655 when Pragma_Export_Object
=> Export_Object
: declare
13656 Args
: Args_List
(1 .. 3);
13657 Names
: constant Name_List
(1 .. 3) := (
13662 Internal
: Node_Id
renames Args
(1);
13663 External
: Node_Id
renames Args
(2);
13664 Size
: Node_Id
renames Args
(3);
13668 Gather_Associations
(Names
, Args
);
13669 Process_Extended_Import_Export_Object_Pragma
(
13670 Arg_Internal
=> Internal
,
13671 Arg_External
=> External
,
13675 ----------------------
13676 -- Export_Procedure --
13677 ----------------------
13679 -- pragma Export_Procedure (
13680 -- [Internal =>] LOCAL_NAME
13681 -- [, [External =>] EXTERNAL_SYMBOL]
13682 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13683 -- [, [Mechanism =>] MECHANISM]);
13685 -- EXTERNAL_SYMBOL ::=
13687 -- | static_string_EXPRESSION
13689 -- PARAMETER_TYPES ::=
13691 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13693 -- TYPE_DESIGNATOR ::=
13695 -- | subtype_Name ' Access
13699 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13701 -- MECHANISM_ASSOCIATION ::=
13702 -- [formal_parameter_NAME =>] MECHANISM_NAME
13704 -- MECHANISM_NAME ::=
13708 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13709 Args
: Args_List
(1 .. 4);
13710 Names
: constant Name_List
(1 .. 4) := (
13713 Name_Parameter_Types
,
13716 Internal
: Node_Id
renames Args
(1);
13717 External
: Node_Id
renames Args
(2);
13718 Parameter_Types
: Node_Id
renames Args
(3);
13719 Mechanism
: Node_Id
renames Args
(4);
13723 Gather_Associations
(Names
, Args
);
13724 Process_Extended_Import_Export_Subprogram_Pragma
(
13725 Arg_Internal
=> Internal
,
13726 Arg_External
=> External
,
13727 Arg_Parameter_Types
=> Parameter_Types
,
13728 Arg_Mechanism
=> Mechanism
);
13729 end Export_Procedure
;
13735 -- pragma Export_Value (
13736 -- [Value =>] static_integer_EXPRESSION,
13737 -- [Link_Name =>] static_string_EXPRESSION);
13739 when Pragma_Export_Value
=>
13741 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13742 Check_Arg_Count
(2);
13744 Check_Optional_Identifier
(Arg1
, Name_Value
);
13745 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13747 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13748 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13750 -----------------------------
13751 -- Export_Valued_Procedure --
13752 -----------------------------
13754 -- pragma Export_Valued_Procedure (
13755 -- [Internal =>] LOCAL_NAME
13756 -- [, [External =>] EXTERNAL_SYMBOL,]
13757 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13758 -- [, [Mechanism =>] MECHANISM]);
13760 -- EXTERNAL_SYMBOL ::=
13762 -- | static_string_EXPRESSION
13764 -- PARAMETER_TYPES ::=
13766 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13768 -- TYPE_DESIGNATOR ::=
13770 -- | subtype_Name ' Access
13774 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13776 -- MECHANISM_ASSOCIATION ::=
13777 -- [formal_parameter_NAME =>] MECHANISM_NAME
13779 -- MECHANISM_NAME ::=
13783 when Pragma_Export_Valued_Procedure
=>
13784 Export_Valued_Procedure
: declare
13785 Args
: Args_List
(1 .. 4);
13786 Names
: constant Name_List
(1 .. 4) := (
13789 Name_Parameter_Types
,
13792 Internal
: Node_Id
renames Args
(1);
13793 External
: Node_Id
renames Args
(2);
13794 Parameter_Types
: Node_Id
renames Args
(3);
13795 Mechanism
: Node_Id
renames Args
(4);
13799 Gather_Associations
(Names
, Args
);
13800 Process_Extended_Import_Export_Subprogram_Pragma
(
13801 Arg_Internal
=> Internal
,
13802 Arg_External
=> External
,
13803 Arg_Parameter_Types
=> Parameter_Types
,
13804 Arg_Mechanism
=> Mechanism
);
13805 end Export_Valued_Procedure
;
13807 -------------------
13808 -- Extend_System --
13809 -------------------
13811 -- pragma Extend_System ([Name =>] Identifier);
13813 when Pragma_Extend_System
=> Extend_System
: declare
13816 Check_Valid_Configuration_Pragma
;
13817 Check_Arg_Count
(1);
13818 Check_Optional_Identifier
(Arg1
, Name_Name
);
13819 Check_Arg_Is_Identifier
(Arg1
);
13821 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13824 and then Name_Buffer
(1 .. 4) = "aux_"
13826 if Present
(System_Extend_Pragma_Arg
) then
13827 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13828 Chars
(Expression
(System_Extend_Pragma_Arg
))
13832 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13833 Error_Pragma
("pragma% conflicts with that #");
13837 System_Extend_Pragma_Arg
:= Arg1
;
13839 if not GNAT_Mode
then
13840 System_Extend_Unit
:= Arg1
;
13844 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13848 ------------------------
13849 -- Extensions_Allowed --
13850 ------------------------
13852 -- pragma Extensions_Allowed (ON | OFF);
13854 when Pragma_Extensions_Allowed
=>
13856 Check_Arg_Count
(1);
13857 Check_No_Identifiers
;
13858 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13860 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13861 Extensions_Allowed
:= True;
13862 Ada_Version
:= Ada_Version_Type
'Last;
13865 Extensions_Allowed
:= False;
13866 Ada_Version
:= Ada_Version_Explicit
;
13867 Ada_Version_Pragma
:= Empty
;
13874 -- pragma External (
13875 -- [ Convention =>] convention_IDENTIFIER,
13876 -- [ Entity =>] LOCAL_NAME
13877 -- [, [External_Name =>] static_string_EXPRESSION ]
13878 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13880 when Pragma_External
=> External
: declare
13881 Def_Id
: Entity_Id
;
13884 pragma Warnings
(Off
, C
);
13891 Name_External_Name
,
13893 Check_At_Least_N_Arguments
(2);
13894 Check_At_Most_N_Arguments
(4);
13895 Process_Convention
(C
, Def_Id
);
13896 Note_Possible_Modification
13897 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13898 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13899 Set_Exported
(Def_Id
, Arg2
);
13902 --------------------------
13903 -- External_Name_Casing --
13904 --------------------------
13906 -- pragma External_Name_Casing (
13907 -- UPPERCASE | LOWERCASE
13908 -- [, AS_IS | UPPERCASE | LOWERCASE]);
13910 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
13913 Check_No_Identifiers
;
13915 if Arg_Count
= 2 then
13916 Check_Arg_Is_One_Of
13917 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
13919 case Chars
(Get_Pragma_Arg
(Arg2
)) is
13921 Opt
.External_Name_Exp_Casing
:= As_Is
;
13923 when Name_Uppercase
=>
13924 Opt
.External_Name_Exp_Casing
:= Uppercase
;
13926 when Name_Lowercase
=>
13927 Opt
.External_Name_Exp_Casing
:= Lowercase
;
13934 Check_Arg_Count
(1);
13937 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
13939 case Chars
(Get_Pragma_Arg
(Arg1
)) is
13940 when Name_Uppercase
=>
13941 Opt
.External_Name_Imp_Casing
:= Uppercase
;
13943 when Name_Lowercase
=>
13944 Opt
.External_Name_Imp_Casing
:= Lowercase
;
13949 end External_Name_Casing
;
13955 -- pragma Fast_Math;
13957 when Pragma_Fast_Math
=>
13959 Check_No_Identifiers
;
13960 Check_Valid_Configuration_Pragma
;
13963 --------------------------
13964 -- Favor_Top_Level --
13965 --------------------------
13967 -- pragma Favor_Top_Level (type_NAME);
13969 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
13970 Named_Entity
: Entity_Id
;
13974 Check_No_Identifiers
;
13975 Check_Arg_Count
(1);
13976 Check_Arg_Is_Local_Name
(Arg1
);
13977 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
13979 -- If it's an access-to-subprogram type (in particular, not a
13980 -- subtype), set the flag on that type.
13982 if Is_Access_Subprogram_Type
(Named_Entity
) then
13983 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
13985 -- Otherwise it's an error (name denotes the wrong sort of entity)
13989 ("access-to-subprogram type expected",
13990 Get_Pragma_Arg
(Arg1
));
13992 end Favor_Top_Level
;
13994 ---------------------------
13995 -- Finalize_Storage_Only --
13996 ---------------------------
13998 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14000 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14001 Assoc
: constant Node_Id
:= Arg1
;
14002 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14007 Check_No_Identifiers
;
14008 Check_Arg_Count
(1);
14009 Check_Arg_Is_Local_Name
(Arg1
);
14011 Find_Type
(Type_Id
);
14012 Typ
:= Entity
(Type_Id
);
14015 or else Rep_Item_Too_Early
(Typ
, N
)
14019 Typ
:= Underlying_Type
(Typ
);
14022 if not Is_Controlled
(Typ
) then
14023 Error_Pragma
("pragma% must specify controlled type");
14026 Check_First_Subtype
(Arg1
);
14028 if Finalize_Storage_Only
(Typ
) then
14029 Error_Pragma
("duplicate pragma%, only one allowed");
14031 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14032 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14034 end Finalize_Storage
;
14040 -- pragma Global (GLOBAL_SPECIFICATION);
14042 -- GLOBAL_SPECIFICATION ::=
14045 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14047 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14049 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14050 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14051 -- GLOBAL_ITEM ::= NAME
14053 when Pragma_Global
=> Global
: declare
14054 Subp_Decl
: Node_Id
;
14058 Check_Arg_Count
(1);
14059 Ensure_Aggregate_Form
(Arg1
);
14061 -- Ensure the proper placement of the pragma. Global must be
14062 -- associated with a subprogram declaration or a body that acts
14066 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14068 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14071 -- Body acts as spec
14073 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14074 and then No
(Corresponding_Spec
(Subp_Decl
))
14078 -- Body stub acts as spec
14080 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14081 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14090 -- When the pragma appears on a subprogram body, perform the full
14093 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14094 Analyze_Global_In_Decl_Part
(N
);
14096 -- When Global applies to a subprogram compilation unit, the
14097 -- corresponding pragma is placed after the unit's declaration
14098 -- node and needs to be analyzed immediately.
14100 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14101 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14103 Analyze_Global_In_Decl_Part
(N
);
14106 -- Chain the pragma on the contract for further processing
14108 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14115 -- pragma Ident (static_string_EXPRESSION)
14117 -- Note: pragma Comment shares this processing. Pragma Ident is
14118 -- identical in effect to pragma Commment.
14120 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14125 Check_Arg_Count
(1);
14126 Check_No_Identifiers
;
14127 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14130 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14137 GP
:= Parent
(Parent
(N
));
14139 if Nkind_In
(GP
, N_Package_Declaration
,
14140 N_Generic_Package_Declaration
)
14145 -- If we have a compilation unit, then record the ident value,
14146 -- checking for improper duplication.
14148 if Nkind
(GP
) = N_Compilation_Unit
then
14149 CS
:= Ident_String
(Current_Sem_Unit
);
14151 if Present
(CS
) then
14153 -- If we have multiple instances, concatenate them, but
14154 -- not in ASIS, where we want the original tree.
14156 if not ASIS_Mode
then
14157 Start_String
(Strval
(CS
));
14158 Store_String_Char
(' ');
14159 Store_String_Chars
(Strval
(Str
));
14160 Set_Strval
(CS
, End_String
);
14164 Set_Ident_String
(Current_Sem_Unit
, Str
);
14167 -- For subunits, we just ignore the Ident, since in GNAT these
14168 -- are not separate object files, and hence not separate units
14169 -- in the unit table.
14171 elsif Nkind
(GP
) = N_Subunit
then
14177 ----------------------------
14178 -- Implementation_Defined --
14179 ----------------------------
14181 -- pragma Implementation_Defined (LOCAL_NAME);
14183 -- Marks previously declared entity as implementation defined. For
14184 -- an overloaded entity, applies to the most recent homonym.
14186 -- pragma Implementation_Defined;
14188 -- The form with no arguments appears anywhere within a scope, most
14189 -- typically a package spec, and indicates that all entities that are
14190 -- defined within the package spec are Implementation_Defined.
14192 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14197 Check_No_Identifiers
;
14199 -- Form with no arguments
14201 if Arg_Count
= 0 then
14202 Set_Is_Implementation_Defined
(Current_Scope
);
14204 -- Form with one argument
14207 Check_Arg_Count
(1);
14208 Check_Arg_Is_Local_Name
(Arg1
);
14209 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14210 Set_Is_Implementation_Defined
(Ent
);
14212 end Implementation_Defined
;
14218 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14220 -- IMPLEMENTATION_KIND ::=
14221 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14223 -- "By_Any" and "Optional" are treated as synonyms in order to
14224 -- support Ada 2012 aspect Synchronization.
14226 when Pragma_Implemented
=> Implemented
: declare
14227 Proc_Id
: Entity_Id
;
14232 Check_Arg_Count
(2);
14233 Check_No_Identifiers
;
14234 Check_Arg_Is_Identifier
(Arg1
);
14235 Check_Arg_Is_Local_Name
(Arg1
);
14236 Check_Arg_Is_One_Of
(Arg2
,
14239 Name_By_Protected_Procedure
,
14242 -- Extract the name of the local procedure
14244 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14246 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14247 -- primitive procedure of a synchronized tagged type.
14249 if Ekind
(Proc_Id
) = E_Procedure
14250 and then Is_Primitive
(Proc_Id
)
14251 and then Present
(First_Formal
(Proc_Id
))
14253 Typ
:= Etype
(First_Formal
(Proc_Id
));
14255 if Is_Tagged_Type
(Typ
)
14258 -- Check for a protected, a synchronized or a task interface
14260 ((Is_Interface
(Typ
)
14261 and then Is_Synchronized_Interface
(Typ
))
14263 -- Check for a protected type or a task type that implements
14267 (Is_Concurrent_Record_Type
(Typ
)
14268 and then Present
(Interfaces
(Typ
)))
14270 -- Check for a private record extension with keyword
14274 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14275 E_Record_Subtype_With_Private
)
14276 and then Synchronized_Present
(Parent
(Typ
))))
14281 ("controlling formal must be of synchronized tagged type",
14286 -- Procedures declared inside a protected type must be accepted
14288 elsif Ekind
(Proc_Id
) = E_Procedure
14289 and then Is_Protected_Type
(Scope
(Proc_Id
))
14293 -- The first argument is not a primitive procedure
14297 ("pragma % must be applied to a primitive procedure", Arg1
);
14301 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14302 -- By_Protected_Procedure to the primitive procedure of a task
14305 if Chars
(Arg2
) = Name_By_Protected_Procedure
14306 and then Is_Interface
(Typ
)
14307 and then Is_Task_Interface
(Typ
)
14310 ("implementation kind By_Protected_Procedure cannot be "
14311 & "applied to a task interface primitive", Arg2
);
14315 Record_Rep_Item
(Proc_Id
, N
);
14318 ----------------------
14319 -- Implicit_Packing --
14320 ----------------------
14322 -- pragma Implicit_Packing;
14324 when Pragma_Implicit_Packing
=>
14326 Check_Arg_Count
(0);
14327 Implicit_Packing
:= True;
14334 -- [Convention =>] convention_IDENTIFIER,
14335 -- [Entity =>] LOCAL_NAME
14336 -- [, [External_Name =>] static_string_EXPRESSION ]
14337 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14339 when Pragma_Import
=>
14340 Check_Ada_83_Warning
;
14344 Name_External_Name
,
14347 Check_At_Least_N_Arguments
(2);
14348 Check_At_Most_N_Arguments
(4);
14349 Process_Import_Or_Interface
;
14351 ---------------------
14352 -- Import_Function --
14353 ---------------------
14355 -- pragma Import_Function (
14356 -- [Internal =>] LOCAL_NAME,
14357 -- [, [External =>] EXTERNAL_SYMBOL]
14358 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14359 -- [, [Result_Type =>] SUBTYPE_MARK]
14360 -- [, [Mechanism =>] MECHANISM]
14361 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14363 -- EXTERNAL_SYMBOL ::=
14365 -- | static_string_EXPRESSION
14367 -- PARAMETER_TYPES ::=
14369 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14371 -- TYPE_DESIGNATOR ::=
14373 -- | subtype_Name ' Access
14377 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14379 -- MECHANISM_ASSOCIATION ::=
14380 -- [formal_parameter_NAME =>] MECHANISM_NAME
14382 -- MECHANISM_NAME ::=
14386 when Pragma_Import_Function
=> Import_Function
: declare
14387 Args
: Args_List
(1 .. 6);
14388 Names
: constant Name_List
(1 .. 6) := (
14391 Name_Parameter_Types
,
14394 Name_Result_Mechanism
);
14396 Internal
: Node_Id
renames Args
(1);
14397 External
: Node_Id
renames Args
(2);
14398 Parameter_Types
: Node_Id
renames Args
(3);
14399 Result_Type
: Node_Id
renames Args
(4);
14400 Mechanism
: Node_Id
renames Args
(5);
14401 Result_Mechanism
: Node_Id
renames Args
(6);
14405 Gather_Associations
(Names
, Args
);
14406 Process_Extended_Import_Export_Subprogram_Pragma
(
14407 Arg_Internal
=> Internal
,
14408 Arg_External
=> External
,
14409 Arg_Parameter_Types
=> Parameter_Types
,
14410 Arg_Result_Type
=> Result_Type
,
14411 Arg_Mechanism
=> Mechanism
,
14412 Arg_Result_Mechanism
=> Result_Mechanism
);
14413 end Import_Function
;
14415 -------------------
14416 -- Import_Object --
14417 -------------------
14419 -- pragma Import_Object (
14420 -- [Internal =>] LOCAL_NAME
14421 -- [, [External =>] EXTERNAL_SYMBOL]
14422 -- [, [Size =>] EXTERNAL_SYMBOL]);
14424 -- EXTERNAL_SYMBOL ::=
14426 -- | static_string_EXPRESSION
14428 when Pragma_Import_Object
=> Import_Object
: declare
14429 Args
: Args_List
(1 .. 3);
14430 Names
: constant Name_List
(1 .. 3) := (
14435 Internal
: Node_Id
renames Args
(1);
14436 External
: Node_Id
renames Args
(2);
14437 Size
: Node_Id
renames Args
(3);
14441 Gather_Associations
(Names
, Args
);
14442 Process_Extended_Import_Export_Object_Pragma
(
14443 Arg_Internal
=> Internal
,
14444 Arg_External
=> External
,
14448 ----------------------
14449 -- Import_Procedure --
14450 ----------------------
14452 -- pragma Import_Procedure (
14453 -- [Internal =>] LOCAL_NAME
14454 -- [, [External =>] EXTERNAL_SYMBOL]
14455 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14456 -- [, [Mechanism =>] MECHANISM]);
14458 -- EXTERNAL_SYMBOL ::=
14460 -- | static_string_EXPRESSION
14462 -- PARAMETER_TYPES ::=
14464 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14466 -- TYPE_DESIGNATOR ::=
14468 -- | subtype_Name ' Access
14472 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14474 -- MECHANISM_ASSOCIATION ::=
14475 -- [formal_parameter_NAME =>] MECHANISM_NAME
14477 -- MECHANISM_NAME ::=
14481 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14482 Args
: Args_List
(1 .. 4);
14483 Names
: constant Name_List
(1 .. 4) := (
14486 Name_Parameter_Types
,
14489 Internal
: Node_Id
renames Args
(1);
14490 External
: Node_Id
renames Args
(2);
14491 Parameter_Types
: Node_Id
renames Args
(3);
14492 Mechanism
: Node_Id
renames Args
(4);
14496 Gather_Associations
(Names
, Args
);
14497 Process_Extended_Import_Export_Subprogram_Pragma
(
14498 Arg_Internal
=> Internal
,
14499 Arg_External
=> External
,
14500 Arg_Parameter_Types
=> Parameter_Types
,
14501 Arg_Mechanism
=> Mechanism
);
14502 end Import_Procedure
;
14504 -----------------------------
14505 -- Import_Valued_Procedure --
14506 -----------------------------
14508 -- pragma Import_Valued_Procedure (
14509 -- [Internal =>] LOCAL_NAME
14510 -- [, [External =>] EXTERNAL_SYMBOL]
14511 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14512 -- [, [Mechanism =>] MECHANISM]);
14514 -- EXTERNAL_SYMBOL ::=
14516 -- | static_string_EXPRESSION
14518 -- PARAMETER_TYPES ::=
14520 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14522 -- TYPE_DESIGNATOR ::=
14524 -- | subtype_Name ' Access
14528 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14530 -- MECHANISM_ASSOCIATION ::=
14531 -- [formal_parameter_NAME =>] MECHANISM_NAME
14533 -- MECHANISM_NAME ::=
14537 when Pragma_Import_Valued_Procedure
=>
14538 Import_Valued_Procedure
: declare
14539 Args
: Args_List
(1 .. 4);
14540 Names
: constant Name_List
(1 .. 4) := (
14543 Name_Parameter_Types
,
14546 Internal
: Node_Id
renames Args
(1);
14547 External
: Node_Id
renames Args
(2);
14548 Parameter_Types
: Node_Id
renames Args
(3);
14549 Mechanism
: Node_Id
renames Args
(4);
14553 Gather_Associations
(Names
, Args
);
14554 Process_Extended_Import_Export_Subprogram_Pragma
(
14555 Arg_Internal
=> Internal
,
14556 Arg_External
=> External
,
14557 Arg_Parameter_Types
=> Parameter_Types
,
14558 Arg_Mechanism
=> Mechanism
);
14559 end Import_Valued_Procedure
;
14565 -- pragma Independent (record_component_LOCAL_NAME);
14567 when Pragma_Independent
=> Independent
: declare
14572 Check_Ada_83_Warning
;
14574 Check_No_Identifiers
;
14575 Check_Arg_Count
(1);
14576 Check_Arg_Is_Local_Name
(Arg1
);
14577 E_Id
:= Get_Pragma_Arg
(Arg1
);
14579 if Etype
(E_Id
) = Any_Type
then
14583 E
:= Entity
(E_Id
);
14585 -- Check we have a record component. We have not yet setup
14586 -- components fully, so identify by syntactic structure.
14588 if Nkind
(Declaration_Node
(E
)) /= N_Component_Declaration
then
14590 ("argument for pragma% must be record component", Arg1
);
14593 -- Check duplicate before we chain ourselves
14595 Check_Duplicate_Pragma
(E
);
14599 if Rep_Item_Too_Early
(E
, N
)
14601 Rep_Item_Too_Late
(E
, N
)
14606 -- Set flag in component
14608 Set_Is_Independent
(E
);
14610 Independence_Checks
.Append
((N
, E
));
14613 ----------------------------
14614 -- Independent_Components --
14615 ----------------------------
14617 -- pragma Atomic_Components (array_LOCAL_NAME);
14619 -- This processing is shared by Volatile_Components
14621 when Pragma_Independent_Components
=> Independent_Components
: declare
14629 Check_Ada_83_Warning
;
14631 Check_No_Identifiers
;
14632 Check_Arg_Count
(1);
14633 Check_Arg_Is_Local_Name
(Arg1
);
14634 E_Id
:= Get_Pragma_Arg
(Arg1
);
14636 if Etype
(E_Id
) = Any_Type
then
14640 E
:= Entity
(E_Id
);
14642 -- Check duplicate before we chain ourselves
14644 Check_Duplicate_Pragma
(E
);
14646 -- Check appropriate entity
14648 if Rep_Item_Too_Early
(E
, N
)
14650 Rep_Item_Too_Late
(E
, N
)
14655 D
:= Declaration_Node
(E
);
14658 if K
= N_Full_Type_Declaration
14659 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
14661 Independence_Checks
.Append
((N
, Base_Type
(E
)));
14662 Set_Has_Independent_Components
(Base_Type
(E
));
14664 -- For record type, set all components independent
14666 if Is_Record_Type
(E
) then
14667 C
:= First_Component
(E
);
14668 while Present
(C
) loop
14669 Set_Is_Independent
(C
);
14670 Next_Component
(C
);
14674 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
14675 and then Nkind
(D
) = N_Object_Declaration
14676 and then Nkind
(Object_Definition
(D
)) =
14677 N_Constrained_Array_Definition
14679 Independence_Checks
.Append
((N
, Base_Type
(Etype
(E
))));
14680 Set_Has_Independent_Components
(Base_Type
(Etype
(E
)));
14683 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
14685 end Independent_Components
;
14687 -----------------------
14688 -- Initial_Condition --
14689 -----------------------
14691 -- pragma Initial_Condition (boolean_EXPRESSION);
14693 when Pragma_Initial_Condition
=> Initial_Condition
: declare
14694 Context
: constant Node_Id
:= Parent
(Parent
(N
));
14695 Pack_Id
: Entity_Id
;
14700 Check_Arg_Count
(1);
14702 -- Ensure the proper placement of the pragma. Initial_Condition
14703 -- must be associated with a package declaration.
14705 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
14706 N_Package_Declaration
)
14713 while Present
(Stmt
) loop
14715 -- Skip prior pragmas, but check for duplicates
14717 if Nkind
(Stmt
) = N_Pragma
then
14718 if Pragma_Name
(Stmt
) = Pname
then
14719 Error_Msg_Name_1
:= Pname
;
14720 Error_Msg_Sloc
:= Sloc
(Stmt
);
14721 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
14724 -- Skip internally generated code
14726 elsif not Comes_From_Source
(Stmt
) then
14729 -- The pragma does not apply to a legal construct, issue an
14730 -- error and stop the analysis.
14737 Stmt
:= Prev
(Stmt
);
14740 -- The pragma must be analyzed at the end of the visible
14741 -- declarations of the related package. Save the pragma for later
14742 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
14743 -- the contract of the package.
14745 Pack_Id
:= Defining_Entity
(Context
);
14746 Add_Contract_Item
(N
, Pack_Id
);
14748 -- Verify the declaration order of pragma Initial_Condition with
14749 -- respect to pragmas Abstract_State and Initializes when SPARK
14750 -- checks are enabled.
14752 if SPARK_Mode
/= Off
then
14753 Check_Declaration_Order
14754 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
14757 Check_Declaration_Order
14758 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
14761 end Initial_Condition
;
14763 ------------------------
14764 -- Initialize_Scalars --
14765 ------------------------
14767 -- pragma Initialize_Scalars;
14769 when Pragma_Initialize_Scalars
=>
14771 Check_Arg_Count
(0);
14772 Check_Valid_Configuration_Pragma
;
14773 Check_Restriction
(No_Initialize_Scalars
, N
);
14775 -- Initialize_Scalars creates false positives in CodePeer, and
14776 -- incorrect negative results in GNATprove mode, so ignore this
14777 -- pragma in these modes.
14779 if not Restriction_Active
(No_Initialize_Scalars
)
14780 and then not (CodePeer_Mode
or GNATprove_Mode
)
14782 Init_Or_Norm_Scalars
:= True;
14783 Initialize_Scalars
:= True;
14790 -- pragma Initializes (INITIALIZATION_SPEC);
14792 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
14794 -- INITIALIZATION_LIST ::=
14795 -- INITIALIZATION_ITEM
14796 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
14798 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
14803 -- | (INPUT {, INPUT})
14807 when Pragma_Initializes
=> Initializes
: declare
14808 Context
: constant Node_Id
:= Parent
(Parent
(N
));
14809 Pack_Id
: Entity_Id
;
14814 Check_Arg_Count
(1);
14815 Ensure_Aggregate_Form
(Arg1
);
14817 -- Ensure the proper placement of the pragma. Initializes must be
14818 -- associated with a package declaration.
14820 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
14821 N_Package_Declaration
)
14828 while Present
(Stmt
) loop
14830 -- Skip prior pragmas, but check for duplicates
14832 if Nkind
(Stmt
) = N_Pragma
then
14833 if Pragma_Name
(Stmt
) = Pname
then
14834 Error_Msg_Name_1
:= Pname
;
14835 Error_Msg_Sloc
:= Sloc
(Stmt
);
14836 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
14839 -- Skip internally generated code
14841 elsif not Comes_From_Source
(Stmt
) then
14844 -- The pragma does not apply to a legal construct, issue an
14845 -- error and stop the analysis.
14852 Stmt
:= Prev
(Stmt
);
14855 -- The pragma must be analyzed at the end of the visible
14856 -- declarations of the related package. Save the pragma for later
14857 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
14858 -- contract of the package.
14860 Pack_Id
:= Defining_Entity
(Context
);
14861 Add_Contract_Item
(N
, Pack_Id
);
14863 -- Verify the declaration order of pragmas Abstract_State and
14864 -- Initializes when SPARK checks are enabled.
14866 if SPARK_Mode
/= Off
then
14867 Check_Declaration_Order
14868 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
14877 -- pragma Inline ( NAME {, NAME} );
14879 when Pragma_Inline
=>
14881 -- Inline status is Enabled if inlining option is active
14883 if Inline_Active
then
14884 Process_Inline
(Enabled
);
14886 Process_Inline
(Disabled
);
14889 -------------------
14890 -- Inline_Always --
14891 -------------------
14893 -- pragma Inline_Always ( NAME {, NAME} );
14895 when Pragma_Inline_Always
=>
14898 -- Pragma always active unless in CodePeer mode. It is disabled
14899 -- in CodePeer mode because inlining is not helpful, and enabling
14900 -- if caused walk order issues.
14902 -- Historical note: this pragma used to be disabled in GNATprove
14903 -- mode as well, but that was odd since walk order should not be
14904 -- an issue in that case.
14906 if not CodePeer_Mode
then
14907 Process_Inline
(Enabled
);
14910 --------------------
14911 -- Inline_Generic --
14912 --------------------
14914 -- pragma Inline_Generic (NAME {, NAME});
14916 when Pragma_Inline_Generic
=>
14918 Process_Generic_List
;
14920 ----------------------
14921 -- Inspection_Point --
14922 ----------------------
14924 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
14926 when Pragma_Inspection_Point
=> Inspection_Point
: declare
14933 if Arg_Count
> 0 then
14936 Exp
:= Get_Pragma_Arg
(Arg
);
14939 if not Is_Entity_Name
(Exp
)
14940 or else not Is_Object
(Entity
(Exp
))
14942 Error_Pragma_Arg
("object name required", Arg
);
14946 exit when No
(Arg
);
14949 end Inspection_Point
;
14955 -- pragma Interface (
14956 -- [ Convention =>] convention_IDENTIFIER,
14957 -- [ Entity =>] LOCAL_NAME
14958 -- [, [External_Name =>] static_string_EXPRESSION ]
14959 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14961 when Pragma_Interface
=>
14966 Name_External_Name
,
14968 Check_At_Least_N_Arguments
(2);
14969 Check_At_Most_N_Arguments
(4);
14970 Process_Import_Or_Interface
;
14972 -- In Ada 2005, the permission to use Interface (a reserved word)
14973 -- as a pragma name is considered an obsolescent feature, and this
14974 -- pragma was already obsolescent in Ada 95.
14976 if Ada_Version
>= Ada_95
then
14978 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14980 if Warn_On_Obsolescent_Feature
then
14982 ("pragma Interface is an obsolescent feature?j?", N
);
14984 ("|use pragma Import instead?j?", N
);
14988 --------------------
14989 -- Interface_Name --
14990 --------------------
14992 -- pragma Interface_Name (
14993 -- [ Entity =>] LOCAL_NAME
14994 -- [,[External_Name =>] static_string_EXPRESSION ]
14995 -- [,[Link_Name =>] static_string_EXPRESSION ]);
14997 when Pragma_Interface_Name
=> Interface_Name
: declare
14999 Def_Id
: Entity_Id
;
15000 Hom_Id
: Entity_Id
;
15006 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15007 Check_At_Least_N_Arguments
(2);
15008 Check_At_Most_N_Arguments
(3);
15009 Id
:= Get_Pragma_Arg
(Arg1
);
15012 -- This is obsolete from Ada 95 on, but it is an implementation
15013 -- defined pragma, so we do not consider that it violates the
15014 -- restriction (No_Obsolescent_Features).
15016 if Ada_Version
>= Ada_95
then
15017 if Warn_On_Obsolescent_Feature
then
15019 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15021 ("|use pragma Import instead?j?", N
);
15025 if not Is_Entity_Name
(Id
) then
15027 ("first argument for pragma% must be entity name", Arg1
);
15028 elsif Etype
(Id
) = Any_Type
then
15031 Def_Id
:= Entity
(Id
);
15034 -- Special DEC-compatible processing for the object case, forces
15035 -- object to be imported.
15037 if Ekind
(Def_Id
) = E_Variable
then
15038 Kill_Size_Check_Code
(Def_Id
);
15039 Note_Possible_Modification
(Id
, Sure
=> False);
15041 -- Initialization is not allowed for imported variable
15043 if Present
(Expression
(Parent
(Def_Id
)))
15044 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15046 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15048 ("no initialization allowed for declaration of& #",
15052 -- For compatibility, support VADS usage of providing both
15053 -- pragmas Interface and Interface_Name to obtain the effect
15054 -- of a single Import pragma.
15056 if Is_Imported
(Def_Id
)
15057 and then Present
(First_Rep_Item
(Def_Id
))
15058 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15060 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15064 Set_Imported
(Def_Id
);
15067 Set_Is_Public
(Def_Id
);
15068 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15071 -- Otherwise must be subprogram
15073 elsif not Is_Subprogram
(Def_Id
) then
15075 ("argument of pragma% is not subprogram", Arg1
);
15078 Check_At_Most_N_Arguments
(3);
15082 -- Loop through homonyms
15085 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15087 if Is_Imported
(Def_Id
) then
15088 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15092 exit when From_Aspect_Specification
(N
);
15093 Hom_Id
:= Homonym
(Hom_Id
);
15095 exit when No
(Hom_Id
)
15096 or else Scope
(Hom_Id
) /= Current_Scope
;
15101 ("argument of pragma% is not imported subprogram",
15105 end Interface_Name
;
15107 -----------------------
15108 -- Interrupt_Handler --
15109 -----------------------
15111 -- pragma Interrupt_Handler (handler_NAME);
15113 when Pragma_Interrupt_Handler
=>
15114 Check_Ada_83_Warning
;
15115 Check_Arg_Count
(1);
15116 Check_No_Identifiers
;
15118 if No_Run_Time_Mode
then
15119 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15121 Check_Interrupt_Or_Attach_Handler
;
15122 Process_Interrupt_Or_Attach_Handler
;
15125 ------------------------
15126 -- Interrupt_Priority --
15127 ------------------------
15129 -- pragma Interrupt_Priority [(EXPRESSION)];
15131 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15132 P
: constant Node_Id
:= Parent
(N
);
15137 Check_Ada_83_Warning
;
15139 if Arg_Count
/= 0 then
15140 Arg
:= Get_Pragma_Arg
(Arg1
);
15141 Check_Arg_Count
(1);
15142 Check_No_Identifiers
;
15144 -- The expression must be analyzed in the special manner
15145 -- described in "Handling of Default and Per-Object
15146 -- Expressions" in sem.ads.
15148 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15151 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15156 Ent
:= Defining_Identifier
(Parent
(P
));
15158 -- Check duplicate pragma before we chain the pragma in the Rep
15159 -- Item chain of Ent.
15161 Check_Duplicate_Pragma
(Ent
);
15162 Record_Rep_Item
(Ent
, N
);
15164 end Interrupt_Priority
;
15166 ---------------------
15167 -- Interrupt_State --
15168 ---------------------
15170 -- pragma Interrupt_State (
15171 -- [Name =>] INTERRUPT_ID,
15172 -- [State =>] INTERRUPT_STATE);
15174 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15175 -- INTERRUPT_STATE => System | Runtime | User
15177 -- Note: if the interrupt id is given as an identifier, then it must
15178 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15179 -- given as a static integer expression which must be in the range of
15180 -- Ada.Interrupts.Interrupt_ID.
15182 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15183 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15184 -- This is the entity Ada.Interrupts.Interrupt_ID;
15186 State_Type
: Character;
15187 -- Set to 's'/'r'/'u' for System/Runtime/User
15190 -- Index to entry in Interrupt_States table
15193 -- Value of interrupt
15195 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15196 -- The first argument to the pragma
15198 Int_Ent
: Entity_Id
;
15199 -- Interrupt entity in Ada.Interrupts.Names
15203 Check_Arg_Order
((Name_Name
, Name_State
));
15204 Check_Arg_Count
(2);
15206 Check_Optional_Identifier
(Arg1
, Name_Name
);
15207 Check_Optional_Identifier
(Arg2
, Name_State
);
15208 Check_Arg_Is_Identifier
(Arg2
);
15210 -- First argument is identifier
15212 if Nkind
(Arg1X
) = N_Identifier
then
15214 -- Search list of names in Ada.Interrupts.Names
15216 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15218 if No
(Int_Ent
) then
15219 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15221 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15222 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15226 Next_Entity
(Int_Ent
);
15229 -- First argument is not an identifier, so it must be a static
15230 -- expression of type Ada.Interrupts.Interrupt_ID.
15233 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15234 Int_Val
:= Expr_Value
(Arg1X
);
15236 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15238 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15241 ("value not in range of type "
15242 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15248 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15249 when Name_Runtime
=> State_Type
:= 'r';
15250 when Name_System
=> State_Type
:= 's';
15251 when Name_User
=> State_Type
:= 'u';
15254 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15257 -- Check if entry is already stored
15259 IST_Num
:= Interrupt_States
.First
;
15261 -- If entry not found, add it
15263 if IST_Num
> Interrupt_States
.Last
then
15264 Interrupt_States
.Append
15265 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15266 Interrupt_State
=> State_Type
,
15267 Pragma_Loc
=> Loc
));
15270 -- Case of entry for the same entry
15272 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15275 -- If state matches, done, no need to make redundant entry
15278 State_Type
= Interrupt_States
.Table
(IST_Num
).
15281 -- Otherwise if state does not match, error
15284 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15286 ("state conflicts with that given #", Arg2
);
15290 IST_Num
:= IST_Num
+ 1;
15292 end Interrupt_State
;
15298 -- pragma Invariant
15299 -- ([Entity =>] type_LOCAL_NAME,
15300 -- [Check =>] EXPRESSION
15301 -- [,[Message =>] String_Expression]);
15303 when Pragma_Invariant
=> Invariant
: declare
15310 Check_At_Least_N_Arguments
(2);
15311 Check_At_Most_N_Arguments
(3);
15312 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15313 Check_Optional_Identifier
(Arg2
, Name_Check
);
15315 if Arg_Count
= 3 then
15316 Check_Optional_Identifier
(Arg3
, Name_Message
);
15317 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15320 Check_Arg_Is_Local_Name
(Arg1
);
15322 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15323 Find_Type
(Type_Id
);
15324 Typ
:= Entity
(Type_Id
);
15326 if Typ
= Any_Type
then
15329 -- An invariant must apply to a private type, or appear in the
15330 -- private part of a package spec and apply to a completion.
15331 -- a class-wide invariant can only appear on a private declaration
15332 -- or private extension, not a completion.
15334 elsif Ekind_In
(Typ
, E_Private_Type
,
15335 E_Record_Type_With_Private
,
15336 E_Limited_Private_Type
)
15340 elsif In_Private_Part
(Current_Scope
)
15341 and then Has_Private_Declaration
(Typ
)
15342 and then not Class_Present
(N
)
15346 elsif In_Private_Part
(Current_Scope
) then
15348 ("pragma% only allowed for private type declared in "
15349 & "visible part", Arg1
);
15353 ("pragma% only allowed for private type", Arg1
);
15356 -- Note that the type has at least one invariant, and also that
15357 -- it has inheritable invariants if we have Invariant'Class
15358 -- or Type_Invariant'Class. Build the corresponding invariant
15359 -- procedure declaration, so that calls to it can be generated
15360 -- before the body is built (e.g. within an expression function).
15362 Insert_After_And_Analyze
15363 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15365 if Class_Present
(N
) then
15366 Set_Has_Inheritable_Invariants
(Typ
);
15369 -- The remaining processing is simply to link the pragma on to
15370 -- the rep item chain, for processing when the type is frozen.
15371 -- This is accomplished by a call to Rep_Item_Too_Late.
15373 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15376 ----------------------
15377 -- Java_Constructor --
15378 ----------------------
15380 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15382 -- Also handles pragma CIL_Constructor
15384 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15385 Java_Constructor
: declare
15386 Convention
: Convention_Id
;
15387 Def_Id
: Entity_Id
;
15388 Hom_Id
: Entity_Id
;
15390 This_Formal
: Entity_Id
;
15394 Check_Arg_Count
(1);
15395 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15396 Check_Arg_Is_Local_Name
(Arg1
);
15398 Id
:= Get_Pragma_Arg
(Arg1
);
15399 Find_Program_Unit_Name
(Id
);
15401 -- If we did not find the name, we are done
15403 if Etype
(Id
) = Any_Type
then
15407 -- Check wrong use of pragma in wrong VM target
15409 if VM_Target
= No_VM
then
15412 elsif VM_Target
= CLI_Target
15413 and then Prag_Id
= Pragma_Java_Constructor
15415 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15417 elsif VM_Target
= JVM_Target
15418 and then Prag_Id
= Pragma_CIL_Constructor
15420 Error_Pragma
("must use pragma 'Java_'Constructor");
15424 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15425 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15426 when others => null;
15429 Hom_Id
:= Entity
(Id
);
15431 -- Loop through homonyms
15434 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15436 -- The constructor is required to be a function
15438 if Ekind
(Def_Id
) /= E_Function
then
15439 if VM_Target
= JVM_Target
then
15441 ("pragma% requires function returning a 'Java access "
15445 ("pragma% requires function returning a 'C'I'L access "
15450 -- Check arguments: For tagged type the first formal must be
15451 -- named "this" and its type must be a named access type
15452 -- designating a class-wide tagged type that has convention
15453 -- CIL/Java. The first formal must also have a null default
15454 -- value. For example:
15456 -- type Typ is tagged ...
15457 -- type Ref is access all Typ;
15458 -- pragma Convention (CIL, Typ);
15460 -- function New_Typ (This : Ref) return Ref;
15461 -- function New_Typ (This : Ref; I : Integer) return Ref;
15462 -- pragma Cil_Constructor (New_Typ);
15464 -- Reason: The first formal must NOT be a primitive of the
15467 -- This rule also applies to constructors of delegates used
15468 -- to interface with standard target libraries. For example:
15470 -- type Delegate is access procedure ...
15471 -- pragma Import (CIL, Delegate, ...);
15473 -- function new_Delegate
15474 -- (This : Delegate := null; ... ) return Delegate;
15476 -- For value-types this rule does not apply.
15478 if not Is_Value_Type
(Etype
(Def_Id
)) then
15479 if No
(First_Formal
(Def_Id
)) then
15480 Error_Msg_Name_1
:= Pname
;
15481 Error_Msg_N
("% function must have parameters", Def_Id
);
15485 -- In the JRE library we have several occurrences in which
15486 -- the "this" parameter is not the first formal.
15488 This_Formal
:= First_Formal
(Def_Id
);
15490 -- In the JRE library we have several occurrences in which
15491 -- the "this" parameter is not the first formal. Search for
15494 if VM_Target
= JVM_Target
then
15495 while Present
(This_Formal
)
15496 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15498 Next_Formal
(This_Formal
);
15501 if No
(This_Formal
) then
15502 This_Formal
:= First_Formal
(Def_Id
);
15506 -- Warning: The first parameter should be named "this".
15507 -- We temporarily allow it because we have the following
15508 -- case in the Java runtime (file s-osinte.ads) ???
15510 -- function new_Thread
15511 -- (Self_Id : System.Address) return Thread_Id;
15512 -- pragma Java_Constructor (new_Thread);
15514 if VM_Target
= JVM_Target
15515 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15517 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15521 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15522 Error_Msg_Name_1
:= Pname
;
15524 ("first formal of % function must be named `this`",
15525 Parent
(This_Formal
));
15527 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15528 Error_Msg_Name_1
:= Pname
;
15530 ("first formal of % function must be an access type",
15531 Parameter_Type
(Parent
(This_Formal
)));
15533 -- For delegates the type of the first formal must be a
15534 -- named access-to-subprogram type (see previous example)
15536 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15537 and then Ekind
(Etype
(This_Formal
))
15538 /= E_Access_Subprogram_Type
15540 Error_Msg_Name_1
:= Pname
;
15542 ("first formal of % function must be a named access "
15543 & "to subprogram type",
15544 Parameter_Type
(Parent
(This_Formal
)));
15546 -- Warning: We should reject anonymous access types because
15547 -- the constructor must not be handled as a primitive of the
15548 -- tagged type. We temporarily allow it because this profile
15549 -- is currently generated by cil2ada???
15551 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15552 and then not Ekind_In
(Etype
(This_Formal
),
15554 E_General_Access_Type
,
15555 E_Anonymous_Access_Type
)
15557 Error_Msg_Name_1
:= Pname
;
15559 ("first formal of % function must be a named access "
15560 & "type", Parameter_Type
(Parent
(This_Formal
)));
15562 elsif Atree
.Convention
15563 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15565 Error_Msg_Name_1
:= Pname
;
15567 if Convention
= Convention_Java
then
15569 ("pragma% requires convention 'Cil in designated "
15570 & "type", Parameter_Type
(Parent
(This_Formal
)));
15573 ("pragma% requires convention 'Java in designated "
15574 & "type", Parameter_Type
(Parent
(This_Formal
)));
15577 elsif No
(Expression
(Parent
(This_Formal
)))
15578 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15580 Error_Msg_Name_1
:= Pname
;
15582 ("pragma% requires first formal with default `null`",
15583 Parameter_Type
(Parent
(This_Formal
)));
15587 -- Check result type: the constructor must be a function
15589 -- * a value type (only allowed in the CIL compiler)
15590 -- * an access-to-subprogram type with convention Java/CIL
15591 -- * an access-type designating a type that has convention
15594 if Is_Value_Type
(Etype
(Def_Id
)) then
15597 -- Access-to-subprogram type with convention Java/CIL
15599 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15600 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15601 if Convention
= Convention_Java
then
15603 ("pragma% requires function returning a 'Java "
15604 & "access type", Arg1
);
15606 pragma Assert
(Convention
= Convention_CIL
);
15608 ("pragma% requires function returning a 'C'I'L "
15609 & "access type", Arg1
);
15613 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15614 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15615 E_General_Access_Type
)
15618 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15620 Error_Msg_Name_1
:= Pname
;
15622 if Convention
= Convention_Java
then
15624 ("pragma% requires function returning a named "
15625 & "'Java access type", Arg1
);
15628 ("pragma% requires function returning a named "
15629 & "'C'I'L access type", Arg1
);
15634 Set_Is_Constructor
(Def_Id
);
15635 Set_Convention
(Def_Id
, Convention
);
15636 Set_Is_Imported
(Def_Id
);
15638 exit when From_Aspect_Specification
(N
);
15639 Hom_Id
:= Homonym
(Hom_Id
);
15641 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
15643 end Java_Constructor
;
15645 ----------------------
15646 -- Java_Interface --
15647 ----------------------
15649 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
15651 when Pragma_Java_Interface
=> Java_Interface
: declare
15657 Check_Arg_Count
(1);
15658 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15659 Check_Arg_Is_Local_Name
(Arg1
);
15661 Arg
:= Get_Pragma_Arg
(Arg1
);
15664 if Etype
(Arg
) = Any_Type
then
15668 if not Is_Entity_Name
(Arg
)
15669 or else not Is_Type
(Entity
(Arg
))
15671 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
15674 Typ
:= Underlying_Type
(Entity
(Arg
));
15676 -- For now simply check some of the semantic constraints on the
15677 -- type. This currently leaves out some restrictions on interface
15678 -- types, namely that the parent type must be java.lang.Object.Typ
15679 -- and that all primitives of the type should be declared
15682 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
15684 ("pragma% requires an abstract tagged type", Arg1
);
15686 elsif not Has_Discriminants
(Typ
)
15687 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
15688 /= E_Anonymous_Access_Type
15690 not Is_Class_Wide_Type
15691 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
15694 ("type must have a class-wide access discriminant", Arg1
);
15696 end Java_Interface
;
15702 -- pragma Keep_Names ([On => ] LOCAL_NAME);
15704 when Pragma_Keep_Names
=> Keep_Names
: declare
15709 Check_Arg_Count
(1);
15710 Check_Optional_Identifier
(Arg1
, Name_On
);
15711 Check_Arg_Is_Local_Name
(Arg1
);
15713 Arg
:= Get_Pragma_Arg
(Arg1
);
15716 if Etype
(Arg
) = Any_Type
then
15720 if not Is_Entity_Name
(Arg
)
15721 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
15724 ("pragma% requires a local enumeration type", Arg1
);
15727 Set_Discard_Names
(Entity
(Arg
), False);
15734 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
15736 when Pragma_License
=>
15738 Check_Arg_Count
(1);
15739 Check_No_Identifiers
;
15740 Check_Valid_Configuration_Pragma
;
15741 Check_Arg_Is_Identifier
(Arg1
);
15744 Sind
: constant Source_File_Index
:=
15745 Source_Index
(Current_Sem_Unit
);
15748 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15750 Set_License
(Sind
, GPL
);
15752 when Name_Modified_GPL
=>
15753 Set_License
(Sind
, Modified_GPL
);
15755 when Name_Restricted
=>
15756 Set_License
(Sind
, Restricted
);
15758 when Name_Unrestricted
=>
15759 Set_License
(Sind
, Unrestricted
);
15762 Error_Pragma_Arg
("invalid license name", Arg1
);
15770 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
15772 when Pragma_Link_With
=> Link_With
: declare
15778 if Operating_Mode
= Generate_Code
15779 and then In_Extended_Main_Source_Unit
(N
)
15781 Check_At_Least_N_Arguments
(1);
15782 Check_No_Identifiers
;
15783 Check_Is_In_Decl_Part_Or_Package_Spec
;
15784 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15788 while Present
(Arg
) loop
15789 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
15791 -- Store argument, converting sequences of spaces to a
15792 -- single null character (this is one of the differences
15793 -- in processing between Link_With and Linker_Options).
15795 Arg_Store
: declare
15796 C
: constant Char_Code
:= Get_Char_Code
(' ');
15797 S
: constant String_Id
:=
15798 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
15799 L
: constant Nat
:= String_Length
(S
);
15802 procedure Skip_Spaces
;
15803 -- Advance F past any spaces
15809 procedure Skip_Spaces
is
15811 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
15816 -- Start of processing for Arg_Store
15819 Skip_Spaces
; -- skip leading spaces
15821 -- Loop through characters, changing any embedded
15822 -- sequence of spaces to a single null character (this
15823 -- is how Link_With/Linker_Options differ)
15826 if Get_String_Char
(S
, F
) = C
then
15829 Store_String_Char
(ASCII
.NUL
);
15832 Store_String_Char
(Get_String_Char
(S
, F
));
15840 if Present
(Arg
) then
15841 Store_String_Char
(ASCII
.NUL
);
15845 Store_Linker_Option_String
(End_String
);
15853 -- pragma Linker_Alias (
15854 -- [Entity =>] LOCAL_NAME
15855 -- [Target =>] static_string_EXPRESSION);
15857 when Pragma_Linker_Alias
=>
15859 Check_Arg_Order
((Name_Entity
, Name_Target
));
15860 Check_Arg_Count
(2);
15861 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15862 Check_Optional_Identifier
(Arg2
, Name_Target
);
15863 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
15864 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15866 -- The only processing required is to link this item on to the
15867 -- list of rep items for the given entity. This is accomplished
15868 -- by the call to Rep_Item_Too_Late (when no error is detected
15869 -- and False is returned).
15871 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
15874 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
15877 ------------------------
15878 -- Linker_Constructor --
15879 ------------------------
15881 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
15883 -- Code is shared with Linker_Destructor
15885 -----------------------
15886 -- Linker_Destructor --
15887 -----------------------
15889 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
15891 when Pragma_Linker_Constructor |
15892 Pragma_Linker_Destructor
=>
15893 Linker_Constructor
: declare
15899 Check_Arg_Count
(1);
15900 Check_No_Identifiers
;
15901 Check_Arg_Is_Local_Name
(Arg1
);
15902 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
15904 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
15906 if not Is_Library_Level_Entity
(Proc
) then
15908 ("argument for pragma% must be library level entity", Arg1
);
15911 -- The only processing required is to link this item on to the
15912 -- list of rep items for the given entity. This is accomplished
15913 -- by the call to Rep_Item_Too_Late (when no error is detected
15914 -- and False is returned).
15916 if Rep_Item_Too_Late
(Proc
, N
) then
15919 Set_Has_Gigi_Rep_Item
(Proc
);
15921 end Linker_Constructor
;
15923 --------------------
15924 -- Linker_Options --
15925 --------------------
15927 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
15929 when Pragma_Linker_Options
=> Linker_Options
: declare
15933 Check_Ada_83_Warning
;
15934 Check_No_Identifiers
;
15935 Check_Arg_Count
(1);
15936 Check_Is_In_Decl_Part_Or_Package_Spec
;
15937 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15938 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
15941 while Present
(Arg
) loop
15942 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
15943 Store_String_Char
(ASCII
.NUL
);
15945 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
15949 if Operating_Mode
= Generate_Code
15950 and then In_Extended_Main_Source_Unit
(N
)
15952 Store_Linker_Option_String
(End_String
);
15954 end Linker_Options
;
15956 --------------------
15957 -- Linker_Section --
15958 --------------------
15960 -- pragma Linker_Section (
15961 -- [Entity =>] LOCAL_NAME
15962 -- [Section =>] static_string_EXPRESSION);
15964 when Pragma_Linker_Section
=> Linker_Section
: declare
15970 Check_Arg_Order
((Name_Entity
, Name_Section
));
15971 Check_Arg_Count
(2);
15972 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15973 Check_Optional_Identifier
(Arg2
, Name_Section
);
15974 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
15975 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15977 -- Check kind of entity
15979 Arg
:= Get_Pragma_Arg
(Arg1
);
15980 Ent
:= Entity
(Arg
);
15982 case Ekind
(Ent
) is
15984 -- Objects (constants and variables) and types. For these cases
15985 -- all we need to do is to set the Linker_Section_pragma field.
15987 when E_Constant | E_Variable | Type_Kind
=>
15988 Set_Linker_Section_Pragma
(Ent
, N
);
15992 when Subprogram_Kind
=>
15994 -- Aspect case, entity already set
15996 if From_Aspect_Specification
(N
) then
15997 Set_Linker_Section_Pragma
15998 (Entity
(Corresponding_Aspect
(N
)), N
);
16000 -- Pragma case, we must climb the homonym chain, but skip
16001 -- any for which the linker section is already set.
16005 if No
(Linker_Section_Pragma
(Ent
)) then
16006 Set_Linker_Section_Pragma
(Ent
, N
);
16009 Ent
:= Homonym
(Ent
);
16011 or else Scope
(Ent
) /= Current_Scope
;
16015 -- All other cases are illegal
16019 ("pragma% applies only to objects, subprograms, and types",
16022 end Linker_Section
;
16028 -- pragma List (On | Off)
16030 -- There is nothing to do here, since we did all the processing for
16031 -- this pragma in Par.Prag (so that it works properly even in syntax
16034 when Pragma_List
=>
16041 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16043 when Pragma_Lock_Free
=> Lock_Free
: declare
16044 P
: constant Node_Id
:= Parent
(N
);
16050 Check_No_Identifiers
;
16051 Check_At_Most_N_Arguments
(1);
16053 -- Protected definition case
16055 if Nkind
(P
) = N_Protected_Definition
then
16056 Ent
:= Defining_Identifier
(Parent
(P
));
16060 if Arg_Count
= 1 then
16061 Arg
:= Get_Pragma_Arg
(Arg1
);
16062 Val
:= Is_True
(Static_Boolean
(Arg
));
16064 -- No arguments (expression is considered to be True)
16070 -- Check duplicate pragma before we chain the pragma in the Rep
16071 -- Item chain of Ent.
16073 Check_Duplicate_Pragma
(Ent
);
16074 Record_Rep_Item
(Ent
, N
);
16075 Set_Uses_Lock_Free
(Ent
, Val
);
16077 -- Anything else is incorrect placement
16084 --------------------
16085 -- Locking_Policy --
16086 --------------------
16088 -- pragma Locking_Policy (policy_IDENTIFIER);
16090 when Pragma_Locking_Policy
=> declare
16091 subtype LP_Range
is Name_Id
16092 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16097 Check_Ada_83_Warning
;
16098 Check_Arg_Count
(1);
16099 Check_No_Identifiers
;
16100 Check_Arg_Is_Locking_Policy
(Arg1
);
16101 Check_Valid_Configuration_Pragma
;
16102 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16105 when Name_Ceiling_Locking
=>
16107 when Name_Inheritance_Locking
=>
16109 when Name_Concurrent_Readers_Locking
=>
16113 if Locking_Policy
/= ' '
16114 and then Locking_Policy
/= LP
16116 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16117 Error_Pragma
("locking policy incompatible with policy#");
16119 -- Set new policy, but always preserve System_Location since we
16120 -- like the error message with the run time name.
16123 Locking_Policy
:= LP
;
16125 if Locking_Policy_Sloc
/= System_Location
then
16126 Locking_Policy_Sloc
:= Loc
;
16131 -------------------
16132 -- Loop_Optimize --
16133 -------------------
16135 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16137 -- OPTIMIZATION_HINT ::=
16138 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16140 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16145 Check_At_Least_N_Arguments
(1);
16146 Check_No_Identifiers
;
16148 Hint
:= First
(Pragma_Argument_Associations
(N
));
16149 while Present
(Hint
) loop
16150 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16158 Check_Loop_Pragma_Placement
;
16165 -- pragma Loop_Variant
16166 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16168 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16170 -- CHANGE_DIRECTION ::= Increases | Decreases
16172 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16177 Check_At_Least_N_Arguments
(1);
16178 Check_Loop_Pragma_Placement
;
16180 -- Process all increasing / decreasing expressions
16182 Variant
:= First
(Pragma_Argument_Associations
(N
));
16183 while Present
(Variant
) loop
16184 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16187 Error_Pragma_Arg
("wrong change modifier", Variant
);
16190 Preanalyze_Assert_Expression
16191 (Expression
(Variant
), Any_Discrete
);
16197 -----------------------
16198 -- Machine_Attribute --
16199 -----------------------
16201 -- pragma Machine_Attribute (
16202 -- [Entity =>] LOCAL_NAME,
16203 -- [Attribute_Name =>] static_string_EXPRESSION
16204 -- [, [Info =>] static_EXPRESSION] );
16206 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16207 Def_Id
: Entity_Id
;
16211 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16213 if Arg_Count
= 3 then
16214 Check_Optional_Identifier
(Arg3
, Name_Info
);
16215 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16217 Check_Arg_Count
(2);
16220 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16221 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16222 Check_Arg_Is_Local_Name
(Arg1
);
16223 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16224 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16226 if Is_Access_Type
(Def_Id
) then
16227 Def_Id
:= Designated_Type
(Def_Id
);
16230 if Rep_Item_Too_Early
(Def_Id
, N
) then
16234 Def_Id
:= Underlying_Type
(Def_Id
);
16236 -- The only processing required is to link this item on to the
16237 -- list of rep items for the given entity. This is accomplished
16238 -- by the call to Rep_Item_Too_Late (when no error is detected
16239 -- and False is returned).
16241 if Rep_Item_Too_Late
(Def_Id
, N
) then
16244 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16246 end Machine_Attribute
;
16253 -- (MAIN_OPTION [, MAIN_OPTION]);
16256 -- [STACK_SIZE =>] static_integer_EXPRESSION
16257 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16258 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16260 when Pragma_Main
=> Main
: declare
16261 Args
: Args_List
(1 .. 3);
16262 Names
: constant Name_List
(1 .. 3) := (
16264 Name_Task_Stack_Size_Default
,
16265 Name_Time_Slicing_Enabled
);
16271 Gather_Associations
(Names
, Args
);
16273 for J
in 1 .. 2 loop
16274 if Present
(Args
(J
)) then
16275 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16279 if Present
(Args
(3)) then
16280 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16284 while Present
(Nod
) loop
16285 if Nkind
(Nod
) = N_Pragma
16286 and then Pragma_Name
(Nod
) = Name_Main
16288 Error_Msg_Name_1
:= Pname
;
16289 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16300 -- pragma Main_Storage
16301 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16303 -- MAIN_STORAGE_OPTION ::=
16304 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16305 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16307 when Pragma_Main_Storage
=> Main_Storage
: declare
16308 Args
: Args_List
(1 .. 2);
16309 Names
: constant Name_List
(1 .. 2) := (
16310 Name_Working_Storage
,
16317 Gather_Associations
(Names
, Args
);
16319 for J
in 1 .. 2 loop
16320 if Present
(Args
(J
)) then
16321 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16325 Check_In_Main_Program
;
16328 while Present
(Nod
) loop
16329 if Nkind
(Nod
) = N_Pragma
16330 and then Pragma_Name
(Nod
) = Name_Main_Storage
16332 Error_Msg_Name_1
:= Pname
;
16333 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16344 -- pragma Memory_Size (NUMERIC_LITERAL)
16346 when Pragma_Memory_Size
=>
16349 -- Memory size is simply ignored
16351 Check_No_Identifiers
;
16352 Check_Arg_Count
(1);
16353 Check_Arg_Is_Integer_Literal
(Arg1
);
16361 -- The only correct use of this pragma is on its own in a file, in
16362 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16363 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16364 -- check for a file containing nothing but a No_Body pragma). If we
16365 -- attempt to process it during normal semantics processing, it means
16366 -- it was misplaced.
16368 when Pragma_No_Body
=>
16372 -----------------------------
16373 -- No_Elaboration_Code_All --
16374 -----------------------------
16376 -- pragma No_Elaboration_Code_All;
16378 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16381 Check_Valid_Library_Unit_Pragma
;
16383 if Nkind
(N
) = N_Null_Statement
then
16387 -- Must appear for a spec
16389 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16390 N_Package_Declaration
,
16391 N_Subprogram_Declaration
)
16395 ("pragma% can only occur for package "
16396 & "or subprogram spec"));
16399 -- Set flag in unit table
16401 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16403 -- Set restriction No_Elaboration_Code, including adding it to the
16404 -- set of configuration restrictions so it will apply to all units
16405 -- in the extended main source.
16407 Set_Restriction
(No_Elaboration_Code
, N
);
16408 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16410 -- If in main extended unit, activate transitive with test
16412 if In_Extended_Main_Source_Unit
(N
) then
16413 Opt
.No_Elab_Code_All_Pragma
:= N
;
16421 -- pragma No_Inline ( NAME {, NAME} );
16423 when Pragma_No_Inline
=>
16425 Process_Inline
(Suppressed
);
16431 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16433 when Pragma_No_Return
=> No_Return
: declare
16441 Check_At_Least_N_Arguments
(1);
16443 -- Loop through arguments of pragma
16446 while Present
(Arg
) loop
16447 Check_Arg_Is_Local_Name
(Arg
);
16448 Id
:= Get_Pragma_Arg
(Arg
);
16451 if not Is_Entity_Name
(Id
) then
16452 Error_Pragma_Arg
("entity name required", Arg
);
16455 if Etype
(Id
) = Any_Type
then
16459 -- Loop to find matching procedures
16464 and then Scope
(E
) = Current_Scope
16466 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16469 -- Set flag on any alias as well
16471 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16472 Set_No_Return
(Alias
(E
));
16478 exit when From_Aspect_Specification
(N
);
16482 -- If entity in not in current scope it may be the enclosing
16483 -- suprogram body to which the aspect applies.
16486 if Entity
(Id
) = Current_Scope
16487 and then From_Aspect_Specification
(N
)
16489 Set_No_Return
(Entity
(Id
));
16491 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16503 -- pragma No_Run_Time;
16505 -- Note: this pragma is retained for backwards compatibility. See
16506 -- body of Rtsfind for full details on its handling.
16508 when Pragma_No_Run_Time
=>
16510 Check_Valid_Configuration_Pragma
;
16511 Check_Arg_Count
(0);
16513 No_Run_Time_Mode
:= True;
16514 Configurable_Run_Time_Mode
:= True;
16516 -- Set Duration to 32 bits if word size is 32
16518 if Ttypes
.System_Word_Size
= 32 then
16519 Duration_32_Bits_On_Target
:= True;
16522 -- Set appropriate restrictions
16524 Set_Restriction
(No_Finalization
, N
);
16525 Set_Restriction
(No_Exception_Handlers
, N
);
16526 Set_Restriction
(Max_Tasks
, N
, 0);
16527 Set_Restriction
(No_Tasking
, N
);
16529 ------------------------
16530 -- No_Strict_Aliasing --
16531 ------------------------
16533 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16535 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16540 Check_At_Most_N_Arguments
(1);
16542 if Arg_Count
= 0 then
16543 Check_Valid_Configuration_Pragma
;
16544 Opt
.No_Strict_Aliasing
:= True;
16547 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16548 Check_Arg_Is_Local_Name
(Arg1
);
16549 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16551 if E_Id
= Any_Type
then
16553 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16554 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16557 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16559 end No_Strict_Aliasing
;
16561 -----------------------
16562 -- Normalize_Scalars --
16563 -----------------------
16565 -- pragma Normalize_Scalars;
16567 when Pragma_Normalize_Scalars
=>
16568 Check_Ada_83_Warning
;
16569 Check_Arg_Count
(0);
16570 Check_Valid_Configuration_Pragma
;
16572 -- Normalize_Scalars creates false positives in CodePeer, and
16573 -- incorrect negative results in GNATprove mode, so ignore this
16574 -- pragma in these modes.
16576 if not (CodePeer_Mode
or GNATprove_Mode
) then
16577 Normalize_Scalars
:= True;
16578 Init_Or_Norm_Scalars
:= True;
16585 -- pragma Obsolescent;
16587 -- pragma Obsolescent (
16588 -- [Message =>] static_string_EXPRESSION
16589 -- [,[Version =>] Ada_05]]);
16591 -- pragma Obsolescent (
16592 -- [Entity =>] NAME
16593 -- [,[Message =>] static_string_EXPRESSION
16594 -- [,[Version =>] Ada_05]] );
16596 when Pragma_Obsolescent
=> Obsolescent
: declare
16600 procedure Set_Obsolescent
(E
: Entity_Id
);
16601 -- Given an entity Ent, mark it as obsolescent if appropriate
16603 ---------------------
16604 -- Set_Obsolescent --
16605 ---------------------
16607 procedure Set_Obsolescent
(E
: Entity_Id
) is
16616 -- Entity name was given
16618 if Present
(Ename
) then
16620 -- If entity name matches, we are fine. Save entity in
16621 -- pragma argument, for ASIS use.
16623 if Chars
(Ename
) = Chars
(Ent
) then
16624 Set_Entity
(Ename
, Ent
);
16625 Generate_Reference
(Ent
, Ename
);
16627 -- If entity name does not match, only possibility is an
16628 -- enumeration literal from an enumeration type declaration.
16630 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
16632 ("pragma % entity name does not match declaration");
16635 Ent
:= First_Literal
(E
);
16639 ("pragma % entity name does not match any "
16640 & "enumeration literal");
16642 elsif Chars
(Ent
) = Chars
(Ename
) then
16643 Set_Entity
(Ename
, Ent
);
16644 Generate_Reference
(Ent
, Ename
);
16648 Ent
:= Next_Literal
(Ent
);
16654 -- Ent points to entity to be marked
16656 if Arg_Count
>= 1 then
16658 -- Deal with static string argument
16660 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16661 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
16663 for J
in 1 .. String_Length
(S
) loop
16664 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
16666 ("pragma% argument does not allow wide characters",
16671 Obsolescent_Warnings
.Append
16672 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
16674 -- Check for Ada_05 parameter
16676 if Arg_Count
/= 1 then
16677 Check_Arg_Count
(2);
16680 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
16683 Check_Arg_Is_Identifier
(Argx
);
16685 if Chars
(Argx
) /= Name_Ada_05
then
16686 Error_Msg_Name_2
:= Name_Ada_05
;
16688 ("only allowed argument for pragma% is %", Argx
);
16691 if Ada_Version_Explicit
< Ada_2005
16692 or else not Warn_On_Ada_2005_Compatibility
16700 -- Set flag if pragma active
16703 Set_Is_Obsolescent
(Ent
);
16707 end Set_Obsolescent
;
16709 -- Start of processing for pragma Obsolescent
16714 Check_At_Most_N_Arguments
(3);
16716 -- See if first argument specifies an entity name
16720 (Chars
(Arg1
) = Name_Entity
16722 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
16724 N_Operator_Symbol
))
16726 Ename
:= Get_Pragma_Arg
(Arg1
);
16728 -- Eliminate first argument, so we can share processing
16732 Arg_Count
:= Arg_Count
- 1;
16734 -- No Entity name argument given
16740 if Arg_Count
>= 1 then
16741 Check_Optional_Identifier
(Arg1
, Name_Message
);
16743 if Arg_Count
= 2 then
16744 Check_Optional_Identifier
(Arg2
, Name_Version
);
16748 -- Get immediately preceding declaration
16751 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
16755 -- Cases where we do not follow anything other than another pragma
16759 -- First case: library level compilation unit declaration with
16760 -- the pragma immediately following the declaration.
16762 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
16764 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
16767 -- Case 2: library unit placement for package
16771 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
16773 if Is_Package_Or_Generic_Package
(Ent
) then
16774 Set_Obsolescent
(Ent
);
16780 -- Cases where we must follow a declaration
16783 if Nkind
(Decl
) not in N_Declaration
16784 and then Nkind
(Decl
) not in N_Later_Decl_Item
16785 and then Nkind
(Decl
) not in N_Generic_Declaration
16786 and then Nkind
(Decl
) not in N_Renaming_Declaration
16789 ("pragma% misplaced, "
16790 & "must immediately follow a declaration");
16793 Set_Obsolescent
(Defining_Entity
(Decl
));
16803 -- pragma Optimize (Time | Space | Off);
16805 -- The actual check for optimize is done in Gigi. Note that this
16806 -- pragma does not actually change the optimization setting, it
16807 -- simply checks that it is consistent with the pragma.
16809 when Pragma_Optimize
=>
16810 Check_No_Identifiers
;
16811 Check_Arg_Count
(1);
16812 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
16814 ------------------------
16815 -- Optimize_Alignment --
16816 ------------------------
16818 -- pragma Optimize_Alignment (Time | Space | Off);
16820 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
16822 Check_No_Identifiers
;
16823 Check_Arg_Count
(1);
16824 Check_Valid_Configuration_Pragma
;
16827 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
16831 Opt
.Optimize_Alignment
:= 'T';
16833 Opt
.Optimize_Alignment
:= 'S';
16835 Opt
.Optimize_Alignment
:= 'O';
16837 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
16841 -- Set indication that mode is set locally. If we are in fact in a
16842 -- configuration pragma file, this setting is harmless since the
16843 -- switch will get reset anyway at the start of each unit.
16845 Optimize_Alignment_Local
:= True;
16846 end Optimize_Alignment
;
16852 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
16854 when Pragma_Ordered
=> Ordered
: declare
16855 Assoc
: constant Node_Id
:= Arg1
;
16861 Check_No_Identifiers
;
16862 Check_Arg_Count
(1);
16863 Check_Arg_Is_Local_Name
(Arg1
);
16865 Type_Id
:= Get_Pragma_Arg
(Assoc
);
16866 Find_Type
(Type_Id
);
16867 Typ
:= Entity
(Type_Id
);
16869 if Typ
= Any_Type
then
16872 Typ
:= Underlying_Type
(Typ
);
16875 if not Is_Enumeration_Type
(Typ
) then
16876 Error_Pragma
("pragma% must specify enumeration type");
16879 Check_First_Subtype
(Arg1
);
16880 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
16883 -------------------
16884 -- Overflow_Mode --
16885 -------------------
16887 -- pragma Overflow_Mode
16888 -- ([General => ] MODE [, [Assertions => ] MODE]);
16890 -- MODE := STRICT | MINIMIZED | ELIMINATED
16892 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
16893 -- since System.Bignums makes this assumption. This is true of nearly
16894 -- all (all?) targets.
16896 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
16897 function Get_Overflow_Mode
16899 Arg
: Node_Id
) return Overflow_Mode_Type
;
16900 -- Function to process one pragma argument, Arg. If an identifier
16901 -- is present, it must be Name. Mode type is returned if a valid
16902 -- argument exists, otherwise an error is signalled.
16904 -----------------------
16905 -- Get_Overflow_Mode --
16906 -----------------------
16908 function Get_Overflow_Mode
16910 Arg
: Node_Id
) return Overflow_Mode_Type
16912 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
16915 Check_Optional_Identifier
(Arg
, Name
);
16916 Check_Arg_Is_Identifier
(Argx
);
16918 if Chars
(Argx
) = Name_Strict
then
16921 elsif Chars
(Argx
) = Name_Minimized
then
16924 elsif Chars
(Argx
) = Name_Eliminated
then
16925 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
16927 ("Eliminated not implemented on this target", Argx
);
16933 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
16935 end Get_Overflow_Mode
;
16937 -- Start of processing for Overflow_Mode
16941 Check_At_Least_N_Arguments
(1);
16942 Check_At_Most_N_Arguments
(2);
16944 -- Process first argument
16946 Scope_Suppress
.Overflow_Mode_General
:=
16947 Get_Overflow_Mode
(Name_General
, Arg1
);
16949 -- Case of only one argument
16951 if Arg_Count
= 1 then
16952 Scope_Suppress
.Overflow_Mode_Assertions
:=
16953 Scope_Suppress
.Overflow_Mode_General
;
16955 -- Case of two arguments present
16958 Scope_Suppress
.Overflow_Mode_Assertions
:=
16959 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
16963 --------------------------
16964 -- Overriding Renamings --
16965 --------------------------
16967 -- pragma Overriding_Renamings;
16969 when Pragma_Overriding_Renamings
=>
16971 Check_Arg_Count
(0);
16972 Check_Valid_Configuration_Pragma
;
16973 Overriding_Renamings
:= True;
16979 -- pragma Pack (first_subtype_LOCAL_NAME);
16981 when Pragma_Pack
=> Pack
: declare
16982 Assoc
: constant Node_Id
:= Arg1
;
16986 Ignore
: Boolean := False;
16989 Check_No_Identifiers
;
16990 Check_Arg_Count
(1);
16991 Check_Arg_Is_Local_Name
(Arg1
);
16992 Type_Id
:= Get_Pragma_Arg
(Assoc
);
16994 if not Is_Entity_Name
(Type_Id
)
16995 or else not Is_Type
(Entity
(Type_Id
))
16998 ("argument for pragma% must be type or subtype", Arg1
);
17001 Find_Type
(Type_Id
);
17002 Typ
:= Entity
(Type_Id
);
17005 or else Rep_Item_Too_Early
(Typ
, N
)
17009 Typ
:= Underlying_Type
(Typ
);
17012 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17013 Error_Pragma
("pragma% must specify array or record type");
17016 Check_First_Subtype
(Arg1
);
17017 Check_Duplicate_Pragma
(Typ
);
17021 if Is_Array_Type
(Typ
) then
17022 Ctyp
:= Component_Type
(Typ
);
17024 -- Ignore pack that does nothing
17026 if Known_Static_Esize
(Ctyp
)
17027 and then Known_Static_RM_Size
(Ctyp
)
17028 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17029 and then Addressable
(Esize
(Ctyp
))
17034 -- Process OK pragma Pack. Note that if there is a separate
17035 -- component clause present, the Pack will be cancelled. This
17036 -- processing is in Freeze.
17038 if not Rep_Item_Too_Late
(Typ
, N
) then
17040 -- In CodePeer mode, we do not need complex front-end
17041 -- expansions related to pragma Pack, so disable handling
17044 if CodePeer_Mode
then
17047 -- Don't attempt any packing for VM targets. We possibly
17048 -- could deal with some cases of array bit-packing, but we
17049 -- don't bother, since this is not a typical kind of
17050 -- representation in the VM context anyway (and would not
17051 -- for example work nicely with the debugger).
17053 elsif VM_Target
/= No_VM
then
17054 if not GNAT_Mode
then
17056 ("??pragma% ignored in this configuration");
17059 -- Normal case where we do the pack action
17063 Set_Is_Packed
(Base_Type
(Typ
));
17064 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17067 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17071 -- For record types, the pack is always effective
17073 else pragma Assert
(Is_Record_Type
(Typ
));
17074 if not Rep_Item_Too_Late
(Typ
, N
) then
17076 -- Ignore pack request with warning in VM mode (skip warning
17077 -- if we are compiling GNAT run time library).
17079 if VM_Target
/= No_VM
then
17080 if not GNAT_Mode
then
17082 ("??pragma% ignored in this configuration");
17085 -- Normal case of pack request active
17088 Set_Is_Packed
(Base_Type
(Typ
));
17089 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17090 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17102 -- There is nothing to do here, since we did all the processing for
17103 -- this pragma in Par.Prag (so that it works properly even in syntax
17106 when Pragma_Page
=>
17113 -- pragma Part_Of (ABSTRACT_STATE);
17115 -- ABSTRACT_STATE ::= NAME
17117 when Pragma_Part_Of
=> Part_Of
: declare
17118 procedure Propagate_Part_Of
17119 (Pack_Id
: Entity_Id
;
17120 State_Id
: Entity_Id
;
17121 Instance
: Node_Id
);
17122 -- Propagate the Part_Of indicator to all abstract states and
17123 -- variables declared in the visible state space of a package
17124 -- denoted by Pack_Id. State_Id is the encapsulating state.
17125 -- Instance is the package instantiation node.
17127 -----------------------
17128 -- Propagate_Part_Of --
17129 -----------------------
17131 procedure Propagate_Part_Of
17132 (Pack_Id
: Entity_Id
;
17133 State_Id
: Entity_Id
;
17134 Instance
: Node_Id
)
17136 Has_Item
: Boolean := False;
17137 -- Flag set when the visible state space contains at least one
17138 -- abstract state or variable.
17140 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17141 -- Propagate the Part_Of indicator to all abstract states and
17142 -- variables declared in the visible state space of a package
17143 -- denoted by Pack_Id.
17145 -----------------------
17146 -- Propagate_Part_Of --
17147 -----------------------
17149 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17150 Item_Id
: Entity_Id
;
17153 -- Traverse the entity chain of the package and set relevant
17154 -- attributes of abstract states and variables declared in
17155 -- the visible state space of the package.
17157 Item_Id
:= First_Entity
(Pack_Id
);
17158 while Present
(Item_Id
)
17159 and then not In_Private_Part
(Item_Id
)
17161 -- Do not consider internally generated items
17163 if not Comes_From_Source
(Item_Id
) then
17166 -- The Part_Of indicator turns an abstract state or
17167 -- variable into a constituent of the encapsulating
17170 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17175 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17176 Set_Encapsulating_State
(Item_Id
, State_Id
);
17178 -- Recursively handle nested packages and instantiations
17180 elsif Ekind
(Item_Id
) = E_Package
then
17181 Propagate_Part_Of
(Item_Id
);
17184 Next_Entity
(Item_Id
);
17186 end Propagate_Part_Of
;
17188 -- Start of processing for Propagate_Part_Of
17191 Propagate_Part_Of
(Pack_Id
);
17193 -- Detect a package instantiation that is subject to a Part_Of
17194 -- indicator, but has no visible state.
17196 if not Has_Item
then
17198 ("package instantiation & has Part_Of indicator but "
17199 & "lacks visible state", Instance
, Pack_Id
);
17201 end Propagate_Part_Of
;
17205 Item_Id
: Entity_Id
;
17208 State_Id
: Entity_Id
;
17211 -- Start of processing for Part_Of
17215 Check_Arg_Count
(1);
17217 -- Ensure the proper placement of the pragma. Part_Of must appear
17218 -- on a variable declaration or a package instantiation.
17221 while Present
(Stmt
) loop
17223 -- Skip prior pragmas, but check for duplicates
17225 if Nkind
(Stmt
) = N_Pragma
then
17226 if Pragma_Name
(Stmt
) = Pname
then
17227 Error_Msg_Name_1
:= Pname
;
17228 Error_Msg_Sloc
:= Sloc
(Stmt
);
17229 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17232 -- Skip internally generated code
17234 elsif not Comes_From_Source
(Stmt
) then
17237 -- The pragma applies to an object declaration (possibly a
17238 -- variable) or a package instantiation. Stop the traversal
17239 -- and continue the analysis.
17241 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17242 N_Package_Instantiation
)
17246 -- The pragma does not apply to a legal construct, issue an
17247 -- error and stop the analysis.
17254 Stmt
:= Prev
(Stmt
);
17257 -- When the context is an object declaration, ensure that we are
17258 -- dealing with a variable.
17260 if Nkind
(Stmt
) = N_Object_Declaration
17261 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17263 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17267 -- Extract the entity of the related object declaration or package
17268 -- instantiation. In the case of the instantiation, use the entity
17269 -- of the instance spec.
17271 if Nkind
(Stmt
) = N_Package_Instantiation
then
17272 Stmt
:= Instance_Spec
(Stmt
);
17275 Item_Id
:= Defining_Entity
(Stmt
);
17276 State
:= Get_Pragma_Arg
(Arg1
);
17278 -- Detect any discrepancies between the placement of the object
17279 -- or package instantiation with respect to state space and the
17280 -- encapsulating state.
17283 (Item_Id
=> Item_Id
,
17289 State_Id
:= Entity
(State
);
17291 -- Add the pragma to the contract of the item. This aids with
17292 -- the detection of a missing but required Part_Of indicator.
17294 Add_Contract_Item
(N
, Item_Id
);
17296 -- The Part_Of indicator turns a variable into a constituent
17297 -- of the encapsulating state.
17299 if Ekind
(Item_Id
) = E_Variable
then
17300 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17301 Set_Encapsulating_State
(Item_Id
, State_Id
);
17303 -- Propagate the Part_Of indicator to the visible state space
17304 -- of the package instantiation.
17308 (Pack_Id
=> Item_Id
,
17309 State_Id
=> State_Id
,
17315 ----------------------------------
17316 -- Partition_Elaboration_Policy --
17317 ----------------------------------
17319 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17321 when Pragma_Partition_Elaboration_Policy
=> declare
17322 subtype PEP_Range
is Name_Id
17323 range First_Partition_Elaboration_Policy_Name
17324 .. Last_Partition_Elaboration_Policy_Name
;
17325 PEP_Val
: PEP_Range
;
17330 Check_Arg_Count
(1);
17331 Check_No_Identifiers
;
17332 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17333 Check_Valid_Configuration_Pragma
;
17334 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17337 when Name_Concurrent
=>
17339 when Name_Sequential
=>
17343 if Partition_Elaboration_Policy
/= ' '
17344 and then Partition_Elaboration_Policy
/= PEP
17346 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17348 ("partition elaboration policy incompatible with policy#");
17350 -- Set new policy, but always preserve System_Location since we
17351 -- like the error message with the run time name.
17354 Partition_Elaboration_Policy
:= PEP
;
17356 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17357 Partition_Elaboration_Policy_Sloc
:= Loc
;
17366 -- pragma Passive [(PASSIVE_FORM)];
17368 -- PASSIVE_FORM ::= Semaphore | No
17370 when Pragma_Passive
=>
17373 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17374 Error_Pragma
("pragma% must be within task definition");
17377 if Arg_Count
/= 0 then
17378 Check_Arg_Count
(1);
17379 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17382 ----------------------------------
17383 -- Preelaborable_Initialization --
17384 ----------------------------------
17386 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17388 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17393 Check_Arg_Count
(1);
17394 Check_No_Identifiers
;
17395 Check_Arg_Is_Identifier
(Arg1
);
17396 Check_Arg_Is_Local_Name
(Arg1
);
17397 Check_First_Subtype
(Arg1
);
17398 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17400 -- The pragma may come from an aspect on a private declaration,
17401 -- even if the freeze point at which this is analyzed in the
17402 -- private part after the full view.
17404 if Has_Private_Declaration
(Ent
)
17405 and then From_Aspect_Specification
(N
)
17409 elsif Is_Private_Type
(Ent
)
17410 or else Is_Protected_Type
(Ent
)
17411 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17417 ("pragma % can only be applied to private, formal derived or "
17418 & "protected type",
17422 -- Give an error if the pragma is applied to a protected type that
17423 -- does not qualify (due to having entries, or due to components
17424 -- that do not qualify).
17426 if Is_Protected_Type
(Ent
)
17427 and then not Has_Preelaborable_Initialization
(Ent
)
17430 ("protected type & does not have preelaborable "
17431 & "initialization", Ent
);
17433 -- Otherwise mark the type as definitely having preelaborable
17437 Set_Known_To_Have_Preelab_Init
(Ent
);
17440 if Has_Pragma_Preelab_Init
(Ent
)
17441 and then Warn_On_Redundant_Constructs
17443 Error_Pragma
("?r?duplicate pragma%!");
17445 Set_Has_Pragma_Preelab_Init
(Ent
);
17449 --------------------
17450 -- Persistent_BSS --
17451 --------------------
17453 -- pragma Persistent_BSS [(object_NAME)];
17455 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17462 Check_At_Most_N_Arguments
(1);
17464 -- Case of application to specific object (one argument)
17466 if Arg_Count
= 1 then
17467 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17469 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17471 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17474 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17477 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17478 Decl
:= Parent
(Ent
);
17480 -- Check for duplication before inserting in list of
17481 -- representation items.
17483 Check_Duplicate_Pragma
(Ent
);
17485 if Rep_Item_Too_Late
(Ent
, N
) then
17489 if Present
(Expression
(Decl
)) then
17491 ("object for pragma% cannot have initialization", Arg1
);
17494 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17496 ("object type for pragma% is not potentially persistent",
17501 Make_Linker_Section_Pragma
17502 (Ent
, Sloc
(N
), ".persistent.bss");
17503 Insert_After
(N
, Prag
);
17506 -- Case of use as configuration pragma with no arguments
17509 Check_Valid_Configuration_Pragma
;
17510 Persistent_BSS_Mode
:= True;
17512 end Persistent_BSS
;
17518 -- pragma Polling (ON | OFF);
17520 when Pragma_Polling
=>
17522 Check_Arg_Count
(1);
17523 Check_No_Identifiers
;
17524 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17525 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17531 -- pragma Post (Boolean_EXPRESSION);
17532 -- pragma Post_Class (Boolean_EXPRESSION);
17534 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
17535 PC_Pragma
: Node_Id
;
17539 Check_Arg_Count
(1);
17540 Check_No_Identifiers
;
17543 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
17544 -- flag Class_Present to True for the Post_Class case.
17546 Set_Class_Present
(N
, Prag_Id
= Pragma_Post_Class
);
17547 PC_Pragma
:= New_Copy
(N
);
17548 Set_Pragma_Identifier
17549 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
17550 Rewrite
(N
, PC_Pragma
);
17551 Set_Analyzed
(N
, False);
17555 -------------------
17556 -- Postcondition --
17557 -------------------
17559 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17560 -- [,[Message =>] String_EXPRESSION]);
17562 when Pragma_Postcondition
=> Postcondition
: declare
17567 Check_At_Least_N_Arguments
(1);
17568 Check_At_Most_N_Arguments
(2);
17569 Check_Optional_Identifier
(Arg1
, Name_Check
);
17571 -- Verify the proper placement of the pragma. The remainder of the
17572 -- processing is found in Sem_Ch6/Sem_Ch7.
17574 Check_Precondition_Postcondition
(In_Body
);
17576 -- When the pragma is a source construct appearing inside a body,
17577 -- preanalyze the boolean_expression to detect illegal forward
17581 -- pragma Postcondition (X'Old ...);
17584 if Comes_From_Source
(N
) and then In_Body
then
17585 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
17593 -- pragma Pre (Boolean_EXPRESSION);
17594 -- pragma Pre_Class (Boolean_EXPRESSION);
17596 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
17597 PC_Pragma
: Node_Id
;
17601 Check_Arg_Count
(1);
17602 Check_No_Identifiers
;
17605 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
17606 -- flag Class_Present to True for the Pre_Class case.
17608 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
17609 PC_Pragma
:= New_Copy
(N
);
17610 Set_Pragma_Identifier
17611 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
17612 Rewrite
(N
, PC_Pragma
);
17613 Set_Analyzed
(N
, False);
17621 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
17622 -- [,[Message =>] String_EXPRESSION]);
17624 when Pragma_Precondition
=> Precondition
: declare
17629 Check_At_Least_N_Arguments
(1);
17630 Check_At_Most_N_Arguments
(2);
17631 Check_Optional_Identifier
(Arg1
, Name_Check
);
17632 Check_Precondition_Postcondition
(In_Body
);
17634 -- If in spec, nothing more to do. If in body, then we convert
17635 -- the pragma to an equivalent pragma Check. That works fine since
17636 -- pragma Check will analyze the condition in the proper context.
17638 -- The form of the pragma Check is either:
17640 -- pragma Check (Precondition, cond [, msg])
17642 -- pragma Check (Pre, cond [, msg])
17644 -- We use the Pre form if this pragma derived from a Pre aspect.
17645 -- This is needed to make sure that the right set of Policy
17646 -- pragmas are checked.
17650 -- Rewrite as Check pragma
17654 Chars
=> Name_Check
,
17655 Pragma_Argument_Associations
=> New_List
(
17656 Make_Pragma_Argument_Association
(Loc
,
17657 Expression
=> Make_Identifier
(Loc
, Pname
)),
17659 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
17661 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
17663 if Arg_Count
= 2 then
17664 Append_To
(Pragma_Argument_Associations
(N
),
17665 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
17667 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
17678 -- pragma Predicate
17679 -- ([Entity =>] type_LOCAL_NAME,
17680 -- [Check =>] boolean_EXPRESSION);
17682 when Pragma_Predicate
=> Predicate
: declare
17689 Check_Arg_Count
(2);
17690 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17691 Check_Optional_Identifier
(Arg2
, Name_Check
);
17693 Check_Arg_Is_Local_Name
(Arg1
);
17695 Type_Id
:= Get_Pragma_Arg
(Arg1
);
17696 Find_Type
(Type_Id
);
17697 Typ
:= Entity
(Type_Id
);
17699 if Typ
= Any_Type
then
17703 -- The remaining processing is simply to link the pragma on to
17704 -- the rep item chain, for processing when the type is frozen.
17705 -- This is accomplished by a call to Rep_Item_Too_Late. We also
17706 -- mark the type as having predicates.
17708 Set_Has_Predicates
(Typ
);
17709 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17716 -- pragma Preelaborate [(library_unit_NAME)];
17718 -- Set the flag Is_Preelaborated of program unit name entity
17720 when Pragma_Preelaborate
=> Preelaborate
: declare
17721 Pa
: constant Node_Id
:= Parent
(N
);
17722 Pk
: constant Node_Kind
:= Nkind
(Pa
);
17726 Check_Ada_83_Warning
;
17727 Check_Valid_Library_Unit_Pragma
;
17729 if Nkind
(N
) = N_Null_Statement
then
17733 Ent
:= Find_Lib_Unit_Name
;
17734 Check_Duplicate_Pragma
(Ent
);
17736 -- This filters out pragmas inside generic parents that show up
17737 -- inside instantiations. Pragmas that come from aspects in the
17738 -- unit are not ignored.
17740 if Present
(Ent
) then
17741 if Pk
= N_Package_Specification
17742 and then Present
(Generic_Parent
(Pa
))
17743 and then not From_Aspect_Specification
(N
)
17748 if not Debug_Flag_U
then
17749 Set_Is_Preelaborated
(Ent
);
17750 Set_Suppress_Elaboration_Warnings
(Ent
);
17756 -------------------------------
17757 -- Prefix_Exception_Messages --
17758 -------------------------------
17760 -- pragma Prefix_Exception_Messages;
17762 when Pragma_Prefix_Exception_Messages
=>
17764 Check_Valid_Configuration_Pragma
;
17765 Check_Arg_Count
(0);
17766 Prefix_Exception_Messages
:= True;
17772 -- pragma Priority (EXPRESSION);
17774 when Pragma_Priority
=> Priority
: declare
17775 P
: constant Node_Id
:= Parent
(N
);
17780 Check_No_Identifiers
;
17781 Check_Arg_Count
(1);
17785 if Nkind
(P
) = N_Subprogram_Body
then
17786 Check_In_Main_Program
;
17788 Ent
:= Defining_Unit_Name
(Specification
(P
));
17790 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
17791 Ent
:= Defining_Identifier
(Ent
);
17794 Arg
:= Get_Pragma_Arg
(Arg1
);
17795 Analyze_And_Resolve
(Arg
, Standard_Integer
);
17799 if not Is_OK_Static_Expression
(Arg
) then
17800 Flag_Non_Static_Expr
17801 ("main subprogram priority is not static!", Arg
);
17804 -- If constraint error, then we already signalled an error
17806 elsif Raises_Constraint_Error
(Arg
) then
17809 -- Otherwise check in range except if Relaxed_RM_Semantics
17810 -- where we ignore the value if out of range.
17814 Val
: constant Uint
:= Expr_Value
(Arg
);
17816 if not Relaxed_RM_Semantics
17819 or else Val
> Expr_Value
(Expression
17820 (Parent
(RTE
(RE_Max_Priority
)))))
17823 ("main subprogram priority is out of range", Arg1
);
17826 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
17831 -- Load an arbitrary entity from System.Tasking.Stages or
17832 -- System.Tasking.Restricted.Stages (depending on the
17833 -- supported profile) to make sure that one of these packages
17834 -- is implicitly with'ed, since we need to have the tasking
17835 -- run time active for the pragma Priority to have any effect.
17836 -- Previously we with'ed the package System.Tasking, but this
17837 -- package does not trigger the required initialization of the
17838 -- run-time library.
17841 Discard
: Entity_Id
;
17842 pragma Warnings
(Off
, Discard
);
17844 if Restricted_Profile
then
17845 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
17847 Discard
:= RTE
(RE_Activate_Tasks
);
17851 -- Task or Protected, must be of type Integer
17853 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
17854 Arg
:= Get_Pragma_Arg
(Arg1
);
17855 Ent
:= Defining_Identifier
(Parent
(P
));
17857 -- The expression must be analyzed in the special manner
17858 -- described in "Handling of Default and Per-Object
17859 -- Expressions" in sem.ads.
17861 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
17863 if not Is_OK_Static_Expression
(Arg
) then
17864 Check_Restriction
(Static_Priorities
, Arg
);
17867 -- Anything else is incorrect
17873 -- Check duplicate pragma before we chain the pragma in the Rep
17874 -- Item chain of Ent.
17876 Check_Duplicate_Pragma
(Ent
);
17877 Record_Rep_Item
(Ent
, N
);
17880 -----------------------------------
17881 -- Priority_Specific_Dispatching --
17882 -----------------------------------
17884 -- pragma Priority_Specific_Dispatching (
17885 -- policy_IDENTIFIER,
17886 -- first_priority_EXPRESSION,
17887 -- last_priority_EXPRESSION);
17889 when Pragma_Priority_Specific_Dispatching
=>
17890 Priority_Specific_Dispatching
: declare
17891 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
17892 -- This is the entity System.Any_Priority;
17895 Lower_Bound
: Node_Id
;
17896 Upper_Bound
: Node_Id
;
17902 Check_Arg_Count
(3);
17903 Check_No_Identifiers
;
17904 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
17905 Check_Valid_Configuration_Pragma
;
17906 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
17907 DP
:= Fold_Upper
(Name_Buffer
(1));
17909 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
17910 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
17911 Lower_Val
:= Expr_Value
(Lower_Bound
);
17913 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
17914 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
17915 Upper_Val
:= Expr_Value
(Upper_Bound
);
17917 -- It is not allowed to use Task_Dispatching_Policy and
17918 -- Priority_Specific_Dispatching in the same partition.
17920 if Task_Dispatching_Policy
/= ' ' then
17921 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
17923 ("pragma% incompatible with Task_Dispatching_Policy#");
17925 -- Check lower bound in range
17927 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
17929 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
17932 ("first_priority is out of range", Arg2
);
17934 -- Check upper bound in range
17936 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
17938 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
17941 ("last_priority is out of range", Arg3
);
17943 -- Check that the priority range is valid
17945 elsif Lower_Val
> Upper_Val
then
17947 ("last_priority_expression must be greater than or equal to "
17948 & "first_priority_expression");
17950 -- Store the new policy, but always preserve System_Location since
17951 -- we like the error message with the run-time name.
17954 -- Check overlapping in the priority ranges specified in other
17955 -- Priority_Specific_Dispatching pragmas within the same
17956 -- partition. We can only check those we know about.
17959 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
17961 if Specific_Dispatching
.Table
(J
).First_Priority
in
17962 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
17963 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
17964 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
17967 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
17969 ("priority range overlaps with "
17970 & "Priority_Specific_Dispatching#");
17974 -- The use of Priority_Specific_Dispatching is incompatible
17975 -- with Task_Dispatching_Policy.
17977 if Task_Dispatching_Policy
/= ' ' then
17978 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
17980 ("Priority_Specific_Dispatching incompatible "
17981 & "with Task_Dispatching_Policy#");
17984 -- The use of Priority_Specific_Dispatching forces ceiling
17987 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
17988 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
17990 ("Priority_Specific_Dispatching incompatible "
17991 & "with Locking_Policy#");
17993 -- Set the Ceiling_Locking policy, but preserve System_Location
17994 -- since we like the error message with the run time name.
17997 Locking_Policy
:= 'C';
17999 if Locking_Policy_Sloc
/= System_Location
then
18000 Locking_Policy_Sloc
:= Loc
;
18004 -- Add entry in the table
18006 Specific_Dispatching
.Append
18007 ((Dispatching_Policy
=> DP
,
18008 First_Priority
=> UI_To_Int
(Lower_Val
),
18009 Last_Priority
=> UI_To_Int
(Upper_Val
),
18010 Pragma_Loc
=> Loc
));
18012 end Priority_Specific_Dispatching
;
18018 -- pragma Profile (profile_IDENTIFIER);
18020 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18022 when Pragma_Profile
=>
18024 Check_Arg_Count
(1);
18025 Check_Valid_Configuration_Pragma
;
18026 Check_No_Identifiers
;
18029 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18032 if Chars
(Argx
) = Name_Ravenscar
then
18033 Set_Ravenscar_Profile
(N
);
18035 elsif Chars
(Argx
) = Name_Restricted
then
18036 Set_Profile_Restrictions
18038 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18040 elsif Chars
(Argx
) = Name_Rational
then
18041 Set_Rational_Profile
;
18043 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18044 Set_Profile_Restrictions
18045 (No_Implementation_Extensions
,
18046 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18049 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18053 ----------------------
18054 -- Profile_Warnings --
18055 ----------------------
18057 -- pragma Profile_Warnings (profile_IDENTIFIER);
18059 -- profile_IDENTIFIER => Restricted | Ravenscar
18061 when Pragma_Profile_Warnings
=>
18063 Check_Arg_Count
(1);
18064 Check_Valid_Configuration_Pragma
;
18065 Check_No_Identifiers
;
18068 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18071 if Chars
(Argx
) = Name_Ravenscar
then
18072 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18074 elsif Chars
(Argx
) = Name_Restricted
then
18075 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18077 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18078 Set_Profile_Restrictions
18079 (No_Implementation_Extensions
, N
, Warn
=> True);
18082 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18086 --------------------------
18087 -- Propagate_Exceptions --
18088 --------------------------
18090 -- pragma Propagate_Exceptions;
18092 -- Note: this pragma is obsolete and has no effect
18094 when Pragma_Propagate_Exceptions
=>
18096 Check_Arg_Count
(0);
18098 if Warn_On_Obsolescent_Feature
then
18100 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18101 "and has no effect?j?", N
);
18104 -----------------------------
18105 -- Provide_Shift_Operators --
18106 -----------------------------
18108 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18110 when Pragma_Provide_Shift_Operators
=>
18111 Provide_Shift_Operators
: declare
18114 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18115 -- Insert declaration and pragma Instrinsic for named shift op
18117 ----------------------------
18118 -- Declare_Shift_Operator --
18119 ----------------------------
18121 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18127 Make_Subprogram_Declaration
(Loc
,
18128 Make_Function_Specification
(Loc
,
18129 Defining_Unit_Name
=>
18130 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18132 Result_Definition
=>
18133 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18135 Parameter_Specifications
=> New_List
(
18136 Make_Parameter_Specification
(Loc
,
18137 Defining_Identifier
=>
18138 Make_Defining_Identifier
(Loc
, Name_Value
),
18140 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18142 Make_Parameter_Specification
(Loc
,
18143 Defining_Identifier
=>
18144 Make_Defining_Identifier
(Loc
, Name_Amount
),
18146 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18150 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18151 Pragma_Argument_Associations
=> New_List
(
18152 Make_Pragma_Argument_Association
(Loc
,
18153 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18154 Make_Pragma_Argument_Association
(Loc
,
18155 Expression
=> Make_Identifier
(Loc
, Nam
))));
18157 Insert_After
(N
, Import
);
18158 Insert_After
(N
, Func
);
18159 end Declare_Shift_Operator
;
18161 -- Start of processing for Provide_Shift_Operators
18165 Check_Arg_Count
(1);
18166 Check_Arg_Is_Local_Name
(Arg1
);
18168 Arg1
:= Get_Pragma_Arg
(Arg1
);
18170 -- We must have an entity name
18172 if not Is_Entity_Name
(Arg1
) then
18174 ("pragma % must apply to integer first subtype", Arg1
);
18177 -- If no Entity, means there was a prior error so ignore
18179 if Present
(Entity
(Arg1
)) then
18180 Ent
:= Entity
(Arg1
);
18182 -- Apply error checks
18184 if not Is_First_Subtype
(Ent
) then
18186 ("cannot apply pragma %",
18187 "\& is not a first subtype",
18190 elsif not Is_Integer_Type
(Ent
) then
18192 ("cannot apply pragma %",
18193 "\& is not an integer type",
18196 elsif Has_Shift_Operator
(Ent
) then
18198 ("cannot apply pragma %",
18199 "\& already has declared shift operators",
18202 elsif Is_Frozen
(Ent
) then
18204 ("pragma % appears too late",
18205 "\& is already frozen",
18209 -- Now declare the operators. We do this during analysis rather
18210 -- than expansion, since we want the operators available if we
18211 -- are operating in -gnatc or ASIS mode.
18213 Declare_Shift_Operator
(Name_Rotate_Left
);
18214 Declare_Shift_Operator
(Name_Rotate_Right
);
18215 Declare_Shift_Operator
(Name_Shift_Left
);
18216 Declare_Shift_Operator
(Name_Shift_Right
);
18217 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18219 end Provide_Shift_Operators
;
18225 -- pragma Psect_Object (
18226 -- [Internal =>] LOCAL_NAME,
18227 -- [, [External =>] EXTERNAL_SYMBOL]
18228 -- [, [Size =>] EXTERNAL_SYMBOL]);
18230 when Pragma_Psect_Object | Pragma_Common_Object
=>
18231 Psect_Object
: declare
18232 Args
: Args_List
(1 .. 3);
18233 Names
: constant Name_List
(1 .. 3) := (
18238 Internal
: Node_Id
renames Args
(1);
18239 External
: Node_Id
renames Args
(2);
18240 Size
: Node_Id
renames Args
(3);
18242 Def_Id
: Entity_Id
;
18244 procedure Check_Arg
(Arg
: Node_Id
);
18245 -- Checks that argument is either a string literal or an
18246 -- identifier, and posts error message if not.
18252 procedure Check_Arg
(Arg
: Node_Id
) is
18254 if not Nkind_In
(Original_Node
(Arg
),
18259 ("inappropriate argument for pragma %", Arg
);
18263 -- Start of processing for Common_Object/Psect_Object
18267 Gather_Associations
(Names
, Args
);
18268 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18270 Def_Id
:= Entity
(Internal
);
18272 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18274 ("pragma% must designate an object", Internal
);
18277 Check_Arg
(Internal
);
18279 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18281 ("cannot use pragma% for imported/exported object",
18285 if Is_Concurrent_Type
(Etype
(Internal
)) then
18287 ("cannot specify pragma % for task/protected object",
18291 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18293 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18295 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18298 if Ekind
(Def_Id
) = E_Constant
then
18300 ("cannot specify pragma % for a constant", Internal
);
18303 if Is_Record_Type
(Etype
(Internal
)) then
18309 Ent
:= First_Entity
(Etype
(Internal
));
18310 while Present
(Ent
) loop
18311 Decl
:= Declaration_Node
(Ent
);
18313 if Ekind
(Ent
) = E_Component
18314 and then Nkind
(Decl
) = N_Component_Declaration
18315 and then Present
(Expression
(Decl
))
18316 and then Warn_On_Export_Import
18319 ("?x?object for pragma % has defaults", Internal
);
18329 if Present
(Size
) then
18333 if Present
(External
) then
18334 Check_Arg_Is_External_Name
(External
);
18337 -- If all error tests pass, link pragma on to the rep item chain
18339 Record_Rep_Item
(Def_Id
, N
);
18346 -- pragma Pure [(library_unit_NAME)];
18348 when Pragma_Pure
=> Pure
: declare
18352 Check_Ada_83_Warning
;
18353 Check_Valid_Library_Unit_Pragma
;
18355 if Nkind
(N
) = N_Null_Statement
then
18359 Ent
:= Find_Lib_Unit_Name
;
18361 Set_Has_Pragma_Pure
(Ent
);
18362 Set_Suppress_Elaboration_Warnings
(Ent
);
18365 -------------------
18366 -- Pure_Function --
18367 -------------------
18369 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18371 when Pragma_Pure_Function
=> Pure_Function
: declare
18374 Def_Id
: Entity_Id
;
18375 Effective
: Boolean := False;
18379 Check_Arg_Count
(1);
18380 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18381 Check_Arg_Is_Local_Name
(Arg1
);
18382 E_Id
:= Get_Pragma_Arg
(Arg1
);
18384 if Error_Posted
(E_Id
) then
18388 -- Loop through homonyms (overloadings) of referenced entity
18390 E
:= Entity
(E_Id
);
18392 if Present
(E
) then
18394 Def_Id
:= Get_Base_Subprogram
(E
);
18396 if not Ekind_In
(Def_Id
, E_Function
,
18397 E_Generic_Function
,
18401 ("pragma% requires a function name", Arg1
);
18404 Set_Is_Pure
(Def_Id
);
18406 if not Has_Pragma_Pure_Function
(Def_Id
) then
18407 Set_Has_Pragma_Pure_Function
(Def_Id
);
18411 exit when From_Aspect_Specification
(N
);
18413 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18417 and then Warn_On_Redundant_Constructs
18420 ("pragma Pure_Function on& is redundant?r?",
18426 --------------------
18427 -- Queuing_Policy --
18428 --------------------
18430 -- pragma Queuing_Policy (policy_IDENTIFIER);
18432 when Pragma_Queuing_Policy
=> declare
18436 Check_Ada_83_Warning
;
18437 Check_Arg_Count
(1);
18438 Check_No_Identifiers
;
18439 Check_Arg_Is_Queuing_Policy
(Arg1
);
18440 Check_Valid_Configuration_Pragma
;
18441 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18442 QP
:= Fold_Upper
(Name_Buffer
(1));
18444 if Queuing_Policy
/= ' '
18445 and then Queuing_Policy
/= QP
18447 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18448 Error_Pragma
("queuing policy incompatible with policy#");
18450 -- Set new policy, but always preserve System_Location since we
18451 -- like the error message with the run time name.
18454 Queuing_Policy
:= QP
;
18456 if Queuing_Policy_Sloc
/= System_Location
then
18457 Queuing_Policy_Sloc
:= Loc
;
18466 -- pragma Rational, for compatibility with foreign compiler
18468 when Pragma_Rational
=>
18469 Set_Rational_Profile
;
18471 ------------------------------------
18472 -- Refined_Depends/Refined_Global --
18473 ------------------------------------
18475 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18477 -- DEPENDENCY_RELATION ::=
18479 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18481 -- DEPENDENCY_CLAUSE ::=
18482 -- OUTPUT_LIST =>[+] INPUT_LIST
18483 -- | NULL_DEPENDENCY_CLAUSE
18485 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18487 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18489 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18491 -- OUTPUT ::= NAME | FUNCTION_RESULT
18494 -- where FUNCTION_RESULT is a function Result attribute_reference
18496 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18498 -- GLOBAL_SPECIFICATION ::=
18501 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18503 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18505 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18506 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18507 -- GLOBAL_ITEM ::= NAME
18509 when Pragma_Refined_Depends |
18510 Pragma_Refined_Global
=> Refined_Depends_Global
:
18512 Body_Id
: Entity_Id
;
18514 Spec_Id
: Entity_Id
;
18517 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18519 -- Save the pragma in the contract of the subprogram body. The
18520 -- remaining analysis is performed at the end of the enclosing
18524 Add_Contract_Item
(N
, Body_Id
);
18526 end Refined_Depends_Global
;
18532 -- pragma Refined_Post (boolean_EXPRESSION);
18534 when Pragma_Refined_Post
=> Refined_Post
: declare
18535 Body_Id
: Entity_Id
;
18537 Result_Seen
: Boolean := False;
18538 Spec_Id
: Entity_Id
;
18541 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18543 -- Analyze the boolean expression as a "spec expression"
18546 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
18548 -- Verify that the refined postcondition mentions attribute
18549 -- 'Result and its expression introduces a post-state.
18551 if Warn_On_Suspicious_Contract
18552 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
18554 Check_Result_And_Post_State
(N
, Result_Seen
);
18556 if not Result_Seen
then
18558 ("pragma % does not mention function result?T?");
18562 -- Chain the pragma on the contract for easy retrieval
18564 Add_Contract_Item
(N
, Body_Id
);
18568 -------------------
18569 -- Refined_State --
18570 -------------------
18572 -- pragma Refined_State (REFINEMENT_LIST);
18574 -- REFINEMENT_LIST ::=
18575 -- REFINEMENT_CLAUSE
18576 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
18578 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
18580 -- CONSTITUENT_LIST ::=
18583 -- | (CONSTITUENT {, CONSTITUENT})
18585 -- CONSTITUENT ::= object_NAME | state_NAME
18587 when Pragma_Refined_State
=> Refined_State
: declare
18588 Context
: constant Node_Id
:= Parent
(N
);
18589 Spec_Id
: Entity_Id
;
18594 Check_Arg_Count
(1);
18596 -- Ensure the proper placement of the pragma. Refined states must
18597 -- be associated with a package body.
18599 if Nkind
(Context
) /= N_Package_Body
then
18605 while Present
(Stmt
) loop
18607 -- Skip prior pragmas, but check for duplicates
18609 if Nkind
(Stmt
) = N_Pragma
then
18610 if Pragma_Name
(Stmt
) = Pname
then
18611 Error_Msg_Name_1
:= Pname
;
18612 Error_Msg_Sloc
:= Sloc
(Stmt
);
18613 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
18616 -- Skip internally generated code
18618 elsif not Comes_From_Source
(Stmt
) then
18621 -- The pragma does not apply to a legal construct, issue an
18622 -- error and stop the analysis.
18629 Stmt
:= Prev
(Stmt
);
18632 Spec_Id
:= Corresponding_Spec
(Context
);
18634 -- State refinement is allowed only when the corresponding package
18635 -- declaration has non-null pragma Abstract_State. Refinement not
18636 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
18638 if SPARK_Mode
/= Off
18640 (No
(Abstract_States
(Spec_Id
))
18641 or else Has_Null_Abstract_State
(Spec_Id
))
18644 ("useless refinement, package & does not define abstract "
18645 & "states", N
, Spec_Id
);
18649 -- The pragma must be analyzed at the end of the declarations as
18650 -- it has visibility over the whole declarative region. Save the
18651 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
18652 -- adding it to the contract of the package body.
18654 Add_Contract_Item
(N
, Defining_Entity
(Context
));
18657 -----------------------
18658 -- Relative_Deadline --
18659 -----------------------
18661 -- pragma Relative_Deadline (time_span_EXPRESSION);
18663 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
18664 P
: constant Node_Id
:= Parent
(N
);
18669 Check_No_Identifiers
;
18670 Check_Arg_Count
(1);
18672 Arg
:= Get_Pragma_Arg
(Arg1
);
18674 -- The expression must be analyzed in the special manner described
18675 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
18677 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
18681 if Nkind
(P
) = N_Subprogram_Body
then
18682 Check_In_Main_Program
;
18684 -- Only Task and subprogram cases allowed
18686 elsif Nkind
(P
) /= N_Task_Definition
then
18690 -- Check duplicate pragma before we set the corresponding flag
18692 if Has_Relative_Deadline_Pragma
(P
) then
18693 Error_Pragma
("duplicate pragma% not allowed");
18696 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
18697 -- Relative_Deadline pragma node cannot be inserted in the Rep
18698 -- Item chain of Ent since it is rewritten by the expander as a
18699 -- procedure call statement that will break the chain.
18701 Set_Has_Relative_Deadline_Pragma
(P
, True);
18702 end Relative_Deadline
;
18704 ------------------------
18705 -- Remote_Access_Type --
18706 ------------------------
18708 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
18710 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
18715 Check_Arg_Count
(1);
18716 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18717 Check_Arg_Is_Local_Name
(Arg1
);
18719 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
18721 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
18722 and then Ekind
(E
) = E_General_Access_Type
18723 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
18724 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
18726 and then Is_Valid_Remote_Object_Type
18727 (Root_Type
(Directly_Designated_Type
(E
)))
18729 Set_Is_Remote_Types
(E
);
18733 ("pragma% applies only to formal access to classwide types",
18736 end Remote_Access_Type
;
18738 ---------------------------
18739 -- Remote_Call_Interface --
18740 ---------------------------
18742 -- pragma Remote_Call_Interface [(library_unit_NAME)];
18744 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
18745 Cunit_Node
: Node_Id
;
18746 Cunit_Ent
: Entity_Id
;
18750 Check_Ada_83_Warning
;
18751 Check_Valid_Library_Unit_Pragma
;
18753 if Nkind
(N
) = N_Null_Statement
then
18757 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
18758 K
:= Nkind
(Unit
(Cunit_Node
));
18759 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
18761 if K
= N_Package_Declaration
18762 or else K
= N_Generic_Package_Declaration
18763 or else K
= N_Subprogram_Declaration
18764 or else K
= N_Generic_Subprogram_Declaration
18765 or else (K
= N_Subprogram_Body
18766 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
18771 "pragma% must apply to package or subprogram declaration");
18774 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
18775 end Remote_Call_Interface
;
18781 -- pragma Remote_Types [(library_unit_NAME)];
18783 when Pragma_Remote_Types
=> Remote_Types
: declare
18784 Cunit_Node
: Node_Id
;
18785 Cunit_Ent
: Entity_Id
;
18788 Check_Ada_83_Warning
;
18789 Check_Valid_Library_Unit_Pragma
;
18791 if Nkind
(N
) = N_Null_Statement
then
18795 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
18796 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
18798 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
18799 N_Generic_Package_Declaration
)
18802 ("pragma% can only apply to a package declaration");
18805 Set_Is_Remote_Types
(Cunit_Ent
);
18812 -- pragma Ravenscar;
18814 when Pragma_Ravenscar
=>
18816 Check_Arg_Count
(0);
18817 Check_Valid_Configuration_Pragma
;
18818 Set_Ravenscar_Profile
(N
);
18820 if Warn_On_Obsolescent_Feature
then
18822 ("pragma Ravenscar is an obsolescent feature?j?", N
);
18824 ("|use pragma Profile (Ravenscar) instead?j?", N
);
18827 -------------------------
18828 -- Restricted_Run_Time --
18829 -------------------------
18831 -- pragma Restricted_Run_Time;
18833 when Pragma_Restricted_Run_Time
=>
18835 Check_Arg_Count
(0);
18836 Check_Valid_Configuration_Pragma
;
18837 Set_Profile_Restrictions
18838 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
18840 if Warn_On_Obsolescent_Feature
then
18842 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
18845 ("|use pragma Profile (Restricted) instead?j?", N
);
18852 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
18855 -- restriction_IDENTIFIER
18856 -- | restriction_parameter_IDENTIFIER => EXPRESSION
18858 when Pragma_Restrictions
=>
18859 Process_Restrictions_Or_Restriction_Warnings
18860 (Warn
=> Treat_Restrictions_As_Warnings
);
18862 --------------------------
18863 -- Restriction_Warnings --
18864 --------------------------
18866 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
18869 -- restriction_IDENTIFIER
18870 -- | restriction_parameter_IDENTIFIER => EXPRESSION
18872 when Pragma_Restriction_Warnings
=>
18874 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
18880 -- pragma Reviewable;
18882 when Pragma_Reviewable
=>
18883 Check_Ada_83_Warning
;
18884 Check_Arg_Count
(0);
18886 -- Call dummy debugging function rv. This is done to assist front
18887 -- end debugging. By placing a Reviewable pragma in the source
18888 -- program, a breakpoint on rv catches this place in the source,
18889 -- allowing convenient stepping to the point of interest.
18893 --------------------------
18894 -- Short_Circuit_And_Or --
18895 --------------------------
18897 -- pragma Short_Circuit_And_Or;
18899 when Pragma_Short_Circuit_And_Or
=>
18901 Check_Arg_Count
(0);
18902 Check_Valid_Configuration_Pragma
;
18903 Short_Circuit_And_Or
:= True;
18905 -------------------
18906 -- Share_Generic --
18907 -------------------
18909 -- pragma Share_Generic (GNAME {, GNAME});
18911 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
18913 when Pragma_Share_Generic
=>
18915 Process_Generic_List
;
18921 -- pragma Shared (LOCAL_NAME);
18923 when Pragma_Shared
=>
18925 Process_Atomic_Shared_Volatile
;
18927 --------------------
18928 -- Shared_Passive --
18929 --------------------
18931 -- pragma Shared_Passive [(library_unit_NAME)];
18933 -- Set the flag Is_Shared_Passive of program unit name entity
18935 when Pragma_Shared_Passive
=> Shared_Passive
: declare
18936 Cunit_Node
: Node_Id
;
18937 Cunit_Ent
: Entity_Id
;
18940 Check_Ada_83_Warning
;
18941 Check_Valid_Library_Unit_Pragma
;
18943 if Nkind
(N
) = N_Null_Statement
then
18947 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
18948 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
18950 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
18951 N_Generic_Package_Declaration
)
18954 ("pragma% can only apply to a package declaration");
18957 Set_Is_Shared_Passive
(Cunit_Ent
);
18958 end Shared_Passive
;
18960 -----------------------
18961 -- Short_Descriptors --
18962 -----------------------
18964 -- pragma Short_Descriptors;
18966 -- Recognize and validate, but otherwise ignore
18968 when Pragma_Short_Descriptors
=>
18970 Check_Arg_Count
(0);
18971 Check_Valid_Configuration_Pragma
;
18973 ------------------------------
18974 -- Simple_Storage_Pool_Type --
18975 ------------------------------
18977 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
18979 when Pragma_Simple_Storage_Pool_Type
=>
18980 Simple_Storage_Pool_Type
: declare
18986 Check_Arg_Count
(1);
18987 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18989 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18990 Find_Type
(Type_Id
);
18991 Typ
:= Entity
(Type_Id
);
18993 if Typ
= Any_Type
then
18997 -- We require the pragma to apply to a type declared in a package
18998 -- declaration, but not (immediately) within a package body.
19000 if Ekind
(Current_Scope
) /= E_Package
19001 or else In_Package_Body
(Current_Scope
)
19004 ("pragma% can only apply to type declared immediately "
19005 & "within a package declaration");
19008 -- A simple storage pool type must be an immutably limited record
19009 -- or private type. If the pragma is given for a private type,
19010 -- the full type is similarly restricted (which is checked later
19011 -- in Freeze_Entity).
19013 if Is_Record_Type
(Typ
)
19014 and then not Is_Limited_View
(Typ
)
19017 ("pragma% can only apply to explicitly limited record type");
19019 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19021 ("pragma% can only apply to a private type that is limited");
19023 elsif not Is_Record_Type
(Typ
)
19024 and then not Is_Private_Type
(Typ
)
19027 ("pragma% can only apply to limited record or private type");
19030 Record_Rep_Item
(Typ
, N
);
19031 end Simple_Storage_Pool_Type
;
19033 ----------------------
19034 -- Source_File_Name --
19035 ----------------------
19037 -- There are five forms for this pragma:
19039 -- pragma Source_File_Name (
19040 -- [UNIT_NAME =>] unit_NAME,
19041 -- BODY_FILE_NAME => STRING_LITERAL
19042 -- [, [INDEX =>] INTEGER_LITERAL]);
19044 -- pragma Source_File_Name (
19045 -- [UNIT_NAME =>] unit_NAME,
19046 -- SPEC_FILE_NAME => STRING_LITERAL
19047 -- [, [INDEX =>] INTEGER_LITERAL]);
19049 -- pragma Source_File_Name (
19050 -- BODY_FILE_NAME => STRING_LITERAL
19051 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19052 -- [, CASING => CASING_SPEC]);
19054 -- pragma Source_File_Name (
19055 -- SPEC_FILE_NAME => STRING_LITERAL
19056 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19057 -- [, CASING => CASING_SPEC]);
19059 -- pragma Source_File_Name (
19060 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19061 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19062 -- [, CASING => CASING_SPEC]);
19064 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19066 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19067 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19068 -- only be used when no project file is used, while SFNP can only be
19069 -- used when a project file is used.
19071 -- No processing here. Processing was completed during parsing, since
19072 -- we need to have file names set as early as possible. Units are
19073 -- loaded well before semantic processing starts.
19075 -- The only processing we defer to this point is the check for
19076 -- correct placement.
19078 when Pragma_Source_File_Name
=>
19080 Check_Valid_Configuration_Pragma
;
19082 ------------------------------
19083 -- Source_File_Name_Project --
19084 ------------------------------
19086 -- See Source_File_Name for syntax
19088 -- No processing here. Processing was completed during parsing, since
19089 -- we need to have file names set as early as possible. Units are
19090 -- loaded well before semantic processing starts.
19092 -- The only processing we defer to this point is the check for
19093 -- correct placement.
19095 when Pragma_Source_File_Name_Project
=>
19097 Check_Valid_Configuration_Pragma
;
19099 -- Check that a pragma Source_File_Name_Project is used only in a
19100 -- configuration pragmas file.
19102 -- Pragmas Source_File_Name_Project should only be generated by
19103 -- the Project Manager in configuration pragmas files.
19105 -- This is really an ugly test. It seems to depend on some
19106 -- accidental and undocumented property. At the very least it
19107 -- needs to be documented, but it would be better to have a
19108 -- clean way of testing if we are in a configuration file???
19110 if Present
(Parent
(N
)) then
19112 ("pragma% can only appear in a configuration pragmas file");
19115 ----------------------
19116 -- Source_Reference --
19117 ----------------------
19119 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19121 -- Nothing to do, all processing completed in Par.Prag, since we need
19122 -- the information for possible parser messages that are output.
19124 when Pragma_Source_Reference
=>
19131 -- pragma SPARK_Mode [(On | Off)];
19133 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19134 procedure Check_Pragma_Conformance
19135 (Context_Pragma
: Node_Id
;
19136 Entity_Pragma
: Node_Id
;
19137 Entity
: Entity_Id
);
19138 -- If Context_Pragma is not Empty, verify that the new pragma N
19139 -- is compatible with the pragma Context_Pragma that was inherited
19140 -- from the context:
19141 -- . if Context_Pragma is ON, then the new mode can be anything
19142 -- . if Context_Pragma is OFF, then the only allowed new mode is
19145 -- If Entity is not Empty, verify that the new pragma N is
19146 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19147 -- for Entity (which may be Empty):
19148 -- . if Entity_Pragma is ON, then the new mode can be anything
19149 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19151 -- . if Entity_Pragma is Empty, we always issue an error, as this
19152 -- corresponds to a case where a previous section of Entity
19153 -- had no SPARK_Mode set.
19155 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19156 -- Verify that pragma is applied to library-level entity E
19158 ------------------------------
19159 -- Check_Pragma_Conformance --
19160 ------------------------------
19162 procedure Check_Pragma_Conformance
19163 (Context_Pragma
: Node_Id
;
19164 Entity_Pragma
: Node_Id
;
19165 Entity
: Entity_Id
)
19168 if Present
(Context_Pragma
) then
19169 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19171 -- New mode less restrictive than the established mode
19173 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19174 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19177 ("cannot change SPARK_Mode from Off to On", Arg1
);
19178 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19179 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg1
);
19184 if Present
(Entity
) then
19185 if Present
(Entity_Pragma
) then
19186 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19187 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19189 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19190 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19192 ("\value Off was set for SPARK_Mode on&#",
19198 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19199 Error_Msg_Sloc
:= Sloc
(Entity
);
19201 ("\no value was set for SPARK_Mode on&#",
19206 end Check_Pragma_Conformance
;
19208 --------------------------------
19209 -- Check_Library_Level_Entity --
19210 --------------------------------
19212 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19213 MsgF
: constant String := "incorrect placement of pragma%";
19216 if not Is_Library_Level_Entity
(E
) then
19217 Error_Msg_Name_1
:= Pname
;
19218 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19220 if Ekind_In
(E
, E_Generic_Package
,
19225 ("\& is not a library-level package", N
, E
);
19228 ("\& is not a library-level subprogram", N
, E
);
19233 end Check_Library_Level_Entity
;
19237 Body_Id
: Entity_Id
;
19240 Mode_Id
: SPARK_Mode_Type
;
19241 Spec_Id
: Entity_Id
;
19244 -- Start of processing for Do_SPARK_Mode
19247 -- When a SPARK_Mode pragma appears inside an instantiation whose
19248 -- enclosing context has SPARK_Mode set to "off", the pragma has
19249 -- no semantic effect.
19251 if Ignore_Pragma_SPARK_Mode
then
19252 Rewrite
(N
, Make_Null_Statement
(Loc
));
19258 Check_No_Identifiers
;
19259 Check_At_Most_N_Arguments
(1);
19261 -- Check the legality of the mode (no argument = ON)
19263 if Arg_Count
= 1 then
19264 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19265 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19270 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19271 Context
:= Parent
(N
);
19273 -- The pragma appears in a configuration pragmas file
19275 if No
(Context
) then
19276 Check_Valid_Configuration_Pragma
;
19278 if Present
(SPARK_Mode_Pragma
) then
19279 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19280 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19284 SPARK_Mode_Pragma
:= N
;
19285 SPARK_Mode
:= Mode_Id
;
19287 -- The pragma acts as a configuration pragma in a compilation unit
19289 -- pragma SPARK_Mode ...;
19290 -- package Pack is ...;
19292 elsif Nkind
(Context
) = N_Compilation_Unit
19293 and then List_Containing
(N
) = Context_Items
(Context
)
19295 Check_Valid_Configuration_Pragma
;
19296 SPARK_Mode_Pragma
:= N
;
19297 SPARK_Mode
:= Mode_Id
;
19299 -- Otherwise the placement of the pragma within the tree dictates
19300 -- its associated construct. Inspect the declarative list where
19301 -- the pragma resides to find a potential construct.
19305 while Present
(Stmt
) loop
19307 -- Skip prior pragmas, but check for duplicates
19309 if Nkind
(Stmt
) = N_Pragma
then
19310 if Pragma_Name
(Stmt
) = Pname
then
19311 Error_Msg_Name_1
:= Pname
;
19312 Error_Msg_Sloc
:= Sloc
(Stmt
);
19313 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19317 -- The pragma applies to a [generic] subprogram declaration.
19318 -- Note that this case covers an internally generated spec
19319 -- for a stand alone body.
19322 -- procedure Proc ...;
19323 -- pragma SPARK_Mode ..;
19325 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19326 N_Subprogram_Declaration
)
19328 Spec_Id
:= Defining_Entity
(Stmt
);
19329 Check_Library_Level_Entity
(Spec_Id
);
19330 Check_Pragma_Conformance
19331 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19332 Entity_Pragma
=> Empty
,
19335 Set_SPARK_Pragma
(Spec_Id
, N
);
19336 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19339 -- Skip internally generated code
19341 elsif not Comes_From_Source
(Stmt
) then
19344 -- Otherwise the pragma does not apply to a legal construct
19345 -- or it does not appear at the top of a declarative or a
19346 -- statement list. Issue an error and stop the analysis.
19356 -- The pragma applies to a package or a subprogram that acts as
19357 -- a compilation unit.
19359 -- procedure Proc ...;
19360 -- pragma SPARK_Mode ...;
19362 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19363 Context
:= Unit
(Parent
(Context
));
19366 -- The pragma appears within package declarations
19368 if Nkind
(Context
) = N_Package_Specification
then
19369 Spec_Id
:= Defining_Entity
(Context
);
19370 Check_Library_Level_Entity
(Spec_Id
);
19372 -- The pragma is at the top of the visible declarations
19375 -- pragma SPARK_Mode ...;
19377 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19378 Check_Pragma_Conformance
19379 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19380 Entity_Pragma
=> Empty
,
19382 SPARK_Mode_Pragma
:= N
;
19383 SPARK_Mode
:= Mode_Id
;
19385 Set_SPARK_Pragma
(Spec_Id
, N
);
19386 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19387 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19388 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19390 -- The pragma is at the top of the private declarations
19394 -- pragma SPARK_Mode ...;
19397 Check_Pragma_Conformance
19398 (Context_Pragma
=> Empty
,
19399 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19400 Entity
=> Spec_Id
);
19401 SPARK_Mode_Pragma
:= N
;
19402 SPARK_Mode
:= Mode_Id
;
19404 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19405 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19408 -- The pragma appears at the top of package body declarations
19410 -- package body Pack is
19411 -- pragma SPARK_Mode ...;
19413 elsif Nkind
(Context
) = N_Package_Body
then
19414 Spec_Id
:= Corresponding_Spec
(Context
);
19415 Body_Id
:= Defining_Entity
(Context
);
19416 Check_Library_Level_Entity
(Body_Id
);
19417 Check_Pragma_Conformance
19418 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19419 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19420 Entity
=> Spec_Id
);
19421 SPARK_Mode_Pragma
:= N
;
19422 SPARK_Mode
:= Mode_Id
;
19424 Set_SPARK_Pragma
(Body_Id
, N
);
19425 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19426 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19427 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19429 -- The pragma appears at the top of package body statements
19431 -- package body Pack is
19433 -- pragma SPARK_Mode;
19435 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19436 and then Nkind
(Parent
(Context
)) = N_Package_Body
19438 Context
:= Parent
(Context
);
19439 Spec_Id
:= Corresponding_Spec
(Context
);
19440 Body_Id
:= Defining_Entity
(Context
);
19441 Check_Library_Level_Entity
(Body_Id
);
19442 Check_Pragma_Conformance
19443 (Context_Pragma
=> Empty
,
19444 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19445 Entity
=> Body_Id
);
19446 SPARK_Mode_Pragma
:= N
;
19447 SPARK_Mode
:= Mode_Id
;
19449 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19450 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19452 -- The pragma appeared as an aspect of a [generic] subprogram
19453 -- declaration that acts as a compilation unit.
19456 -- procedure Proc ...;
19457 -- pragma SPARK_Mode ...;
19459 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19460 N_Subprogram_Declaration
)
19462 Spec_Id
:= Defining_Entity
(Context
);
19463 Check_Library_Level_Entity
(Spec_Id
);
19464 Check_Pragma_Conformance
19465 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19466 Entity_Pragma
=> Empty
,
19469 Set_SPARK_Pragma
(Spec_Id
, N
);
19470 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19472 -- The pragma appears at the top of subprogram body
19475 -- procedure Proc ... is
19476 -- pragma SPARK_Mode;
19478 elsif Nkind
(Context
) = N_Subprogram_Body
then
19479 Spec_Id
:= Corresponding_Spec
(Context
);
19480 Context
:= Specification
(Context
);
19481 Body_Id
:= Defining_Entity
(Context
);
19483 -- Ignore pragma when applied to the special body created
19484 -- for inlining, recognized by its internal name _Parent.
19486 if Chars
(Body_Id
) = Name_uParent
then
19490 Check_Library_Level_Entity
(Body_Id
);
19492 -- The body is a completion of a previous declaration
19494 if Present
(Spec_Id
) then
19495 Check_Pragma_Conformance
19496 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19497 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19498 Entity
=> Spec_Id
);
19500 -- The body acts as spec
19503 Check_Pragma_Conformance
19504 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19505 Entity_Pragma
=> Empty
,
19509 SPARK_Mode_Pragma
:= N
;
19510 SPARK_Mode
:= Mode_Id
;
19512 Set_SPARK_Pragma
(Body_Id
, N
);
19513 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19515 -- The pragma does not apply to a legal construct, issue error
19523 --------------------------------
19524 -- Static_Elaboration_Desired --
19525 --------------------------------
19527 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19529 when Pragma_Static_Elaboration_Desired
=>
19531 Check_At_Most_N_Arguments
(1);
19533 if Is_Compilation_Unit
(Current_Scope
)
19534 and then Ekind
(Current_Scope
) = E_Package
19536 Set_Static_Elaboration_Desired
(Current_Scope
, True);
19538 Error_Pragma
("pragma% must apply to a library-level package");
19545 -- pragma Storage_Size (EXPRESSION);
19547 when Pragma_Storage_Size
=> Storage_Size
: declare
19548 P
: constant Node_Id
:= Parent
(N
);
19552 Check_No_Identifiers
;
19553 Check_Arg_Count
(1);
19555 -- The expression must be analyzed in the special manner described
19556 -- in "Handling of Default Expressions" in sem.ads.
19558 Arg
:= Get_Pragma_Arg
(Arg1
);
19559 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
19561 if not Is_OK_Static_Expression
(Arg
) then
19562 Check_Restriction
(Static_Storage_Size
, Arg
);
19565 if Nkind
(P
) /= N_Task_Definition
then
19570 if Has_Storage_Size_Pragma
(P
) then
19571 Error_Pragma
("duplicate pragma% not allowed");
19573 Set_Has_Storage_Size_Pragma
(P
, True);
19576 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
19584 -- pragma Storage_Unit (NUMERIC_LITERAL);
19586 -- Only permitted argument is System'Storage_Unit value
19588 when Pragma_Storage_Unit
=>
19589 Check_No_Identifiers
;
19590 Check_Arg_Count
(1);
19591 Check_Arg_Is_Integer_Literal
(Arg1
);
19593 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
19594 UI_From_Int
(Ttypes
.System_Storage_Unit
)
19596 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
19598 ("the only allowed argument for pragma% is ^", Arg1
);
19601 --------------------
19602 -- Stream_Convert --
19603 --------------------
19605 -- pragma Stream_Convert (
19606 -- [Entity =>] type_LOCAL_NAME,
19607 -- [Read =>] function_NAME,
19608 -- [Write =>] function NAME);
19610 when Pragma_Stream_Convert
=> Stream_Convert
: declare
19612 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
19613 -- Check that the given argument is the name of a local function
19614 -- of one argument that is not overloaded earlier in the current
19615 -- local scope. A check is also made that the argument is a
19616 -- function with one parameter.
19618 --------------------------------------
19619 -- Check_OK_Stream_Convert_Function --
19620 --------------------------------------
19622 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
19626 Check_Arg_Is_Local_Name
(Arg
);
19627 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
19629 if Has_Homonym
(Ent
) then
19631 ("argument for pragma% may not be overloaded", Arg
);
19634 if Ekind
(Ent
) /= E_Function
19635 or else No
(First_Formal
(Ent
))
19636 or else Present
(Next_Formal
(First_Formal
(Ent
)))
19639 ("argument for pragma% must be function of one argument",
19642 end Check_OK_Stream_Convert_Function
;
19644 -- Start of processing for Stream_Convert
19648 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
19649 Check_Arg_Count
(3);
19650 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19651 Check_Optional_Identifier
(Arg2
, Name_Read
);
19652 Check_Optional_Identifier
(Arg3
, Name_Write
);
19653 Check_Arg_Is_Local_Name
(Arg1
);
19654 Check_OK_Stream_Convert_Function
(Arg2
);
19655 Check_OK_Stream_Convert_Function
(Arg3
);
19658 Typ
: constant Entity_Id
:=
19659 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
19660 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
19661 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
19664 Check_First_Subtype
(Arg1
);
19666 -- Check for too early or too late. Note that we don't enforce
19667 -- the rule about primitive operations in this case, since, as
19668 -- is the case for explicit stream attributes themselves, these
19669 -- restrictions are not appropriate. Note that the chaining of
19670 -- the pragma by Rep_Item_Too_Late is actually the critical
19671 -- processing done for this pragma.
19673 if Rep_Item_Too_Early
(Typ
, N
)
19675 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
19680 -- Return if previous error
19682 if Etype
(Typ
) = Any_Type
19684 Etype
(Read
) = Any_Type
19686 Etype
(Write
) = Any_Type
19693 if Underlying_Type
(Etype
(Read
)) /= Typ
then
19695 ("incorrect return type for function&", Arg2
);
19698 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
19700 ("incorrect parameter type for function&", Arg3
);
19703 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
19704 Underlying_Type
(Etype
(Write
))
19707 ("result type of & does not match Read parameter type",
19711 end Stream_Convert
;
19717 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
19719 -- This is processed by the parser since some of the style checks
19720 -- take place during source scanning and parsing. This means that
19721 -- we don't need to issue error messages here.
19723 when Pragma_Style_Checks
=> Style_Checks
: declare
19724 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19730 Check_No_Identifiers
;
19732 -- Two argument form
19734 if Arg_Count
= 2 then
19735 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19742 E_Id
:= Get_Pragma_Arg
(Arg2
);
19745 if not Is_Entity_Name
(E_Id
) then
19747 ("second argument of pragma% must be entity name",
19751 E
:= Entity
(E_Id
);
19753 if not Ignore_Style_Checks_Pragmas
then
19758 Set_Suppress_Style_Checks
19759 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
19760 exit when No
(Homonym
(E
));
19767 -- One argument form
19770 Check_Arg_Count
(1);
19772 if Nkind
(A
) = N_String_Literal
then
19776 Slen
: constant Natural := Natural (String_Length
(S
));
19777 Options
: String (1 .. Slen
);
19783 C
:= Get_String_Char
(S
, Int
(J
));
19784 exit when not In_Character_Range
(C
);
19785 Options
(J
) := Get_Character
(C
);
19787 -- If at end of string, set options. As per discussion
19788 -- above, no need to check for errors, since we issued
19789 -- them in the parser.
19792 if not Ignore_Style_Checks_Pragmas
then
19793 Set_Style_Check_Options
(Options
);
19803 elsif Nkind
(A
) = N_Identifier
then
19804 if Chars
(A
) = Name_All_Checks
then
19805 if not Ignore_Style_Checks_Pragmas
then
19807 Set_GNAT_Style_Check_Options
;
19809 Set_Default_Style_Check_Options
;
19813 elsif Chars
(A
) = Name_On
then
19814 if not Ignore_Style_Checks_Pragmas
then
19815 Style_Check
:= True;
19818 elsif Chars
(A
) = Name_Off
then
19819 if not Ignore_Style_Checks_Pragmas
then
19820 Style_Check
:= False;
19831 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
19833 when Pragma_Subtitle
=>
19835 Check_Arg_Count
(1);
19836 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
19837 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19844 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
19846 when Pragma_Suppress
=>
19847 Process_Suppress_Unsuppress
(True);
19853 -- pragma Suppress_All;
19855 -- The only check made here is that the pragma has no arguments.
19856 -- There are no placement rules, and the processing required (setting
19857 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
19858 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
19859 -- then creates and inserts a pragma Suppress (All_Checks).
19861 when Pragma_Suppress_All
=>
19863 Check_Arg_Count
(0);
19865 -------------------------
19866 -- Suppress_Debug_Info --
19867 -------------------------
19869 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
19871 when Pragma_Suppress_Debug_Info
=>
19873 Check_Arg_Count
(1);
19874 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19875 Check_Arg_Is_Local_Name
(Arg1
);
19876 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
19878 ----------------------------------
19879 -- Suppress_Exception_Locations --
19880 ----------------------------------
19882 -- pragma Suppress_Exception_Locations;
19884 when Pragma_Suppress_Exception_Locations
=>
19886 Check_Arg_Count
(0);
19887 Check_Valid_Configuration_Pragma
;
19888 Exception_Locations_Suppressed
:= True;
19890 -----------------------------
19891 -- Suppress_Initialization --
19892 -----------------------------
19894 -- pragma Suppress_Initialization ([Entity =>] type_Name);
19896 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
19902 Check_Arg_Count
(1);
19903 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19904 Check_Arg_Is_Local_Name
(Arg1
);
19906 E_Id
:= Get_Pragma_Arg
(Arg1
);
19908 if Etype
(E_Id
) = Any_Type
then
19912 E
:= Entity
(E_Id
);
19914 if not Is_Type
(E
) then
19915 Error_Pragma_Arg
("pragma% requires type or subtype", Arg1
);
19918 if Rep_Item_Too_Early
(E
, N
)
19920 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
19925 -- For incomplete/private type, set flag on full view
19927 if Is_Incomplete_Or_Private_Type
(E
) then
19928 if No
(Full_View
(Base_Type
(E
))) then
19930 ("argument of pragma% cannot be an incomplete type", Arg1
);
19932 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
19935 -- For first subtype, set flag on base type
19937 elsif Is_First_Subtype
(E
) then
19938 Set_Suppress_Initialization
(Base_Type
(E
));
19940 -- For other than first subtype, set flag on subtype itself
19943 Set_Suppress_Initialization
(E
);
19951 -- pragma System_Name (DIRECT_NAME);
19953 -- Syntax check: one argument, which must be the identifier GNAT or
19954 -- the identifier GCC, no other identifiers are acceptable.
19956 when Pragma_System_Name
=>
19958 Check_No_Identifiers
;
19959 Check_Arg_Count
(1);
19960 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
19962 -----------------------------
19963 -- Task_Dispatching_Policy --
19964 -----------------------------
19966 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
19968 when Pragma_Task_Dispatching_Policy
=> declare
19972 Check_Ada_83_Warning
;
19973 Check_Arg_Count
(1);
19974 Check_No_Identifiers
;
19975 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
19976 Check_Valid_Configuration_Pragma
;
19977 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19978 DP
:= Fold_Upper
(Name_Buffer
(1));
19980 if Task_Dispatching_Policy
/= ' '
19981 and then Task_Dispatching_Policy
/= DP
19983 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19985 ("task dispatching policy incompatible with policy#");
19987 -- Set new policy, but always preserve System_Location since we
19988 -- like the error message with the run time name.
19991 Task_Dispatching_Policy
:= DP
;
19993 if Task_Dispatching_Policy_Sloc
/= System_Location
then
19994 Task_Dispatching_Policy_Sloc
:= Loc
;
20003 -- pragma Task_Info (EXPRESSION);
20005 when Pragma_Task_Info
=> Task_Info
: declare
20006 P
: constant Node_Id
:= Parent
(N
);
20012 if Warn_On_Obsolescent_Feature
then
20014 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20015 & "instead?j?", N
);
20018 if Nkind
(P
) /= N_Task_Definition
then
20019 Error_Pragma
("pragma% must appear in task definition");
20022 Check_No_Identifiers
;
20023 Check_Arg_Count
(1);
20025 Analyze_And_Resolve
20026 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20028 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20032 Ent
:= Defining_Identifier
(Parent
(P
));
20034 -- Check duplicate pragma before we chain the pragma in the Rep
20035 -- Item chain of Ent.
20038 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20040 Error_Pragma
("duplicate pragma% not allowed");
20043 Record_Rep_Item
(Ent
, N
);
20050 -- pragma Task_Name (string_EXPRESSION);
20052 when Pragma_Task_Name
=> Task_Name
: declare
20053 P
: constant Node_Id
:= Parent
(N
);
20058 Check_No_Identifiers
;
20059 Check_Arg_Count
(1);
20061 Arg
:= Get_Pragma_Arg
(Arg1
);
20063 -- The expression is used in the call to Create_Task, and must be
20064 -- expanded there, not in the context of the current spec. It must
20065 -- however be analyzed to capture global references, in case it
20066 -- appears in a generic context.
20068 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20070 if Nkind
(P
) /= N_Task_Definition
then
20074 Ent
:= Defining_Identifier
(Parent
(P
));
20076 -- Check duplicate pragma before we chain the pragma in the Rep
20077 -- Item chain of Ent.
20080 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20082 Error_Pragma
("duplicate pragma% not allowed");
20085 Record_Rep_Item
(Ent
, N
);
20092 -- pragma Task_Storage (
20093 -- [Task_Type =>] LOCAL_NAME,
20094 -- [Top_Guard =>] static_integer_EXPRESSION);
20096 when Pragma_Task_Storage
=> Task_Storage
: declare
20097 Args
: Args_List
(1 .. 2);
20098 Names
: constant Name_List
(1 .. 2) := (
20102 Task_Type
: Node_Id
renames Args
(1);
20103 Top_Guard
: Node_Id
renames Args
(2);
20109 Gather_Associations
(Names
, Args
);
20111 if No
(Task_Type
) then
20113 ("missing task_type argument for pragma%");
20116 Check_Arg_Is_Local_Name
(Task_Type
);
20118 Ent
:= Entity
(Task_Type
);
20120 if not Is_Task_Type
(Ent
) then
20122 ("argument for pragma% must be task type", Task_Type
);
20125 if No
(Top_Guard
) then
20127 ("pragma% takes two arguments", Task_Type
);
20129 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20132 Check_First_Subtype
(Task_Type
);
20134 if Rep_Item_Too_Late
(Ent
, N
) then
20143 -- pragma Test_Case
20144 -- ([Name =>] Static_String_EXPRESSION
20145 -- ,[Mode =>] MODE_TYPE
20146 -- [, Requires => Boolean_EXPRESSION]
20147 -- [, Ensures => Boolean_EXPRESSION]);
20149 -- MODE_TYPE ::= Nominal | Robustness
20151 when Pragma_Test_Case
=>
20155 --------------------------
20156 -- Thread_Local_Storage --
20157 --------------------------
20159 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20161 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20167 Check_Arg_Count
(1);
20168 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20169 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20171 Id
:= Get_Pragma_Arg
(Arg1
);
20174 if not Is_Entity_Name
(Id
)
20175 or else Ekind
(Entity
(Id
)) /= E_Variable
20177 Error_Pragma_Arg
("local variable name required", Arg1
);
20182 if Rep_Item_Too_Early
(E
, N
)
20183 or else Rep_Item_Too_Late
(E
, N
)
20188 Set_Has_Pragma_Thread_Local_Storage
(E
);
20189 Set_Has_Gigi_Rep_Item
(E
);
20190 end Thread_Local_Storage
;
20196 -- pragma Time_Slice (static_duration_EXPRESSION);
20198 when Pragma_Time_Slice
=> Time_Slice
: declare
20204 Check_Arg_Count
(1);
20205 Check_No_Identifiers
;
20206 Check_In_Main_Program
;
20207 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20209 if not Error_Posted
(Arg1
) then
20211 while Present
(Nod
) loop
20212 if Nkind
(Nod
) = N_Pragma
20213 and then Pragma_Name
(Nod
) = Name_Time_Slice
20215 Error_Msg_Name_1
:= Pname
;
20216 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20223 -- Process only if in main unit
20225 if Get_Source_Unit
(Loc
) = Main_Unit
then
20226 Opt
.Time_Slice_Set
:= True;
20227 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20229 if Val
<= Ureal_0
then
20230 Opt
.Time_Slice_Value
:= 0;
20232 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20233 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20236 Opt
.Time_Slice_Value
:=
20237 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20246 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20248 -- TITLING_OPTION ::=
20249 -- [Title =>] STRING_LITERAL
20250 -- | [Subtitle =>] STRING_LITERAL
20252 when Pragma_Title
=> Title
: declare
20253 Args
: Args_List
(1 .. 2);
20254 Names
: constant Name_List
(1 .. 2) := (
20260 Gather_Associations
(Names
, Args
);
20263 for J
in 1 .. 2 loop
20264 if Present
(Args
(J
)) then
20265 Check_Arg_Is_OK_Static_Expression
20266 (Args
(J
), Standard_String
);
20271 ----------------------------
20272 -- Type_Invariant[_Class] --
20273 ----------------------------
20275 -- pragma Type_Invariant[_Class]
20276 -- ([Entity =>] type_LOCAL_NAME,
20277 -- [Check =>] EXPRESSION);
20279 when Pragma_Type_Invariant |
20280 Pragma_Type_Invariant_Class
=>
20281 Type_Invariant
: declare
20282 I_Pragma
: Node_Id
;
20285 Check_Arg_Count
(2);
20287 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20288 -- setting Class_Present for the Type_Invariant_Class case.
20290 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20291 I_Pragma
:= New_Copy
(N
);
20292 Set_Pragma_Identifier
20293 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20294 Rewrite
(N
, I_Pragma
);
20295 Set_Analyzed
(N
, False);
20297 end Type_Invariant
;
20299 ---------------------
20300 -- Unchecked_Union --
20301 ---------------------
20303 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20305 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20306 Assoc
: constant Node_Id
:= Arg1
;
20307 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20317 Check_No_Identifiers
;
20318 Check_Arg_Count
(1);
20319 Check_Arg_Is_Local_Name
(Arg1
);
20321 Find_Type
(Type_Id
);
20323 Typ
:= Entity
(Type_Id
);
20326 or else Rep_Item_Too_Early
(Typ
, N
)
20330 Typ
:= Underlying_Type
(Typ
);
20333 if Rep_Item_Too_Late
(Typ
, N
) then
20337 Check_First_Subtype
(Arg1
);
20339 -- Note remaining cases are references to a type in the current
20340 -- declarative part. If we find an error, we post the error on
20341 -- the relevant type declaration at an appropriate point.
20343 if not Is_Record_Type
(Typ
) then
20344 Error_Msg_N
("unchecked union must be record type", Typ
);
20347 elsif Is_Tagged_Type
(Typ
) then
20348 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20351 elsif not Has_Discriminants
(Typ
) then
20353 ("unchecked union must have one discriminant", Typ
);
20356 -- Note: in previous versions of GNAT we used to check for limited
20357 -- types and give an error, but in fact the standard does allow
20358 -- Unchecked_Union on limited types, so this check was removed.
20360 -- Similarly, GNAT used to require that all discriminants have
20361 -- default values, but this is not mandated by the RM.
20363 -- Proceed with basic error checks completed
20366 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20367 Clist
:= Component_List
(Tdef
);
20369 -- Check presence of component list and variant part
20371 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20373 ("unchecked union must have variant part", Tdef
);
20377 -- Check components
20379 Comp
:= First
(Component_Items
(Clist
));
20380 while Present
(Comp
) loop
20381 Check_Component
(Comp
, Typ
);
20385 -- Check variant part
20387 Vpart
:= Variant_Part
(Clist
);
20389 Variant
:= First
(Variants
(Vpart
));
20390 while Present
(Variant
) loop
20391 Check_Variant
(Variant
, Typ
);
20396 Set_Is_Unchecked_Union
(Typ
);
20397 Set_Convention
(Typ
, Convention_C
);
20398 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20399 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20400 end Unchecked_Union
;
20402 ------------------------
20403 -- Unimplemented_Unit --
20404 ------------------------
20406 -- pragma Unimplemented_Unit;
20408 -- Note: this only gives an error if we are generating code, or if
20409 -- we are in a generic library unit (where the pragma appears in the
20410 -- body, not in the spec).
20412 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20413 Cunitent
: constant Entity_Id
:=
20414 Cunit_Entity
(Get_Source_Unit
(Loc
));
20415 Ent_Kind
: constant Entity_Kind
:=
20420 Check_Arg_Count
(0);
20422 if Operating_Mode
= Generate_Code
20423 or else Ent_Kind
= E_Generic_Function
20424 or else Ent_Kind
= E_Generic_Procedure
20425 or else Ent_Kind
= E_Generic_Package
20427 Get_Name_String
(Chars
(Cunitent
));
20428 Set_Casing
(Mixed_Case
);
20429 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20430 Write_Str
(" is not supported in this configuration");
20432 raise Unrecoverable_Error
;
20434 end Unimplemented_Unit
;
20436 ------------------------
20437 -- Universal_Aliasing --
20438 ------------------------
20440 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20442 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20447 Check_Arg_Count
(1);
20448 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20449 Check_Arg_Is_Local_Name
(Arg1
);
20450 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20452 if E_Id
= Any_Type
then
20454 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20455 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20458 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20459 Record_Rep_Item
(E_Id
, N
);
20460 end Universal_Alias
;
20462 --------------------
20463 -- Universal_Data --
20464 --------------------
20466 -- pragma Universal_Data [(library_unit_NAME)];
20468 when Pragma_Universal_Data
=>
20471 -- If this is a configuration pragma, then set the universal
20472 -- addressing option, otherwise confirm that the pragma satisfies
20473 -- the requirements of library unit pragma placement and leave it
20474 -- to the GNAAMP back end to detect the pragma (avoids transitive
20475 -- setting of the option due to withed units).
20477 if Is_Configuration_Pragma
then
20478 Universal_Addressing_On_AAMP
:= True;
20480 Check_Valid_Library_Unit_Pragma
;
20483 if not AAMP_On_Target
then
20484 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20491 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20493 when Pragma_Unmodified
=> Unmodified
: declare
20494 Arg_Node
: Node_Id
;
20495 Arg_Expr
: Node_Id
;
20496 Arg_Ent
: Entity_Id
;
20500 Check_At_Least_N_Arguments
(1);
20502 -- Loop through arguments
20505 while Present
(Arg_Node
) loop
20506 Check_No_Identifier
(Arg_Node
);
20508 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
20509 -- in fact generate reference, so that the entity will have a
20510 -- reference, which will inhibit any warnings about it not
20511 -- being referenced, and also properly show up in the ali file
20512 -- as a reference. But this reference is recorded before the
20513 -- Has_Pragma_Unreferenced flag is set, so that no warning is
20514 -- generated for this reference.
20516 Check_Arg_Is_Local_Name
(Arg_Node
);
20517 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20519 if Is_Entity_Name
(Arg_Expr
) then
20520 Arg_Ent
:= Entity
(Arg_Expr
);
20522 if not Is_Assignable
(Arg_Ent
) then
20524 ("pragma% can only be applied to a variable",
20527 Set_Has_Pragma_Unmodified
(Arg_Ent
);
20539 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
20541 -- or when used in a context clause:
20543 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
20545 when Pragma_Unreferenced
=> Unreferenced
: declare
20546 Arg_Node
: Node_Id
;
20547 Arg_Expr
: Node_Id
;
20548 Arg_Ent
: Entity_Id
;
20553 Check_At_Least_N_Arguments
(1);
20555 -- Check case of appearing within context clause
20557 if Is_In_Context_Clause
then
20559 -- The arguments must all be units mentioned in a with clause
20560 -- in the same context clause. Note we already checked (in
20561 -- Par.Prag) that the arguments are either identifiers or
20562 -- selected components.
20565 while Present
(Arg_Node
) loop
20566 Citem
:= First
(List_Containing
(N
));
20567 while Citem
/= N
loop
20568 if Nkind
(Citem
) = N_With_Clause
20570 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
20572 Set_Has_Pragma_Unreferenced
20575 (Library_Unit
(Citem
))));
20577 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
20586 ("argument of pragma% is not withed unit", Arg_Node
);
20592 -- Case of not in list of context items
20596 while Present
(Arg_Node
) loop
20597 Check_No_Identifier
(Arg_Node
);
20599 -- Note: the analyze call done by Check_Arg_Is_Local_Name
20600 -- will in fact generate reference, so that the entity will
20601 -- have a reference, which will inhibit any warnings about
20602 -- it not being referenced, and also properly show up in the
20603 -- ali file as a reference. But this reference is recorded
20604 -- before the Has_Pragma_Unreferenced flag is set, so that
20605 -- no warning is generated for this reference.
20607 Check_Arg_Is_Local_Name
(Arg_Node
);
20608 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20610 if Is_Entity_Name
(Arg_Expr
) then
20611 Arg_Ent
:= Entity
(Arg_Expr
);
20613 -- If the entity is overloaded, the pragma applies to the
20614 -- most recent overloading, as documented. In this case,
20615 -- name resolution does not generate a reference, so it
20616 -- must be done here explicitly.
20618 if Is_Overloaded
(Arg_Expr
) then
20619 Generate_Reference
(Arg_Ent
, N
);
20622 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
20630 --------------------------
20631 -- Unreferenced_Objects --
20632 --------------------------
20634 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
20636 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
20637 Arg_Node
: Node_Id
;
20638 Arg_Expr
: Node_Id
;
20642 Check_At_Least_N_Arguments
(1);
20645 while Present
(Arg_Node
) loop
20646 Check_No_Identifier
(Arg_Node
);
20647 Check_Arg_Is_Local_Name
(Arg_Node
);
20648 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20650 if not Is_Entity_Name
(Arg_Expr
)
20651 or else not Is_Type
(Entity
(Arg_Expr
))
20654 ("argument for pragma% must be type or subtype", Arg_Node
);
20657 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
20660 end Unreferenced_Objects
;
20662 ------------------------------
20663 -- Unreserve_All_Interrupts --
20664 ------------------------------
20666 -- pragma Unreserve_All_Interrupts;
20668 when Pragma_Unreserve_All_Interrupts
=>
20670 Check_Arg_Count
(0);
20672 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
20673 Unreserve_All_Interrupts
:= True;
20680 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
20682 when Pragma_Unsuppress
=>
20684 Process_Suppress_Unsuppress
(False);
20686 ----------------------------
20687 -- Unevaluated_Use_Of_Old --
20688 ----------------------------
20690 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
20692 when Pragma_Unevaluated_Use_Of_Old
=>
20694 Check_Arg_Count
(1);
20695 Check_No_Identifiers
;
20696 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
20698 -- Suppress/Unsuppress can appear as a configuration pragma, or in
20699 -- a declarative part or a package spec.
20701 if not Is_Configuration_Pragma
then
20702 Check_Is_In_Decl_Part_Or_Package_Spec
;
20705 -- Store proper setting of Uneval_Old
20707 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20708 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
20710 -------------------
20711 -- Use_VADS_Size --
20712 -------------------
20714 -- pragma Use_VADS_Size;
20716 when Pragma_Use_VADS_Size
=>
20718 Check_Arg_Count
(0);
20719 Check_Valid_Configuration_Pragma
;
20720 Use_VADS_Size
:= True;
20722 ---------------------
20723 -- Validity_Checks --
20724 ---------------------
20726 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20728 when Pragma_Validity_Checks
=> Validity_Checks
: declare
20729 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20735 Check_Arg_Count
(1);
20736 Check_No_Identifiers
;
20738 -- Pragma always active unless in CodePeer or GNATprove modes,
20739 -- which use a fixed configuration of validity checks.
20741 if not (CodePeer_Mode
or GNATprove_Mode
) then
20742 if Nkind
(A
) = N_String_Literal
then
20746 Slen
: constant Natural := Natural (String_Length
(S
));
20747 Options
: String (1 .. Slen
);
20751 -- Couldn't we use a for loop here over Options'Range???
20755 C
:= Get_String_Char
(S
, Int
(J
));
20757 -- This is a weird test, it skips setting validity
20758 -- checks entirely if any element of S is out of
20759 -- range of Character, what is that about ???
20761 exit when not In_Character_Range
(C
);
20762 Options
(J
) := Get_Character
(C
);
20765 Set_Validity_Check_Options
(Options
);
20773 elsif Nkind
(A
) = N_Identifier
then
20774 if Chars
(A
) = Name_All_Checks
then
20775 Set_Validity_Check_Options
("a");
20776 elsif Chars
(A
) = Name_On
then
20777 Validity_Checks_On
:= True;
20778 elsif Chars
(A
) = Name_Off
then
20779 Validity_Checks_On
:= False;
20783 end Validity_Checks
;
20789 -- pragma Volatile (LOCAL_NAME);
20791 when Pragma_Volatile
=>
20792 Process_Atomic_Shared_Volatile
;
20794 -------------------------
20795 -- Volatile_Components --
20796 -------------------------
20798 -- pragma Volatile_Components (array_LOCAL_NAME);
20800 -- Volatile is handled by the same circuit as Atomic_Components
20802 ----------------------
20803 -- Warning_As_Error --
20804 ----------------------
20806 -- pragma Warning_As_Error (static_string_EXPRESSION);
20808 when Pragma_Warning_As_Error
=>
20810 Check_Arg_Count
(1);
20811 Check_No_Identifiers
;
20812 Check_Valid_Configuration_Pragma
;
20814 if not Is_Static_String_Expression
(Arg1
) then
20816 ("argument of pragma% must be static string expression",
20819 -- OK static string expression
20822 Acquire_Warning_Match_String
(Arg1
);
20823 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
20824 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
20825 new String'(Name_Buffer (1 .. Name_Len));
20832 -- pragma Warnings (On | Off [,REASON]);
20833 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
20834 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
20835 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
20837 -- REASON ::= Reason => Static_String_Expression
20839 when Pragma_Warnings => Warnings : declare
20840 Reason : String_Id;
20844 Check_At_Least_N_Arguments (1);
20846 -- See if last argument is labeled Reason. If so, make sure we
20847 -- have a static string expression, and acquire the REASON string.
20848 -- Then remove the REASON argument by decreasing Num_Args by one;
20849 -- Remaining processing looks only at first Num_Args arguments).
20852 Last_Arg : constant Node_Id :=
20853 Last (Pragma_Argument_Associations (N));
20856 if Nkind (Last_Arg) = N_Pragma_Argument_Association
20857 and then Chars (Last_Arg) = Name_Reason
20860 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
20861 Reason := End_String;
20862 Arg_Count := Arg_Count - 1;
20864 -- Not allowed in compiler units (bootstrap issues)
20866 Check_Compiler_Unit ("Reason for pragma Warnings", N);
20868 -- No REASON string, set null string as reason
20871 Reason := Null_String_Id;
20875 -- Now proceed with REASON taken care of and eliminated
20877 Check_No_Identifiers;
20879 -- If debug flag -gnatd.i is set, pragma is ignored
20881 if Debug_Flag_Dot_I then
20885 -- Process various forms of the pragma
20888 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
20891 -- One argument case
20893 if Arg_Count = 1 then
20895 -- On/Off one argument case was processed by parser
20897 if Nkind (Argx) = N_Identifier
20898 and then Nam_In (Chars (Argx), Name_On, Name_Off)
20902 -- One argument case must be ON/OFF or static string expr
20904 elsif not Is_Static_String_Expression (Arg1) then
20906 ("argument of pragma% must be On/Off or static string "
20907 & "expression", Arg1);
20909 -- One argument string expression case
20913 Lit : constant Node_Id := Expr_Value_S (Argx);
20914 Str : constant String_Id := Strval (Lit);
20915 Len : constant Nat := String_Length (Str);
20923 while J <= Len loop
20924 C := Get_String_Char (Str, J);
20925 OK := In_Character_Range (C);
20928 Chr := Get_Character (C);
20930 -- Dash case: only -Wxxx is accepted
20937 C := Get_String_Char (Str, J);
20938 Chr := Get_Character (C);
20939 exit when Chr = 'W
';
20944 elsif J < Len and then Chr = '.' then
20946 C := Get_String_Char (Str, J);
20947 Chr := Get_Character (C);
20949 if not Set_Dot_Warning_Switch (Chr) then
20951 ("invalid warning switch character "
20952 & '.' & Chr, Arg1);
20958 OK := Set_Warning_Switch (Chr);
20964 ("invalid warning switch character " & Chr,
20973 -- Two or more arguments (must be two)
20976 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20977 Check_Arg_Count (2);
20985 E_Id := Get_Pragma_Arg (Arg2);
20988 -- In the expansion of an inlined body, a reference to
20989 -- the formal may be wrapped in a conversion if the
20990 -- actual is a conversion. Retrieve the real entity name.
20992 if (In_Instance_Body or In_Inlined_Body)
20993 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
20995 E_Id := Expression (E_Id);
20998 -- Entity name case
21000 if Is_Entity_Name (E_Id) then
21001 E := Entity (E_Id);
21008 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21011 -- For OFF case, make entry in warnings off
21012 -- pragma table for later processing. But we do
21013 -- not do that within an instance, since these
21014 -- warnings are about what is needed in the
21015 -- template, not an instance of it.
21017 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21018 and then Warn_On_Warnings_Off
21019 and then not In_Instance
21021 Warnings_Off_Pragmas.Append ((N, E, Reason));
21024 if Is_Enumeration_Type (E) then
21028 Lit := First_Literal (E);
21029 while Present (Lit) loop
21030 Set_Warnings_Off (Lit);
21031 Next_Literal (Lit);
21036 exit when No (Homonym (E));
21041 -- Error if not entity or static string expression case
21043 elsif not Is_Static_String_Expression (Arg2) then
21045 ("second argument of pragma% must be entity name "
21046 & "or static string expression", Arg2);
21048 -- Static string expression case
21051 Acquire_Warning_Match_String (Arg2);
21053 -- Note on configuration pragma case: If this is a
21054 -- configuration pragma, then for an OFF pragma, we
21055 -- just set Config True in the call, which is all
21056 -- that needs to be done. For the case of ON, this
21057 -- is normally an error, unless it is canceling the
21058 -- effect of a previous OFF pragma in the same file.
21059 -- In any other case, an error will be signalled (ON
21060 -- with no matching OFF).
21062 -- Note: We set Used if we are inside a generic to
21063 -- disable the test that the non-config case actually
21064 -- cancels a warning. That's because we can't be sure
21065 -- there isn't an instantiation in some other unit
21066 -- where a warning is suppressed.
21068 -- We could do a little better here by checking if the
21069 -- generic unit we are inside is public, but for now
21070 -- we don't bother with that refinement.
21072 if Chars (Argx) = Name_Off then
21073 Set_Specific_Warning_Off
21074 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21075 Config => Is_Configuration_Pragma,
21076 Used => Inside_A_Generic or else In_Instance);
21078 elsif Chars (Argx) = Name_On then
21079 Set_Specific_Warning_On
21080 (Loc, Name_Buffer (1 .. Name_Len), Err);
21084 ("??pragma Warnings On with no matching "
21085 & "Warnings Off", Loc);
21094 -------------------
21095 -- Weak_External --
21096 -------------------
21098 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21100 when Pragma_Weak_External => Weak_External : declare
21105 Check_Arg_Count (1);
21106 Check_Optional_Identifier (Arg1, Name_Entity);
21107 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21108 Ent := Entity (Get_Pragma_Arg (Arg1));
21110 if Rep_Item_Too_Early (Ent, N) then
21113 Ent := Underlying_Type (Ent);
21116 -- The only processing required is to link this item on to the
21117 -- list of rep items for the given entity. This is accomplished
21118 -- by the call to Rep_Item_Too_Late (when no error is detected
21119 -- and False is returned).
21121 if Rep_Item_Too_Late (Ent, N) then
21124 Set_Has_Gigi_Rep_Item (Ent);
21128 -----------------------------
21129 -- Wide_Character_Encoding --
21130 -----------------------------
21132 -- pragma Wide_Character_Encoding (IDENTIFIER);
21134 when Pragma_Wide_Character_Encoding =>
21137 -- Nothing to do, handled in parser. Note that we do not enforce
21138 -- configuration pragma placement, this pragma can appear at any
21139 -- place in the source, allowing mixed encodings within a single
21144 --------------------
21145 -- Unknown_Pragma --
21146 --------------------
21148 -- Should be impossible, since the case of an unknown pragma is
21149 -- separately processed before the case statement is entered.
21151 when Unknown_Pragma =>
21152 raise Program_Error;
21155 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21156 -- until AI is formally approved.
21158 -- Check_Order_Dependence;
21161 when Pragma_Exit => null;
21162 end Analyze_Pragma;
21164 ---------------------------------------------
21165 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21166 ---------------------------------------------
21168 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21170 Subp_Id : Entity_Id)
21172 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21173 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21176 Restore_Scope : Boolean := False;
21177 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21180 -- Ensure that the subprogram and its formals are visible when analyzing
21181 -- the expression of the pragma.
21183 if not In_Open_Scopes (Subp_Id) then
21184 Restore_Scope := True;
21185 Push_Scope (Subp_Id);
21186 Install_Formals (Subp_Id);
21189 -- Preanalyze the boolean expression, we treat this as a spec expression
21190 -- (i.e. similar to a default expression).
21192 Expr := Get_Pragma_Arg (Arg1);
21194 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21195 -- the original aspect expression, which is shared with the generated
21198 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21199 Expr := Expression (Corresponding_Aspect (Prag));
21202 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21204 -- For a class-wide condition, a reference to a controlling formal must
21205 -- be interpreted as having the class-wide type (or an access to such)
21206 -- so that the inherited condition can be properly applied to any
21207 -- overriding operation (see ARM12 6.6.1 (7)).
21209 if Class_Present (Prag) then
21210 Class_Wide_Condition : declare
21211 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21213 ACW : Entity_Id := Empty;
21214 -- Access to T'class, created if there is a controlling formal
21215 -- that is an access parameter.
21217 function Get_ACW return Entity_Id;
21218 -- If the expression has a reference to an controlling access
21219 -- parameter, create an access to T'class for the necessary
21220 -- conversions if one does not exist.
21222 function Process (N : Node_Id) return Traverse_Result;
21223 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21224 -- aspect for a primitive subprogram of a tagged type T, a name
21225 -- that denotes a formal parameter of type T is interpreted as
21226 -- having type T'Class. Similarly, a name that denotes a formal
21227 -- accessparameter of type access-to-T is interpreted as having
21228 -- type access-to-T'Class. This ensures the expression is well-
21229 -- defined for a primitive subprogram of a type descended from T.
21230 -- Note that this replacement is not done for selector names in
21231 -- parameter associations. These carry an entity for reference
21232 -- purposes, but semantically they are just identifiers.
21238 function Get_ACW return Entity_Id is
21239 Loc : constant Source_Ptr := Sloc (Prag);
21245 Make_Full_Type_Declaration (Loc,
21246 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21248 Make_Access_To_Object_Definition (Loc,
21249 Subtype_Indication =>
21250 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21251 All_Present => True));
21253 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21255 ACW := Defining_Identifier (Decl);
21256 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21266 function Process (N : Node_Id) return Traverse_Result is
21267 Loc : constant Source_Ptr := Sloc (N);
21271 if Is_Entity_Name (N)
21272 and then Present (Entity (N))
21273 and then Is_Formal (Entity (N))
21274 and then Nkind (Parent (N)) /= N_Type_Conversion
21276 (Nkind (Parent (N)) /= N_Parameter_Association
21277 or else N /= Selector_Name (Parent (N)))
21279 if Etype (Entity (N)) = T then
21280 Typ := Class_Wide_Type (T);
21282 elsif Is_Access_Type (Etype (Entity (N)))
21283 and then Designated_Type (Etype (Entity (N))) = T
21290 if Present (Typ) then
21292 Make_Type_Conversion (Loc,
21294 New_Occurrence_Of (Typ, Loc),
21295 Expression => New_Occurrence_Of (Entity (N), Loc)));
21296 Set_Etype (N, Typ);
21303 procedure Replace_Type is new Traverse_Proc (Process);
21305 -- Start of processing for Class_Wide_Condition
21308 if not Present (T) then
21310 -- Pre'Class/Post'Class aspect cases
21312 if From_Aspect_Specification (Prag) then
21313 if Nam = Name_uPre then
21314 Error_Msg_Name_1 := Name_Pre;
21316 Error_Msg_Name_1 := Name_Post;
21319 Error_Msg_Name_2 := Name_Class;
21322 ("aspect `%''%` can only be specified for a primitive "
21323 & "operation of a tagged type",
21324 Corresponding_Aspect (Prag));
21326 -- Pre_Class, Post_Class pragma cases
21329 if Nam = Name_uPre then
21330 Error_Msg_Name_1 := Name_Pre_Class;
21332 Error_Msg_Name_1 := Name_Post_Class;
21336 ("pragma% can only be specified for a primitive "
21337 & "operation of a tagged type",
21338 Corresponding_Aspect (Prag));
21342 Replace_Type (Get_Pragma_Arg (Arg1));
21343 end Class_Wide_Condition;
21346 -- Remove the subprogram from the scope stack now that the pre-analysis
21347 -- of the precondition/postcondition is done.
21349 if Restore_Scope then
21352 end Analyze_Pre_Post_Condition_In_Decl_Part;
21354 ------------------------------------------
21355 -- Analyze_Refined_Depends_In_Decl_Part --
21356 ------------------------------------------
21358 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21359 Dependencies : List_Id := No_List;
21361 -- The corresponding Depends pragma along with its clauses
21363 Matched_Items : Elist_Id := No_Elist;
21364 -- A list containing the entities of all successfully matched items
21365 -- found in pragma Depends.
21367 Refinements : List_Id := No_List;
21368 -- The clauses of pragma Refined_Depends
21370 Spec_Id : Entity_Id;
21371 -- The entity of the subprogram subject to pragma Refined_Depends
21373 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21374 -- Try to match a single dependency clause Dep_Clause against one or
21375 -- more refinement clauses found in list Refinements. Each successful
21376 -- match eliminates at least one refinement clause from Refinements.
21378 procedure Normalize_Clauses (Clauses : List_Id);
21379 -- Given a list of dependence or refinement clauses Clauses, normalize
21380 -- each clause by creating multiple dependencies with exactly one input
21383 procedure Report_Extra_Clauses;
21384 -- Emit an error for each extra clause found in list Refinements
21386 -----------------------------
21387 -- Check_Dependency_Clause --
21388 -----------------------------
21390 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21391 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21392 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21394 function Is_In_Out_State_Clause return Boolean;
21395 -- Determine whether dependence clause Dep_Clause denotes an abstract
21396 -- state that depends on itself (State => State).
21398 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21399 -- Determine whether item Item denotes an abstract state with visible
21400 -- null refinement.
21402 procedure Match_Items
21403 (Dep_Item : Node_Id;
21404 Ref_Item : Node_Id;
21405 Matched : out Boolean);
21406 -- Try to match dependence item Dep_Item against refinement item
21407 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21408 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21409 -- the following conformance scenarios is in effect:
21410 -- 1) Both items denote null
21411 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21412 -- 3) Both items denote attribute 'Result
21413 -- 4) Both items denote the same formal parameter
21414 -- 5) Both items denote the same variable
21415 -- 6) Dep_Item is an abstract state with visible null refinement
21416 -- and Ref_Item denotes null.
21417 -- 7) Dep_Item is an abstract state with visible null refinement
21418 -- and Ref_Item is Empty (special case).
21419 -- 8) Dep_Item is an abstract state with visible non-null
21420 -- refinement and Ref_Item denotes one of its constituents.
21421 -- 9) Dep_Item is an abstract state without a visible refinement
21422 -- and Ref_Item denotes the same state.
21423 -- When scenario 8 is in effect, the entity of the abstract state
21424 -- denoted by Dep_Item is added to list Refined_States.
21426 procedure Record_Item
(Item_Id
: Entity_Id
);
21427 -- Store the entity of an item denoted by Item_Id in Matched_Items
21429 ----------------------------
21430 -- Is_In_Out_State_Clause --
21431 ----------------------------
21433 function Is_In_Out_State_Clause
return Boolean is
21434 Dep_Input_Id
: Entity_Id
;
21435 Dep_Output_Id
: Entity_Id
;
21438 -- Detect the following clause:
21441 if Is_Entity_Name
(Dep_Input
)
21442 and then Is_Entity_Name
(Dep_Output
)
21444 -- Handle abstract views generated for limited with clauses
21446 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
21447 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
21450 Ekind
(Dep_Input_Id
) = E_Abstract_State
21451 and then Dep_Input_Id
= Dep_Output_Id
;
21455 end Is_In_Out_State_Clause
;
21457 ---------------------------
21458 -- Is_Null_Refined_State --
21459 ---------------------------
21461 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
21462 Item_Id
: Entity_Id
;
21465 if Is_Entity_Name
(Item
) then
21467 -- Handle abstract views generated for limited with clauses
21469 Item_Id
:= Available_View
(Entity_Of
(Item
));
21471 return Ekind
(Item_Id
) = E_Abstract_State
21472 and then Has_Null_Refinement
(Item_Id
);
21477 end Is_Null_Refined_State
;
21483 procedure Match_Items
21484 (Dep_Item
: Node_Id
;
21485 Ref_Item
: Node_Id
;
21486 Matched
: out Boolean)
21488 Dep_Item_Id
: Entity_Id
;
21489 Ref_Item_Id
: Entity_Id
;
21492 -- Assume that the two items do not match
21496 -- A null matches null or Empty (special case)
21498 if Nkind
(Dep_Item
) = N_Null
21499 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21503 -- Attribute 'Result matches attribute 'Result
21505 elsif Is_Attribute_Result
(Dep_Item
)
21506 and then Is_Attribute_Result
(Dep_Item
)
21510 -- Abstract states, formal parameters and variables
21512 elsif Is_Entity_Name
(Dep_Item
) then
21514 -- Handle abstract views generated for limited with clauses
21516 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
21518 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
21520 -- An abstract state with visible null refinement matches
21521 -- null or Empty (special case).
21523 if Has_Null_Refinement
(Dep_Item_Id
)
21524 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21526 Record_Item
(Dep_Item_Id
);
21529 -- An abstract state with visible non-null refinement
21530 -- matches one of its constituents.
21532 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
21533 if Is_Entity_Name
(Ref_Item
) then
21534 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
21536 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
, E_Variable
)
21537 and then Present
(Encapsulating_State
(Ref_Item_Id
))
21538 and then Encapsulating_State
(Ref_Item_Id
) =
21541 Record_Item
(Dep_Item_Id
);
21546 -- An abstract state without a visible refinement matches
21549 elsif Is_Entity_Name
(Ref_Item
)
21550 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
21552 Record_Item
(Dep_Item_Id
);
21556 -- A formal parameter or a variable matches itself
21558 elsif Is_Entity_Name
(Ref_Item
)
21559 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
21561 Record_Item
(Dep_Item_Id
);
21571 procedure Record_Item
(Item_Id
: Entity_Id
) is
21573 if not Contains
(Matched_Items
, Item_Id
) then
21574 Add_Item
(Item_Id
, Matched_Items
);
21580 Clause_Matched
: Boolean := False;
21581 Dummy
: Boolean := False;
21582 Inputs_Match
: Boolean;
21583 Next_Ref_Clause
: Node_Id
;
21584 Outputs_Match
: Boolean;
21585 Ref_Clause
: Node_Id
;
21586 Ref_Input
: Node_Id
;
21587 Ref_Output
: Node_Id
;
21589 -- Start of processing for Check_Dependency_Clause
21592 -- Examine all refinement clauses and compare them against the
21593 -- dependence clause.
21595 Ref_Clause
:= First
(Refinements
);
21596 while Present
(Ref_Clause
) loop
21597 Next_Ref_Clause
:= Next
(Ref_Clause
);
21599 -- Obtain the attributes of the current refinement clause
21601 Ref_Input
:= Expression
(Ref_Clause
);
21602 Ref_Output
:= First
(Choices
(Ref_Clause
));
21604 -- The current refinement clause matches the dependence clause
21605 -- when both outputs match and both inputs match. See routine
21606 -- Match_Items for all possible conformance scenarios.
21608 -- Depends Dep_Output => Dep_Input
21612 -- Refined_Depends Ref_Output => Ref_Input
21615 (Dep_Item
=> Dep_Input
,
21616 Ref_Item
=> Ref_Input
,
21617 Matched
=> Inputs_Match
);
21620 (Dep_Item
=> Dep_Output
,
21621 Ref_Item
=> Ref_Output
,
21622 Matched
=> Outputs_Match
);
21624 -- An In_Out state clause may be matched against a refinement with
21625 -- a null input or null output as long as the non-null side of the
21626 -- relation contains a valid constituent of the In_Out_State.
21628 if Is_In_Out_State_Clause
then
21630 -- Depends => (State => State)
21631 -- Refined_Depends => (null => Constit) -- OK
21634 and then not Outputs_Match
21635 and then Nkind
(Ref_Output
) = N_Null
21637 Outputs_Match
:= True;
21640 -- Depends => (State => State)
21641 -- Refined_Depends => (Constit => null) -- OK
21643 if not Inputs_Match
21644 and then Outputs_Match
21645 and then Nkind
(Ref_Input
) = N_Null
21647 Inputs_Match
:= True;
21651 -- The current refinement clause is legally constructed following
21652 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
21653 -- the pool of candidates. The seach continues because a single
21654 -- dependence clause may have multiple matching refinements.
21656 if Inputs_Match
and then Outputs_Match
then
21657 Clause_Matched
:= True;
21658 Remove
(Ref_Clause
);
21661 Ref_Clause
:= Next_Ref_Clause
;
21664 -- Depending on the order or composition of refinement clauses, an
21665 -- In_Out state clause may not be directly refinable.
21667 -- Depends => ((Output, State) => (Input, State))
21668 -- Refined_State => (State => (Constit_1, Constit_2))
21669 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
21671 -- Matching normalized clause (State => State) fails because there is
21672 -- no direct refinement capable of satisfying this relation. Another
21673 -- similar case arises when clauses (Constit_1 => Input) and (Output
21674 -- => Constit_2) are matched first, leaving no candidates for clause
21675 -- (State => State). Both scenarios are legal as long as one of the
21676 -- previous clauses mentioned a valid constituent of State.
21678 if not Clause_Matched
21679 and then Is_In_Out_State_Clause
21681 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
21683 Clause_Matched
:= True;
21686 -- A clause where the input is an abstract state with visible null
21687 -- refinement is implicitly matched when the output has already been
21688 -- matched in a previous clause.
21690 -- Depends => (Output => State) -- implicitly OK
21691 -- Refined_State => (State => null)
21692 -- Refined_Depends => (Output => ...)
21694 if not Clause_Matched
21695 and then Is_Null_Refined_State
(Dep_Input
)
21696 and then Is_Entity_Name
(Dep_Output
)
21698 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
21700 Clause_Matched
:= True;
21703 -- A clause where the output is an abstract state with visible null
21704 -- refinement is implicitly matched when the input has already been
21705 -- matched in a previous clause.
21707 -- Depends => (State => Input) -- implicitly OK
21708 -- Refined_State => (State => null)
21709 -- Refined_Depends => (... => Input)
21711 if not Clause_Matched
21712 and then Is_Null_Refined_State
(Dep_Output
)
21713 and then Is_Entity_Name
(Dep_Input
)
21715 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
21717 Clause_Matched
:= True;
21720 -- At this point either all refinement clauses have been examined or
21721 -- pragma Refined_Depends contains a solitary null. Only an abstract
21722 -- state with null refinement can possibly match these cases.
21724 -- Depends => (State => null)
21725 -- Refined_State => (State => null)
21726 -- Refined_Depends => null -- OK
21728 if not Clause_Matched
then
21730 (Dep_Item
=> Dep_Input
,
21732 Matched
=> Inputs_Match
);
21735 (Dep_Item
=> Dep_Output
,
21737 Matched
=> Outputs_Match
);
21739 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
21742 -- If the contents of Refined_Depends are legal, then the current
21743 -- dependence clause should be satisfied either by an explicit match
21744 -- or by one of the special cases.
21746 if not Clause_Matched
then
21748 ("dependence clause of subprogram & has no matching refinement "
21749 & "in body", Dep_Clause
, Spec_Id
);
21751 end Check_Dependency_Clause
;
21753 -----------------------
21754 -- Normalize_Clauses --
21755 -----------------------
21757 procedure Normalize_Clauses
(Clauses
: List_Id
) is
21758 procedure Normalize_Inputs
(Clause
: Node_Id
);
21759 -- Normalize clause Clause by creating multiple clauses for each
21760 -- input item of Clause. It is assumed that Clause has exactly one
21761 -- output. The transformation is as follows:
21763 -- Output => (Input_1, Input_2) -- original
21765 -- Output => Input_1 -- normalizations
21766 -- Output => Input_2
21768 ----------------------
21769 -- Normalize_Inputs --
21770 ----------------------
21772 procedure Normalize_Inputs
(Clause
: Node_Id
) is
21773 Inputs
: constant Node_Id
:= Expression
(Clause
);
21774 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
21775 Output
: constant List_Id
:= Choices
(Clause
);
21776 Last_Input
: Node_Id
;
21778 New_Clause
: Node_Id
;
21779 Next_Input
: Node_Id
;
21782 -- Normalization is performed only when the original clause has
21783 -- more than one input. Multiple inputs appear as an aggregate.
21785 if Nkind
(Inputs
) = N_Aggregate
then
21786 Last_Input
:= Last
(Expressions
(Inputs
));
21788 -- Create a new clause for each input
21790 Input
:= First
(Expressions
(Inputs
));
21791 while Present
(Input
) loop
21792 Next_Input
:= Next
(Input
);
21794 -- Unhook the current input from the original input list
21795 -- because it will be relocated to a new clause.
21799 -- Special processing for the last input. At this point the
21800 -- original aggregate has been stripped down to one element.
21801 -- Replace the aggregate by the element itself.
21803 if Input
= Last_Input
then
21804 Rewrite
(Inputs
, Input
);
21806 -- Generate a clause of the form:
21811 Make_Component_Association
(Loc
,
21812 Choices
=> New_Copy_List_Tree
(Output
),
21813 Expression
=> Input
);
21815 -- The new clause contains replicated content that has
21816 -- already been analyzed, mark the clause as analyzed.
21818 Set_Analyzed
(New_Clause
);
21819 Insert_After
(Clause
, New_Clause
);
21822 Input
:= Next_Input
;
21825 end Normalize_Inputs
;
21831 -- Start of processing for Normalize_Clauses
21834 Clause
:= First
(Clauses
);
21835 while Present
(Clause
) loop
21836 Normalize_Inputs
(Clause
);
21839 end Normalize_Clauses
;
21841 --------------------------
21842 -- Report_Extra_Clauses --
21843 --------------------------
21845 procedure Report_Extra_Clauses
is
21849 if Present
(Refinements
) then
21850 Clause
:= First
(Refinements
);
21851 while Present
(Clause
) loop
21853 -- Do not complain about a null input refinement, since a null
21854 -- input legitimately matches anything.
21856 if Nkind
(Clause
) /= N_Component_Association
21857 or else Nkind
(Expression
(Clause
)) /= N_Null
21860 ("unmatched or extra clause in dependence refinement",
21867 end Report_Extra_Clauses
;
21871 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
21872 Errors
: constant Nat
:= Serious_Errors_Detected
;
21873 Refs
: constant Node_Id
:=
21874 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
21878 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
21881 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
21882 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
21884 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
21887 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
21889 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
21890 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
21892 if No
(Depends
) then
21894 ("useless refinement, declaration of subprogram & lacks aspect or "
21895 & "pragma Depends", N
, Spec_Id
);
21899 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
21901 -- A null dependency relation renders the refinement useless because it
21902 -- cannot possibly mention abstract states with visible refinement. Note
21903 -- that the inverse is not true as states may be refined to null
21904 -- (SPARK RM 7.2.5(2)).
21906 if Nkind
(Deps
) = N_Null
then
21908 ("useless refinement, subprogram & does not depend on abstract "
21909 & "state with visible refinement", N
, Spec_Id
);
21913 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
21914 -- This ensures that the categorization of all refined dependency items
21915 -- is consistent with their role.
21917 Analyze_Depends_In_Decl_Part
(N
);
21919 -- Do not match dependencies against refinements if Refined_Depends is
21920 -- illegal to avoid emitting misleading error.
21922 if Serious_Errors_Detected
= Errors
then
21924 -- Multiple dependency clauses appear as component associations of an
21925 -- aggregate. Note that the clauses are copied because the algorithm
21926 -- modifies them and this should not be visible in Depends.
21928 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
21929 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
21930 Normalize_Clauses
(Dependencies
);
21932 if Nkind
(Refs
) = N_Null
then
21933 Refinements
:= No_List
;
21935 -- Multiple dependency clauses appear as component associations of an
21936 -- aggregate. Note that the clauses are copied because the algorithm
21937 -- modifies them and this should not be visible in Refined_Depends.
21939 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
21940 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
21941 Normalize_Clauses
(Refinements
);
21944 -- At this point the clauses of pragmas Depends and Refined_Depends
21945 -- have been normalized into simple dependencies between one output
21946 -- and one input. Examine all clauses of pragma Depends looking for
21947 -- matching clauses in pragma Refined_Depends.
21949 Clause
:= First
(Dependencies
);
21950 while Present
(Clause
) loop
21951 Check_Dependency_Clause
(Clause
);
21955 if Serious_Errors_Detected
= Errors
then
21956 Report_Extra_Clauses
;
21959 end Analyze_Refined_Depends_In_Decl_Part
;
21961 -----------------------------------------
21962 -- Analyze_Refined_Global_In_Decl_Part --
21963 -----------------------------------------
21965 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
21967 -- The corresponding Global pragma
21969 Has_In_State
: Boolean := False;
21970 Has_In_Out_State
: Boolean := False;
21971 Has_Out_State
: Boolean := False;
21972 Has_Proof_In_State
: Boolean := False;
21973 -- These flags are set when the corresponding Global pragma has a state
21974 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
21977 Has_Null_State
: Boolean := False;
21978 -- This flag is set when the corresponding Global pragma has at least
21979 -- one state with a null refinement.
21981 In_Constits
: Elist_Id
:= No_Elist
;
21982 In_Out_Constits
: Elist_Id
:= No_Elist
;
21983 Out_Constits
: Elist_Id
:= No_Elist
;
21984 Proof_In_Constits
: Elist_Id
:= No_Elist
;
21985 -- These lists contain the entities of all Input, In_Out, Output and
21986 -- Proof_In constituents that appear in Refined_Global and participate
21987 -- in state refinement.
21989 In_Items
: Elist_Id
:= No_Elist
;
21990 In_Out_Items
: Elist_Id
:= No_Elist
;
21991 Out_Items
: Elist_Id
:= No_Elist
;
21992 Proof_In_Items
: Elist_Id
:= No_Elist
;
21993 -- These list contain the entities of all Input, In_Out, Output and
21994 -- Proof_In items defined in the corresponding Global pragma.
21996 procedure Check_In_Out_States
;
21997 -- Determine whether the corresponding Global pragma mentions In_Out
21998 -- states with visible refinement and if so, ensure that one of the
21999 -- following completions apply to the constituents of the state:
22000 -- 1) there is at least one constituent of mode In_Out
22001 -- 2) there is at least one Input and one Output constituent
22002 -- 3) not all constituents are present and one of them is of mode
22004 -- This routine may remove elements from In_Constits, In_Out_Constits,
22005 -- Out_Constits and Proof_In_Constits.
22007 procedure Check_Input_States
;
22008 -- Determine whether the corresponding Global pragma mentions Input
22009 -- states with visible refinement and if so, ensure that at least one of
22010 -- its constituents appears as an Input item in Refined_Global.
22011 -- This routine may remove elements from In_Constits, In_Out_Constits,
22012 -- Out_Constits and Proof_In_Constits.
22014 procedure Check_Output_States
;
22015 -- Determine whether the corresponding Global pragma mentions Output
22016 -- states with visible refinement and if so, ensure that all of its
22017 -- constituents appear as Output items in Refined_Global.
22018 -- This routine may remove elements from In_Constits, In_Out_Constits,
22019 -- Out_Constits and Proof_In_Constits.
22021 procedure Check_Proof_In_States
;
22022 -- Determine whether the corresponding Global pragma mentions Proof_In
22023 -- states with visible refinement and if so, ensure that at least one of
22024 -- its constituents appears as a Proof_In item in Refined_Global.
22025 -- This routine may remove elements from In_Constits, In_Out_Constits,
22026 -- Out_Constits and Proof_In_Constits.
22028 procedure Check_Refined_Global_List
22030 Global_Mode
: Name_Id
:= Name_Input
);
22031 -- Verify the legality of a single global list declaration. Global_Mode
22032 -- denotes the current mode in effect.
22034 function Present_Then_Remove
22036 Item
: Entity_Id
) return Boolean;
22037 -- Search List for a particular entity Item. If Item has been found,
22038 -- remove it from List. This routine is used to strip lists In_Constits,
22039 -- In_Out_Constits and Out_Constits of valid constituents.
22041 procedure Report_Extra_Constituents
;
22042 -- Emit an error for each constituent found in lists In_Constits,
22043 -- In_Out_Constits and Out_Constits.
22045 -------------------------
22046 -- Check_In_Out_States --
22047 -------------------------
22049 procedure Check_In_Out_States
is
22050 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22051 -- Determine whether one of the following coverage scenarios is in
22053 -- 1) there is at least one constituent of mode In_Out
22054 -- 2) there is at least one Input and one Output constituent
22055 -- 3) not all constituents are present and one of them is of mode
22057 -- If this is not the case, emit an error.
22059 -----------------------------
22060 -- Check_Constituent_Usage --
22061 -----------------------------
22063 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22064 Constit_Elmt
: Elmt_Id
;
22065 Constit_Id
: Entity_Id
;
22066 Has_Missing
: Boolean := False;
22067 In_Out_Seen
: Boolean := False;
22068 In_Seen
: Boolean := False;
22069 Out_Seen
: Boolean := False;
22072 -- Process all the constituents of the state and note their modes
22073 -- within the global refinement.
22075 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22076 while Present
(Constit_Elmt
) loop
22077 Constit_Id
:= Node
(Constit_Elmt
);
22079 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22082 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22083 In_Out_Seen
:= True;
22085 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22088 -- A Proof_In constituent cannot participate in the completion
22089 -- of an Output state (SPARK RM 7.2.4(5)).
22091 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22092 Error_Msg_Name_1
:= Chars
(State_Id
);
22094 ("constituent & of state % must have mode Input, In_Out "
22095 & "or Output in global refinement",
22099 Has_Missing
:= True;
22102 Next_Elmt
(Constit_Elmt
);
22105 -- A single In_Out constituent is a valid completion
22107 if In_Out_Seen
then
22110 -- A pair of one Input and one Output constituent is a valid
22113 elsif In_Seen
and then Out_Seen
then
22116 -- A single Output constituent is a valid completion only when
22117 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22119 elsif Has_Missing
and then Out_Seen
then
22124 ("global refinement of state & redefines the mode of its "
22125 & "constituents", N
, State_Id
);
22127 end Check_Constituent_Usage
;
22131 Item_Elmt
: Elmt_Id
;
22132 Item_Id
: Entity_Id
;
22134 -- Start of processing for Check_In_Out_States
22137 -- Inspect the In_Out items of the corresponding Global pragma
22138 -- looking for a state with a visible refinement.
22140 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22141 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22142 while Present
(Item_Elmt
) loop
22143 Item_Id
:= Node
(Item_Elmt
);
22145 -- Ensure that one of the three coverage variants is satisfied
22147 if Ekind
(Item_Id
) = E_Abstract_State
22148 and then Has_Non_Null_Refinement
(Item_Id
)
22150 Check_Constituent_Usage
(Item_Id
);
22153 Next_Elmt
(Item_Elmt
);
22156 end Check_In_Out_States
;
22158 ------------------------
22159 -- Check_Input_States --
22160 ------------------------
22162 procedure Check_Input_States
is
22163 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22164 -- Determine whether at least one constituent of state State_Id with
22165 -- visible refinement is used and has mode Input. Ensure that the
22166 -- remaining constituents do not have In_Out, Output or Proof_In
22169 -----------------------------
22170 -- Check_Constituent_Usage --
22171 -----------------------------
22173 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22174 Constit_Elmt
: Elmt_Id
;
22175 Constit_Id
: Entity_Id
;
22176 In_Seen
: Boolean := False;
22179 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22180 while Present
(Constit_Elmt
) loop
22181 Constit_Id
:= Node
(Constit_Elmt
);
22183 -- At least one of the constituents appears as an Input
22185 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22188 -- The constituent appears in the global refinement, but has
22189 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22191 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22192 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22193 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22195 Error_Msg_Name_1
:= Chars
(State_Id
);
22197 ("constituent & of state % must have mode Input in global "
22198 & "refinement", N
, Constit_Id
);
22201 Next_Elmt
(Constit_Elmt
);
22204 -- Not one of the constituents appeared as Input
22206 if not In_Seen
then
22208 ("global refinement of state & must include at least one "
22209 & "constituent of mode Input", N
, State_Id
);
22211 end Check_Constituent_Usage
;
22215 Item_Elmt
: Elmt_Id
;
22216 Item_Id
: Entity_Id
;
22218 -- Start of processing for Check_Input_States
22221 -- Inspect the Input items of the corresponding Global pragma
22222 -- looking for a state with a visible refinement.
22224 if Has_In_State
and then Present
(In_Items
) then
22225 Item_Elmt
:= First_Elmt
(In_Items
);
22226 while Present
(Item_Elmt
) loop
22227 Item_Id
:= Node
(Item_Elmt
);
22229 -- Ensure that at least one of the constituents is utilized and
22230 -- is of mode Input.
22232 if Ekind
(Item_Id
) = E_Abstract_State
22233 and then Has_Non_Null_Refinement
(Item_Id
)
22235 Check_Constituent_Usage
(Item_Id
);
22238 Next_Elmt
(Item_Elmt
);
22241 end Check_Input_States
;
22243 -------------------------
22244 -- Check_Output_States --
22245 -------------------------
22247 procedure Check_Output_States
is
22248 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22249 -- Determine whether all constituents of state State_Id with visible
22250 -- refinement are used and have mode Output. Emit an error if this is
22253 -----------------------------
22254 -- Check_Constituent_Usage --
22255 -----------------------------
22257 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22258 Constit_Elmt
: Elmt_Id
;
22259 Constit_Id
: Entity_Id
;
22260 Posted
: Boolean := False;
22263 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22264 while Present
(Constit_Elmt
) loop
22265 Constit_Id
:= Node
(Constit_Elmt
);
22267 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22270 -- The constituent appears in the global refinement, but has
22271 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22273 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22274 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22275 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22277 Error_Msg_Name_1
:= Chars
(State_Id
);
22279 ("constituent & of state % must have mode Output in "
22280 & "global refinement", N
, Constit_Id
);
22282 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22288 ("output state & must be replaced by all its "
22289 & "constituents in global refinement", N
, State_Id
);
22293 ("\constituent & is missing in output list",
22297 Next_Elmt
(Constit_Elmt
);
22299 end Check_Constituent_Usage
;
22303 Item_Elmt
: Elmt_Id
;
22304 Item_Id
: Entity_Id
;
22306 -- Start of processing for Check_Output_States
22309 -- Inspect the Output items of the corresponding Global pragma
22310 -- looking for a state with a visible refinement.
22312 if Has_Out_State
and then Present
(Out_Items
) then
22313 Item_Elmt
:= First_Elmt
(Out_Items
);
22314 while Present
(Item_Elmt
) loop
22315 Item_Id
:= Node
(Item_Elmt
);
22317 -- Ensure that all of the constituents are utilized and they
22318 -- have mode Output.
22320 if Ekind
(Item_Id
) = E_Abstract_State
22321 and then Has_Non_Null_Refinement
(Item_Id
)
22323 Check_Constituent_Usage
(Item_Id
);
22326 Next_Elmt
(Item_Elmt
);
22329 end Check_Output_States
;
22331 ---------------------------
22332 -- Check_Proof_In_States --
22333 ---------------------------
22335 procedure Check_Proof_In_States
is
22336 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22337 -- Determine whether at least one constituent of state State_Id with
22338 -- visible refinement is used and has mode Proof_In. Ensure that the
22339 -- remaining constituents do not have Input, In_Out or Output modes.
22341 -----------------------------
22342 -- Check_Constituent_Usage --
22343 -----------------------------
22345 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22346 Constit_Elmt
: Elmt_Id
;
22347 Constit_Id
: Entity_Id
;
22348 Proof_In_Seen
: Boolean := False;
22351 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22352 while Present
(Constit_Elmt
) loop
22353 Constit_Id
:= Node
(Constit_Elmt
);
22355 -- At least one of the constituents appears as Proof_In
22357 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22358 Proof_In_Seen
:= True;
22360 -- The constituent appears in the global refinement, but has
22361 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
22363 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22364 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22365 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22367 Error_Msg_Name_1
:= Chars
(State_Id
);
22369 ("constituent & of state % must have mode Proof_In in "
22370 & "global refinement", N
, Constit_Id
);
22373 Next_Elmt
(Constit_Elmt
);
22376 -- Not one of the constituents appeared as Proof_In
22378 if not Proof_In_Seen
then
22380 ("global refinement of state & must include at least one "
22381 & "constituent of mode Proof_In", N
, State_Id
);
22383 end Check_Constituent_Usage
;
22387 Item_Elmt
: Elmt_Id
;
22388 Item_Id
: Entity_Id
;
22390 -- Start of processing for Check_Proof_In_States
22393 -- Inspect the Proof_In items of the corresponding Global pragma
22394 -- looking for a state with a visible refinement.
22396 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
22397 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
22398 while Present
(Item_Elmt
) loop
22399 Item_Id
:= Node
(Item_Elmt
);
22401 -- Ensure that at least one of the constituents is utilized and
22402 -- is of mode Proof_In
22404 if Ekind
(Item_Id
) = E_Abstract_State
22405 and then Has_Non_Null_Refinement
(Item_Id
)
22407 Check_Constituent_Usage
(Item_Id
);
22410 Next_Elmt
(Item_Elmt
);
22413 end Check_Proof_In_States
;
22415 -------------------------------
22416 -- Check_Refined_Global_List --
22417 -------------------------------
22419 procedure Check_Refined_Global_List
22421 Global_Mode
: Name_Id
:= Name_Input
)
22423 procedure Check_Refined_Global_Item
22425 Global_Mode
: Name_Id
);
22426 -- Verify the legality of a single global item declaration. Parameter
22427 -- Global_Mode denotes the current mode in effect.
22429 -------------------------------
22430 -- Check_Refined_Global_Item --
22431 -------------------------------
22433 procedure Check_Refined_Global_Item
22435 Global_Mode
: Name_Id
)
22437 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
22439 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
22440 -- Issue a common error message for all mode mismatches. Expect
22441 -- denotes the expected mode.
22443 -----------------------------
22444 -- Inconsistent_Mode_Error --
22445 -----------------------------
22447 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
22450 ("global item & has inconsistent modes", Item
, Item_Id
);
22452 Error_Msg_Name_1
:= Global_Mode
;
22453 Error_Msg_Name_2
:= Expect
;
22454 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
22455 end Inconsistent_Mode_Error
;
22457 -- Start of processing for Check_Refined_Global_Item
22460 -- When the state or variable acts as a constituent of another
22461 -- state with a visible refinement, collect it for the state
22462 -- completeness checks performed later on.
22464 if Present
(Encapsulating_State
(Item_Id
))
22465 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
22467 if Global_Mode
= Name_Input
then
22468 Add_Item
(Item_Id
, In_Constits
);
22470 elsif Global_Mode
= Name_In_Out
then
22471 Add_Item
(Item_Id
, In_Out_Constits
);
22473 elsif Global_Mode
= Name_Output
then
22474 Add_Item
(Item_Id
, Out_Constits
);
22476 elsif Global_Mode
= Name_Proof_In
then
22477 Add_Item
(Item_Id
, Proof_In_Constits
);
22480 -- When not a constituent, ensure that both occurrences of the
22481 -- item in pragmas Global and Refined_Global match.
22483 elsif Contains
(In_Items
, Item_Id
) then
22484 if Global_Mode
/= Name_Input
then
22485 Inconsistent_Mode_Error
(Name_Input
);
22488 elsif Contains
(In_Out_Items
, Item_Id
) then
22489 if Global_Mode
/= Name_In_Out
then
22490 Inconsistent_Mode_Error
(Name_In_Out
);
22493 elsif Contains
(Out_Items
, Item_Id
) then
22494 if Global_Mode
/= Name_Output
then
22495 Inconsistent_Mode_Error
(Name_Output
);
22498 elsif Contains
(Proof_In_Items
, Item_Id
) then
22501 -- The item does not appear in the corresponding Global pragma,
22502 -- it must be an extra (SPARK RM 7.2.4(3)).
22505 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
22507 end Check_Refined_Global_Item
;
22513 -- Start of processing for Check_Refined_Global_List
22516 if Nkind
(List
) = N_Null
then
22519 -- Single global item declaration
22521 elsif Nkind_In
(List
, N_Expanded_Name
,
22523 N_Selected_Component
)
22525 Check_Refined_Global_Item
(List
, Global_Mode
);
22527 -- Simple global list or moded global list declaration
22529 elsif Nkind
(List
) = N_Aggregate
then
22531 -- The declaration of a simple global list appear as a collection
22534 if Present
(Expressions
(List
)) then
22535 Item
:= First
(Expressions
(List
));
22536 while Present
(Item
) loop
22537 Check_Refined_Global_Item
(Item
, Global_Mode
);
22542 -- The declaration of a moded global list appears as a collection
22543 -- of component associations where individual choices denote
22546 elsif Present
(Component_Associations
(List
)) then
22547 Item
:= First
(Component_Associations
(List
));
22548 while Present
(Item
) loop
22549 Check_Refined_Global_List
22550 (List
=> Expression
(Item
),
22551 Global_Mode
=> Chars
(First
(Choices
(Item
))));
22559 raise Program_Error
;
22565 raise Program_Error
;
22567 end Check_Refined_Global_List
;
22569 -------------------------
22570 -- Present_Then_Remove --
22571 -------------------------
22573 function Present_Then_Remove
22575 Item
: Entity_Id
) return Boolean
22580 if Present
(List
) then
22581 Elmt
:= First_Elmt
(List
);
22582 while Present
(Elmt
) loop
22583 if Node
(Elmt
) = Item
then
22584 Remove_Elmt
(List
, Elmt
);
22593 end Present_Then_Remove
;
22595 -------------------------------
22596 -- Report_Extra_Constituents --
22597 -------------------------------
22599 procedure Report_Extra_Constituents
is
22600 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
22601 -- Emit an error for every element of List
22603 ---------------------------------------
22604 -- Report_Extra_Constituents_In_List --
22605 ---------------------------------------
22607 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
22608 Constit_Elmt
: Elmt_Id
;
22611 if Present
(List
) then
22612 Constit_Elmt
:= First_Elmt
(List
);
22613 while Present
(Constit_Elmt
) loop
22614 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
22615 Next_Elmt
(Constit_Elmt
);
22618 end Report_Extra_Constituents_In_List
;
22620 -- Start of processing for Report_Extra_Constituents
22623 Report_Extra_Constituents_In_List
(In_Constits
);
22624 Report_Extra_Constituents_In_List
(In_Out_Constits
);
22625 Report_Extra_Constituents_In_List
(Out_Constits
);
22626 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
22627 end Report_Extra_Constituents
;
22631 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22632 Errors
: constant Nat
:= Serious_Errors_Detected
;
22633 Items
: constant Node_Id
:=
22634 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22635 Spec_Id
: Entity_Id
;
22637 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
22640 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22641 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22643 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22646 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
22648 -- The subprogram declaration lacks pragma Global. This renders
22649 -- Refined_Global useless as there is nothing to refine.
22651 if No
(Global
) then
22653 ("useless refinement, declaration of subprogram & lacks aspect or "
22654 & "pragma Global", N
, Spec_Id
);
22658 -- Extract all relevant items from the corresponding Global pragma
22660 Collect_Global_Items
22662 In_Items
=> In_Items
,
22663 In_Out_Items
=> In_Out_Items
,
22664 Out_Items
=> Out_Items
,
22665 Proof_In_Items
=> Proof_In_Items
,
22666 Has_In_State
=> Has_In_State
,
22667 Has_In_Out_State
=> Has_In_Out_State
,
22668 Has_Out_State
=> Has_Out_State
,
22669 Has_Proof_In_State
=> Has_Proof_In_State
,
22670 Has_Null_State
=> Has_Null_State
);
22672 -- Corresponding Global pragma must mention at least one state witha
22673 -- visible refinement at the point Refined_Global is processed. States
22674 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
22676 if not Has_In_State
22677 and then not Has_In_Out_State
22678 and then not Has_Out_State
22679 and then not Has_Proof_In_State
22680 and then not Has_Null_State
22683 ("useless refinement, subprogram & does not depend on abstract "
22684 & "state with visible refinement", N
, Spec_Id
);
22688 -- The global refinement of inputs and outputs cannot be null when the
22689 -- corresponding Global pragma contains at least one item except in the
22690 -- case where we have states with null refinements.
22692 if Nkind
(Items
) = N_Null
22694 (Present
(In_Items
)
22695 or else Present
(In_Out_Items
)
22696 or else Present
(Out_Items
)
22697 or else Present
(Proof_In_Items
))
22698 and then not Has_Null_State
22701 ("refinement cannot be null, subprogram & has global items",
22706 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
22707 -- This ensures that the categorization of all refined global items is
22708 -- consistent with their role.
22710 Analyze_Global_In_Decl_Part
(N
);
22712 -- Perform all refinement checks with respect to completeness and mode
22715 if Serious_Errors_Detected
= Errors
then
22716 Check_Refined_Global_List
(Items
);
22719 -- For Input states with visible refinement, at least one constituent
22720 -- must be used as an Input in the global refinement.
22722 if Serious_Errors_Detected
= Errors
then
22723 Check_Input_States
;
22726 -- Verify all possible completion variants for In_Out states with
22727 -- visible refinement.
22729 if Serious_Errors_Detected
= Errors
then
22730 Check_In_Out_States
;
22733 -- For Output states with visible refinement, all constituents must be
22734 -- used as Outputs in the global refinement.
22736 if Serious_Errors_Detected
= Errors
then
22737 Check_Output_States
;
22740 -- For Proof_In states with visible refinement, at least one constituent
22741 -- must be used as Proof_In in the global refinement.
22743 if Serious_Errors_Detected
= Errors
then
22744 Check_Proof_In_States
;
22747 -- Emit errors for all constituents that belong to other states with
22748 -- visible refinement that do not appear in Global.
22750 if Serious_Errors_Detected
= Errors
then
22751 Report_Extra_Constituents
;
22753 end Analyze_Refined_Global_In_Decl_Part
;
22755 ----------------------------------------
22756 -- Analyze_Refined_State_In_Decl_Part --
22757 ----------------------------------------
22759 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
22760 Available_States
: Elist_Id
:= No_Elist
;
22761 -- A list of all abstract states defined in the package declaration that
22762 -- are available for refinement. The list is used to report unrefined
22765 Body_Id
: Entity_Id
;
22766 -- The body entity of the package subject to pragma Refined_State
22768 Body_States
: Elist_Id
:= No_Elist
;
22769 -- A list of all hidden states that appear in the body of the related
22770 -- package. The list is used to report unused hidden states.
22772 Constituents_Seen
: Elist_Id
:= No_Elist
;
22773 -- A list that contains all constituents processed so far. The list is
22774 -- used to detect multiple uses of the same constituent.
22776 Refined_States_Seen
: Elist_Id
:= No_Elist
;
22777 -- A list that contains all refined states processed so far. The list is
22778 -- used to detect duplicate refinements.
22780 Spec_Id
: Entity_Id
;
22781 -- The spec entity of the package subject to pragma Refined_State
22783 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
22784 -- Perform full analysis of a single refinement clause
22786 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
22787 -- Gather the entities of all abstract states and variables declared in
22788 -- the body state space of package Pack_Id.
22790 procedure Report_Unrefined_States
(States
: Elist_Id
);
22791 -- Emit errors for all unrefined abstract states found in list States
22793 procedure Report_Unused_States
(States
: Elist_Id
);
22794 -- Emit errors for all unused states found in list States
22796 -------------------------------
22797 -- Analyze_Refinement_Clause --
22798 -------------------------------
22800 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
22801 AR_Constit
: Entity_Id
:= Empty
;
22802 AW_Constit
: Entity_Id
:= Empty
;
22803 ER_Constit
: Entity_Id
:= Empty
;
22804 EW_Constit
: Entity_Id
:= Empty
;
22805 -- The entities of external constituents that contain one of the
22806 -- following enabled properties: Async_Readers, Async_Writers,
22807 -- Effective_Reads and Effective_Writes.
22809 External_Constit_Seen
: Boolean := False;
22810 -- Flag used to mark when at least one external constituent is part
22811 -- of the state refinement.
22813 Non_Null_Seen
: Boolean := False;
22814 Null_Seen
: Boolean := False;
22815 -- Flags used to detect multiple uses of null in a single clause or a
22816 -- mixture of null and non-null constituents.
22818 Part_Of_Constits
: Elist_Id
:= No_Elist
;
22819 -- A list of all candidate constituents subject to indicator Part_Of
22820 -- where the encapsulating state is the current state.
22823 State_Id
: Entity_Id
;
22824 -- The current state being refined
22826 procedure Analyze_Constituent
(Constit
: Node_Id
);
22827 -- Perform full analysis of a single constituent
22829 procedure Check_External_Property
22830 (Prop_Nam
: Name_Id
;
22832 Constit
: Entity_Id
);
22833 -- Determine whether a property denoted by name Prop_Nam is present
22834 -- in both the refined state and constituent Constit. Flag Enabled
22835 -- should be set when the property applies to the refined state. If
22836 -- this is not the case, emit an error message.
22838 procedure Check_Matching_State
;
22839 -- Determine whether the state being refined appears in list
22840 -- Available_States. Emit an error when attempting to re-refine the
22841 -- state or when the state is not defined in the package declaration,
22842 -- otherwise remove the state from Available_States.
22844 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
22845 -- Emit errors for all unused Part_Of constituents in list Constits
22847 -------------------------
22848 -- Analyze_Constituent --
22849 -------------------------
22851 procedure Analyze_Constituent
(Constit
: Node_Id
) is
22852 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
22853 -- Determine whether constituent Constit denoted by its entity
22854 -- Constit_Id appears in Hidden_States. Emit an error when the
22855 -- constituent is not a valid hidden state of the related package
22856 -- or when it is used more than once. Otherwise remove the
22857 -- constituent from Hidden_States.
22859 --------------------------------
22860 -- Check_Matching_Constituent --
22861 --------------------------------
22863 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
22864 procedure Collect_Constituent
;
22865 -- Add constituent Constit_Id to the refinements of State_Id
22867 -------------------------
22868 -- Collect_Constituent --
22869 -------------------------
22871 procedure Collect_Constituent
is
22873 -- Add the constituent to the list of processed items to aid
22874 -- with the detection of duplicates.
22876 Add_Item
(Constit_Id
, Constituents_Seen
);
22878 -- Collect the constituent in the list of refinement items
22879 -- and establish a relation between the refined state and
22882 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
22883 Set_Encapsulating_State
(Constit_Id
, State_Id
);
22885 -- The state has at least one legal constituent, mark the
22886 -- start of the refinement region. The region ends when the
22887 -- body declarations end (see routine Analyze_Declarations).
22889 Set_Has_Visible_Refinement
(State_Id
);
22891 -- When the constituent is external, save its relevant
22892 -- property for further checks.
22894 if Async_Readers_Enabled
(Constit_Id
) then
22895 AR_Constit
:= Constit_Id
;
22896 External_Constit_Seen
:= True;
22899 if Async_Writers_Enabled
(Constit_Id
) then
22900 AW_Constit
:= Constit_Id
;
22901 External_Constit_Seen
:= True;
22904 if Effective_Reads_Enabled
(Constit_Id
) then
22905 ER_Constit
:= Constit_Id
;
22906 External_Constit_Seen
:= True;
22909 if Effective_Writes_Enabled
(Constit_Id
) then
22910 EW_Constit
:= Constit_Id
;
22911 External_Constit_Seen
:= True;
22913 end Collect_Constituent
;
22917 State_Elmt
: Elmt_Id
;
22919 -- Start of processing for Check_Matching_Constituent
22922 -- Detect a duplicate use of a constituent
22924 if Contains
(Constituents_Seen
, Constit_Id
) then
22926 ("duplicate use of constituent &", Constit
, Constit_Id
);
22930 -- The constituent is subject to a Part_Of indicator
22932 if Present
(Encapsulating_State
(Constit_Id
)) then
22933 if Encapsulating_State
(Constit_Id
) = State_Id
then
22934 Remove
(Part_Of_Constits
, Constit_Id
);
22935 Collect_Constituent
;
22937 -- The constituent is part of another state and is used
22938 -- incorrectly in the refinement of the current state.
22941 Error_Msg_Name_1
:= Chars
(State_Id
);
22943 ("& cannot act as constituent of state %",
22944 Constit
, Constit_Id
);
22946 ("\Part_Of indicator specifies & as encapsulating "
22947 & "state", Constit
, Encapsulating_State
(Constit_Id
));
22950 -- The only other source of legal constituents is the body
22951 -- state space of the related package.
22954 if Present
(Body_States
) then
22955 State_Elmt
:= First_Elmt
(Body_States
);
22956 while Present
(State_Elmt
) loop
22958 -- Consume a valid constituent to signal that it has
22959 -- been encountered.
22961 if Node
(State_Elmt
) = Constit_Id
then
22962 Remove_Elmt
(Body_States
, State_Elmt
);
22963 Collect_Constituent
;
22967 Next_Elmt
(State_Elmt
);
22971 -- If we get here, then the constituent is not a hidden
22972 -- state of the related package and may not be used in a
22973 -- refinement (SPARK RM 7.2.2(9)).
22975 Error_Msg_Name_1
:= Chars
(Spec_Id
);
22977 ("cannot use & in refinement, constituent is not a hidden "
22978 & "state of package %", Constit
, Constit_Id
);
22980 end Check_Matching_Constituent
;
22984 Constit_Id
: Entity_Id
;
22986 -- Start of processing for Analyze_Constituent
22989 -- Detect multiple uses of null in a single refinement clause or a
22990 -- mixture of null and non-null constituents.
22992 if Nkind
(Constit
) = N_Null
then
22995 ("multiple null constituents not allowed", Constit
);
22997 elsif Non_Null_Seen
then
22999 ("cannot mix null and non-null constituents", Constit
);
23004 -- Collect the constituent in the list of refinement items
23006 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23008 -- The state has at least one legal constituent, mark the
23009 -- start of the refinement region. The region ends when the
23010 -- body declarations end (see Analyze_Declarations).
23012 Set_Has_Visible_Refinement
(State_Id
);
23015 -- Non-null constituents
23018 Non_Null_Seen
:= True;
23022 ("cannot mix null and non-null constituents", Constit
);
23026 Resolve_State
(Constit
);
23028 -- Ensure that the constituent denotes a valid state or a
23031 if Is_Entity_Name
(Constit
) then
23032 Constit_Id
:= Entity_Of
(Constit
);
23034 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
23035 Check_Matching_Constituent
(Constit_Id
);
23039 ("constituent & must denote a variable or state (SPARK "
23040 & "RM 7.2.2(5))", Constit
, Constit_Id
);
23043 -- The constituent is illegal
23046 SPARK_Msg_N
("malformed constituent", Constit
);
23049 end Analyze_Constituent
;
23051 -----------------------------
23052 -- Check_External_Property --
23053 -----------------------------
23055 procedure Check_External_Property
23056 (Prop_Nam
: Name_Id
;
23058 Constit
: Entity_Id
)
23061 Error_Msg_Name_1
:= Prop_Nam
;
23063 -- The property is enabled in the related Abstract_State pragma
23064 -- that defines the state (SPARK RM 7.2.8(3)).
23067 if No
(Constit
) then
23069 ("external state & requires at least one constituent with "
23070 & "property %", State
, State_Id
);
23073 -- The property is missing in the declaration of the state, but
23074 -- a constituent is introducing it in the state refinement
23075 -- (SPARK RM 7.2.8(3)).
23077 elsif Present
(Constit
) then
23078 Error_Msg_Name_2
:= Chars
(Constit
);
23080 ("external state & lacks property % set by constituent %",
23083 end Check_External_Property
;
23085 --------------------------
23086 -- Check_Matching_State --
23087 --------------------------
23089 procedure Check_Matching_State
is
23090 State_Elmt
: Elmt_Id
;
23093 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23095 if Contains
(Refined_States_Seen
, State_Id
) then
23097 ("duplicate refinement of state &", State
, State_Id
);
23101 -- Inspect the abstract states defined in the package declaration
23102 -- looking for a match.
23104 State_Elmt
:= First_Elmt
(Available_States
);
23105 while Present
(State_Elmt
) loop
23107 -- A valid abstract state is being refined in the body. Add
23108 -- the state to the list of processed refined states to aid
23109 -- with the detection of duplicate refinements. Remove the
23110 -- state from Available_States to signal that it has already
23113 if Node
(State_Elmt
) = State_Id
then
23114 Add_Item
(State_Id
, Refined_States_Seen
);
23115 Remove_Elmt
(Available_States
, State_Elmt
);
23119 Next_Elmt
(State_Elmt
);
23122 -- If we get here, we are refining a state that is not defined in
23123 -- the package declaration.
23125 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23127 ("cannot refine state, & is not defined in package %",
23129 end Check_Matching_State
;
23131 --------------------------------
23132 -- Report_Unused_Constituents --
23133 --------------------------------
23135 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
23136 Constit_Elmt
: Elmt_Id
;
23137 Constit_Id
: Entity_Id
;
23138 Posted
: Boolean := False;
23141 if Present
(Constits
) then
23142 Constit_Elmt
:= First_Elmt
(Constits
);
23143 while Present
(Constit_Elmt
) loop
23144 Constit_Id
:= Node
(Constit_Elmt
);
23146 -- Generate an error message of the form:
23148 -- state ... has unused Part_Of constituents
23149 -- abstract state ... defined at ...
23150 -- variable ... defined at ...
23155 ("state & has unused Part_Of constituents",
23159 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
23161 if Ekind
(Constit_Id
) = E_Abstract_State
then
23163 ("\abstract state & defined #", State
, Constit_Id
);
23166 ("\variable & defined #", State
, Constit_Id
);
23169 Next_Elmt
(Constit_Elmt
);
23172 end Report_Unused_Constituents
;
23174 -- Local declarations
23176 Body_Ref
: Node_Id
;
23177 Body_Ref_Elmt
: Elmt_Id
;
23179 Extra_State
: Node_Id
;
23181 -- Start of processing for Analyze_Refinement_Clause
23184 -- A refinement clause appears as a component association where the
23185 -- sole choice is the state and the expressions are the constituents.
23186 -- This is a syntax error, always report.
23188 if Nkind
(Clause
) /= N_Component_Association
then
23189 Error_Msg_N
("malformed state refinement clause", Clause
);
23193 -- Analyze the state name of a refinement clause
23195 State
:= First
(Choices
(Clause
));
23198 Resolve_State
(State
);
23200 -- Ensure that the state name denotes a valid abstract state that is
23201 -- defined in the spec of the related package.
23203 if Is_Entity_Name
(State
) then
23204 State_Id
:= Entity_Of
(State
);
23206 -- Catch any attempts to re-refine a state or refine a state that
23207 -- is not defined in the package declaration.
23209 if Ekind
(State_Id
) = E_Abstract_State
then
23210 Check_Matching_State
;
23213 ("& must denote an abstract state", State
, State_Id
);
23217 -- References to a state with visible refinement are illegal.
23218 -- When nested packages are involved, detecting such references is
23219 -- tricky because pragma Refined_State is analyzed later than the
23220 -- offending pragma Depends or Global. References that occur in
23221 -- such nested context are stored in a list. Emit errors for all
23222 -- references found in Body_References (SPARK RM 6.1.4(8)).
23224 if Present
(Body_References
(State_Id
)) then
23225 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
23226 while Present
(Body_Ref_Elmt
) loop
23227 Body_Ref
:= Node
(Body_Ref_Elmt
);
23229 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
23230 Error_Msg_Sloc
:= Sloc
(State
);
23231 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
23233 Next_Elmt
(Body_Ref_Elmt
);
23237 -- The state name is illegal. This is a syntax error, always report.
23240 Error_Msg_N
("malformed state name in refinement clause", State
);
23244 -- A refinement clause may only refine one state at a time
23246 Extra_State
:= Next
(State
);
23248 if Present
(Extra_State
) then
23250 ("refinement clause cannot cover multiple states", Extra_State
);
23253 -- Replicate the Part_Of constituents of the refined state because
23254 -- the algorithm will consume items.
23256 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
23258 -- Analyze all constituents of the refinement. Multiple constituents
23259 -- appear as an aggregate.
23261 Constit
:= Expression
(Clause
);
23263 if Nkind
(Constit
) = N_Aggregate
then
23264 if Present
(Component_Associations
(Constit
)) then
23266 ("constituents of refinement clause must appear in "
23267 & "positional form", Constit
);
23269 else pragma Assert
(Present
(Expressions
(Constit
)));
23270 Constit
:= First
(Expressions
(Constit
));
23271 while Present
(Constit
) loop
23272 Analyze_Constituent
(Constit
);
23278 -- Various forms of a single constituent. Note that these may include
23279 -- malformed constituents.
23282 Analyze_Constituent
(Constit
);
23285 -- A refined external state is subject to special rules with respect
23286 -- to its properties and constituents.
23288 if Is_External_State
(State_Id
) then
23290 -- The set of properties that all external constituents yield must
23291 -- match that of the refined state. There are two cases to detect:
23292 -- the refined state lacks a property or has an extra property.
23294 if External_Constit_Seen
then
23295 Check_External_Property
23296 (Prop_Nam
=> Name_Async_Readers
,
23297 Enabled
=> Async_Readers_Enabled
(State_Id
),
23298 Constit
=> AR_Constit
);
23300 Check_External_Property
23301 (Prop_Nam
=> Name_Async_Writers
,
23302 Enabled
=> Async_Writers_Enabled
(State_Id
),
23303 Constit
=> AW_Constit
);
23305 Check_External_Property
23306 (Prop_Nam
=> Name_Effective_Reads
,
23307 Enabled
=> Effective_Reads_Enabled
(State_Id
),
23308 Constit
=> ER_Constit
);
23310 Check_External_Property
23311 (Prop_Nam
=> Name_Effective_Writes
,
23312 Enabled
=> Effective_Writes_Enabled
(State_Id
),
23313 Constit
=> EW_Constit
);
23315 -- An external state may be refined to null (SPARK RM 7.2.8(2))
23317 elsif Null_Seen
then
23320 -- The external state has constituents, but none of them are
23321 -- external (SPARK RM 7.2.8(2)).
23325 ("external state & requires at least one external "
23326 & "constituent or null refinement", State
, State_Id
);
23329 -- When a refined state is not external, it should not have external
23330 -- constituents (SPARK RM 7.2.8(1)).
23332 elsif External_Constit_Seen
then
23334 ("non-external state & cannot contain external constituents in "
23335 & "refinement", State
, State_Id
);
23338 -- Ensure that all Part_Of candidate constituents have been mentioned
23339 -- in the refinement clause.
23341 Report_Unused_Constituents
(Part_Of_Constits
);
23342 end Analyze_Refinement_Clause
;
23344 -------------------------
23345 -- Collect_Body_States --
23346 -------------------------
23348 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
23349 Result
: Elist_Id
:= No_Elist
;
23350 -- A list containing all body states of Pack_Id
23352 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
23353 -- Gather the entities of all abstract states and variables declared
23354 -- in the visible state space of package Pack_Id.
23356 ----------------------------
23357 -- Collect_Visible_States --
23358 ----------------------------
23360 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
23361 Item_Id
: Entity_Id
;
23364 -- Traverse the entity chain of the package and inspect all
23367 Item_Id
:= First_Entity
(Pack_Id
);
23368 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
23370 -- Do not consider internally generated items as those cannot
23371 -- be named and participate in refinement.
23373 if not Comes_From_Source
(Item_Id
) then
23376 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
23377 Add_Item
(Item_Id
, Result
);
23379 -- Recursively gather the visible states of a nested package
23381 elsif Ekind
(Item_Id
) = E_Package
then
23382 Collect_Visible_States
(Item_Id
);
23385 Next_Entity
(Item_Id
);
23387 end Collect_Visible_States
;
23391 Pack_Body
: constant Node_Id
:=
23392 Declaration_Node
(Body_Entity
(Pack_Id
));
23394 Item_Id
: Entity_Id
;
23396 -- Start of processing for Collect_Body_States
23399 -- Inspect the declarations of the body looking for source variables,
23400 -- packages and package instantiations.
23402 Decl
:= First
(Declarations
(Pack_Body
));
23403 while Present
(Decl
) loop
23404 if Nkind
(Decl
) = N_Object_Declaration
then
23405 Item_Id
:= Defining_Entity
(Decl
);
23407 -- Capture source variables only as internally generated
23408 -- temporaries cannot be named and participate in refinement.
23410 if Ekind
(Item_Id
) = E_Variable
23411 and then Comes_From_Source
(Item_Id
)
23413 Add_Item
(Item_Id
, Result
);
23416 elsif Nkind
(Decl
) = N_Package_Declaration
then
23417 Item_Id
:= Defining_Entity
(Decl
);
23419 -- Capture the visible abstract states and variables of a
23420 -- source package [instantiation].
23422 if Comes_From_Source
(Item_Id
) then
23423 Collect_Visible_States
(Item_Id
);
23431 end Collect_Body_States
;
23433 -----------------------------
23434 -- Report_Unrefined_States --
23435 -----------------------------
23437 procedure Report_Unrefined_States
(States
: Elist_Id
) is
23438 State_Elmt
: Elmt_Id
;
23441 if Present
(States
) then
23442 State_Elmt
:= First_Elmt
(States
);
23443 while Present
(State_Elmt
) loop
23445 ("abstract state & must be refined", Node
(State_Elmt
));
23447 Next_Elmt
(State_Elmt
);
23450 end Report_Unrefined_States
;
23452 --------------------------
23453 -- Report_Unused_States --
23454 --------------------------
23456 procedure Report_Unused_States
(States
: Elist_Id
) is
23457 Posted
: Boolean := False;
23458 State_Elmt
: Elmt_Id
;
23459 State_Id
: Entity_Id
;
23462 if Present
(States
) then
23463 State_Elmt
:= First_Elmt
(States
);
23464 while Present
(State_Elmt
) loop
23465 State_Id
:= Node
(State_Elmt
);
23467 -- Generate an error message of the form:
23469 -- body of package ... has unused hidden states
23470 -- abstract state ... defined at ...
23471 -- variable ... defined at ...
23476 ("body of package & has unused hidden states", Body_Id
);
23479 Error_Msg_Sloc
:= Sloc
(State_Id
);
23481 if Ekind
(State_Id
) = E_Abstract_State
then
23483 ("\abstract state & defined #", Body_Id
, State_Id
);
23486 ("\variable & defined #", Body_Id
, State_Id
);
23489 Next_Elmt
(State_Elmt
);
23492 end Report_Unused_States
;
23494 -- Local declarations
23496 Body_Decl
: constant Node_Id
:= Parent
(N
);
23497 Clauses
: constant Node_Id
:=
23498 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23501 -- Start of processing for Analyze_Refined_State_In_Decl_Part
23506 Body_Id
:= Defining_Entity
(Body_Decl
);
23507 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23509 -- Replicate the abstract states declared by the package because the
23510 -- matching algorithm will consume states.
23512 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
23514 -- Gather all abstract states and variables declared in the visible
23515 -- state space of the package body. These items must be utilized as
23516 -- constituents in a state refinement.
23518 Body_States
:= Collect_Body_States
(Spec_Id
);
23520 -- Multiple non-null state refinements appear as an aggregate
23522 if Nkind
(Clauses
) = N_Aggregate
then
23523 if Present
(Expressions
(Clauses
)) then
23525 ("state refinements must appear as component associations",
23528 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
23529 Clause
:= First
(Component_Associations
(Clauses
));
23530 while Present
(Clause
) loop
23531 Analyze_Refinement_Clause
(Clause
);
23537 -- Various forms of a single state refinement. Note that these may
23538 -- include malformed refinements.
23541 Analyze_Refinement_Clause
(Clauses
);
23544 -- List all abstract states that were left unrefined
23546 Report_Unrefined_States
(Available_States
);
23548 -- Ensure that all abstract states and variables declared in the body
23549 -- state space of the related package are utilized as constituents.
23551 Report_Unused_States
(Body_States
);
23552 end Analyze_Refined_State_In_Decl_Part
;
23554 ------------------------------------
23555 -- Analyze_Test_Case_In_Decl_Part --
23556 ------------------------------------
23558 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
23560 -- Install formals and push subprogram spec onto scope stack so that we
23561 -- can see the formals from the pragma.
23564 Install_Formals
(S
);
23566 -- Preanalyze the boolean expressions, we treat these as spec
23567 -- expressions (i.e. similar to a default expression).
23569 if Pragma_Name
(N
) = Name_Test_Case
then
23570 Preanalyze_CTC_Args
23572 Get_Requires_From_CTC_Pragma
(N
),
23573 Get_Ensures_From_CTC_Pragma
(N
));
23576 -- Remove the subprogram from the scope stack now that the pre-analysis
23577 -- of the expressions in the contract case or test case is done.
23580 end Analyze_Test_Case_In_Decl_Part
;
23586 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
23591 if Present
(List
) then
23592 Elmt
:= First_Elmt
(List
);
23593 while Present
(Elmt
) loop
23594 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
23597 Id
:= Entity_Of
(Node
(Elmt
));
23600 if Id
= Item_Id
then
23611 -----------------------------
23612 -- Check_Applicable_Policy --
23613 -----------------------------
23615 procedure Check_Applicable_Policy
(N
: Node_Id
) is
23619 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
23622 -- No effect if not valid assertion kind name
23624 if not Is_Valid_Assertion_Kind
(Ename
) then
23628 -- Loop through entries in check policy list
23630 PP
:= Opt
.Check_Policy_List
;
23631 while Present
(PP
) loop
23633 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
23634 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
23638 or else Pnm
= Name_Assertion
23639 or else (Pnm
= Name_Statement_Assertions
23640 and then Nam_In
(Ename
, Name_Assert
,
23641 Name_Assert_And_Cut
,
23643 Name_Loop_Invariant
,
23644 Name_Loop_Variant
))
23646 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
23649 when Name_Off | Name_Ignore
=>
23650 Set_Is_Ignored
(N
, True);
23651 Set_Is_Checked
(N
, False);
23653 when Name_On | Name_Check
=>
23654 Set_Is_Checked
(N
, True);
23655 Set_Is_Ignored
(N
, False);
23657 when Name_Disable
=>
23658 Set_Is_Ignored
(N
, True);
23659 Set_Is_Checked
(N
, False);
23660 Set_Is_Disabled
(N
, True);
23662 -- That should be exhaustive, the null here is a defence
23663 -- against a malformed tree from previous errors.
23672 PP
:= Next_Pragma
(PP
);
23676 -- If there are no specific entries that matched, then we let the
23677 -- setting of assertions govern. Note that this provides the needed
23678 -- compatibility with the RM for the cases of assertion, invariant,
23679 -- precondition, predicate, and postcondition.
23681 if Assertions_Enabled
then
23682 Set_Is_Checked
(N
, True);
23683 Set_Is_Ignored
(N
, False);
23685 Set_Is_Checked
(N
, False);
23686 Set_Is_Ignored
(N
, True);
23688 end Check_Applicable_Policy
;
23690 -------------------------------
23691 -- Check_External_Properties --
23692 -------------------------------
23694 procedure Check_External_Properties
23702 -- All properties enabled
23704 if AR
and AW
and ER
and EW
then
23707 -- Async_Readers + Effective_Writes
23708 -- Async_Readers + Async_Writers + Effective_Writes
23710 elsif AR
and EW
and not ER
then
23713 -- Async_Writers + Effective_Reads
23714 -- Async_Readers + Async_Writers + Effective_Reads
23716 elsif AW
and ER
and not EW
then
23719 -- Async_Readers + Async_Writers
23721 elsif AR
and AW
and not ER
and not EW
then
23726 elsif AR
and not AW
and not ER
and not EW
then
23731 elsif AW
and not AR
and not ER
and not EW
then
23736 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
23739 end Check_External_Properties
;
23745 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
23749 -- Loop through entries in check policy list
23751 PP
:= Opt
.Check_Policy_List
;
23752 while Present
(PP
) loop
23754 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
23755 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
23759 or else (Pnm
= Name_Assertion
23760 and then Is_Valid_Assertion_Kind
(Nam
))
23761 or else (Pnm
= Name_Statement_Assertions
23762 and then Nam_In
(Nam
, Name_Assert
,
23763 Name_Assert_And_Cut
,
23765 Name_Loop_Invariant
,
23766 Name_Loop_Variant
))
23768 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
23769 when Name_On | Name_Check
=>
23771 when Name_Off | Name_Ignore
=>
23772 return Name_Ignore
;
23773 when Name_Disable
=>
23774 return Name_Disable
;
23776 raise Program_Error
;
23780 PP
:= Next_Pragma
(PP
);
23785 -- If there are no specific entries that matched, then we let the
23786 -- setting of assertions govern. Note that this provides the needed
23787 -- compatibility with the RM for the cases of assertion, invariant,
23788 -- precondition, predicate, and postcondition.
23790 if Assertions_Enabled
then
23793 return Name_Ignore
;
23797 ---------------------------
23798 -- Check_Missing_Part_Of --
23799 ---------------------------
23801 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
23802 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
23803 -- Determine whether a package denoted by Pack_Id declares at least one
23806 -----------------------
23807 -- Has_Visible_State --
23808 -----------------------
23810 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
23811 Item_Id
: Entity_Id
;
23814 -- Traverse the entity chain of the package trying to find at least
23815 -- one visible abstract state, variable or a package [instantiation]
23816 -- that declares a visible state.
23818 Item_Id
:= First_Entity
(Pack_Id
);
23819 while Present
(Item_Id
)
23820 and then not In_Private_Part
(Item_Id
)
23822 -- Do not consider internally generated items
23824 if not Comes_From_Source
(Item_Id
) then
23827 -- A visible state has been found
23829 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
23832 -- Recursively peek into nested packages and instantiations
23834 elsif Ekind
(Item_Id
) = E_Package
23835 and then Has_Visible_State
(Item_Id
)
23840 Next_Entity
(Item_Id
);
23844 end Has_Visible_State
;
23848 Pack_Id
: Entity_Id
;
23849 Placement
: State_Space_Kind
;
23851 -- Start of processing for Check_Missing_Part_Of
23854 -- Do not consider abstract states, variables or package instantiations
23855 -- coming from an instance as those always inherit the Part_Of indicator
23856 -- of the instance itself.
23858 if In_Instance
then
23861 -- Do not consider internally generated entities as these can never
23862 -- have a Part_Of indicator.
23864 elsif not Comes_From_Source
(Item_Id
) then
23867 -- Perform these checks only when SPARK_Mode is enabled as they will
23868 -- interfere with standard Ada rules and produce false positives.
23870 elsif SPARK_Mode
/= On
then
23874 -- Find where the abstract state, variable or package instantiation
23875 -- lives with respect to the state space.
23877 Find_Placement_In_State_Space
23878 (Item_Id
=> Item_Id
,
23879 Placement
=> Placement
,
23880 Pack_Id
=> Pack_Id
);
23882 -- Items that appear in a non-package construct (subprogram, block, etc)
23883 -- do not require a Part_Of indicator because they can never act as a
23886 if Placement
= Not_In_Package
then
23889 -- An item declared in the body state space of a package always act as a
23890 -- constituent and does not need explicit Part_Of indicator.
23892 elsif Placement
= Body_State_Space
then
23895 -- In general an item declared in the visible state space of a package
23896 -- does not require a Part_Of indicator. The only exception is when the
23897 -- related package is a private child unit in which case Part_Of must
23898 -- denote a state in the parent unit or in one of its descendants.
23900 elsif Placement
= Visible_State_Space
then
23901 if Is_Child_Unit
(Pack_Id
)
23902 and then Is_Private_Descendant
(Pack_Id
)
23904 -- A package instantiation does not need a Part_Of indicator when
23905 -- the related generic template has no visible state.
23907 if Ekind
(Item_Id
) = E_Package
23908 and then Is_Generic_Instance
(Item_Id
)
23909 and then not Has_Visible_State
(Item_Id
)
23913 -- All other cases require Part_Of
23917 ("indicator Part_Of is required in this context "
23918 & "(SPARK RM 7.2.6(3))", Item_Id
);
23919 Error_Msg_Name_1
:= Chars
(Pack_Id
);
23921 ("\& is declared in the visible part of private child "
23922 & "unit %", Item_Id
);
23926 -- When the item appears in the private state space of a packge, it must
23927 -- be a part of some state declared by the said package.
23929 else pragma Assert
(Placement
= Private_State_Space
);
23931 -- The related package does not declare a state, the item cannot act
23932 -- as a Part_Of constituent.
23934 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
23937 -- A package instantiation does not need a Part_Of indicator when the
23938 -- related generic template has no visible state.
23940 elsif Ekind
(Pack_Id
) = E_Package
23941 and then Is_Generic_Instance
(Pack_Id
)
23942 and then not Has_Visible_State
(Pack_Id
)
23946 -- All other cases require Part_Of
23950 ("indicator Part_Of is required in this context "
23951 & "(SPARK RM 7.2.6(2))", Item_Id
);
23952 Error_Msg_Name_1
:= Chars
(Pack_Id
);
23954 ("\& is declared in the private part of package %", Item_Id
);
23957 end Check_Missing_Part_Of
;
23959 ---------------------------------
23960 -- Check_SPARK_Aspect_For_ASIS --
23961 ---------------------------------
23963 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
23967 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
23968 Expr
:= Expression
(Corresponding_Aspect
(N
));
23969 if Nkind
(Expr
) /= N_Aggregate
then
23970 Preanalyze_And_Resolve
(Expr
);
23974 Comps
: constant List_Id
:= Component_Associations
(Expr
);
23975 Exprs
: constant List_Id
:= Expressions
(Expr
);
23980 E
:= First
(Exprs
);
23981 while Present
(E
) loop
23986 C
:= First
(Comps
);
23987 while Present
(C
) loop
23988 Analyze
(Expression
(C
));
23994 end Check_SPARK_Aspect_For_ASIS
;
23996 -------------------------------------
23997 -- Check_State_And_Constituent_Use --
23998 -------------------------------------
24000 procedure Check_State_And_Constituent_Use
24001 (States
: Elist_Id
;
24002 Constits
: Elist_Id
;
24005 function Find_Encapsulating_State
24006 (Constit_Id
: Entity_Id
) return Entity_Id
;
24007 -- Given the entity of a constituent, try to find a corresponding
24008 -- encapsulating state that appears in the same context. The routine
24009 -- returns Empty is no such state is found.
24011 ------------------------------
24012 -- Find_Encapsulating_State --
24013 ------------------------------
24015 function Find_Encapsulating_State
24016 (Constit_Id
: Entity_Id
) return Entity_Id
24018 State_Id
: Entity_Id
;
24021 -- Since a constituent may be part of a larger constituent set, climb
24022 -- the encapsulated state chain looking for a state that appears in
24023 -- the same context.
24025 State_Id
:= Encapsulating_State
(Constit_Id
);
24026 while Present
(State_Id
) loop
24027 if Contains
(States
, State_Id
) then
24031 State_Id
:= Encapsulating_State
(State_Id
);
24035 end Find_Encapsulating_State
;
24039 Constit_Elmt
: Elmt_Id
;
24040 Constit_Id
: Entity_Id
;
24041 State_Id
: Entity_Id
;
24043 -- Start of processing for Check_State_And_Constituent_Use
24046 -- Nothing to do if there are no states or constituents
24048 if No
(States
) or else No
(Constits
) then
24052 -- Inspect the list of constituents and try to determine whether its
24053 -- encapsulating state is in list States.
24055 Constit_Elmt
:= First_Elmt
(Constits
);
24056 while Present
(Constit_Elmt
) loop
24057 Constit_Id
:= Node
(Constit_Elmt
);
24059 -- Determine whether the constituent is part of an encapsulating
24060 -- state that appears in the same context and if this is the case,
24061 -- emit an error (SPARK RM 7.2.6(7)).
24063 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
24065 if Present
(State_Id
) then
24066 Error_Msg_Name_1
:= Chars
(Constit_Id
);
24068 ("cannot mention state & and its constituent % in the same "
24069 & "context", Context
, State_Id
);
24073 Next_Elmt
(Constit_Elmt
);
24075 end Check_State_And_Constituent_Use
;
24077 --------------------------
24078 -- Collect_Global_Items --
24079 --------------------------
24081 procedure Collect_Global_Items
24083 In_Items
: in out Elist_Id
;
24084 In_Out_Items
: in out Elist_Id
;
24085 Out_Items
: in out Elist_Id
;
24086 Proof_In_Items
: in out Elist_Id
;
24087 Has_In_State
: out Boolean;
24088 Has_In_Out_State
: out Boolean;
24089 Has_Out_State
: out Boolean;
24090 Has_Proof_In_State
: out Boolean;
24091 Has_Null_State
: out Boolean)
24093 procedure Process_Global_List
24095 Mode
: Name_Id
:= Name_Input
);
24096 -- Collect all items housed in a global list. Formal Mode denotes the
24097 -- current mode in effect.
24099 -------------------------
24100 -- Process_Global_List --
24101 -------------------------
24103 procedure Process_Global_List
24105 Mode
: Name_Id
:= Name_Input
)
24107 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24108 -- Add a single item to the appropriate list. Formal Mode denotes the
24109 -- current mode in effect.
24111 -------------------------
24112 -- Process_Global_Item --
24113 -------------------------
24115 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24116 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
24117 -- The above handles abstract views of variables and states built
24118 -- for limited with clauses.
24121 -- Signal that the global list contains at least one abstract
24122 -- state with a visible refinement. Note that the refinement may
24123 -- be null in which case there are no constituents.
24125 if Ekind
(Item_Id
) = E_Abstract_State
then
24126 if Has_Null_Refinement
(Item_Id
) then
24127 Has_Null_State
:= True;
24129 elsif Has_Non_Null_Refinement
(Item_Id
) then
24130 if Mode
= Name_Input
then
24131 Has_In_State
:= True;
24132 elsif Mode
= Name_In_Out
then
24133 Has_In_Out_State
:= True;
24134 elsif Mode
= Name_Output
then
24135 Has_Out_State
:= True;
24136 elsif Mode
= Name_Proof_In
then
24137 Has_Proof_In_State
:= True;
24142 -- Add the item to the proper list
24144 if Mode
= Name_Input
then
24145 Add_Item
(Item_Id
, In_Items
);
24146 elsif Mode
= Name_In_Out
then
24147 Add_Item
(Item_Id
, In_Out_Items
);
24148 elsif Mode
= Name_Output
then
24149 Add_Item
(Item_Id
, Out_Items
);
24150 elsif Mode
= Name_Proof_In
then
24151 Add_Item
(Item_Id
, Proof_In_Items
);
24153 end Process_Global_Item
;
24159 -- Start of processing for Process_Global_List
24162 if Nkind
(List
) = N_Null
then
24165 -- Single global item declaration
24167 elsif Nkind_In
(List
, N_Expanded_Name
,
24169 N_Selected_Component
)
24171 Process_Global_Item
(List
, Mode
);
24173 -- Single global list or moded global list declaration
24175 elsif Nkind
(List
) = N_Aggregate
then
24177 -- The declaration of a simple global list appear as a collection
24180 if Present
(Expressions
(List
)) then
24181 Item
:= First
(Expressions
(List
));
24182 while Present
(Item
) loop
24183 Process_Global_Item
(Item
, Mode
);
24188 -- The declaration of a moded global list appears as a collection
24189 -- of component associations where individual choices denote mode.
24191 elsif Present
(Component_Associations
(List
)) then
24192 Item
:= First
(Component_Associations
(List
));
24193 while Present
(Item
) loop
24194 Process_Global_List
24195 (List
=> Expression
(Item
),
24196 Mode
=> Chars
(First
(Choices
(Item
))));
24204 raise Program_Error
;
24207 -- To accomodate partial decoration of disabled SPARK features, this
24208 -- routine may be called with illegal input. If this is the case, do
24209 -- not raise Program_Error.
24214 end Process_Global_List
;
24218 Items
: constant Node_Id
:=
24219 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
)));
24221 -- Start of processing for Collect_Global_Items
24224 -- Assume that no states have been encountered
24226 Has_In_State
:= False;
24227 Has_In_Out_State
:= False;
24228 Has_Out_State
:= False;
24229 Has_Proof_In_State
:= False;
24230 Has_Null_State
:= False;
24232 Process_Global_List
(Items
);
24233 end Collect_Global_Items
;
24235 ---------------------------------------
24236 -- Collect_Subprogram_Inputs_Outputs --
24237 ---------------------------------------
24239 procedure Collect_Subprogram_Inputs_Outputs
24240 (Subp_Id
: Entity_Id
;
24241 Subp_Inputs
: in out Elist_Id
;
24242 Subp_Outputs
: in out Elist_Id
;
24243 Global_Seen
: out Boolean)
24245 procedure Collect_Global_List
24247 Mode
: Name_Id
:= Name_Input
);
24248 -- Collect all relevant items from a global list
24250 -------------------------
24251 -- Collect_Global_List --
24252 -------------------------
24254 procedure Collect_Global_List
24256 Mode
: Name_Id
:= Name_Input
)
24258 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24259 -- Add an item to the proper subprogram input or output collection
24261 -------------------------
24262 -- Collect_Global_Item --
24263 -------------------------
24265 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24267 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
24268 Add_Item
(Item
, Subp_Inputs
);
24271 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
24272 Add_Item
(Item
, Subp_Outputs
);
24274 end Collect_Global_Item
;
24281 -- Start of processing for Collect_Global_List
24284 if Nkind
(List
) = N_Null
then
24287 -- Single global item declaration
24289 elsif Nkind_In
(List
, N_Expanded_Name
,
24291 N_Selected_Component
)
24293 Collect_Global_Item
(List
, Mode
);
24295 -- Simple global list or moded global list declaration
24297 elsif Nkind
(List
) = N_Aggregate
then
24298 if Present
(Expressions
(List
)) then
24299 Item
:= First
(Expressions
(List
));
24300 while Present
(Item
) loop
24301 Collect_Global_Item
(Item
, Mode
);
24306 Assoc
:= First
(Component_Associations
(List
));
24307 while Present
(Assoc
) loop
24308 Collect_Global_List
24309 (List
=> Expression
(Assoc
),
24310 Mode
=> Chars
(First
(Choices
(Assoc
))));
24315 -- To accomodate partial decoration of disabled SPARK features, this
24316 -- routine may be called with illegal input. If this is the case, do
24317 -- not raise Program_Error.
24322 end Collect_Global_List
;
24326 Subp_Decl
: constant Node_Id
:= Parent
(Parent
(Subp_Id
));
24327 Formal
: Entity_Id
;
24330 Spec_Id
: Entity_Id
;
24332 -- Start of processing for Collect_Subprogram_Inputs_Outputs
24335 Global_Seen
:= False;
24337 -- Find the entity of the corresponding spec when processing a body
24339 if Nkind
(Subp_Decl
) = N_Subprogram_Body
24340 and then Present
(Corresponding_Spec
(Subp_Decl
))
24342 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
24344 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
24345 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
24347 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
24350 Spec_Id
:= Subp_Id
;
24353 -- Process all formal parameters
24355 Formal
:= First_Formal
(Spec_Id
);
24356 while Present
(Formal
) loop
24357 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
24358 Add_Item
(Formal
, Subp_Inputs
);
24361 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
24362 Add_Item
(Formal
, Subp_Outputs
);
24364 -- Out parameters can act as inputs when the related type is
24365 -- tagged, unconstrained array, unconstrained record or record
24366 -- with unconstrained components.
24368 if Ekind
(Formal
) = E_Out_Parameter
24369 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
24371 Add_Item
(Formal
, Subp_Inputs
);
24375 Next_Formal
(Formal
);
24378 -- When processing a subprogram body, look for pragma Refined_Global as
24379 -- it provides finer granularity of inputs and outputs.
24381 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
24382 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
24384 -- Subprogram declaration case, look for pragma Global
24387 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
24390 if Present
(Global
) then
24391 Global_Seen
:= True;
24392 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
24394 -- The pragma may not have been analyzed because of the arbitrary
24395 -- declaration order of aspects. Make sure that it is analyzed for
24396 -- the purposes of item extraction.
24398 if not Analyzed
(List
) then
24399 if Pragma_Name
(Global
) = Name_Refined_Global
then
24400 Analyze_Refined_Global_In_Decl_Part
(Global
);
24402 Analyze_Global_In_Decl_Part
(Global
);
24406 -- Nothing to be done for a null global list
24408 if Nkind
(List
) /= N_Null
then
24409 Collect_Global_List
(List
);
24412 end Collect_Subprogram_Inputs_Outputs
;
24414 ---------------------------------
24415 -- Delay_Config_Pragma_Analyze --
24416 ---------------------------------
24418 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
24420 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
24421 Name_Priority_Specific_Dispatching
);
24422 end Delay_Config_Pragma_Analyze
;
24424 -------------------------------------
24425 -- Find_Related_Subprogram_Or_Body --
24426 -------------------------------------
24428 function Find_Related_Subprogram_Or_Body
24430 Do_Checks
: Boolean := False) return Node_Id
24432 Context
: constant Node_Id
:= Parent
(Prag
);
24433 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
24436 Look_For_Body
: constant Boolean :=
24437 Nam_In
(Nam
, Name_Refined_Depends
,
24438 Name_Refined_Global
,
24439 Name_Refined_Post
);
24440 -- Refinement pragmas must be associated with a subprogram body [stub]
24443 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
24445 -- If the pragma is a byproduct of aspect expansion, return the related
24446 -- context of the original aspect.
24448 if Present
(Corresponding_Aspect
(Prag
)) then
24449 return Parent
(Corresponding_Aspect
(Prag
));
24452 -- Otherwise the pragma is a source construct, most likely part of a
24453 -- declarative list. Skip preceding declarations while looking for a
24454 -- proper subprogram declaration.
24456 pragma Assert
(Is_List_Member
(Prag
));
24458 Stmt
:= Prev
(Prag
);
24459 while Present
(Stmt
) loop
24461 -- Skip prior pragmas, but check for duplicates
24463 if Nkind
(Stmt
) = N_Pragma
then
24464 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
24465 Error_Msg_Name_1
:= Nam
;
24466 Error_Msg_Sloc
:= Sloc
(Stmt
);
24467 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
24470 -- Emit an error when a refinement pragma appears on an expression
24471 -- function without a completion.
24474 and then Look_For_Body
24475 and then Nkind
(Stmt
) = N_Subprogram_Declaration
24476 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
24477 and then not Has_Completion
(Defining_Entity
(Stmt
))
24479 Error_Msg_Name_1
:= Nam
;
24481 ("pragma % cannot apply to a stand alone expression function",
24486 -- The refinement pragma applies to a subprogram body stub
24488 elsif Look_For_Body
24489 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
24493 -- Skip internally generated code
24495 elsif not Comes_From_Source
(Stmt
) then
24498 -- Return the current construct which is either a subprogram body,
24499 -- a subprogram declaration or is illegal.
24508 -- If we fall through, then the pragma was either the first declaration
24509 -- or it was preceded by other pragmas and no source constructs.
24511 -- The pragma is associated with a library-level subprogram
24513 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
24514 return Unit
(Parent
(Context
));
24516 -- The pragma appears inside the declarative part of a subprogram body
24518 elsif Nkind
(Context
) = N_Subprogram_Body
then
24521 -- No candidate subprogram [body] found
24526 end Find_Related_Subprogram_Or_Body
;
24528 -------------------------
24529 -- Get_Base_Subprogram --
24530 -------------------------
24532 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
24533 Result
: Entity_Id
;
24536 -- Follow subprogram renaming chain
24540 if Is_Subprogram
(Result
)
24542 Nkind
(Parent
(Declaration_Node
(Result
))) =
24543 N_Subprogram_Renaming_Declaration
24544 and then Present
(Alias
(Result
))
24546 Result
:= Alias
(Result
);
24550 end Get_Base_Subprogram
;
24552 -----------------------
24553 -- Get_SPARK_Mode_Type --
24554 -----------------------
24556 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
24558 if N
= Name_On
then
24560 elsif N
= Name_Off
then
24563 -- Any other argument is illegal
24566 raise Program_Error
;
24568 end Get_SPARK_Mode_Type
;
24570 --------------------------------
24571 -- Get_SPARK_Mode_From_Pragma --
24572 --------------------------------
24574 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
24579 pragma Assert
(Nkind
(N
) = N_Pragma
);
24580 Args
:= Pragma_Argument_Associations
(N
);
24582 -- Extract the mode from the argument list
24584 if Present
(Args
) then
24585 Mode
:= First
(Pragma_Argument_Associations
(N
));
24586 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
24588 -- If SPARK_Mode pragma has no argument, default is ON
24593 end Get_SPARK_Mode_From_Pragma
;
24595 ---------------------------
24596 -- Has_Extra_Parentheses --
24597 ---------------------------
24599 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
24603 -- The aggregate should not have an expression list because a clause
24604 -- is always interpreted as a component association. The only way an
24605 -- expression list can sneak in is by adding extra parentheses around
24606 -- the individual clauses:
24608 -- Depends (Output => Input) -- proper form
24609 -- Depends ((Output => Input)) -- extra parentheses
24611 -- Since the extra parentheses are not allowed by the syntax of the
24612 -- pragma, flag them now to avoid emitting misleading errors down the
24615 if Nkind
(Clause
) = N_Aggregate
24616 and then Present
(Expressions
(Clause
))
24618 Expr
:= First
(Expressions
(Clause
));
24619 while Present
(Expr
) loop
24621 -- A dependency clause surrounded by extra parentheses appears
24622 -- as an aggregate of component associations with an optional
24623 -- Paren_Count set.
24625 if Nkind
(Expr
) = N_Aggregate
24626 and then Present
(Component_Associations
(Expr
))
24629 ("dependency clause contains extra parentheses", Expr
);
24631 -- Otherwise the expression is a malformed construct
24634 SPARK_Msg_N
("malformed dependency clause", Expr
);
24644 end Has_Extra_Parentheses
;
24650 procedure Initialize
is
24661 Dummy
:= Dummy
+ 1;
24664 -----------------------------
24665 -- Is_Config_Static_String --
24666 -----------------------------
24668 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
24670 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
24671 -- This is an internal recursive function that is just like the outer
24672 -- function except that it adds the string to the name buffer rather
24673 -- than placing the string in the name buffer.
24675 ------------------------------
24676 -- Add_Config_Static_String --
24677 ------------------------------
24679 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
24686 if Nkind
(N
) = N_Op_Concat
then
24687 if Add_Config_Static_String
(Left_Opnd
(N
)) then
24688 N
:= Right_Opnd
(N
);
24694 if Nkind
(N
) /= N_String_Literal
then
24695 Error_Msg_N
("string literal expected for pragma argument", N
);
24699 for J
in 1 .. String_Length
(Strval
(N
)) loop
24700 C
:= Get_String_Char
(Strval
(N
), J
);
24702 if not In_Character_Range
(C
) then
24704 ("string literal contains invalid wide character",
24705 Sloc
(N
) + 1 + Source_Ptr
(J
));
24709 Add_Char_To_Name_Buffer
(Get_Character
(C
));
24714 end Add_Config_Static_String
;
24716 -- Start of processing for Is_Config_Static_String
24721 return Add_Config_Static_String
(Arg
);
24722 end Is_Config_Static_String
;
24724 -------------------------------
24725 -- Is_Elaboration_SPARK_Mode --
24726 -------------------------------
24728 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
24731 (Nkind
(N
) = N_Pragma
24732 and then Pragma_Name
(N
) = Name_SPARK_Mode
24733 and then Is_List_Member
(N
));
24735 -- Pragma SPARK_Mode affects the elaboration of a package body when it
24736 -- appears in the statement part of the body.
24739 Present
(Parent
(N
))
24740 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
24741 and then List_Containing
(N
) = Statements
(Parent
(N
))
24742 and then Present
(Parent
(Parent
(N
)))
24743 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
24744 end Is_Elaboration_SPARK_Mode
;
24746 -----------------------------------------
24747 -- Is_Non_Significant_Pragma_Reference --
24748 -----------------------------------------
24750 -- This function makes use of the following static table which indicates
24751 -- whether appearance of some name in a given pragma is to be considered
24752 -- as a reference for the purposes of warnings about unreferenced objects.
24754 -- -1 indicates that appearence in any argument is significant
24755 -- 0 indicates that appearance in any argument is not significant
24756 -- +n indicates that appearance as argument n is significant, but all
24757 -- other arguments are not significant
24758 -- 9n arguments from n on are significant, before n inisignificant
24760 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
24761 (Pragma_Abort_Defer
=> -1,
24762 Pragma_Abstract_State
=> -1,
24763 Pragma_Ada_83
=> -1,
24764 Pragma_Ada_95
=> -1,
24765 Pragma_Ada_05
=> -1,
24766 Pragma_Ada_2005
=> -1,
24767 Pragma_Ada_12
=> -1,
24768 Pragma_Ada_2012
=> -1,
24769 Pragma_All_Calls_Remote
=> -1,
24770 Pragma_Allow_Integer_Address
=> -1,
24771 Pragma_Annotate
=> 93,
24772 Pragma_Assert
=> -1,
24773 Pragma_Assert_And_Cut
=> -1,
24774 Pragma_Assertion_Policy
=> 0,
24775 Pragma_Assume
=> -1,
24776 Pragma_Assume_No_Invalid_Values
=> 0,
24777 Pragma_Async_Readers
=> 0,
24778 Pragma_Async_Writers
=> 0,
24779 Pragma_Asynchronous
=> 0,
24780 Pragma_Atomic
=> 0,
24781 Pragma_Atomic_Components
=> 0,
24782 Pragma_Attach_Handler
=> -1,
24783 Pragma_Attribute_Definition
=> 92,
24784 Pragma_Check
=> -1,
24785 Pragma_Check_Float_Overflow
=> 0,
24786 Pragma_Check_Name
=> 0,
24787 Pragma_Check_Policy
=> 0,
24788 Pragma_CIL_Constructor
=> 0,
24789 Pragma_CPP_Class
=> 0,
24790 Pragma_CPP_Constructor
=> 0,
24791 Pragma_CPP_Virtual
=> 0,
24792 Pragma_CPP_Vtable
=> 0,
24794 Pragma_C_Pass_By_Copy
=> 0,
24795 Pragma_Comment
=> -1,
24796 Pragma_Common_Object
=> 0,
24797 Pragma_Compile_Time_Error
=> -1,
24798 Pragma_Compile_Time_Warning
=> -1,
24799 Pragma_Compiler_Unit
=> -1,
24800 Pragma_Compiler_Unit_Warning
=> -1,
24801 Pragma_Complete_Representation
=> 0,
24802 Pragma_Complex_Representation
=> 0,
24803 Pragma_Component_Alignment
=> 0,
24804 Pragma_Contract_Cases
=> -1,
24805 Pragma_Controlled
=> 0,
24806 Pragma_Convention
=> 0,
24807 Pragma_Convention_Identifier
=> 0,
24808 Pragma_Debug
=> -1,
24809 Pragma_Debug_Policy
=> 0,
24810 Pragma_Detect_Blocking
=> 0,
24811 Pragma_Default_Initial_Condition
=> -1,
24812 Pragma_Default_Scalar_Storage_Order
=> 0,
24813 Pragma_Default_Storage_Pool
=> 0,
24814 Pragma_Depends
=> -1,
24815 Pragma_Disable_Atomic_Synchronization
=> 0,
24816 Pragma_Discard_Names
=> 0,
24817 Pragma_Dispatching_Domain
=> -1,
24818 Pragma_Effective_Reads
=> 0,
24819 Pragma_Effective_Writes
=> 0,
24820 Pragma_Elaborate
=> 0,
24821 Pragma_Elaborate_All
=> 0,
24822 Pragma_Elaborate_Body
=> 0,
24823 Pragma_Elaboration_Checks
=> 0,
24824 Pragma_Eliminate
=> 0,
24825 Pragma_Enable_Atomic_Synchronization
=> 0,
24826 Pragma_Export
=> -1,
24827 Pragma_Export_Function
=> -1,
24828 Pragma_Export_Object
=> -1,
24829 Pragma_Export_Procedure
=> -1,
24830 Pragma_Export_Value
=> -1,
24831 Pragma_Export_Valued_Procedure
=> -1,
24832 Pragma_Extend_System
=> -1,
24833 Pragma_Extensions_Allowed
=> 0,
24834 Pragma_External
=> -1,
24835 Pragma_Favor_Top_Level
=> 0,
24836 Pragma_External_Name_Casing
=> 0,
24837 Pragma_Fast_Math
=> 0,
24838 Pragma_Finalize_Storage_Only
=> 0,
24839 Pragma_Global
=> -1,
24840 Pragma_Ident
=> -1,
24841 Pragma_Implementation_Defined
=> -1,
24842 Pragma_Implemented
=> -1,
24843 Pragma_Implicit_Packing
=> 0,
24844 Pragma_Import
=> 93,
24845 Pragma_Import_Function
=> 0,
24846 Pragma_Import_Object
=> 0,
24847 Pragma_Import_Procedure
=> 0,
24848 Pragma_Import_Valued_Procedure
=> 0,
24849 Pragma_Independent
=> 0,
24850 Pragma_Independent_Components
=> 0,
24851 Pragma_Initial_Condition
=> -1,
24852 Pragma_Initialize_Scalars
=> 0,
24853 Pragma_Initializes
=> -1,
24854 Pragma_Inline
=> 0,
24855 Pragma_Inline_Always
=> 0,
24856 Pragma_Inline_Generic
=> 0,
24857 Pragma_Inspection_Point
=> -1,
24858 Pragma_Interface
=> 92,
24859 Pragma_Interface_Name
=> 0,
24860 Pragma_Interrupt_Handler
=> -1,
24861 Pragma_Interrupt_Priority
=> -1,
24862 Pragma_Interrupt_State
=> -1,
24863 Pragma_Invariant
=> -1,
24864 Pragma_Java_Constructor
=> -1,
24865 Pragma_Java_Interface
=> -1,
24866 Pragma_Keep_Names
=> 0,
24867 Pragma_License
=> 0,
24868 Pragma_Link_With
=> -1,
24869 Pragma_Linker_Alias
=> -1,
24870 Pragma_Linker_Constructor
=> -1,
24871 Pragma_Linker_Destructor
=> -1,
24872 Pragma_Linker_Options
=> -1,
24873 Pragma_Linker_Section
=> 0,
24875 Pragma_Lock_Free
=> 0,
24876 Pragma_Locking_Policy
=> 0,
24877 Pragma_Loop_Invariant
=> -1,
24878 Pragma_Loop_Optimize
=> 0,
24879 Pragma_Loop_Variant
=> -1,
24880 Pragma_Machine_Attribute
=> -1,
24882 Pragma_Main_Storage
=> -1,
24883 Pragma_Memory_Size
=> 0,
24884 Pragma_No_Return
=> 0,
24885 Pragma_No_Body
=> 0,
24886 Pragma_No_Elaboration_Code_All
=> 0,
24887 Pragma_No_Inline
=> 0,
24888 Pragma_No_Run_Time
=> -1,
24889 Pragma_No_Strict_Aliasing
=> -1,
24890 Pragma_Normalize_Scalars
=> 0,
24891 Pragma_Obsolescent
=> 0,
24892 Pragma_Optimize
=> 0,
24893 Pragma_Optimize_Alignment
=> 0,
24894 Pragma_Overflow_Mode
=> 0,
24895 Pragma_Overriding_Renamings
=> 0,
24896 Pragma_Ordered
=> 0,
24899 Pragma_Part_Of
=> 0,
24900 Pragma_Partition_Elaboration_Policy
=> 0,
24901 Pragma_Passive
=> 0,
24902 Pragma_Persistent_BSS
=> 0,
24903 Pragma_Polling
=> 0,
24904 Pragma_Prefix_Exception_Messages
=> 0,
24906 Pragma_Postcondition
=> -1,
24907 Pragma_Post_Class
=> -1,
24909 Pragma_Precondition
=> -1,
24910 Pragma_Predicate
=> -1,
24911 Pragma_Preelaborable_Initialization
=> -1,
24912 Pragma_Preelaborate
=> 0,
24913 Pragma_Pre_Class
=> -1,
24914 Pragma_Priority
=> -1,
24915 Pragma_Priority_Specific_Dispatching
=> 0,
24916 Pragma_Profile
=> 0,
24917 Pragma_Profile_Warnings
=> 0,
24918 Pragma_Propagate_Exceptions
=> 0,
24919 Pragma_Provide_Shift_Operators
=> 0,
24920 Pragma_Psect_Object
=> 0,
24922 Pragma_Pure_Function
=> 0,
24923 Pragma_Queuing_Policy
=> 0,
24924 Pragma_Rational
=> 0,
24925 Pragma_Ravenscar
=> 0,
24926 Pragma_Refined_Depends
=> -1,
24927 Pragma_Refined_Global
=> -1,
24928 Pragma_Refined_Post
=> -1,
24929 Pragma_Refined_State
=> -1,
24930 Pragma_Relative_Deadline
=> 0,
24931 Pragma_Remote_Access_Type
=> -1,
24932 Pragma_Remote_Call_Interface
=> -1,
24933 Pragma_Remote_Types
=> -1,
24934 Pragma_Restricted_Run_Time
=> 0,
24935 Pragma_Restriction_Warnings
=> 0,
24936 Pragma_Restrictions
=> 0,
24937 Pragma_Reviewable
=> -1,
24938 Pragma_Short_Circuit_And_Or
=> 0,
24939 Pragma_Share_Generic
=> 0,
24940 Pragma_Shared
=> 0,
24941 Pragma_Shared_Passive
=> 0,
24942 Pragma_Short_Descriptors
=> 0,
24943 Pragma_Simple_Storage_Pool_Type
=> 0,
24944 Pragma_Source_File_Name
=> 0,
24945 Pragma_Source_File_Name_Project
=> 0,
24946 Pragma_Source_Reference
=> 0,
24947 Pragma_SPARK_Mode
=> 0,
24948 Pragma_Storage_Size
=> -1,
24949 Pragma_Storage_Unit
=> 0,
24950 Pragma_Static_Elaboration_Desired
=> 0,
24951 Pragma_Stream_Convert
=> 0,
24952 Pragma_Style_Checks
=> 0,
24953 Pragma_Subtitle
=> 0,
24954 Pragma_Suppress
=> 0,
24955 Pragma_Suppress_Exception_Locations
=> 0,
24956 Pragma_Suppress_All
=> 0,
24957 Pragma_Suppress_Debug_Info
=> 0,
24958 Pragma_Suppress_Initialization
=> 0,
24959 Pragma_System_Name
=> 0,
24960 Pragma_Task_Dispatching_Policy
=> 0,
24961 Pragma_Task_Info
=> -1,
24962 Pragma_Task_Name
=> -1,
24963 Pragma_Task_Storage
=> -1,
24964 Pragma_Test_Case
=> -1,
24965 Pragma_Thread_Local_Storage
=> -1,
24966 Pragma_Time_Slice
=> -1,
24968 Pragma_Type_Invariant
=> -1,
24969 Pragma_Type_Invariant_Class
=> -1,
24970 Pragma_Unchecked_Union
=> 0,
24971 Pragma_Unimplemented_Unit
=> 0,
24972 Pragma_Universal_Aliasing
=> 0,
24973 Pragma_Universal_Data
=> 0,
24974 Pragma_Unmodified
=> 0,
24975 Pragma_Unreferenced
=> 0,
24976 Pragma_Unreferenced_Objects
=> 0,
24977 Pragma_Unreserve_All_Interrupts
=> 0,
24978 Pragma_Unsuppress
=> 0,
24979 Pragma_Unevaluated_Use_Of_Old
=> 0,
24980 Pragma_Use_VADS_Size
=> 0,
24981 Pragma_Validity_Checks
=> 0,
24982 Pragma_Volatile
=> 0,
24983 Pragma_Volatile_Components
=> 0,
24984 Pragma_Warning_As_Error
=> 0,
24985 Pragma_Warnings
=> 0,
24986 Pragma_Weak_External
=> 0,
24987 Pragma_Wide_Character_Encoding
=> 0,
24988 Unknown_Pragma
=> 0);
24990 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
24996 function Arg_No
return Nat
;
24997 -- Returns an integer showing what argument we are in. A value of
24998 -- zero means we are not in any of the arguments.
25004 function Arg_No
return Nat
is
25009 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25023 -- Start of processing for Non_Significant_Pragma_Reference
25028 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25032 Id
:= Get_Pragma_Id
(Parent
(P
));
25033 C
:= Sig_Flags
(Id
);
25048 return AN
< (C
- 90);
25054 end Is_Non_Significant_Pragma_Reference
;
25056 ------------------------------
25057 -- Is_Pragma_String_Literal --
25058 ------------------------------
25060 -- This function returns true if the corresponding pragma argument is a
25061 -- static string expression. These are the only cases in which string
25062 -- literals can appear as pragma arguments. We also allow a string literal
25063 -- as the first argument to pragma Assert (although it will of course
25064 -- always generate a type error).
25066 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
25067 Pragn
: constant Node_Id
:= Parent
(Par
);
25068 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
25069 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
25075 N
:= First
(Assoc
);
25082 if Pname
= Name_Assert
then
25085 elsif Pname
= Name_Export
then
25088 elsif Pname
= Name_Ident
then
25091 elsif Pname
= Name_Import
then
25094 elsif Pname
= Name_Interface_Name
then
25097 elsif Pname
= Name_Linker_Alias
then
25100 elsif Pname
= Name_Linker_Section
then
25103 elsif Pname
= Name_Machine_Attribute
then
25106 elsif Pname
= Name_Source_File_Name
then
25109 elsif Pname
= Name_Source_Reference
then
25112 elsif Pname
= Name_Title
then
25115 elsif Pname
= Name_Subtitle
then
25121 end Is_Pragma_String_Literal
;
25123 ---------------------------
25124 -- Is_Private_SPARK_Mode --
25125 ---------------------------
25127 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
25130 (Nkind
(N
) = N_Pragma
25131 and then Pragma_Name
(N
) = Name_SPARK_Mode
25132 and then Is_List_Member
(N
));
25134 -- For pragma SPARK_Mode to be private, it has to appear in the private
25135 -- declarations of a package.
25138 Present
(Parent
(N
))
25139 and then Nkind
(Parent
(N
)) = N_Package_Specification
25140 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
25141 end Is_Private_SPARK_Mode
;
25143 -------------------------------------
25144 -- Is_Unconstrained_Or_Tagged_Item --
25145 -------------------------------------
25147 function Is_Unconstrained_Or_Tagged_Item
25148 (Item
: Entity_Id
) return Boolean
25150 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
25151 -- Determine whether record type Typ has at least one unconstrained
25154 ---------------------------------
25155 -- Has_Unconstrained_Component --
25156 ---------------------------------
25158 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
25162 Comp
:= First_Component
(Typ
);
25163 while Present
(Comp
) loop
25164 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
25168 Next_Component
(Comp
);
25172 end Has_Unconstrained_Component
;
25176 Typ
: constant Entity_Id
:= Etype
(Item
);
25178 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
25181 if Is_Tagged_Type
(Typ
) then
25184 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
25187 elsif Is_Record_Type
(Typ
) then
25188 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
25191 return Has_Unconstrained_Component
(Typ
);
25194 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
25200 end Is_Unconstrained_Or_Tagged_Item
;
25202 -----------------------------
25203 -- Is_Valid_Assertion_Kind --
25204 -----------------------------
25206 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
25213 Name_Static_Predicate |
25214 Name_Dynamic_Predicate |
25219 Name_Type_Invariant |
25220 Name_uType_Invariant |
25224 Name_Assert_And_Cut |
25226 Name_Contract_Cases |
25228 Name_Default_Initial_Condition |
25229 Name_Initial_Condition |
25232 Name_Loop_Invariant |
25233 Name_Loop_Variant |
25234 Name_Postcondition |
25235 Name_Precondition |
25237 Name_Refined_Post |
25238 Name_Statement_Assertions
=> return True;
25240 when others => return False;
25242 end Is_Valid_Assertion_Kind
;
25244 -----------------------------------------
25245 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
25246 -----------------------------------------
25248 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
25249 Aspects
: constant List_Id
:= New_List
;
25250 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
25251 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
25253 Original_Aspects
: List_Id
;
25254 -- To capture global references, a copy of the created aspects must be
25255 -- inserted in the original tree.
25258 Prag_Arg_Ass
: Node_Id
;
25259 Prag_Id
: Pragma_Id
;
25262 -- Check for any PPC pragmas that appear within Decl
25264 Prag
:= Next
(Decl
);
25265 while Nkind
(Prag
) = N_Pragma
loop
25266 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
25269 when Pragma_Postcondition | Pragma_Precondition
=>
25270 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
25272 -- Make an aspect from any PPC pragma
25274 Append_To
(Aspects
,
25275 Make_Aspect_Specification
(Loc
,
25277 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
25279 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
25281 -- Generate the analysis information in the pragma expression
25282 -- and then set the pragma node analyzed to avoid any further
25285 Analyze
(Expression
(Prag_Arg_Ass
));
25286 Set_Analyzed
(Prag
, True);
25288 when others => null;
25294 -- Set all new aspects into the generic declaration node
25296 if Is_Non_Empty_List
(Aspects
) then
25298 -- Create the list of aspects to be inserted in the original tree
25300 Original_Aspects
:= Copy_Separate_List
(Aspects
);
25302 -- Check if Decl already has aspects
25304 -- Attach the new lists of aspects to both the generic copy and the
25307 if Has_Aspects
(Decl
) then
25308 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
25309 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
25312 Set_Parent
(Aspects
, Decl
);
25313 Set_Aspect_Specifications
(Decl
, Aspects
);
25314 Set_Parent
(Original_Aspects
, Or_Decl
);
25315 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
25318 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
25320 -------------------------
25321 -- Preanalyze_CTC_Args --
25322 -------------------------
25324 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
25326 -- Preanalyze the boolean expressions, we treat these as spec
25327 -- expressions (i.e. similar to a default expression).
25329 if Present
(Arg_Req
) then
25330 Preanalyze_Assert_Expression
25331 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
25333 -- In ASIS mode, for a pragma generated from a source aspect, also
25334 -- analyze the original aspect expression.
25336 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
25337 Preanalyze_Assert_Expression
25338 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
25342 if Present
(Arg_Ens
) then
25343 Preanalyze_Assert_Expression
25344 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
25346 -- In ASIS mode, for a pragma generated from a source aspect, also
25347 -- analyze the original aspect expression.
25349 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
25350 Preanalyze_Assert_Expression
25351 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
25354 end Preanalyze_CTC_Args
;
25356 --------------------------------------
25357 -- Process_Compilation_Unit_Pragmas --
25358 --------------------------------------
25360 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
25362 -- A special check for pragma Suppress_All, a very strange DEC pragma,
25363 -- strange because it comes at the end of the unit. Rational has the
25364 -- same name for a pragma, but treats it as a program unit pragma, In
25365 -- GNAT we just decide to allow it anywhere at all. If it appeared then
25366 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
25367 -- node, and we insert a pragma Suppress (All_Checks) at the start of
25368 -- the context clause to ensure the correct processing.
25370 if Has_Pragma_Suppress_All
(N
) then
25371 Prepend_To
(Context_Items
(N
),
25372 Make_Pragma
(Sloc
(N
),
25373 Chars
=> Name_Suppress
,
25374 Pragma_Argument_Associations
=> New_List
(
25375 Make_Pragma_Argument_Association
(Sloc
(N
),
25376 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
25379 -- Nothing else to do at the current time
25381 end Process_Compilation_Unit_Pragmas
;
25383 ------------------------------------
25384 -- Record_Possible_Body_Reference --
25385 ------------------------------------
25387 procedure Record_Possible_Body_Reference
25388 (State_Id
: Entity_Id
;
25392 Spec_Id
: Entity_Id
;
25395 -- Ensure that we are dealing with a reference to a state
25397 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
25399 -- Climb the tree starting from the reference looking for a package body
25400 -- whose spec declares the referenced state. This criteria automatically
25401 -- excludes references in package specs which are legal. Note that it is
25402 -- not wise to emit an error now as the package body may lack pragma
25403 -- Refined_State or the referenced state may not be mentioned in the
25404 -- refinement. This approach avoids the generation of misleading errors.
25407 while Present
(Context
) loop
25408 if Nkind
(Context
) = N_Package_Body
then
25409 Spec_Id
:= Corresponding_Spec
(Context
);
25411 if Present
(Abstract_States
(Spec_Id
))
25412 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
25414 if No
(Body_References
(State_Id
)) then
25415 Set_Body_References
(State_Id
, New_Elmt_List
);
25418 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
25423 Context
:= Parent
(Context
);
25425 end Record_Possible_Body_Reference
;
25427 ------------------------------
25428 -- Relocate_Pragmas_To_Body --
25429 ------------------------------
25431 procedure Relocate_Pragmas_To_Body
25432 (Subp_Body
: Node_Id
;
25433 Target_Body
: Node_Id
:= Empty
)
25435 procedure Relocate_Pragma
(Prag
: Node_Id
);
25436 -- Remove a single pragma from its current list and add it to the
25437 -- declarations of the proper body (either Subp_Body or Target_Body).
25439 ---------------------
25440 -- Relocate_Pragma --
25441 ---------------------
25443 procedure Relocate_Pragma
(Prag
: Node_Id
) is
25448 -- When subprogram stubs or expression functions are involves, the
25449 -- destination declaration list belongs to the proper body.
25451 if Present
(Target_Body
) then
25452 Target
:= Target_Body
;
25454 Target
:= Subp_Body
;
25457 Decls
:= Declarations
(Target
);
25461 Set_Declarations
(Target
, Decls
);
25464 -- Unhook the pragma from its current list
25467 Prepend
(Prag
, Decls
);
25468 end Relocate_Pragma
;
25472 Body_Id
: constant Entity_Id
:=
25473 Defining_Unit_Name
(Specification
(Subp_Body
));
25474 Next_Stmt
: Node_Id
;
25477 -- Start of processing for Relocate_Pragmas_To_Body
25480 -- Do not process a body that comes from a separate unit as no construct
25481 -- can possibly follow it.
25483 if not Is_List_Member
(Subp_Body
) then
25486 -- Do not relocate pragmas that follow a stub if the stub does not have
25489 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
25490 and then No
(Target_Body
)
25494 -- Do not process internally generated routine _Postconditions
25496 elsif Ekind
(Body_Id
) = E_Procedure
25497 and then Chars
(Body_Id
) = Name_uPostconditions
25502 -- Look at what is following the body. We are interested in certain kind
25503 -- of pragmas (either from source or byproducts of expansion) that can
25504 -- apply to a body [stub].
25506 Stmt
:= Next
(Subp_Body
);
25507 while Present
(Stmt
) loop
25509 -- Preserve the following statement for iteration purposes due to a
25510 -- possible relocation of a pragma.
25512 Next_Stmt
:= Next
(Stmt
);
25514 -- Move a candidate pragma following the body to the declarations of
25517 if Nkind
(Stmt
) = N_Pragma
25518 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
25520 Relocate_Pragma
(Stmt
);
25522 -- Skip internally generated code
25524 elsif not Comes_From_Source
(Stmt
) then
25527 -- No candidate pragmas are available for relocation
25535 end Relocate_Pragmas_To_Body
;
25537 -------------------
25538 -- Resolve_State --
25539 -------------------
25541 procedure Resolve_State
(N
: Node_Id
) is
25546 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
25547 Func
:= Entity
(N
);
25549 -- Handle overloading of state names by functions. Traverse the
25550 -- homonym chain looking for an abstract state.
25552 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
25553 State
:= Homonym
(Func
);
25554 while Present
(State
) loop
25556 -- Resolve the overloading by setting the proper entity of the
25557 -- reference to that of the state.
25559 if Ekind
(State
) = E_Abstract_State
then
25560 Set_Etype
(N
, Standard_Void_Type
);
25561 Set_Entity
(N
, State
);
25562 Set_Associated_Node
(N
, State
);
25566 State
:= Homonym
(State
);
25569 -- A function can never act as a state. If the homonym chain does
25570 -- not contain a corresponding state, then something went wrong in
25571 -- the overloading mechanism.
25573 raise Program_Error
;
25578 ----------------------------
25579 -- Rewrite_Assertion_Kind --
25580 ----------------------------
25582 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
25586 if Nkind
(N
) = N_Attribute_Reference
25587 and then Attribute_Name
(N
) = Name_Class
25588 and then Nkind
(Prefix
(N
)) = N_Identifier
25590 case Chars
(Prefix
(N
)) is
25595 when Name_Type_Invariant
=>
25596 Nam
:= Name_uType_Invariant
;
25597 when Name_Invariant
=>
25598 Nam
:= Name_uInvariant
;
25603 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
25605 end Rewrite_Assertion_Kind
;
25613 Dummy
:= Dummy
+ 1;
25616 --------------------------------
25617 -- Set_Encoded_Interface_Name --
25618 --------------------------------
25620 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
25621 Str
: constant String_Id
:= Strval
(S
);
25622 Len
: constant Int
:= String_Length
(Str
);
25627 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
25630 -- Stores encoded value of character code CC. The encoding we use an
25631 -- underscore followed by four lower case hex digits.
25637 procedure Encode
is
25639 Store_String_Char
(Get_Char_Code
('_'));
25641 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
25643 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
25645 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
25647 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
25650 -- Start of processing for Set_Encoded_Interface_Name
25653 -- If first character is asterisk, this is a link name, and we leave it
25654 -- completely unmodified. We also ignore null strings (the latter case
25655 -- happens only in error cases) and no encoding should occur for Java or
25656 -- AAMP interface names.
25659 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
25660 or else VM_Target
/= No_VM
25661 or else AAMP_On_Target
25663 Set_Interface_Name
(E
, S
);
25668 CC
:= Get_String_Char
(Str
, J
);
25670 exit when not In_Character_Range
(CC
);
25672 C
:= Get_Character
(CC
);
25674 exit when C
/= '_' and then C
/= '$'
25675 and then C
not in '0' .. '9'
25676 and then C
not in 'a' .. 'z'
25677 and then C
not in 'A' .. 'Z';
25680 Set_Interface_Name
(E
, S
);
25688 -- Here we need to encode. The encoding we use as follows:
25689 -- three underscores + four hex digits (lower case)
25693 for J
in 1 .. String_Length
(Str
) loop
25694 CC
:= Get_String_Char
(Str
, J
);
25696 if not In_Character_Range
(CC
) then
25699 C
:= Get_Character
(CC
);
25701 if C
= '_' or else C
= '$'
25702 or else C
in '0' .. '9'
25703 or else C
in 'a' .. 'z'
25704 or else C
in 'A' .. 'Z'
25706 Store_String_Char
(CC
);
25713 Set_Interface_Name
(E
,
25714 Make_String_Literal
(Sloc
(S
),
25715 Strval
=> End_String
));
25717 end Set_Encoded_Interface_Name
;
25719 -------------------
25720 -- Set_Unit_Name --
25721 -------------------
25723 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
25728 if Nkind
(N
) = N_Identifier
25729 and then Nkind
(With_Item
) = N_Identifier
25731 Set_Entity
(N
, Entity
(With_Item
));
25733 elsif Nkind
(N
) = N_Selected_Component
then
25734 Change_Selected_Component_To_Expanded_Name
(N
);
25735 Set_Entity
(N
, Entity
(With_Item
));
25736 Set_Entity
(Selector_Name
(N
), Entity
(N
));
25738 Pref
:= Prefix
(N
);
25739 Scop
:= Scope
(Entity
(N
));
25740 while Nkind
(Pref
) = N_Selected_Component
loop
25741 Change_Selected_Component_To_Expanded_Name
(Pref
);
25742 Set_Entity
(Selector_Name
(Pref
), Scop
);
25743 Set_Entity
(Pref
, Scop
);
25744 Pref
:= Prefix
(Pref
);
25745 Scop
:= Scope
(Scop
);
25748 Set_Entity
(Pref
, Scop
);