1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Csets
; use Csets
;
37 with Debug
; use Debug
;
38 with Einfo
; use Einfo
;
39 with Elists
; use Elists
;
40 with Errout
; use Errout
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
45 with Lib
.Writ
; use Lib
.Writ
;
46 with Lib
.Xref
; use Lib
.Xref
;
47 with Namet
.Sp
; use Namet
.Sp
;
48 with Nlists
; use Nlists
;
49 with Nmake
; use Nmake
;
50 with Output
; use Output
;
51 with Par_SCO
; use Par_SCO
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch6
; use Sem_Ch6
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Ch12
; use Sem_Ch12
;
61 with Sem_Ch13
; use Sem_Ch13
;
62 with Sem_Disp
; use Sem_Disp
;
63 with Sem_Dist
; use Sem_Dist
;
64 with Sem_Elim
; use Sem_Elim
;
65 with Sem_Eval
; use Sem_Eval
;
66 with Sem_Intr
; use Sem_Intr
;
67 with Sem_Mech
; use Sem_Mech
;
68 with Sem_Res
; use Sem_Res
;
69 with Sem_Type
; use Sem_Type
;
70 with Sem_Util
; use Sem_Util
;
71 with Sem_Warn
; use Sem_Warn
;
72 with Stand
; use Stand
;
73 with Sinfo
; use Sinfo
;
74 with Sinfo
.CN
; use Sinfo
.CN
;
75 with Sinput
; use Sinput
;
76 with Stringt
; use Stringt
;
77 with Stylesw
; use Stylesw
;
79 with Targparm
; use Targparm
;
80 with Tbuild
; use Tbuild
;
82 with Uintp
; use Uintp
;
83 with Uname
; use Uname
;
84 with Urealp
; use Urealp
;
85 with Validsw
; use Validsw
;
86 with Warnsw
; use Warnsw
;
88 package body Sem_Prag
is
90 ----------------------------------------------
91 -- Common Handling of Import-Export Pragmas --
92 ----------------------------------------------
94 -- In the following section, a number of Import_xxx and Export_xxx pragmas
95 -- are defined by GNAT. These are compatible with the DEC pragmas of the
96 -- same name, and all have the following common form and processing:
99 -- [Internal =>] LOCAL_NAME
100 -- [, [External =>] EXTERNAL_SYMBOL]
101 -- [, other optional parameters ]);
104 -- [Internal =>] LOCAL_NAME
105 -- [, [External =>] EXTERNAL_SYMBOL]
106 -- [, other optional parameters ]);
108 -- EXTERNAL_SYMBOL ::=
110 -- | static_string_EXPRESSION
112 -- The internal LOCAL_NAME designates the entity that is imported or
113 -- exported, and must refer to an entity in the current declarative
114 -- part (as required by the rules for LOCAL_NAME).
116 -- The external linker name is designated by the External parameter if
117 -- given, or the Internal parameter if not (if there is no External
118 -- parameter, the External parameter is a copy of the Internal name).
120 -- If the External parameter is given as a string, then this string is
121 -- treated as an external name (exactly as though it had been given as an
122 -- External_Name parameter for a normal Import pragma).
124 -- If the External parameter is given as an identifier (or there is no
125 -- External parameter, so that the Internal identifier is used), then
126 -- the external name is the characters of the identifier, translated
127 -- to all lower case letters.
129 -- Note: the external name specified or implied by any of these special
130 -- Import_xxx or Export_xxx pragmas override an external or link name
131 -- specified in a previous Import or Export pragma.
133 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
134 -- named notation, following the standard rules for subprogram calls, i.e.
135 -- parameters can be given in any order if named notation is used, and
136 -- positional and named notation can be mixed, subject to the rule that all
137 -- positional parameters must appear first.
139 -- Note: All these pragmas are implemented exactly following the DEC design
140 -- and implementation and are intended to be fully compatible with the use
141 -- of these pragmas in the DEC Ada compiler.
143 --------------------------------------------
144 -- Checking for Duplicated External Names --
145 --------------------------------------------
147 -- It is suspicious if two separate Export pragmas use the same external
148 -- name. The following table is used to diagnose this situation so that
149 -- an appropriate warning can be issued.
151 -- The Node_Id stored is for the N_String_Literal node created to hold
152 -- the value of the external name. The Sloc of this node is used to
153 -- cross-reference the location of the duplication.
155 package Externals
is new Table
.Table
(
156 Table_Component_Type
=> Node_Id
,
157 Table_Index_Type
=> Int
,
158 Table_Low_Bound
=> 0,
159 Table_Initial
=> 100,
160 Table_Increment
=> 100,
161 Table_Name
=> "Name_Externals");
163 -------------------------------------
164 -- Local Subprograms and Variables --
165 -------------------------------------
167 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
);
168 -- Subsidiary routine to the analysis of pragmas Depends, Global and
169 -- Refined_State. Append an entity to a list. If the list is empty, create
172 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
173 -- This routine is used for possible casing adjustment of an explicit
174 -- external name supplied as a string literal (the node N), according to
175 -- the casing requirement of Opt.External_Name_Casing. If this is set to
176 -- As_Is, then the string literal is returned unchanged, but if it is set
177 -- to Uppercase or Lowercase, then a new string literal with appropriate
178 -- casing is constructed.
180 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
181 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
182 -- whether a particular item appears in a mixed list of nodes and entities.
183 -- It is assumed that all nodes in the list have entities.
185 function Check_Kind
(Nam
: Name_Id
) return Name_Id
;
186 -- This function is used in connection with pragmas Assert, Check,
187 -- and assertion aspects and pragmas, to determine if Check pragmas
188 -- (or corresponding assertion aspects or pragmas) are currently active
189 -- as determined by the presence of -gnata on the command line (which
190 -- sets the default), and the appearance of pragmas Check_Policy and
191 -- Assertion_Policy as configuration pragmas either in a configuration
192 -- pragma file, or at the start of the current unit, or locally given
193 -- Check_Policy and Assertion_Policy pragmas that are currently active.
195 -- The value returned is one of the names Check, Ignore, Disable (On
196 -- returns Check, and Off returns Ignore).
198 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
199 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
200 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
201 -- _Post, _Invariant, or _Type_Invariant, which are special names used
202 -- in identifiers to represent these attribute references.
204 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
);
205 -- In ASIS mode we need to analyze the original expression in the aspect
206 -- specification. For Initializes, Global, and related SPARK aspects, the
207 -- expression has a sui-generis syntax which may be a list, an expression,
210 procedure Check_State_And_Constituent_Use
214 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
215 -- Global and Initializes. Determine whether a state from list States and a
216 -- corresponding constituent from list Constits (if any) appear in the same
217 -- context denoted by Context. If this is the case, emit an error.
219 procedure Collect_Global_Items
221 In_Items
: in out Elist_Id
;
222 In_Out_Items
: in out Elist_Id
;
223 Out_Items
: in out Elist_Id
;
224 Proof_In_Items
: in out Elist_Id
;
225 Has_In_State
: out Boolean;
226 Has_In_Out_State
: out Boolean;
227 Has_Out_State
: out Boolean;
228 Has_Proof_In_State
: out Boolean;
229 Has_Null_State
: out Boolean);
230 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
231 -- Prag denotes pragma [Refined_]Global. Gather all input, in out, output
232 -- and Proof_In items of Prag in lists In_Items, In_Out_Items, Out_Items
233 -- and Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
234 -- and Has_Proof_In_State are set when there is at least one abstract state
235 -- with visible refinement available in the corresponding mode. Flag
236 -- Has_Null_State is set when at least state has a null refinement.
238 function Find_Related_Subprogram_Or_Body
240 Do_Checks
: Boolean := False) return Node_Id
;
241 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
242 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
243 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
244 -- Do_Checks is set, the routine reports duplicate pragmas and detects
245 -- improper use of refinement pragmas in stand alone expression functions.
246 -- The returned value depends on the related pragma as follows:
247 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
248 -- N_Subprogram_Declaration node or if the pragma applies to a stand
249 -- alone body, the N_Subprogram_Body node or Empty if illegal.
250 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
251 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
254 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
255 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
256 -- original one, following the renaming chain) is returned. Otherwise the
257 -- entity is returned unchanged. Should be in Einfo???
259 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
260 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
261 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
264 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
265 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
266 -- Determine whether dependency clause Clause is surrounded by extra
267 -- parentheses. If this is the case, issue an error message.
269 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
270 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
271 -- pragma Depends. Determine whether the type of dependency item Item is
272 -- tagged, unconstrained array, unconstrained record or a record with at
273 -- least one unconstrained component.
275 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
);
276 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
277 -- of a Test_Case pragma if present (possibly Empty). We treat these as
278 -- spec expressions (i.e. similar to a default expression).
280 procedure Record_Possible_Body_Reference
281 (State_Id
: Entity_Id
;
283 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
284 -- Global. Given an abstract state denoted by State_Id and a reference Ref
285 -- to it, determine whether the reference appears in a package body that
286 -- will eventually refine the state. If this is the case, record the
287 -- reference for future checks (see Analyze_Refined_State_In_Decls).
289 procedure Resolve_State
(N
: Node_Id
);
290 -- Handle the overloading of state names by functions. When N denotes a
291 -- function, this routine finds the corresponding state and sets the entity
292 -- of N to that of the state.
294 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
295 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
296 -- then it is rewritten as an identifier with the corresponding special
297 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
298 -- Check, Check_Policy.
300 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
301 -- Place semantic information on the argument of an Elaborate/Elaborate_All
302 -- pragma. Entity name for unit and its parents is taken from item in
303 -- previous with_clause that mentions the unit.
305 Dummy
: Integer := 0;
306 pragma Volatile
(Dummy
);
307 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
310 pragma No_Inline
(ip
);
311 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
312 -- is just to help debugging the front end. If a pragma Inspection_Point
313 -- is added to a source program, then breaking on ip will get you to that
314 -- point in the program.
317 pragma No_Inline
(rv
);
318 -- This is a dummy function called by the processing for pragma Reviewable.
319 -- It is there for assisting front end debugging. By placing a Reviewable
320 -- pragma in the source program, a breakpoint on rv catches this place in
321 -- the source, allowing convenient stepping to the point of interest.
327 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
329 Append_New_Elmt
(Item
, To
=> To_List
);
332 -------------------------------
333 -- Adjust_External_Name_Case --
334 -------------------------------
336 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
340 -- Adjust case of literal if required
342 if Opt
.External_Name_Exp_Casing
= As_Is
then
346 -- Copy existing string
352 for J
in 1 .. String_Length
(Strval
(N
)) loop
353 CC
:= Get_String_Char
(Strval
(N
), J
);
355 if Opt
.External_Name_Exp_Casing
= Uppercase
356 and then CC
>= Get_Char_Code
('a')
357 and then CC
<= Get_Char_Code
('z')
359 Store_String_Char
(CC
- 32);
361 elsif Opt
.External_Name_Exp_Casing
= Lowercase
362 and then CC
>= Get_Char_Code
('A')
363 and then CC
<= Get_Char_Code
('Z')
365 Store_String_Char
(CC
+ 32);
368 Store_String_Char
(CC
);
373 Make_String_Literal
(Sloc
(N
),
374 Strval
=> End_String
);
376 end Adjust_External_Name_Case
;
378 -----------------------------------------
379 -- Analyze_Contract_Cases_In_Decl_Part --
380 -----------------------------------------
382 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
383 Others_Seen
: Boolean := False;
385 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
386 -- Verify the legality of a single contract case
388 ---------------------------
389 -- Analyze_Contract_Case --
390 ---------------------------
392 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
393 Case_Guard
: Node_Id
;
395 Extra_Guard
: Node_Id
;
398 if Nkind
(CCase
) = N_Component_Association
then
399 Case_Guard
:= First
(Choices
(CCase
));
400 Conseq
:= Expression
(CCase
);
402 -- Each contract case must have exactly one case guard
404 Extra_Guard
:= Next
(Case_Guard
);
406 if Present
(Extra_Guard
) then
408 ("contract case must have exactly one case guard",
412 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
414 if Nkind
(Case_Guard
) = N_Others_Choice
then
417 ("only one others choice allowed in contract cases",
423 elsif Others_Seen
then
425 ("others must be the last choice in contract cases", N
);
428 -- Preanalyze the case guard and consequence
430 if Nkind
(Case_Guard
) /= N_Others_Choice
then
431 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
434 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
436 -- The contract case is malformed
439 Error_Msg_N
("wrong syntax in contract case", CCase
);
441 end Analyze_Contract_Case
;
450 Restore_Scope
: Boolean := False;
451 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
453 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
458 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
459 Subp_Id
:= Defining_Entity
(Subp_Decl
);
460 All_Cases
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
462 -- Single and multiple contract cases must appear in aggregate form. If
463 -- this is not the case, then either the parser of the analysis of the
464 -- pragma failed to produce an aggregate.
466 pragma Assert
(Nkind
(All_Cases
) = N_Aggregate
);
468 if No
(Component_Associations
(All_Cases
)) then
469 Error_Msg_N
("wrong syntax for constract cases", N
);
471 -- Individual contract cases appear as component associations
474 -- Ensure that the formal parameters are visible when analyzing all
475 -- clauses. This falls out of the general rule of aspects pertaining
476 -- to subprogram declarations. Skip the installation for subprogram
477 -- bodies because the formals are already visible.
479 if not In_Open_Scopes
(Subp_Id
) then
480 Restore_Scope
:= True;
481 Push_Scope
(Subp_Id
);
482 Install_Formals
(Subp_Id
);
485 CCase
:= First
(Component_Associations
(All_Cases
));
486 while Present
(CCase
) loop
487 Analyze_Contract_Case
(CCase
);
491 if Restore_Scope
then
495 end Analyze_Contract_Cases_In_Decl_Part
;
497 ----------------------------------
498 -- Analyze_Depends_In_Decl_Part --
499 ----------------------------------
501 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
502 Loc
: constant Source_Ptr
:= Sloc
(N
);
504 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
505 -- A list containing the entities of all the inputs processed so far.
506 -- The list is populated with unique entities because the same input
507 -- may appear in multiple input lists.
509 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
510 -- A list containing the entities of all the outputs processed so far.
511 -- The list is populated with unique entities because output items are
512 -- unique in a dependence relation.
514 Constits_Seen
: Elist_Id
:= No_Elist
;
515 -- A list containing the entities of all constituents processed so far.
516 -- It aids in detecting illegal usage of a state and a corresponding
517 -- constituent in pragma [Refinde_]Depends.
519 Global_Seen
: Boolean := False;
520 -- A flag set when pragma Global has been processed
522 Null_Output_Seen
: Boolean := False;
523 -- A flag used to track the legality of a null output
525 Result_Seen
: Boolean := False;
526 -- A flag set when Subp_Id'Result is processed
529 -- The entity of the subprogram subject to pragma [Refined_]Depends
531 States_Seen
: Elist_Id
:= No_Elist
;
532 -- A list containing the entities of all states processed so far. It
533 -- helps in detecting illegal usage of a state and a corresponding
534 -- constituent in pragma [Refined_]Depends.
537 -- The entity of the subprogram [body or stub] subject to pragma
538 -- [Refined_]Depends.
540 Subp_Inputs
: Elist_Id
:= No_Elist
;
541 Subp_Outputs
: Elist_Id
:= No_Elist
;
542 -- Two lists containing the full set of inputs and output of the related
543 -- subprograms. Note that these lists contain both nodes and entities.
545 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
546 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
547 -- to the name buffer. The individual kinds are as follows:
548 -- E_Abstract_State - "state"
549 -- E_In_Parameter - "parameter"
550 -- E_In_Out_Parameter - "parameter"
551 -- E_Out_Parameter - "parameter"
552 -- E_Variable - "global"
554 procedure Analyze_Dependency_Clause
557 -- Verify the legality of a single dependency clause. Flag Is_Last
558 -- denotes whether Clause is the last clause in the relation.
560 procedure Check_Function_Return
;
561 -- Verify that Funtion'Result appears as one of the outputs
562 -- (SPARK RM 6.1.5(10)).
569 -- Ensure that an item fulfils its designated input and/or output role
570 -- as specified by pragma Global (if any) or the enclosing context. If
571 -- this is not the case, emit an error. Item and Item_Id denote the
572 -- attributes of an item. Flag Is_Input should be set when item comes
573 -- from an input list. Flag Self_Ref should be set when the item is an
574 -- output and the dependency clause has operator "+".
576 procedure Check_Usage
577 (Subp_Items
: Elist_Id
;
578 Used_Items
: Elist_Id
;
580 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
581 -- error if this is not the case.
583 procedure Normalize_Clause
(Clause
: Node_Id
);
584 -- Remove a self-dependency "+" from the input list of a clause. Split
585 -- a clause with multiple outputs into multiple clauses with a single
588 -----------------------------
589 -- Add_Item_To_Name_Buffer --
590 -----------------------------
592 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
594 if Ekind
(Item_Id
) = E_Abstract_State
then
595 Add_Str_To_Name_Buffer
("state");
597 elsif Is_Formal
(Item_Id
) then
598 Add_Str_To_Name_Buffer
("parameter");
600 elsif Ekind
(Item_Id
) = E_Variable
then
601 Add_Str_To_Name_Buffer
("global");
603 -- The routine should not be called with non-SPARK items
608 end Add_Item_To_Name_Buffer
;
610 -------------------------------
611 -- Analyze_Dependency_Clause --
612 -------------------------------
614 procedure Analyze_Dependency_Clause
618 procedure Analyze_Input_List
(Inputs
: Node_Id
);
619 -- Verify the legality of a single input list
621 procedure Analyze_Input_Output
626 Seen
: in out Elist_Id
;
627 Null_Seen
: in out Boolean;
628 Non_Null_Seen
: in out Boolean);
629 -- Verify the legality of a single input or output item. Flag
630 -- Is_Input should be set whenever Item is an input, False when it
631 -- denotes an output. Flag Self_Ref should be set when the item is an
632 -- output and the dependency clause has a "+". Flag Top_Level should
633 -- be set whenever Item appears immediately within an input or output
634 -- list. Seen is a collection of all abstract states, variables and
635 -- formals processed so far. Flag Null_Seen denotes whether a null
636 -- input or output has been encountered. Flag Non_Null_Seen denotes
637 -- whether a non-null input or output has been encountered.
639 ------------------------
640 -- Analyze_Input_List --
641 ------------------------
643 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
644 Inputs_Seen
: Elist_Id
:= No_Elist
;
645 -- A list containing the entities of all inputs that appear in the
646 -- current input list.
648 Non_Null_Input_Seen
: Boolean := False;
649 Null_Input_Seen
: Boolean := False;
650 -- Flags used to check the legality of an input list
655 -- Multiple inputs appear as an aggregate
657 if Nkind
(Inputs
) = N_Aggregate
then
658 if Present
(Component_Associations
(Inputs
)) then
660 ("nested dependency relations not allowed", Inputs
);
662 elsif Present
(Expressions
(Inputs
)) then
663 Input
:= First
(Expressions
(Inputs
));
664 while Present
(Input
) loop
671 Null_Seen
=> Null_Input_Seen
,
672 Non_Null_Seen
=> Non_Null_Input_Seen
);
677 -- Syntax error, always report
680 Error_Msg_N
("malformed input dependency list", Inputs
);
683 -- Process a solitary input
692 Null_Seen
=> Null_Input_Seen
,
693 Non_Null_Seen
=> Non_Null_Input_Seen
);
696 -- Detect an illegal dependency clause of the form
700 if Null_Output_Seen
and then Null_Input_Seen
then
702 ("null dependency clause cannot have a null input list",
705 end Analyze_Input_List
;
707 --------------------------
708 -- Analyze_Input_Output --
709 --------------------------
711 procedure Analyze_Input_Output
716 Seen
: in out Elist_Id
;
717 Null_Seen
: in out Boolean;
718 Non_Null_Seen
: in out Boolean)
720 Is_Output
: constant Boolean := not Is_Input
;
725 -- Multiple input or output items appear as an aggregate
727 if Nkind
(Item
) = N_Aggregate
then
728 if not Top_Level
then
729 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
731 elsif Present
(Component_Associations
(Item
)) then
733 ("nested dependency relations not allowed", Item
);
735 -- Recursively analyze the grouped items
737 elsif Present
(Expressions
(Item
)) then
738 Grouped
:= First
(Expressions
(Item
));
739 while Present
(Grouped
) loop
742 Is_Input
=> Is_Input
,
743 Self_Ref
=> Self_Ref
,
746 Null_Seen
=> Null_Seen
,
747 Non_Null_Seen
=> Non_Null_Seen
);
752 -- Syntax error, always report
755 Error_Msg_N
("malformed dependency list", Item
);
758 -- Process Function'Result in the context of a dependency clause
760 elsif Is_Attribute_Result
(Item
) then
761 Non_Null_Seen
:= True;
763 -- It is sufficent to analyze the prefix of 'Result in order to
764 -- establish legality of the attribute.
766 Analyze
(Prefix
(Item
));
768 -- The prefix of 'Result must denote the function for which
769 -- pragma Depends applies (SPARK RM 6.1.5(11)).
771 if not Is_Entity_Name
(Prefix
(Item
))
772 or else Ekind
(Spec_Id
) /= E_Function
773 or else Entity
(Prefix
(Item
)) /= Spec_Id
775 Error_Msg_Name_1
:= Name_Result
;
777 ("prefix of attribute % must denote the enclosing "
780 -- Function'Result is allowed to appear on the output side of a
781 -- dependency clause (SPARK RM 6.1.5(6)).
784 SPARK_Msg_N
("function result cannot act as input", Item
);
788 ("cannot mix null and non-null dependency items", Item
);
794 -- Detect multiple uses of null in a single dependency list or
795 -- throughout the whole relation. Verify the placement of a null
796 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
798 elsif Nkind
(Item
) = N_Null
then
801 ("multiple null dependency relations not allowed", Item
);
803 elsif Non_Null_Seen
then
805 ("cannot mix null and non-null dependency items", Item
);
813 ("null output list must be the last clause in a "
814 & "dependency relation", Item
);
816 -- Catch a useless dependence of the form:
821 ("useless dependence, null depends on itself", Item
);
829 Non_Null_Seen
:= True;
832 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
836 Resolve_State
(Item
);
838 -- Find the entity of the item. If this is a renaming, climb
839 -- the renaming chain to reach the root object. Renamings of
840 -- non-entire objects do not yield an entity (Empty).
842 Item_Id
:= Entity_Of
(Item
);
844 if Present
(Item_Id
) then
845 if Ekind_In
(Item_Id
, E_Abstract_State
,
851 -- Ensure that the item fulfils its role as input and/or
852 -- output as specified by pragma Global or the enclosing
855 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
857 -- Detect multiple uses of the same state, variable or
858 -- formal parameter. If this is not the case, add the
859 -- item to the list of processed relations.
861 if Contains
(Seen
, Item_Id
) then
863 ("duplicate use of item &", Item
, Item_Id
);
865 Add_Item
(Item_Id
, Seen
);
868 -- Detect illegal use of an input related to a null
869 -- output. Such input items cannot appear in other
870 -- input lists (SPARK RM 6.1.5(13)).
873 and then Null_Output_Seen
874 and then Contains
(All_Inputs_Seen
, Item_Id
)
877 ("input of a null output list cannot appear in "
878 & "multiple input lists", Item
);
881 -- Add an input or a self-referential output to the list
882 -- of all processed inputs.
884 if Is_Input
or else Self_Ref
then
885 Add_Item
(Item_Id
, All_Inputs_Seen
);
888 -- State related checks (SPARK RM 6.1.5(3))
890 if Ekind
(Item_Id
) = E_Abstract_State
then
891 if Has_Visible_Refinement
(Item_Id
) then
893 ("cannot mention state & in global refinement",
896 ("\use its constituents instead", Item
);
899 -- If the reference to the abstract state appears in
900 -- an enclosing package body that will eventually
901 -- refine the state, record the reference for future
905 Record_Possible_Body_Reference
906 (State_Id
=> Item_Id
,
911 -- When the item renames an entire object, replace the
912 -- item with a reference to the object.
914 if Present
(Renamed_Object
(Entity
(Item
))) then
916 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
920 -- Add the entity of the current item to the list of
923 if Ekind
(Item_Id
) = E_Abstract_State
then
924 Add_Item
(Item_Id
, States_Seen
);
927 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
928 and then Present
(Encapsulating_State
(Item_Id
))
930 Add_Item
(Item_Id
, Constits_Seen
);
933 -- All other input/output items are illegal
934 -- (SPARK RM 6.1.5(1)).
938 ("item must denote parameter, variable, or state",
942 -- All other input/output items are illegal
943 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
947 ("item must denote parameter, variable, or state", Item
);
950 end Analyze_Input_Output
;
958 Non_Null_Output_Seen
: Boolean := False;
959 -- Flag used to check the legality of an output list
961 -- Start of processing for Analyze_Dependency_Clause
964 Inputs
:= Expression
(Clause
);
967 -- An input list with a self-dependency appears as operator "+" where
968 -- the actuals inputs are the right operand.
970 if Nkind
(Inputs
) = N_Op_Plus
then
971 Inputs
:= Right_Opnd
(Inputs
);
975 -- Process the output_list of a dependency_clause
977 Output
:= First
(Choices
(Clause
));
978 while Present
(Output
) loop
982 Self_Ref
=> Self_Ref
,
984 Seen
=> All_Outputs_Seen
,
985 Null_Seen
=> Null_Output_Seen
,
986 Non_Null_Seen
=> Non_Null_Output_Seen
);
991 -- Process the input_list of a dependency_clause
993 Analyze_Input_List
(Inputs
);
994 end Analyze_Dependency_Clause
;
996 ---------------------------
997 -- Check_Function_Return --
998 ---------------------------
1000 procedure Check_Function_Return
is
1002 if Ekind
(Spec_Id
) = E_Function
and then not Result_Seen
then
1004 ("result of & must appear in exactly one output list",
1007 end Check_Function_Return
;
1013 procedure Check_Role
1015 Item_Id
: Entity_Id
;
1020 (Item_Is_Input
: out Boolean;
1021 Item_Is_Output
: out Boolean);
1022 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1023 -- Item_Is_Output are set depending on the role.
1025 procedure Role_Error
1026 (Item_Is_Input
: Boolean;
1027 Item_Is_Output
: Boolean);
1028 -- Emit an error message concerning the incorrect use of Item in
1029 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1030 -- denote whether the item is an input and/or an output.
1037 (Item_Is_Input
: out Boolean;
1038 Item_Is_Output
: out Boolean)
1041 Item_Is_Input
:= False;
1042 Item_Is_Output
:= False;
1044 -- Abstract state cases
1046 if Ekind
(Item_Id
) = E_Abstract_State
then
1048 -- When pragma Global is present, the mode of the state may be
1049 -- further constrained by setting a more restrictive mode.
1052 if Appears_In
(Subp_Inputs
, Item_Id
) then
1053 Item_Is_Input
:= True;
1056 if Appears_In
(Subp_Outputs
, Item_Id
) then
1057 Item_Is_Output
:= True;
1060 -- Otherwise the state has a default IN OUT mode
1063 Item_Is_Input
:= True;
1064 Item_Is_Output
:= True;
1069 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1070 Item_Is_Input
:= True;
1072 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1073 Item_Is_Input
:= True;
1074 Item_Is_Output
:= True;
1076 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1077 if Scope
(Item_Id
) = Spec_Id
then
1079 -- An OUT parameter of the related subprogram has mode IN
1080 -- if its type is unconstrained or tagged because array
1081 -- bounds, discriminants or tags can be read.
1083 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1084 Item_Is_Input
:= True;
1087 Item_Is_Output
:= True;
1089 -- An OUT parameter of an enclosing subprogram behaves as a
1090 -- read-write variable in which case the mode is IN OUT.
1093 Item_Is_Input
:= True;
1094 Item_Is_Output
:= True;
1099 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1101 -- When pragma Global is present, the mode of the variable may
1102 -- be further constrained by setting a more restrictive mode.
1106 -- A variable has mode IN when its type is unconstrained or
1107 -- tagged because array bounds, discriminants or tags can be
1110 if Appears_In
(Subp_Inputs
, Item_Id
)
1111 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1113 Item_Is_Input
:= True;
1116 if Appears_In
(Subp_Outputs
, Item_Id
) then
1117 Item_Is_Output
:= True;
1120 -- Otherwise the variable has a default IN OUT mode
1123 Item_Is_Input
:= True;
1124 Item_Is_Output
:= True;
1133 procedure Role_Error
1134 (Item_Is_Input
: Boolean;
1135 Item_Is_Output
: Boolean)
1137 Error_Msg
: Name_Id
;
1142 -- When the item is not part of the input and the output set of
1143 -- the related subprogram, then it appears as extra in pragma
1144 -- [Refined_]Depends.
1146 if not Item_Is_Input
and then not Item_Is_Output
then
1147 Add_Item_To_Name_Buffer
(Item_Id
);
1148 Add_Str_To_Name_Buffer
1149 (" & cannot appear in dependence relation");
1151 Error_Msg
:= Name_Find
;
1152 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1154 Error_Msg_Name_1
:= Chars
(Subp_Id
);
1156 ("\& is not part of the input or output set of subprogram %",
1159 -- The mode of the item and its role in pragma [Refined_]Depends
1160 -- are in conflict. Construct a detailed message explaining the
1161 -- illegality (SPARK RM 6.1.5(5-6)).
1164 if Item_Is_Input
then
1165 Add_Str_To_Name_Buffer
("read-only");
1167 Add_Str_To_Name_Buffer
("write-only");
1170 Add_Char_To_Name_Buffer
(' ');
1171 Add_Item_To_Name_Buffer
(Item_Id
);
1172 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1174 if Item_Is_Input
then
1175 Add_Str_To_Name_Buffer
("output");
1177 Add_Str_To_Name_Buffer
("input");
1180 Add_Str_To_Name_Buffer
(" in dependence relation");
1181 Error_Msg
:= Name_Find
;
1182 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1188 Item_Is_Input
: Boolean;
1189 Item_Is_Output
: Boolean;
1191 -- Start of processing for Check_Role
1194 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1199 if not Item_Is_Input
then
1200 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1203 -- Self-referential item
1206 if not Item_Is_Input
or else not Item_Is_Output
then
1207 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1212 elsif not Item_Is_Output
then
1213 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1221 procedure Check_Usage
1222 (Subp_Items
: Elist_Id
;
1223 Used_Items
: Elist_Id
;
1226 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
1227 -- Emit an error concerning the illegal usage of an item
1233 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
1234 Error_Msg
: Name_Id
;
1241 -- Unconstrained and tagged items are not part of the explicit
1242 -- input set of the related subprogram, they do not have to be
1243 -- present in a dependence relation and should not be flagged
1244 -- (SPARK RM 6.1.5(8)).
1246 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1249 Add_Item_To_Name_Buffer
(Item_Id
);
1250 Add_Str_To_Name_Buffer
1251 (" & must appear in at least one input dependence list");
1253 Error_Msg
:= Name_Find
;
1254 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1257 -- Output case (SPARK RM 6.1.5(10))
1262 Add_Item_To_Name_Buffer
(Item_Id
);
1263 Add_Str_To_Name_Buffer
1264 (" & must appear in exactly one output dependence list");
1266 Error_Msg
:= Name_Find
;
1267 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1275 Item_Id
: Entity_Id
;
1277 -- Start of processing for Check_Usage
1280 if No
(Subp_Items
) then
1284 -- Each input or output of the subprogram must appear in a dependency
1287 Elmt
:= First_Elmt
(Subp_Items
);
1288 while Present
(Elmt
) loop
1289 Item
:= Node
(Elmt
);
1291 if Nkind
(Item
) = N_Defining_Identifier
then
1294 Item_Id
:= Entity_Of
(Item
);
1297 -- The item does not appear in a dependency
1299 if Present
(Item_Id
)
1300 and then not Contains
(Used_Items
, Item_Id
)
1302 if Is_Formal
(Item_Id
) then
1303 Usage_Error
(Item
, Item_Id
);
1305 -- States and global variables are not used properly only when
1306 -- the subprogram is subject to pragma Global.
1308 elsif Global_Seen
then
1309 Usage_Error
(Item
, Item_Id
);
1317 ----------------------
1318 -- Normalize_Clause --
1319 ----------------------
1321 procedure Normalize_Clause
(Clause
: Node_Id
) is
1322 procedure Create_Or_Modify_Clause
1328 Multiple
: Boolean);
1329 -- Create a brand new clause to represent the self-reference or
1330 -- modify the input and/or output lists of an existing clause. Output
1331 -- denotes a self-referencial output. Outputs is the output list of a
1332 -- clause. Inputs is the input list of a clause. After denotes the
1333 -- clause after which the new clause is to be inserted. Flag In_Place
1334 -- should be set when normalizing the last output of an output list.
1335 -- Flag Multiple should be set when Output comes from a list with
1338 procedure Normalize_Outputs
;
1339 -- If Clause contains more than one output, split the clause into
1340 -- multiple clauses with a single output. All new clauses are added
1343 -----------------------------
1344 -- Create_Or_Modify_Clause --
1345 -----------------------------
1347 procedure Create_Or_Modify_Clause
1355 procedure Propagate_Output
1358 -- Handle the various cases of output propagation to the input
1359 -- list. Output denotes a self-referencial output item. Inputs is
1360 -- the input list of a clause.
1362 ----------------------
1363 -- Propagate_Output --
1364 ----------------------
1366 procedure Propagate_Output
1370 function In_Input_List
1372 Inputs
: List_Id
) return Boolean;
1373 -- Determine whether a particulat item appears in the input
1374 -- list of a clause.
1380 function In_Input_List
1382 Inputs
: List_Id
) return Boolean
1387 Elmt
:= First
(Inputs
);
1388 while Present
(Elmt
) loop
1389 if Entity_Of
(Elmt
) = Item
then
1401 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1404 -- Start of processing for Propagate_Output
1407 -- The clause is of the form:
1409 -- (Output =>+ null)
1411 -- Remove the null input and replace it with a copy of the
1414 -- (Output => Output)
1416 if Nkind
(Inputs
) = N_Null
then
1417 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1419 -- The clause is of the form:
1421 -- (Output =>+ (Input1, ..., InputN))
1423 -- Determine whether the output is not already mentioned in the
1424 -- input list and if not, add it to the list of inputs:
1426 -- (Output => (Output, Input1, ..., InputN))
1428 elsif Nkind
(Inputs
) = N_Aggregate
then
1429 Grouped
:= Expressions
(Inputs
);
1431 if not In_Input_List
1435 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1438 -- The clause is of the form:
1440 -- (Output =>+ Input)
1442 -- If the input does not mention the output, group the two
1445 -- (Output => (Output, Input))
1447 elsif Entity_Of
(Inputs
) /= Output_Id
then
1449 Make_Aggregate
(Loc
,
1450 Expressions
=> New_List
(
1451 New_Copy_Tree
(Output
),
1452 New_Copy_Tree
(Inputs
))));
1454 end Propagate_Output
;
1458 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1459 New_Clause
: Node_Id
;
1461 -- Start of processing for Create_Or_Modify_Clause
1464 -- A null output depending on itself does not require any
1467 if Nkind
(Output
) = N_Null
then
1470 -- A function result cannot depend on itself because it cannot
1471 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1473 elsif Is_Attribute_Result
(Output
) then
1474 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1478 -- When performing the transformation in place, simply add the
1479 -- output to the list of inputs (if not already there). This case
1480 -- arises when dealing with the last output of an output list -
1481 -- we perform the normalization in place to avoid generating a
1485 Propagate_Output
(Output
, Inputs
);
1487 -- A list with multiple outputs is slowly trimmed until only
1488 -- one element remains. When this happens, replace the
1489 -- aggregate with the element itself.
1493 Rewrite
(Outputs
, Output
);
1499 -- Unchain the output from its output list as it will appear in
1500 -- a new clause. Note that we cannot simply rewrite the output
1501 -- as null because this will violate the semantics of pragma
1506 -- Generate a new clause of the form:
1507 -- (Output => Inputs)
1510 Make_Component_Association
(Loc
,
1511 Choices
=> New_List
(Output
),
1512 Expression
=> New_Copy_Tree
(Inputs
));
1514 -- The new clause contains replicated content that has already
1515 -- been analyzed. There is not need to reanalyze it or
1516 -- renormalize it again.
1518 Set_Analyzed
(New_Clause
);
1521 (Output
=> First
(Choices
(New_Clause
)),
1522 Inputs
=> Expression
(New_Clause
));
1524 Insert_After
(After
, New_Clause
);
1526 end Create_Or_Modify_Clause
;
1528 -----------------------
1529 -- Normalize_Outputs --
1530 -----------------------
1532 procedure Normalize_Outputs
is
1533 Inputs
: constant Node_Id
:= Expression
(Clause
);
1534 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1535 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1536 Last_Output
: Node_Id
;
1537 New_Clause
: Node_Id
;
1538 Next_Output
: Node_Id
;
1542 -- Multiple outputs appear as an aggregate. Nothing to do when
1543 -- the clause has exactly one output.
1545 if Nkind
(Outputs
) = N_Aggregate
then
1546 Last_Output
:= Last
(Expressions
(Outputs
));
1548 -- Create a clause for each output. Note that each time a new
1549 -- clause is created, the original output list slowly shrinks
1550 -- until there is one item left.
1552 Output
:= First
(Expressions
(Outputs
));
1553 while Present
(Output
) loop
1554 Next_Output
:= Next
(Output
);
1556 -- Unhook the output from the original output list as it
1557 -- will be relocated to a new clause.
1561 -- Special processing for the last output. At this point
1562 -- the original aggregate has been stripped down to one
1563 -- element. Replace the aggregate by the element itself.
1565 if Output
= Last_Output
then
1566 Rewrite
(Outputs
, Output
);
1569 -- Generate a clause of the form:
1570 -- (Output => Inputs)
1573 Make_Component_Association
(Loc
,
1574 Choices
=> New_List
(Output
),
1575 Expression
=> New_Copy_Tree
(Inputs
));
1577 -- The new clause contains replicated content that has
1578 -- already been analyzed. There is not need to reanalyze
1581 Set_Analyzed
(New_Clause
);
1582 Insert_After
(Clause
, New_Clause
);
1585 Output
:= Next_Output
;
1588 end Normalize_Outputs
;
1592 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1594 Last_Output
: Node_Id
;
1595 Next_Output
: Node_Id
;
1598 -- Start of processing for Normalize_Clause
1601 -- A self-dependency appears as operator "+". Remove the "+" from the
1602 -- tree by moving the real inputs to their proper place.
1604 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1605 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1606 Inputs
:= Expression
(Clause
);
1608 -- Multiple outputs appear as an aggregate
1610 if Nkind
(Outputs
) = N_Aggregate
then
1611 Last_Output
:= Last
(Expressions
(Outputs
));
1613 Output
:= First
(Expressions
(Outputs
));
1614 while Present
(Output
) loop
1616 -- Normalization may remove an output from its list,
1617 -- preserve the subsequent output now.
1619 Next_Output
:= Next
(Output
);
1621 Create_Or_Modify_Clause
1626 In_Place
=> Output
= Last_Output
,
1629 Output
:= Next_Output
;
1635 Create_Or_Modify_Clause
1645 -- Split a clause with multiple outputs into multiple clauses with a
1649 end Normalize_Clause
;
1653 Deps
: constant Node_Id
:=
1655 (First
(Pragma_Argument_Associations
(N
)));
1658 Last_Clause
: Node_Id
;
1659 Subp_Decl
: Node_Id
;
1661 Restore_Scope
: Boolean := False;
1662 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1664 -- Start of processing for Analyze_Depends_In_Decl_Part
1669 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
1670 Subp_Id
:= Defining_Entity
(Subp_Decl
);
1672 -- The logic in this routine is used to analyze both pragma Depends and
1673 -- pragma Refined_Depends since they have the same syntax and base
1674 -- semantics. Find the entity of the corresponding spec when analyzing
1677 if Nkind
(Subp_Decl
) = N_Subprogram_Body
1678 and then Present
(Corresponding_Spec
(Subp_Decl
))
1680 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
1682 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
1683 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
1685 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
1691 -- Empty dependency list
1693 if Nkind
(Deps
) = N_Null
then
1695 -- Gather all states, variables and formal parameters that the
1696 -- subprogram may depend on. These items are obtained from the
1697 -- parameter profile or pragma [Refined_]Global (if available).
1699 Collect_Subprogram_Inputs_Outputs
1700 (Subp_Id
=> Subp_Id
,
1701 Subp_Inputs
=> Subp_Inputs
,
1702 Subp_Outputs
=> Subp_Outputs
,
1703 Global_Seen
=> Global_Seen
);
1705 -- Verify that every input or output of the subprogram appear in a
1708 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1709 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1710 Check_Function_Return
;
1712 -- Dependency clauses appear as component associations of an aggregate
1714 elsif Nkind
(Deps
) = N_Aggregate
then
1716 -- Do not attempt to perform analysis of a syntactically illegal
1717 -- clause as this will lead to misleading errors.
1719 if Has_Extra_Parentheses
(Deps
) then
1723 if Present
(Component_Associations
(Deps
)) then
1724 Last_Clause
:= Last
(Component_Associations
(Deps
));
1726 -- Gather all states, variables and formal parameters that the
1727 -- subprogram may depend on. These items are obtained from the
1728 -- parameter profile or pragma [Refined_]Global (if available).
1730 Collect_Subprogram_Inputs_Outputs
1731 (Subp_Id
=> Subp_Id
,
1732 Subp_Inputs
=> Subp_Inputs
,
1733 Subp_Outputs
=> Subp_Outputs
,
1734 Global_Seen
=> Global_Seen
);
1736 -- Ensure that the formal parameters are visible when analyzing
1737 -- all clauses. This falls out of the general rule of aspects
1738 -- pertaining to subprogram declarations. Skip the installation
1739 -- for subprogram bodies because the formals are already visible.
1741 if not In_Open_Scopes
(Spec_Id
) then
1742 Restore_Scope
:= True;
1743 Push_Scope
(Spec_Id
);
1744 Install_Formals
(Spec_Id
);
1747 Clause
:= First
(Component_Associations
(Deps
));
1748 while Present
(Clause
) loop
1749 Errors
:= Serious_Errors_Detected
;
1751 -- Normalization may create extra clauses that contain
1752 -- replicated input and output names. There is no need to
1755 if not Analyzed
(Clause
) then
1756 Set_Analyzed
(Clause
);
1758 Analyze_Dependency_Clause
1760 Is_Last
=> Clause
= Last_Clause
);
1763 -- Do not normalize a clause if errors were detected (count
1764 -- of Serious_Errors has increased) because the inputs and/or
1765 -- outputs may denote illegal items. Normalization is disabled
1766 -- in ASIS mode as it alters the tree by introducing new nodes
1767 -- similar to expansion.
1769 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1770 Normalize_Clause
(Clause
);
1776 if Restore_Scope
then
1780 -- Verify that every input or output of the subprogram appear in a
1783 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1784 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1785 Check_Function_Return
;
1787 -- The dependency list is malformed. This is a syntax error, always
1791 Error_Msg_N
("malformed dependency relation", Deps
);
1795 -- The top level dependency relation is malformed. This is a syntax
1796 -- error, always report.
1799 Error_Msg_N
("malformed dependency relation", Deps
);
1803 -- Ensure that a state and a corresponding constituent do not appear
1804 -- together in pragma [Refined_]Depends.
1806 Check_State_And_Constituent_Use
1807 (States
=> States_Seen
,
1808 Constits
=> Constits_Seen
,
1810 end Analyze_Depends_In_Decl_Part
;
1812 --------------------------------------------
1813 -- Analyze_External_Property_In_Decl_Part --
1814 --------------------------------------------
1816 procedure Analyze_External_Property_In_Decl_Part
1818 Expr_Val
: out Boolean)
1820 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1821 Obj_Id
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
1822 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Next
(Arg1
));
1825 Error_Msg_Name_1
:= Pragma_Name
(N
);
1827 -- An external property pragma must apply to an effectively volatile
1828 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1829 -- The check is performed at the end of the declarative region due to a
1830 -- possible out-of-order arrangement of pragmas:
1833 -- pragma Async_Readers (Obj);
1834 -- pragma Volatile (Obj);
1836 if not Is_Effectively_Volatile
(Obj_Id
) then
1838 ("external property % must apply to a volatile object", N
);
1841 -- Ensure that the Boolean expression (if present) is static. A missing
1842 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1846 if Present
(Expr
) then
1847 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
1849 if Is_OK_Static_Expression
(Expr
) then
1850 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1852 SPARK_Msg_N
("expression of % must be static", Expr
);
1855 end Analyze_External_Property_In_Decl_Part
;
1857 ---------------------------------
1858 -- Analyze_Global_In_Decl_Part --
1859 ---------------------------------
1861 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1862 Constits_Seen
: Elist_Id
:= No_Elist
;
1863 -- A list containing the entities of all constituents processed so far.
1864 -- It aids in detecting illegal usage of a state and a corresponding
1865 -- constituent in pragma [Refinde_]Global.
1867 Seen
: Elist_Id
:= No_Elist
;
1868 -- A list containing the entities of all the items processed so far. It
1869 -- plays a role in detecting distinct entities.
1871 Spec_Id
: Entity_Id
;
1872 -- The entity of the subprogram subject to pragma [Refined_]Global
1874 States_Seen
: Elist_Id
:= No_Elist
;
1875 -- A list containing the entities of all states processed so far. It
1876 -- helps in detecting illegal usage of a state and a corresponding
1877 -- constituent in pragma [Refined_]Global.
1879 Subp_Id
: Entity_Id
;
1880 -- The entity of the subprogram [body or stub] subject to pragma
1881 -- [Refined_]Global.
1883 In_Out_Seen
: Boolean := False;
1884 Input_Seen
: Boolean := False;
1885 Output_Seen
: Boolean := False;
1886 Proof_Seen
: Boolean := False;
1887 -- Flags used to verify the consistency of modes
1889 procedure Analyze_Global_List
1891 Global_Mode
: Name_Id
:= Name_Input
);
1892 -- Verify the legality of a single global list declaration. Global_Mode
1893 -- denotes the current mode in effect.
1895 -------------------------
1896 -- Analyze_Global_List --
1897 -------------------------
1899 procedure Analyze_Global_List
1901 Global_Mode
: Name_Id
:= Name_Input
)
1903 procedure Analyze_Global_Item
1905 Global_Mode
: Name_Id
);
1906 -- Verify the legality of a single global item declaration.
1907 -- Global_Mode denotes the current mode in effect.
1909 procedure Check_Duplicate_Mode
1911 Status
: in out Boolean);
1912 -- Flag Status denotes whether a particular mode has been seen while
1913 -- processing a global list. This routine verifies that Mode is not a
1914 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1916 procedure Check_Mode_Restriction_In_Enclosing_Context
1918 Item_Id
: Entity_Id
);
1919 -- Verify that an item of mode In_Out or Output does not appear as an
1920 -- input in the Global aspect of an enclosing subprogram. If this is
1921 -- the case, emit an error. Item and Item_Id are respectively the
1922 -- item and its entity.
1924 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1925 -- Mode denotes either In_Out or Output. Depending on the kind of the
1926 -- related subprogram, emit an error if those two modes apply to a
1927 -- function (SPARK RM 6.1.4(10)).
1929 -------------------------
1930 -- Analyze_Global_Item --
1931 -------------------------
1933 procedure Analyze_Global_Item
1935 Global_Mode
: Name_Id
)
1937 Item_Id
: Entity_Id
;
1940 -- Detect one of the following cases
1942 -- with Global => (null, Name)
1943 -- with Global => (Name_1, null, Name_2)
1944 -- with Global => (Name, null)
1946 if Nkind
(Item
) = N_Null
then
1947 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
1952 Resolve_State
(Item
);
1954 -- Find the entity of the item. If this is a renaming, climb the
1955 -- renaming chain to reach the root object. Renamings of non-
1956 -- entire objects do not yield an entity (Empty).
1958 Item_Id
:= Entity_Of
(Item
);
1960 if Present
(Item_Id
) then
1962 -- A global item may denote a formal parameter of an enclosing
1963 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1964 -- provide a better error diagnostic.
1966 if Is_Formal
(Item_Id
) then
1967 if Scope
(Item_Id
) = Spec_Id
then
1969 ("global item cannot reference parameter of subprogram",
1974 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1975 -- Do this check first to provide a better error diagnostic.
1977 elsif Ekind
(Item_Id
) = E_Constant
then
1978 SPARK_Msg_N
("global item cannot denote a constant", Item
);
1980 -- A formal object may act as a global item inside a generic
1982 elsif Is_Formal_Object
(Item_Id
) then
1985 -- The only legal references are those to abstract states and
1986 -- variables (SPARK RM 6.1.4(4)).
1988 elsif not Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
1990 ("global item must denote variable or state", Item
);
1994 -- State related checks
1996 if Ekind
(Item_Id
) = E_Abstract_State
then
1998 -- An abstract state with visible refinement cannot appear
1999 -- in pragma [Refined_]Global as its place must be taken by
2000 -- some of its constituents (SPARK RM 6.1.4(8)).
2002 if Has_Visible_Refinement
(Item_Id
) then
2004 ("cannot mention state & in global refinement",
2006 SPARK_Msg_N
("\use its constituents instead", Item
);
2009 -- If the reference to the abstract state appears in an
2010 -- enclosing package body that will eventually refine the
2011 -- state, record the reference for future checks.
2014 Record_Possible_Body_Reference
2015 (State_Id
=> Item_Id
,
2019 -- Variable related checks. These are only relevant when
2020 -- SPARK_Mode is on as they are not standard Ada legality
2023 elsif SPARK_Mode
= On
2024 and then Is_Effectively_Volatile
(Item_Id
)
2026 -- An effectively volatile object cannot appear as a global
2027 -- item of a function (SPARK RM 7.1.3(9)).
2029 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2031 ("volatile object & cannot act as global item of a "
2032 & "function", Item
, Item_Id
);
2035 -- An effectively volatile object with external property
2036 -- Effective_Reads set to True must have mode Output or
2039 elsif Effective_Reads_Enabled
(Item_Id
)
2040 and then Global_Mode
= Name_Input
2043 ("volatile object & with property Effective_Reads must "
2044 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
2050 -- When the item renames an entire object, replace the item
2051 -- with a reference to the object.
2053 if Present
(Renamed_Object
(Entity
(Item
))) then
2054 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2058 -- Some form of illegal construct masquerading as a name
2059 -- (SPARK RM 6.1.4(4)).
2062 Error_Msg_N
("global item must denote variable or state", Item
);
2066 -- Verify that an output does not appear as an input in an
2067 -- enclosing subprogram.
2069 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2070 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2073 -- The same entity might be referenced through various way.
2074 -- Check the entity of the item rather than the item itself
2075 -- (SPARK RM 6.1.4(11)).
2077 if Contains
(Seen
, Item_Id
) then
2078 SPARK_Msg_N
("duplicate global item", Item
);
2080 -- Add the entity of the current item to the list of processed
2084 Add_Item
(Item_Id
, Seen
);
2086 if Ekind
(Item_Id
) = E_Abstract_State
then
2087 Add_Item
(Item_Id
, States_Seen
);
2090 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
2091 and then Present
(Encapsulating_State
(Item_Id
))
2093 Add_Item
(Item_Id
, Constits_Seen
);
2096 end Analyze_Global_Item
;
2098 --------------------------
2099 -- Check_Duplicate_Mode --
2100 --------------------------
2102 procedure Check_Duplicate_Mode
2104 Status
: in out Boolean)
2108 SPARK_Msg_N
("duplicate global mode", Mode
);
2112 end Check_Duplicate_Mode
;
2114 -------------------------------------------------
2115 -- Check_Mode_Restriction_In_Enclosing_Context --
2116 -------------------------------------------------
2118 procedure Check_Mode_Restriction_In_Enclosing_Context
2120 Item_Id
: Entity_Id
)
2122 Context
: Entity_Id
;
2124 Inputs
: Elist_Id
:= No_Elist
;
2125 Outputs
: Elist_Id
:= No_Elist
;
2128 -- Traverse the scope stack looking for enclosing subprograms
2129 -- subject to pragma [Refined_]Global.
2131 Context
:= Scope
(Subp_Id
);
2132 while Present
(Context
) and then Context
/= Standard_Standard
loop
2133 if Is_Subprogram
(Context
)
2135 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2137 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2139 Collect_Subprogram_Inputs_Outputs
2140 (Subp_Id
=> Context
,
2141 Subp_Inputs
=> Inputs
,
2142 Subp_Outputs
=> Outputs
,
2143 Global_Seen
=> Dummy
);
2145 -- The item is classified as In_Out or Output but appears as
2146 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2148 if Appears_In
(Inputs
, Item_Id
)
2149 and then not Appears_In
(Outputs
, Item_Id
)
2152 ("global item & cannot have mode In_Out or Output",
2155 ("\item already appears as input of subprogram &",
2158 -- Stop the traversal once an error has been detected
2164 Context
:= Scope
(Context
);
2166 end Check_Mode_Restriction_In_Enclosing_Context
;
2168 ----------------------------------------
2169 -- Check_Mode_Restriction_In_Function --
2170 ----------------------------------------
2172 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2174 if Ekind
(Spec_Id
) = E_Function
then
2176 ("global mode & is not applicable to functions", Mode
);
2178 end Check_Mode_Restriction_In_Function
;
2186 -- Start of processing for Analyze_Global_List
2189 if Nkind
(List
) = N_Null
then
2190 Set_Analyzed
(List
);
2192 -- Single global item declaration
2194 elsif Nkind_In
(List
, N_Expanded_Name
,
2196 N_Selected_Component
)
2198 Analyze_Global_Item
(List
, Global_Mode
);
2200 -- Simple global list or moded global list declaration
2202 elsif Nkind
(List
) = N_Aggregate
then
2203 Set_Analyzed
(List
);
2205 -- The declaration of a simple global list appear as a collection
2208 if Present
(Expressions
(List
)) then
2209 if Present
(Component_Associations
(List
)) then
2211 ("cannot mix moded and non-moded global lists", List
);
2214 Item
:= First
(Expressions
(List
));
2215 while Present
(Item
) loop
2216 Analyze_Global_Item
(Item
, Global_Mode
);
2221 -- The declaration of a moded global list appears as a collection
2222 -- of component associations where individual choices denote
2225 elsif Present
(Component_Associations
(List
)) then
2226 if Present
(Expressions
(List
)) then
2228 ("cannot mix moded and non-moded global lists", List
);
2231 Assoc
:= First
(Component_Associations
(List
));
2232 while Present
(Assoc
) loop
2233 Mode
:= First
(Choices
(Assoc
));
2235 if Nkind
(Mode
) = N_Identifier
then
2236 if Chars
(Mode
) = Name_In_Out
then
2237 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2238 Check_Mode_Restriction_In_Function
(Mode
);
2240 elsif Chars
(Mode
) = Name_Input
then
2241 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2243 elsif Chars
(Mode
) = Name_Output
then
2244 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2245 Check_Mode_Restriction_In_Function
(Mode
);
2247 elsif Chars
(Mode
) = Name_Proof_In
then
2248 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2251 SPARK_Msg_N
("invalid mode selector", Mode
);
2255 SPARK_Msg_N
("invalid mode selector", Mode
);
2258 -- Items in a moded list appear as a collection of
2259 -- expressions. Reuse the existing machinery to analyze
2263 (List
=> Expression
(Assoc
),
2264 Global_Mode
=> Chars
(Mode
));
2272 raise Program_Error
;
2275 -- Any other attempt to declare a global item is illegal. This is a
2276 -- syntax error, always report.
2279 Error_Msg_N
("malformed global list", List
);
2281 end Analyze_Global_List
;
2285 Items
: constant Node_Id
:=
2286 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2287 Subp_Decl
: Node_Id
;
2289 Restore_Scope
: Boolean := False;
2290 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2292 -- Start of processing for Analyze_Global_In_Decl_List
2296 Check_SPARK_Aspect_For_ASIS
(N
);
2298 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
2299 Subp_Id
:= Defining_Entity
(Subp_Decl
);
2301 -- The logic in this routine is used to analyze both pragma Global and
2302 -- pragma Refined_Global since they have the same syntax and base
2303 -- semantics. Find the entity of the corresponding spec when analyzing
2306 if Nkind
(Subp_Decl
) = N_Subprogram_Body
2307 and then Present
(Corresponding_Spec
(Subp_Decl
))
2309 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
2311 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
2312 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
2314 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
2320 -- There is nothing to be done for a null global list
2322 if Nkind
(Items
) = N_Null
then
2323 Set_Analyzed
(Items
);
2325 -- Analyze the various forms of global lists and items. Note that some
2326 -- of these may be malformed in which case the analysis emits error
2330 -- Ensure that the formal parameters are visible when processing an
2331 -- item. This falls out of the general rule of aspects pertaining to
2332 -- subprogram declarations.
2334 if not In_Open_Scopes
(Spec_Id
) then
2335 Restore_Scope
:= True;
2336 Push_Scope
(Spec_Id
);
2337 Install_Formals
(Spec_Id
);
2340 Analyze_Global_List
(Items
);
2342 if Restore_Scope
then
2347 -- Ensure that a state and a corresponding constituent do not appear
2348 -- together in pragma [Refined_]Global.
2350 Check_State_And_Constituent_Use
2351 (States
=> States_Seen
,
2352 Constits
=> Constits_Seen
,
2354 end Analyze_Global_In_Decl_Part
;
2356 --------------------------------------------
2357 -- Analyze_Initial_Condition_In_Decl_Part --
2358 --------------------------------------------
2360 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2361 Expr
: constant Node_Id
:=
2362 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2367 -- The expression is preanalyzed because it has not been moved to its
2368 -- final place yet. A direct analysis may generate side effects and this
2369 -- is not desired at this point.
2371 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2372 end Analyze_Initial_Condition_In_Decl_Part
;
2374 --------------------------------------
2375 -- Analyze_Initializes_In_Decl_Part --
2376 --------------------------------------
2378 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2379 Pack_Spec
: constant Node_Id
:= Parent
(N
);
2380 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Parent
(Pack_Spec
));
2382 Constits_Seen
: Elist_Id
:= No_Elist
;
2383 -- A list containing the entities of all constituents processed so far.
2384 -- It aids in detecting illegal usage of a state and a corresponding
2385 -- constituent in pragma Initializes.
2387 Items_Seen
: Elist_Id
:= No_Elist
;
2388 -- A list of all initialization items processed so far. This list is
2389 -- used to detect duplicate items.
2391 Non_Null_Seen
: Boolean := False;
2392 Null_Seen
: Boolean := False;
2393 -- Flags used to check the legality of a null initialization list
2395 States_And_Vars
: Elist_Id
:= No_Elist
;
2396 -- A list of all abstract states and variables declared in the visible
2397 -- declarations of the related package. This list is used to detect the
2398 -- legality of initialization items.
2400 States_Seen
: Elist_Id
:= No_Elist
;
2401 -- A list containing the entities of all states processed so far. It
2402 -- helps in detecting illegal usage of a state and a corresponding
2403 -- constituent in pragma Initializes.
2405 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2406 -- Verify the legality of a single initialization item
2408 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2409 -- Verify the legality of a single initialization item followed by a
2410 -- list of input items.
2412 procedure Collect_States_And_Variables
;
2413 -- Inspect the visible declarations of the related package and gather
2414 -- the entities of all abstract states and variables in States_And_Vars.
2416 ---------------------------------
2417 -- Analyze_Initialization_Item --
2418 ---------------------------------
2420 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2421 Item_Id
: Entity_Id
;
2424 -- Null initialization list
2426 if Nkind
(Item
) = N_Null
then
2428 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2430 elsif Non_Null_Seen
then
2432 ("cannot mix null and non-null initialization items", Item
);
2437 -- Initialization item
2440 Non_Null_Seen
:= True;
2444 ("cannot mix null and non-null initialization items", Item
);
2448 Resolve_State
(Item
);
2450 if Is_Entity_Name
(Item
) then
2451 Item_Id
:= Entity_Of
(Item
);
2453 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
2455 -- The state or variable must be declared in the visible
2456 -- declarations of the package (SPARK RM 7.1.5(7)).
2458 if not Contains
(States_And_Vars
, Item_Id
) then
2459 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2461 ("initialization item & must appear in the visible "
2462 & "declarations of package %", Item
, Item_Id
);
2464 -- Detect a duplicate use of the same initialization item
2465 -- (SPARK RM 7.1.5(5)).
2467 elsif Contains
(Items_Seen
, Item_Id
) then
2468 SPARK_Msg_N
("duplicate initialization item", Item
);
2470 -- The item is legal, add it to the list of processed states
2474 Add_Item
(Item_Id
, Items_Seen
);
2476 if Ekind
(Item_Id
) = E_Abstract_State
then
2477 Add_Item
(Item_Id
, States_Seen
);
2480 if Present
(Encapsulating_State
(Item_Id
)) then
2481 Add_Item
(Item_Id
, Constits_Seen
);
2485 -- The item references something that is not a state or a
2486 -- variable (SPARK RM 7.1.5(3)).
2490 ("initialization item must denote variable or state",
2494 -- Some form of illegal construct masquerading as a name
2495 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2499 ("initialization item must denote variable or state", Item
);
2502 end Analyze_Initialization_Item
;
2504 ---------------------------------------------
2505 -- Analyze_Initialization_Item_With_Inputs --
2506 ---------------------------------------------
2508 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2509 Inputs_Seen
: Elist_Id
:= No_Elist
;
2510 -- A list of all inputs processed so far. This list is used to detect
2511 -- duplicate uses of an input.
2513 Non_Null_Seen
: Boolean := False;
2514 Null_Seen
: Boolean := False;
2515 -- Flags used to check the legality of an input list
2517 procedure Analyze_Input_Item
(Input
: Node_Id
);
2518 -- Verify the legality of a single input item
2520 ------------------------
2521 -- Analyze_Input_Item --
2522 ------------------------
2524 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2525 Input_Id
: Entity_Id
;
2530 if Nkind
(Input
) = N_Null
then
2533 ("multiple null initializations not allowed", Item
);
2535 elsif Non_Null_Seen
then
2537 ("cannot mix null and non-null initialization item", Item
);
2545 Non_Null_Seen
:= True;
2549 ("cannot mix null and non-null initialization item", Item
);
2553 Resolve_State
(Input
);
2555 if Is_Entity_Name
(Input
) then
2556 Input_Id
:= Entity_Of
(Input
);
2558 if Ekind_In
(Input_Id
, E_Abstract_State
,
2564 -- The input cannot denote states or variables declared
2565 -- within the related package.
2567 if Within_Scope
(Input_Id
, Current_Scope
) then
2568 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2570 ("input item & cannot denote a visible variable or "
2571 & "state of package % (SPARK RM 7.1.5(4))",
2574 -- Detect a duplicate use of the same input item
2575 -- (SPARK RM 7.1.5(5)).
2577 elsif Contains
(Inputs_Seen
, Input_Id
) then
2578 SPARK_Msg_N
("duplicate input item", Input
);
2580 -- Input is legal, add it to the list of processed inputs
2583 Add_Item
(Input_Id
, Inputs_Seen
);
2585 if Ekind
(Input_Id
) = E_Abstract_State
then
2586 Add_Item
(Input_Id
, States_Seen
);
2589 if Ekind_In
(Input_Id
, E_Abstract_State
, E_Variable
)
2590 and then Present
(Encapsulating_State
(Input_Id
))
2592 Add_Item
(Input_Id
, Constits_Seen
);
2596 -- The input references something that is not a state or a
2597 -- variable (SPARK RM 7.1.5(3)).
2601 ("input item must denote variable or state", Input
);
2604 -- Some form of illegal construct masquerading as a name
2605 -- (SPARK RM 7.1.5(3)).
2609 ("input item must denote variable or state", Input
);
2612 end Analyze_Input_Item
;
2616 Inputs
: constant Node_Id
:= Expression
(Item
);
2620 Name_Seen
: Boolean := False;
2621 -- A flag used to detect multiple item names
2623 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2626 -- Inspect the name of an item with inputs
2628 Elmt
:= First
(Choices
(Item
));
2629 while Present
(Elmt
) loop
2631 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2634 Analyze_Initialization_Item
(Elmt
);
2640 -- Multiple input items appear as an aggregate
2642 if Nkind
(Inputs
) = N_Aggregate
then
2643 if Present
(Expressions
(Inputs
)) then
2644 Input
:= First
(Expressions
(Inputs
));
2645 while Present
(Input
) loop
2646 Analyze_Input_Item
(Input
);
2651 if Present
(Component_Associations
(Inputs
)) then
2653 ("inputs must appear in named association form", Inputs
);
2656 -- Single input item
2659 Analyze_Input_Item
(Inputs
);
2661 end Analyze_Initialization_Item_With_Inputs
;
2663 ----------------------------------
2664 -- Collect_States_And_Variables --
2665 ----------------------------------
2667 procedure Collect_States_And_Variables
is
2671 -- Collect the abstract states defined in the package (if any)
2673 if Present
(Abstract_States
(Pack_Id
)) then
2674 States_And_Vars
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2677 -- Collect all variables the appear in the visible declarations of
2678 -- the related package.
2680 if Present
(Visible_Declarations
(Pack_Spec
)) then
2681 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2682 while Present
(Decl
) loop
2683 if Nkind
(Decl
) = N_Object_Declaration
2684 and then Ekind
(Defining_Entity
(Decl
)) = E_Variable
2685 and then Comes_From_Source
(Decl
)
2687 Add_Item
(Defining_Entity
(Decl
), States_And_Vars
);
2693 end Collect_States_And_Variables
;
2697 Inits
: constant Node_Id
:=
2698 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2701 -- Start of processing for Analyze_Initializes_In_Decl_Part
2706 Check_SPARK_Aspect_For_ASIS
(N
);
2708 -- Nothing to do when the initialization list is empty
2710 if Nkind
(Inits
) = N_Null
then
2714 -- Single and multiple initialization clauses appear as an aggregate. If
2715 -- this is not the case, then either the parser or the analysis of the
2716 -- pragma failed to produce an aggregate.
2718 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2720 -- Initialize the various lists used during analysis
2722 Collect_States_And_Variables
;
2724 if Present
(Expressions
(Inits
)) then
2725 Init
:= First
(Expressions
(Inits
));
2726 while Present
(Init
) loop
2727 Analyze_Initialization_Item
(Init
);
2732 if Present
(Component_Associations
(Inits
)) then
2733 Init
:= First
(Component_Associations
(Inits
));
2734 while Present
(Init
) loop
2735 Analyze_Initialization_Item_With_Inputs
(Init
);
2740 -- Ensure that a state and a corresponding constituent do not appear
2741 -- together in pragma Initializes.
2743 Check_State_And_Constituent_Use
2744 (States
=> States_Seen
,
2745 Constits
=> Constits_Seen
,
2747 end Analyze_Initializes_In_Decl_Part
;
2749 --------------------
2750 -- Analyze_Pragma --
2751 --------------------
2753 procedure Analyze_Pragma
(N
: Node_Id
) is
2754 Loc
: constant Source_Ptr
:= Sloc
(N
);
2755 Prag_Id
: Pragma_Id
;
2758 -- Name of the source pragma, or name of the corresponding aspect for
2759 -- pragmas which originate in a source aspect. In the latter case, the
2760 -- name may be different from the pragma name.
2762 Pragma_Exit
: exception;
2763 -- This exception is used to exit pragma processing completely. It
2764 -- is used when an error is detected, and no further processing is
2765 -- required. It is also used if an earlier error has left the tree in
2766 -- a state where the pragma should not be processed.
2769 -- Number of pragma argument associations
2775 -- First four pragma arguments (pragma argument association nodes, or
2776 -- Empty if the corresponding argument does not exist).
2778 type Name_List
is array (Natural range <>) of Name_Id
;
2779 type Args_List
is array (Natural range <>) of Node_Id
;
2780 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2782 -----------------------
2783 -- Local Subprograms --
2784 -----------------------
2786 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
2787 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2788 -- get the given string argument, and place it in Name_Buffer, adding
2789 -- leading and trailing asterisks if they are not already present. The
2790 -- caller has already checked that Arg is a static string expression.
2792 procedure Ada_2005_Pragma
;
2793 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2794 -- Ada 95 mode, these are implementation defined pragmas, so should be
2795 -- caught by the No_Implementation_Pragmas restriction.
2797 procedure Ada_2012_Pragma
;
2798 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2799 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2800 -- should be caught by the No_Implementation_Pragmas restriction.
2802 procedure Analyze_Part_Of
2803 (Item_Id
: Entity_Id
;
2806 Legal
: out Boolean);
2807 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2808 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2809 -- an abstract state, variable or package instantiation. State is the
2810 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2811 -- set when the indicator is legal.
2813 procedure Analyze_Refined_Pragma
2814 (Spec_Id
: out Entity_Id
;
2815 Body_Id
: out Entity_Id
;
2816 Legal
: out Boolean);
2817 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2818 -- Refined_Global and Refined_Post. Check the placement and related
2819 -- context of the pragma. Spec_Id is the entity of the related
2820 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2821 -- Legal is set when the pragma is properly placed.
2823 procedure Check_Ada_83_Warning
;
2824 -- Issues a warning message for the current pragma if operating in Ada
2825 -- 83 mode (used for language pragmas that are not a standard part of
2826 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2829 procedure Check_Arg_Count
(Required
: Nat
);
2830 -- Check argument count for pragma is equal to given parameter. If not,
2831 -- then issue an error message and raise Pragma_Exit.
2833 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2834 -- Arg which can either be a pragma argument association, in which case
2835 -- the check is applied to the expression of the association or an
2836 -- expression directly.
2838 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
2839 -- Check that an argument has the right form for an EXTERNAL_NAME
2840 -- parameter of an extended import/export pragma. The rule is that the
2841 -- name must be an identifier or string literal (in Ada 83 mode) or a
2842 -- static string expression (in Ada 95 mode).
2844 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
2845 -- Check the specified argument Arg to make sure that it is an
2846 -- identifier. If not give error and raise Pragma_Exit.
2848 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
2849 -- Check the specified argument Arg to make sure that it is an integer
2850 -- literal. If not give error and raise Pragma_Exit.
2852 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
2853 -- Check the specified argument Arg to make sure that it has the proper
2854 -- syntactic form for a local name and meets the semantic requirements
2855 -- for a local name. The local name is analyzed as part of the
2856 -- processing for this call. In addition, the local name is required
2857 -- to represent an entity at the library level.
2859 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
2860 -- Check the specified argument Arg to make sure that it has the proper
2861 -- syntactic form for a local name and meets the semantic requirements
2862 -- for a local name. The local name is analyzed as part of the
2863 -- processing for this call.
2865 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
2866 -- Check the specified argument Arg to make sure that it is a valid
2867 -- locking policy name. If not give error and raise Pragma_Exit.
2869 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
2870 -- Check the specified argument Arg to make sure that it is a valid
2871 -- elaboration policy name. If not give error and raise Pragma_Exit.
2873 procedure Check_Arg_Is_One_Of
2876 procedure Check_Arg_Is_One_Of
2878 N1
, N2
, N3
: Name_Id
);
2879 procedure Check_Arg_Is_One_Of
2881 N1
, N2
, N3
, N4
: Name_Id
);
2882 procedure Check_Arg_Is_One_Of
2884 N1
, N2
, N3
, N4
, N5
: Name_Id
);
2885 -- Check the specified argument Arg to make sure that it is an
2886 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2887 -- present). If not then give error and raise Pragma_Exit.
2889 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
2890 -- Check the specified argument Arg to make sure that it is a valid
2891 -- queuing policy name. If not give error and raise Pragma_Exit.
2893 procedure Check_Arg_Is_OK_Static_Expression
2895 Typ
: Entity_Id
:= Empty
);
2896 -- Check the specified argument Arg to make sure that it is a static
2897 -- expression of the given type (i.e. it will be analyzed and resolved
2898 -- using this type, which can be any valid argument to Resolve, e.g.
2899 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2900 -- Typ is left Empty, then any static expression is allowed. Includes
2901 -- checking that the argument does not raise Constraint_Error.
2903 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
2904 -- Check the specified argument Arg to make sure that it is a valid task
2905 -- dispatching policy name. If not give error and raise Pragma_Exit.
2907 procedure Check_Arg_Order
(Names
: Name_List
);
2908 -- Checks for an instance of two arguments with identifiers for the
2909 -- current pragma which are not in the sequence indicated by Names,
2910 -- and if so, generates a fatal message about bad order of arguments.
2912 procedure Check_At_Least_N_Arguments
(N
: Nat
);
2913 -- Check there are at least N arguments present
2915 procedure Check_At_Most_N_Arguments
(N
: Nat
);
2916 -- Check there are no more than N arguments present
2918 procedure Check_Component
2921 In_Variant_Part
: Boolean := False);
2922 -- Examine an Unchecked_Union component for correct use of per-object
2923 -- constrained subtypes, and for restrictions on finalizable components.
2924 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2925 -- should be set when Comp comes from a record variant.
2927 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
);
2928 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2929 -- Initial_Condition and Initializes. Determine whether pragma First
2930 -- appears before pragma Second. If this is not the case, emit an error.
2932 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
2933 -- Check if a rep item of the same name as the current pragma is already
2934 -- chained as a rep pragma to the given entity. If so give a message
2935 -- about the duplicate, and then raise Pragma_Exit so does not return.
2936 -- Note that if E is a type, then this routine avoids flagging a pragma
2937 -- which applies to a parent type from which E is derived.
2939 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
2940 -- Nam is an N_String_Literal node containing the external name set by
2941 -- an Import or Export pragma (or extended Import or Export pragma).
2942 -- This procedure checks for possible duplications if this is the export
2943 -- case, and if found, issues an appropriate error message.
2945 procedure Check_Expr_Is_OK_Static_Expression
2947 Typ
: Entity_Id
:= Empty
);
2948 -- Check the specified expression Expr to make sure that it is a static
2949 -- expression of the given type (i.e. it will be analyzed and resolved
2950 -- using this type, which can be any valid argument to Resolve, e.g.
2951 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2952 -- Typ is left Empty, then any static expression is allowed. Includes
2953 -- checking that the expression does not raise Constraint_Error.
2955 procedure Check_First_Subtype
(Arg
: Node_Id
);
2956 -- Checks that Arg, whose expression is an entity name, references a
2959 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2960 -- Checks that the given argument has an identifier, and if so, requires
2961 -- it to match the given identifier name. If there is no identifier, or
2962 -- a non-matching identifier, then an error message is given and
2963 -- Pragma_Exit is raised.
2965 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
2966 -- Checks that the given argument has an identifier, and if so, requires
2967 -- it to match one of the given identifier names. If there is no
2968 -- identifier, or a non-matching identifier, then an error message is
2969 -- given and Pragma_Exit is raised.
2971 procedure Check_In_Main_Program
;
2972 -- Common checks for pragmas that appear within a main program
2973 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2975 procedure Check_Interrupt_Or_Attach_Handler
;
2976 -- Common processing for first argument of pragma Interrupt_Handler or
2977 -- pragma Attach_Handler.
2979 procedure Check_Loop_Pragma_Placement
;
2980 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2981 -- appear immediately within a construct restricted to loops, and that
2982 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2984 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
2985 -- Check that pragma appears in a declarative part, or in a package
2986 -- specification, i.e. that it does not occur in a statement sequence
2989 procedure Check_No_Identifier
(Arg
: Node_Id
);
2990 -- Checks that the given argument does not have an identifier. If
2991 -- an identifier is present, then an error message is issued, and
2992 -- Pragma_Exit is raised.
2994 procedure Check_No_Identifiers
;
2995 -- Checks that none of the arguments to the pragma has an identifier.
2996 -- If any argument has an identifier, then an error message is issued,
2997 -- and Pragma_Exit is raised.
2999 procedure Check_No_Link_Name
;
3000 -- Checks that no link name is specified
3002 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3003 -- Checks if the given argument has an identifier, and if so, requires
3004 -- it to match the given identifier name. If there is a non-matching
3005 -- identifier, then an error message is given and Pragma_Exit is raised.
3007 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3008 -- Checks if the given argument has an identifier, and if so, requires
3009 -- it to match the given identifier name. If there is a non-matching
3010 -- identifier, then an error message is given and Pragma_Exit is raised.
3011 -- In this version of the procedure, the identifier name is given as
3012 -- a string with lower case letters.
3014 procedure Check_Pre_Post
;
3015 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
3016 -- pragmas. These are processed by transformation to equivalent
3017 -- Precondition and Postcondition pragmas, but Pre and Post need an
3018 -- additional check that they are not used in a subprogram body when
3019 -- there is a separate spec present.
3021 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
3022 -- Called to process a precondition or postcondition pragma. There are
3025 -- The pragma appears after a subprogram spec
3027 -- If the corresponding check is not enabled, the pragma is analyzed
3028 -- but otherwise ignored and control returns with In_Body set False.
3030 -- If the check is enabled, then the first step is to analyze the
3031 -- pragma, but this is skipped if the subprogram spec appears within
3032 -- a package specification (because this is the case where we delay
3033 -- analysis till the end of the spec). Then (whether or not it was
3034 -- analyzed), the pragma is chained to the subprogram in question
3035 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
3036 -- to the caller with In_Body set False.
3038 -- The pragma appears at the start of subprogram body declarations
3040 -- In this case an immediate return to the caller is made with
3041 -- In_Body set True, and the pragma is NOT analyzed.
3043 -- In all other cases, an error message for bad placement is given
3045 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3046 -- Constr is a constraint from an N_Subtype_Indication node from a
3047 -- component constraint in an Unchecked_Union type. This routine checks
3048 -- that the constraint is static as required by the restrictions for
3051 procedure Check_Test_Case
;
3052 -- Called to process a test-case pragma. It starts with checking pragma
3053 -- arguments, and the rest of the treatment is similar to the one for
3054 -- pre- and postcondition in Check_Precondition_Postcondition, except
3055 -- the placement rules for the test-case pragma are stricter. These
3056 -- pragmas may only occur after a subprogram spec declared directly
3057 -- in a package spec unit. In this case, the pragma is chained to the
3058 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
3059 -- and analysis of the pragma is delayed till the end of the spec. In
3060 -- all other cases, an error message for bad placement is given.
3062 procedure Check_Valid_Configuration_Pragma
;
3063 -- Legality checks for placement of a configuration pragma
3065 procedure Check_Valid_Library_Unit_Pragma
;
3066 -- Legality checks for library unit pragmas. A special case arises for
3067 -- pragmas in generic instances that come from copies of the original
3068 -- library unit pragmas in the generic templates. In the case of other
3069 -- than library level instantiations these can appear in contexts which
3070 -- would normally be invalid (they only apply to the original template
3071 -- and to library level instantiations), and they are simply ignored,
3072 -- which is implemented by rewriting them as null statements.
3074 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3075 -- Check an Unchecked_Union variant for lack of nested variants and
3076 -- presence of at least one component. UU_Typ is the related Unchecked_
3079 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3080 -- Subsidiary routine to the processing of pragmas Abstract_State,
3081 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3082 -- Refined_Global and Refined_State. Transform argument Arg into an
3083 -- aggregate if not one already. N_Null is never transformed.
3085 procedure Error_Pragma
(Msg
: String);
3086 pragma No_Return
(Error_Pragma
);
3087 -- Outputs error message for current pragma. The message contains a %
3088 -- that will be replaced with the pragma name, and the flag is placed
3089 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3090 -- calls Fix_Error (see spec of that procedure for details).
3092 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3093 pragma No_Return
(Error_Pragma_Arg
);
3094 -- Outputs error message for current pragma. The message may contain
3095 -- a % that will be replaced with the pragma name. The parameter Arg
3096 -- may either be a pragma argument association, in which case the flag
3097 -- is placed on the expression of this association, or an expression,
3098 -- in which case the flag is placed directly on the expression. The
3099 -- message is placed using Error_Msg_N, so the message may also contain
3100 -- an & insertion character which will reference the given Arg value.
3101 -- After placing the message, Pragma_Exit is raised. Note: this routine
3102 -- calls Fix_Error (see spec of that procedure for details).
3104 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3105 pragma No_Return
(Error_Pragma_Arg
);
3106 -- Similar to above form of Error_Pragma_Arg except that two messages
3107 -- are provided, the second is a continuation comment starting with \.
3109 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3110 pragma No_Return
(Error_Pragma_Arg_Ident
);
3111 -- Outputs error message for current pragma. The message may contain a %
3112 -- that will be replaced with the pragma name. The parameter Arg must be
3113 -- a pragma argument association with a non-empty identifier (i.e. its
3114 -- Chars field must be set), and the error message is placed on the
3115 -- identifier. The message is placed using Error_Msg_N so the message
3116 -- may also contain an & insertion character which will reference
3117 -- the identifier. After placing the message, Pragma_Exit is raised.
3118 -- Note: this routine calls Fix_Error (see spec of that procedure for
3121 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3122 pragma No_Return
(Error_Pragma_Ref
);
3123 -- Outputs error message for current pragma. The message may contain
3124 -- a % that will be replaced with the pragma name. The parameter Ref
3125 -- must be an entity whose name can be referenced by & and sloc by #.
3126 -- After placing the message, Pragma_Exit is raised. Note: this routine
3127 -- calls Fix_Error (see spec of that procedure for details).
3129 function Find_Lib_Unit_Name
return Entity_Id
;
3130 -- Used for a library unit pragma to find the entity to which the
3131 -- library unit pragma applies, returns the entity found.
3133 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3134 -- If the pragma is a compilation unit pragma, the id must denote the
3135 -- compilation unit in the same compilation, and the pragma must appear
3136 -- in the list of preceding or trailing pragmas. If it is a program
3137 -- unit pragma that is not a compilation unit pragma, then the
3138 -- identifier must be visible.
3140 function Find_Unique_Parameterless_Procedure
3142 Arg
: Node_Id
) return Entity_Id
;
3143 -- Used for a procedure pragma to find the unique parameterless
3144 -- procedure identified by Name, returns it if it exists, otherwise
3145 -- errors out and uses Arg as the pragma argument for the message.
3147 function Fix_Error
(Msg
: String) return String;
3148 -- This is called prior to issuing an error message. Msg is the normal
3149 -- error message issued in the pragma case. This routine checks for the
3150 -- case of a pragma coming from an aspect in the source, and returns a
3151 -- message suitable for the aspect case as follows:
3153 -- Each substring "pragma" is replaced by "aspect"
3155 -- If "argument of" is at the start of the error message text, it is
3156 -- replaced by "entity for".
3158 -- If "argument" is at the start of the error message text, it is
3159 -- replaced by "entity".
3161 -- So for example, "argument of pragma X must be discrete type"
3162 -- returns "entity for aspect X must be a discrete type".
3164 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3165 -- be different from the pragma name). If the current pragma results
3166 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3167 -- original pragma name.
3169 procedure Gather_Associations
3171 Args
: out Args_List
);
3172 -- This procedure is used to gather the arguments for a pragma that
3173 -- permits arbitrary ordering of parameters using the normal rules
3174 -- for named and positional parameters. The Names argument is a list
3175 -- of Name_Id values that corresponds to the allowed pragma argument
3176 -- association identifiers in order. The result returned in Args is
3177 -- a list of corresponding expressions that are the pragma arguments.
3178 -- Note that this is a list of expressions, not of pragma argument
3179 -- associations (Gather_Associations has completely checked all the
3180 -- optional identifiers when it returns). An entry in Args is Empty
3181 -- on return if the corresponding argument is not present.
3183 procedure GNAT_Pragma
;
3184 -- Called for all GNAT defined pragmas to check the relevant restriction
3185 -- (No_Implementation_Pragmas).
3187 function Is_Before_First_Decl
3188 (Pragma_Node
: Node_Id
;
3189 Decls
: List_Id
) return Boolean;
3190 -- Return True if Pragma_Node is before the first declarative item in
3191 -- Decls where Decls is the list of declarative items.
3193 function Is_Configuration_Pragma
return Boolean;
3194 -- Determines if the placement of the current pragma is appropriate
3195 -- for a configuration pragma.
3197 function Is_In_Context_Clause
return Boolean;
3198 -- Returns True if pragma appears within the context clause of a unit,
3199 -- and False for any other placement (does not generate any messages).
3201 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3202 -- Analyzes the argument, and determines if it is a static string
3203 -- expression, returns True if so, False if non-static or not String.
3204 -- A special case is that a string literal returns True in Ada 83 mode
3205 -- (which has no such thing as static string expressions).
3207 procedure Pragma_Misplaced
;
3208 pragma No_Return
(Pragma_Misplaced
);
3209 -- Issue fatal error message for misplaced pragma
3211 procedure Process_Atomic_Shared_Volatile
;
3212 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3213 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3214 -- in effect to pragma Atomic.
3216 procedure Process_Compile_Time_Warning_Or_Error
;
3217 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3219 procedure Process_Convention
3220 (C
: out Convention_Id
;
3221 Ent
: out Entity_Id
);
3222 -- Common processing for Convention, Interface, Import and Export.
3223 -- Checks first two arguments of pragma, and sets the appropriate
3224 -- convention value in the specified entity or entities. On return
3225 -- C is the convention, Ent is the referenced entity.
3227 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3228 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3229 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3231 procedure Process_Extended_Import_Export_Object_Pragma
3232 (Arg_Internal
: Node_Id
;
3233 Arg_External
: Node_Id
;
3234 Arg_Size
: Node_Id
);
3235 -- Common processing for the pragmas Import/Export_Object. The three
3236 -- arguments correspond to the three named parameters of the pragmas. An
3237 -- argument is empty if the corresponding parameter is not present in
3240 procedure Process_Extended_Import_Export_Internal_Arg
3241 (Arg_Internal
: Node_Id
:= Empty
);
3242 -- Common processing for all extended Import and Export pragmas. The
3243 -- argument is the pragma parameter for the Internal argument. If
3244 -- Arg_Internal is empty or inappropriate, an error message is posted.
3245 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3246 -- set to identify the referenced entity.
3248 procedure Process_Extended_Import_Export_Subprogram_Pragma
3249 (Arg_Internal
: Node_Id
;
3250 Arg_External
: Node_Id
;
3251 Arg_Parameter_Types
: Node_Id
;
3252 Arg_Result_Type
: Node_Id
:= Empty
;
3253 Arg_Mechanism
: Node_Id
;
3254 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3255 -- Common processing for all extended Import and Export pragmas applying
3256 -- to subprograms. The caller omits any arguments that do not apply to
3257 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3258 -- only in the Import_Function and Export_Function cases). The argument
3259 -- names correspond to the allowed pragma association identifiers.
3261 procedure Process_Generic_List
;
3262 -- Common processing for Share_Generic and Inline_Generic
3264 procedure Process_Import_Or_Interface
;
3265 -- Common processing for Import of Interface
3267 procedure Process_Import_Predefined_Type
;
3268 -- Processing for completing a type with pragma Import. This is used
3269 -- to declare types that match predefined C types, especially for cases
3270 -- without corresponding Ada predefined type.
3272 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3273 -- Inline status of a subprogram, indicated as follows:
3274 -- Suppressed: inlining is suppressed for the subprogram
3275 -- Disabled: no inlining is requested for the subprogram
3276 -- Enabled: inlining is requested/required for the subprogram
3278 procedure Process_Inline
(Status
: Inline_Status
);
3279 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3280 -- indicates the inline status specified by the pragma.
3282 procedure Process_Interface_Name
3283 (Subprogram_Def
: Entity_Id
;
3285 Link_Arg
: Node_Id
);
3286 -- Given the last two arguments of pragma Import, pragma Export, or
3287 -- pragma Interface_Name, performs validity checks and sets the
3288 -- Interface_Name field of the given subprogram entity to the
3289 -- appropriate external or link name, depending on the arguments given.
3290 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3291 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3292 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3293 -- nor Link_Arg is present, the interface name is set to the default
3294 -- from the subprogram name.
3296 procedure Process_Interrupt_Or_Attach_Handler
;
3297 -- Common processing for Interrupt and Attach_Handler pragmas
3299 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3300 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3301 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3302 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3303 -- is not set in the Restrictions case.
3305 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3306 -- Common processing for Suppress and Unsuppress. The boolean parameter
3307 -- Suppress_Case is True for the Suppress case, and False for the
3310 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3311 -- This procedure sets the Is_Exported flag for the given entity,
3312 -- checking that the entity was not previously imported. Arg is
3313 -- the argument that specified the entity. A check is also made
3314 -- for exporting inappropriate entities.
3316 procedure Set_Extended_Import_Export_External_Name
3317 (Internal_Ent
: Entity_Id
;
3318 Arg_External
: Node_Id
);
3319 -- Common processing for all extended import export pragmas. The first
3320 -- argument, Internal_Ent, is the internal entity, which has already
3321 -- been checked for validity by the caller. Arg_External is from the
3322 -- Import or Export pragma, and may be null if no External parameter
3323 -- was present. If Arg_External is present and is a non-null string
3324 -- (a null string is treated as the default), then the Interface_Name
3325 -- field of Internal_Ent is set appropriately.
3327 procedure Set_Imported
(E
: Entity_Id
);
3328 -- This procedure sets the Is_Imported flag for the given entity,
3329 -- checking that it is not previously exported or imported.
3331 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3332 -- Mech is a parameter passing mechanism (see Import_Function syntax
3333 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3334 -- has the right form, and if not issues an error message. If the
3335 -- argument has the right form then the Mechanism field of Ent is
3336 -- set appropriately.
3338 procedure Set_Rational_Profile
;
3339 -- Activate the set of configuration pragmas and permissions that make
3340 -- up the Rational profile.
3342 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3343 -- Activate the set of configuration pragmas and restrictions that make
3344 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3345 -- is used for error messages on any constructs violating the profile.
3347 ----------------------------------
3348 -- Acquire_Warning_Match_String --
3349 ----------------------------------
3351 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3353 String_To_Name_Buffer
3354 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3356 -- Add asterisk at start if not already there
3358 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3359 Name_Buffer
(2 .. Name_Len
+ 1) :=
3360 Name_Buffer
(1 .. Name_Len
);
3361 Name_Buffer
(1) := '*';
3362 Name_Len
:= Name_Len
+ 1;
3365 -- Add asterisk at end if not already there
3367 if Name_Buffer
(Name_Len
) /= '*' then
3368 Name_Len
:= Name_Len
+ 1;
3369 Name_Buffer
(Name_Len
) := '*';
3371 end Acquire_Warning_Match_String
;
3373 ---------------------
3374 -- Ada_2005_Pragma --
3375 ---------------------
3377 procedure Ada_2005_Pragma
is
3379 if Ada_Version
<= Ada_95
then
3380 Check_Restriction
(No_Implementation_Pragmas
, N
);
3382 end Ada_2005_Pragma
;
3384 ---------------------
3385 -- Ada_2012_Pragma --
3386 ---------------------
3388 procedure Ada_2012_Pragma
is
3390 if Ada_Version
<= Ada_2005
then
3391 Check_Restriction
(No_Implementation_Pragmas
, N
);
3393 end Ada_2012_Pragma
;
3395 ---------------------
3396 -- Analyze_Part_Of --
3397 ---------------------
3399 procedure Analyze_Part_Of
3400 (Item_Id
: Entity_Id
;
3403 Legal
: out Boolean)
3405 Pack_Id
: Entity_Id
;
3406 Placement
: State_Space_Kind
;
3407 Parent_Unit
: Entity_Id
;
3408 State_Id
: Entity_Id
;
3411 -- Assume that the pragma/option is illegal
3415 if Nkind_In
(State
, N_Expanded_Name
,
3417 N_Selected_Component
)
3420 Resolve_State
(State
);
3422 if Is_Entity_Name
(State
)
3423 and then Ekind
(Entity
(State
)) = E_Abstract_State
3425 State_Id
:= Entity
(State
);
3429 ("indicator Part_Of must denote an abstract state", State
);
3433 -- This is a syntax error, always report
3437 ("indicator Part_Of must denote an abstract state", State
);
3441 -- Determine where the state, variable or the package instantiation
3442 -- lives with respect to the enclosing packages or package bodies (if
3443 -- any). This placement dictates the legality of the encapsulating
3446 Find_Placement_In_State_Space
3447 (Item_Id
=> Item_Id
,
3448 Placement
=> Placement
,
3449 Pack_Id
=> Pack_Id
);
3451 -- The item appears in a non-package construct with a declarative
3452 -- part (subprogram, block, etc). As such, the item is not allowed
3453 -- to be a part of an encapsulating state because the item is not
3456 if Placement
= Not_In_Package
then
3458 ("indicator Part_Of cannot appear in this context "
3459 & "(SPARK RM 7.2.6(5))", Indic
);
3460 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3462 ("\& is not part of the hidden state of package %",
3465 -- The item appears in the visible state space of some package. In
3466 -- general this scenario does not warrant Part_Of except when the
3467 -- package is a private child unit and the encapsulating state is
3468 -- declared in a parent unit or a public descendant of that parent
3471 elsif Placement
= Visible_State_Space
then
3472 if Is_Child_Unit
(Pack_Id
)
3473 and then Is_Private_Descendant
(Pack_Id
)
3475 -- A variable or state abstraction which is part of the
3476 -- visible state of a private child unit (or one of its public
3477 -- descendants) must have its Part_Of indicator specified. The
3478 -- Part_Of indicator must denote a state abstraction declared
3479 -- by either the parent unit of the private unit or by a public
3480 -- descendant of that parent unit.
3482 -- Find nearest private ancestor (which can be the current unit
3485 Parent_Unit
:= Pack_Id
;
3486 while Present
(Parent_Unit
) loop
3487 exit when Private_Present
3488 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3489 Parent_Unit
:= Scope
(Parent_Unit
);
3492 Parent_Unit
:= Scope
(Parent_Unit
);
3494 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3496 ("indicator Part_Of must denote an abstract state of& "
3497 & "or public descendant (SPARK RM 7.2.6(3))",
3498 Indic
, Parent_Unit
);
3500 elsif Scope
(State_Id
) = Parent_Unit
3501 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3503 not Is_Private_Descendant
(Scope
(State_Id
)))
3509 ("indicator Part_Of must denote an abstract state of& "
3510 & "or public descendant (SPARK RM 7.2.6(3))",
3511 Indic
, Parent_Unit
);
3514 -- Indicator Part_Of is not needed when the related package is not
3515 -- a private child unit or a public descendant thereof.
3519 ("indicator Part_Of cannot appear in this context "
3520 & "(SPARK RM 7.2.6(5))", Indic
);
3521 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3523 ("\& is declared in the visible part of package %",
3527 -- When the item appears in the private state space of a package, the
3528 -- encapsulating state must be declared in the same package.
3530 elsif Placement
= Private_State_Space
then
3531 if Scope
(State_Id
) /= Pack_Id
then
3533 ("indicator Part_Of must designate an abstract state of "
3534 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3535 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3537 ("\& is declared in the private part of package %",
3541 -- Items declared in the body state space of a package do not need
3542 -- Part_Of indicators as the refinement has already been seen.
3546 ("indicator Part_Of cannot appear in this context "
3547 & "(SPARK RM 7.2.6(5))", Indic
);
3549 if Scope
(State_Id
) = Pack_Id
then
3550 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3552 ("\& is declared in the body of package %", Indic
, Item_Id
);
3557 end Analyze_Part_Of
;
3559 ----------------------------
3560 -- Analyze_Refined_Pragma --
3561 ----------------------------
3563 procedure Analyze_Refined_Pragma
3564 (Spec_Id
: out Entity_Id
;
3565 Body_Id
: out Entity_Id
;
3566 Legal
: out Boolean)
3568 Body_Decl
: Node_Id
;
3569 Spec_Decl
: Node_Id
;
3572 -- Assume that the pragma is illegal
3579 Check_Arg_Count
(1);
3580 Check_No_Identifiers
;
3582 if Nam_In
(Pname
, Name_Refined_Depends
,
3583 Name_Refined_Global
,
3586 Ensure_Aggregate_Form
(Arg1
);
3589 -- Verify the placement of the pragma and check for duplicates. The
3590 -- pragma must apply to a subprogram body [stub].
3592 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3594 -- Extract the entities of the spec and body
3596 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3597 Body_Id
:= Defining_Entity
(Body_Decl
);
3598 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3600 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3601 Body_Id
:= Defining_Entity
(Body_Decl
);
3602 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3609 -- The pragma must apply to the second declaration of a subprogram.
3610 -- In other words, the body [stub] cannot acts as a spec.
3612 if No
(Spec_Id
) then
3613 Error_Pragma
("pragma % cannot apply to a stand alone body");
3616 -- Catch the case where the subprogram body is a subunit and acts as
3617 -- the third declaration of the subprogram.
3619 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3620 Error_Pragma
("pragma % cannot apply to a subunit");
3624 -- The pragma can only apply to the body [stub] of a subprogram
3625 -- declared in the visible part of a package. Retrieve the context of
3626 -- the subprogram declaration.
3628 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3630 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3632 ("pragma % must apply to the body of a subprogram declared in a "
3633 & "package specification");
3637 -- If we get here, then the pragma is legal
3640 end Analyze_Refined_Pragma
;
3642 --------------------------
3643 -- Check_Ada_83_Warning --
3644 --------------------------
3646 procedure Check_Ada_83_Warning
is
3648 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3649 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3651 end Check_Ada_83_Warning
;
3653 ---------------------
3654 -- Check_Arg_Count --
3655 ---------------------
3657 procedure Check_Arg_Count
(Required
: Nat
) is
3659 if Arg_Count
/= Required
then
3660 Error_Pragma
("wrong number of arguments for pragma%");
3662 end Check_Arg_Count
;
3664 --------------------------------
3665 -- Check_Arg_Is_External_Name --
3666 --------------------------------
3668 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3669 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3672 if Nkind
(Argx
) = N_Identifier
then
3676 Analyze_And_Resolve
(Argx
, Standard_String
);
3678 if Is_OK_Static_Expression
(Argx
) then
3681 elsif Etype
(Argx
) = Any_Type
then
3684 -- An interesting special case, if we have a string literal and
3685 -- we are in Ada 83 mode, then we allow it even though it will
3686 -- not be flagged as static. This allows expected Ada 83 mode
3687 -- use of external names which are string literals, even though
3688 -- technically these are not static in Ada 83.
3690 elsif Ada_Version
= Ada_83
3691 and then Nkind
(Argx
) = N_String_Literal
3695 -- Static expression that raises Constraint_Error. This has
3696 -- already been flagged, so just exit from pragma processing.
3698 elsif Is_OK_Static_Expression
(Argx
) then
3701 -- Here we have a real error (non-static expression)
3704 Error_Msg_Name_1
:= Pname
;
3707 Msg
: constant String :=
3708 "argument for pragma% must be a identifier or "
3709 & "static string expression!";
3711 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3716 end Check_Arg_Is_External_Name
;
3718 -----------------------------
3719 -- Check_Arg_Is_Identifier --
3720 -----------------------------
3722 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3723 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3725 if Nkind
(Argx
) /= N_Identifier
then
3727 ("argument for pragma% must be identifier", Argx
);
3729 end Check_Arg_Is_Identifier
;
3731 ----------------------------------
3732 -- Check_Arg_Is_Integer_Literal --
3733 ----------------------------------
3735 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3736 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3738 if Nkind
(Argx
) /= N_Integer_Literal
then
3740 ("argument for pragma% must be integer literal", Argx
);
3742 end Check_Arg_Is_Integer_Literal
;
3744 -------------------------------------------
3745 -- Check_Arg_Is_Library_Level_Local_Name --
3746 -------------------------------------------
3750 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3751 -- | library_unit_NAME
3753 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3755 Check_Arg_Is_Local_Name
(Arg
);
3757 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3758 and then Comes_From_Source
(N
)
3761 ("argument for pragma% must be library level entity", Arg
);
3763 end Check_Arg_Is_Library_Level_Local_Name
;
3765 -----------------------------
3766 -- Check_Arg_Is_Local_Name --
3767 -----------------------------
3771 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3772 -- | library_unit_NAME
3774 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3775 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3780 if Nkind
(Argx
) not in N_Direct_Name
3781 and then (Nkind
(Argx
) /= N_Attribute_Reference
3782 or else Present
(Expressions
(Argx
))
3783 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3784 and then (not Is_Entity_Name
(Argx
)
3785 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3787 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3790 -- No further check required if not an entity name
3792 if not Is_Entity_Name
(Argx
) then
3798 Ent
: constant Entity_Id
:= Entity
(Argx
);
3799 Scop
: constant Entity_Id
:= Scope
(Ent
);
3802 -- Case of a pragma applied to a compilation unit: pragma must
3803 -- occur immediately after the program unit in the compilation.
3805 if Is_Compilation_Unit
(Ent
) then
3807 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3810 -- Case of pragma placed immediately after spec
3812 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3815 -- Case of pragma placed immediately after body
3817 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3818 and then Present
(Corresponding_Body
(Decl
))
3822 (Parent
(Unit_Declaration_Node
3823 (Corresponding_Body
(Decl
))));
3825 -- All other cases are illegal
3832 -- Special restricted placement rule from 10.2.1(11.8/2)
3834 elsif Is_Generic_Formal
(Ent
)
3835 and then Prag_Id
= Pragma_Preelaborable_Initialization
3837 OK
:= List_Containing
(N
) =
3838 Generic_Formal_Declarations
3839 (Unit_Declaration_Node
(Scop
));
3841 -- If this is an aspect applied to a subprogram body, the
3842 -- pragma is inserted in its declarative part.
3844 elsif From_Aspect_Specification
(N
)
3845 and then Ent
= Current_Scope
3847 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3851 -- If the aspect is a predicate (possibly others ???) and the
3852 -- context is a record type, this is a discriminant expression
3853 -- within a type declaration, that freezes the predicated
3856 elsif From_Aspect_Specification
(N
)
3857 and then Prag_Id
= Pragma_Predicate
3858 and then Ekind
(Current_Scope
) = E_Record_Type
3859 and then Scop
= Scope
(Current_Scope
)
3863 -- Default case, just check that the pragma occurs in the scope
3864 -- of the entity denoted by the name.
3867 OK
:= Current_Scope
= Scop
;
3872 ("pragma% argument must be in same declarative part", Arg
);
3876 end Check_Arg_Is_Local_Name
;
3878 ---------------------------------
3879 -- Check_Arg_Is_Locking_Policy --
3880 ---------------------------------
3882 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3883 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3886 Check_Arg_Is_Identifier
(Argx
);
3888 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3889 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3891 end Check_Arg_Is_Locking_Policy
;
3893 -----------------------------------------------
3894 -- Check_Arg_Is_Partition_Elaboration_Policy --
3895 -----------------------------------------------
3897 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3898 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3901 Check_Arg_Is_Identifier
(Argx
);
3903 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3905 ("& is not a valid partition elaboration policy name", Argx
);
3907 end Check_Arg_Is_Partition_Elaboration_Policy
;
3909 -------------------------
3910 -- Check_Arg_Is_One_Of --
3911 -------------------------
3913 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3914 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3917 Check_Arg_Is_Identifier
(Argx
);
3919 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3920 Error_Msg_Name_2
:= N1
;
3921 Error_Msg_Name_3
:= N2
;
3922 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3924 end Check_Arg_Is_One_Of
;
3926 procedure Check_Arg_Is_One_Of
3928 N1
, N2
, N3
: Name_Id
)
3930 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3933 Check_Arg_Is_Identifier
(Argx
);
3935 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3936 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3938 end Check_Arg_Is_One_Of
;
3940 procedure Check_Arg_Is_One_Of
3942 N1
, N2
, N3
, N4
: Name_Id
)
3944 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3947 Check_Arg_Is_Identifier
(Argx
);
3949 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3950 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3952 end Check_Arg_Is_One_Of
;
3954 procedure Check_Arg_Is_One_Of
3956 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3958 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3961 Check_Arg_Is_Identifier
(Argx
);
3963 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3964 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3966 end Check_Arg_Is_One_Of
;
3968 ---------------------------------
3969 -- Check_Arg_Is_Queuing_Policy --
3970 ---------------------------------
3972 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3973 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3976 Check_Arg_Is_Identifier
(Argx
);
3978 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3979 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3981 end Check_Arg_Is_Queuing_Policy
;
3983 ---------------------------------------
3984 -- Check_Arg_Is_OK_Static_Expression --
3985 ---------------------------------------
3987 procedure Check_Arg_Is_OK_Static_Expression
3989 Typ
: Entity_Id
:= Empty
)
3992 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
3993 end Check_Arg_Is_OK_Static_Expression
;
3995 ------------------------------------------
3996 -- Check_Arg_Is_Task_Dispatching_Policy --
3997 ------------------------------------------
3999 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4000 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4003 Check_Arg_Is_Identifier
(Argx
);
4005 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4007 ("& is not an allowed task dispatching policy name", Argx
);
4009 end Check_Arg_Is_Task_Dispatching_Policy
;
4011 ---------------------
4012 -- Check_Arg_Order --
4013 ---------------------
4015 procedure Check_Arg_Order
(Names
: Name_List
) is
4018 Highest_So_Far
: Natural := 0;
4019 -- Highest index in Names seen do far
4023 for J
in 1 .. Arg_Count
loop
4024 if Chars
(Arg
) /= No_Name
then
4025 for K
in Names
'Range loop
4026 if Chars
(Arg
) = Names
(K
) then
4027 if K
< Highest_So_Far
then
4028 Error_Msg_Name_1
:= Pname
;
4030 ("parameters out of order for pragma%", Arg
);
4031 Error_Msg_Name_1
:= Names
(K
);
4032 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4033 Error_Msg_N
("\% must appear before %", Arg
);
4037 Highest_So_Far
:= K
;
4045 end Check_Arg_Order
;
4047 --------------------------------
4048 -- Check_At_Least_N_Arguments --
4049 --------------------------------
4051 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4053 if Arg_Count
< N
then
4054 Error_Pragma
("too few arguments for pragma%");
4056 end Check_At_Least_N_Arguments
;
4058 -------------------------------
4059 -- Check_At_Most_N_Arguments --
4060 -------------------------------
4062 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4065 if Arg_Count
> N
then
4067 for J
in 1 .. N
loop
4069 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4072 end Check_At_Most_N_Arguments
;
4074 ---------------------
4075 -- Check_Component --
4076 ---------------------
4078 procedure Check_Component
4081 In_Variant_Part
: Boolean := False)
4083 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4084 Sindic
: constant Node_Id
:=
4085 Subtype_Indication
(Component_Definition
(Comp
));
4086 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4089 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4090 -- object constraint, then the component type shall be an Unchecked_
4093 if Nkind
(Sindic
) = N_Subtype_Indication
4094 and then Has_Per_Object_Constraint
(Comp_Id
)
4095 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4098 ("component subtype subject to per-object constraint "
4099 & "must be an Unchecked_Union", Comp
);
4101 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4102 -- the body of a generic unit, or within the body of any of its
4103 -- descendant library units, no part of the type of a component
4104 -- declared in a variant_part of the unchecked union type shall be of
4105 -- a formal private type or formal private extension declared within
4106 -- the formal part of the generic unit.
4108 elsif Ada_Version
>= Ada_2012
4109 and then In_Generic_Body
(UU_Typ
)
4110 and then In_Variant_Part
4111 and then Is_Private_Type
(Typ
)
4112 and then Is_Generic_Type
(Typ
)
4115 ("component of unchecked union cannot be of generic type", Comp
);
4117 elsif Needs_Finalization
(Typ
) then
4119 ("component of unchecked union cannot be controlled", Comp
);
4121 elsif Has_Task
(Typ
) then
4123 ("component of unchecked union cannot have tasks", Comp
);
4125 end Check_Component
;
4127 -----------------------------
4128 -- Check_Declaration_Order --
4129 -----------------------------
4131 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4132 procedure Check_Aspect_Specification_Order
;
4133 -- Inspect the aspect specifications of the context to determine the
4136 --------------------------------------
4137 -- Check_Aspect_Specification_Order --
4138 --------------------------------------
4140 procedure Check_Aspect_Specification_Order
is
4141 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4142 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4146 -- Both aspects must be part of the same aspect specification list
4149 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4151 -- Try to reach Second starting from First in a left to right
4152 -- traversal of the aspect specifications.
4154 Asp
:= Next
(Asp_First
);
4155 while Present
(Asp
) loop
4157 -- The order is ok, First is followed by Second
4159 if Asp
= Asp_Second
then
4166 -- If we get here, then the aspects are out of order
4168 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4169 end Check_Aspect_Specification_Order
;
4175 -- Start of processing for Check_Declaration_Order
4178 -- Cannot check the order if one of the pragmas is missing
4180 if No
(First
) or else No
(Second
) then
4184 -- Set up the error names in case the order is incorrect
4186 Error_Msg_Name_1
:= Pragma_Name
(First
);
4187 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4189 if From_Aspect_Specification
(First
) then
4191 -- Both pragmas are actually aspects, check their declaration
4192 -- order in the associated aspect specification list. Otherwise
4193 -- First is an aspect and Second a source pragma.
4195 if From_Aspect_Specification
(Second
) then
4196 Check_Aspect_Specification_Order
;
4199 -- Abstract_States is a source pragma
4202 if From_Aspect_Specification
(Second
) then
4203 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4205 -- Both pragmas are source constructs. Try to reach First from
4206 -- Second by traversing the declarations backwards.
4209 Stmt
:= Prev
(Second
);
4210 while Present
(Stmt
) loop
4212 -- The order is ok, First is followed by Second
4214 if Stmt
= First
then
4221 -- If we get here, then the pragmas are out of order
4223 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4226 end Check_Declaration_Order
;
4228 ----------------------------
4229 -- Check_Duplicate_Pragma --
4230 ----------------------------
4232 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4233 Id
: Entity_Id
:= E
;
4237 -- Nothing to do if this pragma comes from an aspect specification,
4238 -- since we could not be duplicating a pragma, and we dealt with the
4239 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4241 if From_Aspect_Specification
(N
) then
4245 -- Otherwise current pragma may duplicate previous pragma or a
4246 -- previously given aspect specification or attribute definition
4247 -- clause for the same pragma.
4249 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4253 -- If the entity is a type, then we have to make sure that the
4254 -- ostensible duplicate is not for a parent type from which this
4258 if Nkind
(P
) = N_Pragma
then
4260 Args
: constant List_Id
:=
4261 Pragma_Argument_Associations
(P
);
4264 and then Is_Entity_Name
(Expression
(First
(Args
)))
4265 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4266 and then Entity
(Expression
(First
(Args
))) /= E
4272 elsif Nkind
(P
) = N_Aspect_Specification
4273 and then Is_Type
(Entity
(P
))
4274 and then Entity
(P
) /= E
4280 -- Here we have a definite duplicate
4282 Error_Msg_Name_1
:= Pragma_Name
(N
);
4283 Error_Msg_Sloc
:= Sloc
(P
);
4285 -- For a single protected or a single task object, the error is
4286 -- issued on the original entity.
4288 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4289 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4292 if Nkind
(P
) = N_Aspect_Specification
4293 or else From_Aspect_Specification
(P
)
4295 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4297 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4302 end Check_Duplicate_Pragma
;
4304 ----------------------------------
4305 -- Check_Duplicated_Export_Name --
4306 ----------------------------------
4308 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4309 String_Val
: constant String_Id
:= Strval
(Nam
);
4312 -- We are only interested in the export case, and in the case of
4313 -- generics, it is the instance, not the template, that is the
4314 -- problem (the template will generate a warning in any case).
4316 if not Inside_A_Generic
4317 and then (Prag_Id
= Pragma_Export
4319 Prag_Id
= Pragma_Export_Procedure
4321 Prag_Id
= Pragma_Export_Valued_Procedure
4323 Prag_Id
= Pragma_Export_Function
)
4325 for J
in Externals
.First
.. Externals
.Last
loop
4326 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4327 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4328 Error_Msg_N
("external name duplicates name given#", Nam
);
4333 Externals
.Append
(Nam
);
4335 end Check_Duplicated_Export_Name
;
4337 ----------------------------------------
4338 -- Check_Expr_Is_OK_Static_Expression --
4339 ----------------------------------------
4341 procedure Check_Expr_Is_OK_Static_Expression
4343 Typ
: Entity_Id
:= Empty
)
4346 if Present
(Typ
) then
4347 Analyze_And_Resolve
(Expr
, Typ
);
4349 Analyze_And_Resolve
(Expr
);
4352 if Is_OK_Static_Expression
(Expr
) then
4355 elsif Etype
(Expr
) = Any_Type
then
4358 -- An interesting special case, if we have a string literal and we
4359 -- are in Ada 83 mode, then we allow it even though it will not be
4360 -- flagged as static. This allows the use of Ada 95 pragmas like
4361 -- Import in Ada 83 mode. They will of course be flagged with
4362 -- warnings as usual, but will not cause errors.
4364 elsif Ada_Version
= Ada_83
4365 and then Nkind
(Expr
) = N_String_Literal
4369 -- Static expression that raises Constraint_Error. This has already
4370 -- been flagged, so just exit from pragma processing.
4372 elsif Is_OK_Static_Expression
(Expr
) then
4375 -- Finally, we have a real error
4378 Error_Msg_Name_1
:= Pname
;
4379 Flag_Non_Static_Expr
4380 (Fix_Error
("argument for pragma% must be a static expression!"),
4384 end Check_Expr_Is_OK_Static_Expression
;
4386 -------------------------
4387 -- Check_First_Subtype --
4388 -------------------------
4390 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4391 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4392 Ent
: constant Entity_Id
:= Entity
(Argx
);
4395 if Is_First_Subtype
(Ent
) then
4398 elsif Is_Type
(Ent
) then
4400 ("pragma% cannot apply to subtype", Argx
);
4402 elsif Is_Object
(Ent
) then
4404 ("pragma% cannot apply to object, requires a type", Argx
);
4408 ("pragma% cannot apply to&, requires a type", Argx
);
4410 end Check_First_Subtype
;
4412 ----------------------
4413 -- Check_Identifier --
4414 ----------------------
4416 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4419 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4421 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4422 Error_Msg_Name_1
:= Pname
;
4423 Error_Msg_Name_2
:= Id
;
4424 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4428 end Check_Identifier
;
4430 --------------------------------
4431 -- Check_Identifier_Is_One_Of --
4432 --------------------------------
4434 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4437 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4439 if Chars
(Arg
) = No_Name
then
4440 Error_Msg_Name_1
:= Pname
;
4441 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4444 elsif Chars
(Arg
) /= N1
4445 and then Chars
(Arg
) /= N2
4447 Error_Msg_Name_1
:= Pname
;
4448 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4452 end Check_Identifier_Is_One_Of
;
4454 ---------------------------
4455 -- Check_In_Main_Program --
4456 ---------------------------
4458 procedure Check_In_Main_Program
is
4459 P
: constant Node_Id
:= Parent
(N
);
4462 -- Must be at in subprogram body
4464 if Nkind
(P
) /= N_Subprogram_Body
then
4465 Error_Pragma
("% pragma allowed only in subprogram");
4467 -- Otherwise warn if obviously not main program
4469 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4470 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4472 Error_Msg_Name_1
:= Pname
;
4474 ("??pragma% is only effective in main program", N
);
4476 end Check_In_Main_Program
;
4478 ---------------------------------------
4479 -- Check_Interrupt_Or_Attach_Handler --
4480 ---------------------------------------
4482 procedure Check_Interrupt_Or_Attach_Handler
is
4483 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4484 Handler_Proc
, Proc_Scope
: Entity_Id
;
4489 if Prag_Id
= Pragma_Interrupt_Handler
then
4490 Check_Restriction
(No_Dynamic_Attachment
, N
);
4493 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4494 Proc_Scope
:= Scope
(Handler_Proc
);
4496 -- On AAMP only, a pragma Interrupt_Handler is supported for
4497 -- nonprotected parameterless procedures.
4499 if not AAMP_On_Target
4500 or else Prag_Id
= Pragma_Attach_Handler
4502 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4504 ("argument of pragma% must be protected procedure", Arg1
);
4507 -- For pragma case (as opposed to access case), check placement.
4508 -- We don't need to do that for aspects, because we have the
4509 -- check that they aspect applies an appropriate procedure.
4511 if not From_Aspect_Specification
(N
)
4512 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4514 Error_Pragma
("pragma% must be in protected definition");
4518 if not Is_Library_Level_Entity
(Proc_Scope
)
4519 or else (AAMP_On_Target
4520 and then not Is_Library_Level_Entity
(Handler_Proc
))
4523 ("argument for pragma% must be library level entity", Arg1
);
4526 -- AI05-0033: A pragma cannot appear within a generic body, because
4527 -- instance can be in a nested scope. The check that protected type
4528 -- is itself a library-level declaration is done elsewhere.
4530 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4531 -- handle code prior to AI-0033. Analysis tools typically are not
4532 -- interested in this pragma in any case, so no need to worry too
4533 -- much about its placement.
4535 if Inside_A_Generic
then
4536 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4537 and then In_Package_Body
(Scope
(Current_Scope
))
4538 and then not Relaxed_RM_Semantics
4540 Error_Pragma
("pragma% cannot be used inside a generic");
4543 end Check_Interrupt_Or_Attach_Handler
;
4545 ---------------------------------
4546 -- Check_Loop_Pragma_Placement --
4547 ---------------------------------
4549 procedure Check_Loop_Pragma_Placement
is
4550 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4551 -- Verify whether the current pragma is properly grouped with other
4552 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4553 -- related loop where the pragma appears.
4555 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4556 -- Determine whether an arbitrary statement Stmt denotes pragma
4557 -- Loop_Invariant or Loop_Variant.
4559 procedure Placement_Error
(Constr
: Node_Id
);
4560 pragma No_Return
(Placement_Error
);
4561 -- Node Constr denotes the last loop restricted construct before we
4562 -- encountered an illegal relation between enclosing constructs. Emit
4563 -- an error depending on what Constr was.
4565 --------------------------------
4566 -- Check_Loop_Pragma_Grouping --
4567 --------------------------------
4569 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4570 Stop_Search
: exception;
4571 -- This exception is used to terminate the recursive descent of
4572 -- routine Check_Grouping.
4574 procedure Check_Grouping
(L
: List_Id
);
4575 -- Find the first group of pragmas in list L and if successful,
4576 -- ensure that the current pragma is part of that group. The
4577 -- routine raises Stop_Search once such a check is performed to
4578 -- halt the recursive descent.
4580 procedure Grouping_Error
(Prag
: Node_Id
);
4581 pragma No_Return
(Grouping_Error
);
4582 -- Emit an error concerning the current pragma indicating that it
4583 -- should be placed after pragma Prag.
4585 --------------------
4586 -- Check_Grouping --
4587 --------------------
4589 procedure Check_Grouping
(L
: List_Id
) is
4595 -- Inspect the list of declarations or statements looking for
4596 -- the first grouping of pragmas:
4599 -- pragma Loop_Invariant ...;
4600 -- pragma Loop_Variant ...;
4602 -- pragma Loop_Variant ...; -- current pragma
4604 -- If the current pragma is not in the grouping, then it must
4605 -- either appear in a different declarative or statement list
4606 -- or the construct at (1) is separating the pragma from the
4610 while Present
(Stmt
) loop
4612 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4613 -- inside a loop or a block housed inside a loop. Inspect
4614 -- the declarations and statements of the block as they may
4615 -- contain the first grouping.
4617 if Nkind
(Stmt
) = N_Block_Statement
then
4618 HSS
:= Handled_Statement_Sequence
(Stmt
);
4620 Check_Grouping
(Declarations
(Stmt
));
4622 if Present
(HSS
) then
4623 Check_Grouping
(Statements
(HSS
));
4626 -- First pragma of the first topmost grouping has been found
4628 elsif Is_Loop_Pragma
(Stmt
) then
4630 -- The group and the current pragma are not in the same
4631 -- declarative or statement list.
4633 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4634 Grouping_Error
(Stmt
);
4636 -- Try to reach the current pragma from the first pragma
4637 -- of the grouping while skipping other members:
4639 -- pragma Loop_Invariant ...; -- first pragma
4640 -- pragma Loop_Variant ...; -- member
4642 -- pragma Loop_Variant ...; -- current pragma
4645 while Present
(Stmt
) loop
4647 -- The current pragma is either the first pragma
4648 -- of the group or is a member of the group. Stop
4649 -- the search as the placement is legal.
4654 -- Skip group members, but keep track of the last
4655 -- pragma in the group.
4657 elsif Is_Loop_Pragma
(Stmt
) then
4660 -- A non-pragma is separating the group from the
4661 -- current pragma, the placement is illegal.
4664 Grouping_Error
(Prag
);
4670 -- If the traversal did not reach the current pragma,
4671 -- then the list must be malformed.
4673 raise Program_Error
;
4681 --------------------
4682 -- Grouping_Error --
4683 --------------------
4685 procedure Grouping_Error
(Prag
: Node_Id
) is
4687 Error_Msg_Sloc
:= Sloc
(Prag
);
4688 Error_Pragma
("pragma% must appear next to pragma#");
4691 -- Start of processing for Check_Loop_Pragma_Grouping
4694 -- Inspect the statements of the loop or nested blocks housed
4695 -- within to determine whether the current pragma is part of the
4696 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4698 Check_Grouping
(Statements
(Loop_Stmt
));
4701 when Stop_Search
=> null;
4702 end Check_Loop_Pragma_Grouping
;
4704 --------------------
4705 -- Is_Loop_Pragma --
4706 --------------------
4708 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4710 -- Inspect the original node as Loop_Invariant and Loop_Variant
4711 -- pragmas are rewritten to null when assertions are disabled.
4713 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4715 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4716 Name_Loop_Invariant
,
4723 ---------------------
4724 -- Placement_Error --
4725 ---------------------
4727 procedure Placement_Error
(Constr
: Node_Id
) is
4728 LA
: constant String := " with Loop_Entry";
4731 if Prag_Id
= Pragma_Assert
then
4732 Error_Msg_String
(1 .. LA
'Length) := LA
;
4733 Error_Msg_Strlen
:= LA
'Length;
4735 Error_Msg_Strlen
:= 0;
4738 if Nkind
(Constr
) = N_Pragma
then
4740 ("pragma %~ must appear immediately within the statements "
4744 ("block containing pragma %~ must appear immediately within "
4745 & "the statements of a loop", Constr
);
4747 end Placement_Error
;
4749 -- Local declarations
4754 -- Start of processing for Check_Loop_Pragma_Placement
4757 -- Check that pragma appears immediately within a loop statement,
4758 -- ignoring intervening block statements.
4762 while Present
(Stmt
) loop
4764 -- The pragma or previous block must appear immediately within the
4765 -- current block's declarative or statement part.
4767 if Nkind
(Stmt
) = N_Block_Statement
then
4768 if (No
(Declarations
(Stmt
))
4769 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4771 List_Containing
(Prev
) /=
4772 Statements
(Handled_Statement_Sequence
(Stmt
))
4774 Placement_Error
(Prev
);
4777 -- Keep inspecting the parents because we are now within a
4778 -- chain of nested blocks.
4782 Stmt
:= Parent
(Stmt
);
4785 -- The pragma or previous block must appear immediately within the
4786 -- statements of the loop.
4788 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4789 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4790 Placement_Error
(Prev
);
4793 -- Stop the traversal because we reached the innermost loop
4794 -- regardless of whether we encountered an error or not.
4798 -- Ignore a handled statement sequence. Note that this node may
4799 -- be related to a subprogram body in which case we will emit an
4800 -- error on the next iteration of the search.
4802 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4803 Stmt
:= Parent
(Stmt
);
4805 -- Any other statement breaks the chain from the pragma to the
4809 Placement_Error
(Prev
);
4814 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4815 -- grouped together with other such pragmas.
4817 if Is_Loop_Pragma
(N
) then
4819 -- The previous check should have located the related loop
4821 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4822 Check_Loop_Pragma_Grouping
(Stmt
);
4824 end Check_Loop_Pragma_Placement
;
4826 -------------------------------------------
4827 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4828 -------------------------------------------
4830 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4839 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4842 elsif Nkind_In
(P
, N_Package_Specification
,
4847 -- Note: the following tests seem a little peculiar, because
4848 -- they test for bodies, but if we were in the statement part
4849 -- of the body, we would already have hit the handled statement
4850 -- sequence, so the only way we get here is by being in the
4851 -- declarative part of the body.
4853 elsif Nkind_In
(P
, N_Subprogram_Body
,
4864 Error_Pragma
("pragma% is not in declarative part or package spec");
4865 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4867 -------------------------
4868 -- Check_No_Identifier --
4869 -------------------------
4871 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4873 if Nkind
(Arg
) = N_Pragma_Argument_Association
4874 and then Chars
(Arg
) /= No_Name
4876 Error_Pragma_Arg_Ident
4877 ("pragma% does not permit identifier& here", Arg
);
4879 end Check_No_Identifier
;
4881 --------------------------
4882 -- Check_No_Identifiers --
4883 --------------------------
4885 procedure Check_No_Identifiers
is
4889 for J
in 1 .. Arg_Count
loop
4890 Check_No_Identifier
(Arg_Node
);
4893 end Check_No_Identifiers
;
4895 ------------------------
4896 -- Check_No_Link_Name --
4897 ------------------------
4899 procedure Check_No_Link_Name
is
4901 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4905 if Present
(Arg4
) then
4907 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4909 end Check_No_Link_Name
;
4911 -------------------------------
4912 -- Check_Optional_Identifier --
4913 -------------------------------
4915 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4918 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4919 and then Chars
(Arg
) /= No_Name
4921 if Chars
(Arg
) /= Id
then
4922 Error_Msg_Name_1
:= Pname
;
4923 Error_Msg_Name_2
:= Id
;
4924 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4928 end Check_Optional_Identifier
;
4930 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4932 Name_Buffer
(1 .. Id
'Length) := Id
;
4933 Name_Len
:= Id
'Length;
4934 Check_Optional_Identifier
(Arg
, Name_Find
);
4935 end Check_Optional_Identifier
;
4937 --------------------
4938 -- Check_Pre_Post --
4939 --------------------
4941 procedure Check_Pre_Post
is
4946 if not Is_List_Member
(N
) then
4950 -- If we are within an inlined body, the legality of the pragma
4951 -- has been checked already.
4953 if In_Inlined_Body
then
4957 -- Search prior declarations
4960 while Present
(Prev
(P
)) loop
4963 -- If the previous node is a generic subprogram, do not go to to
4964 -- the original node, which is the unanalyzed tree: we need to
4965 -- attach the pre/postconditions to the analyzed version at this
4966 -- point. They get propagated to the original tree when analyzing
4967 -- the corresponding body.
4969 if Nkind
(P
) not in N_Generic_Declaration
then
4970 PO
:= Original_Node
(P
);
4975 -- Skip past prior pragma
4977 if Nkind
(PO
) = N_Pragma
then
4980 -- Skip stuff not coming from source
4982 elsif not Comes_From_Source
(PO
) then
4984 -- The condition may apply to a subprogram instantiation
4986 if Nkind
(PO
) = N_Subprogram_Declaration
4987 and then Present
(Generic_Parent
(Specification
(PO
)))
4991 elsif Nkind
(PO
) = N_Subprogram_Declaration
4992 and then In_Instance
4996 -- For all other cases of non source code, do nothing
5002 -- Only remaining possibility is subprogram declaration
5009 -- If we fall through loop, pragma is at start of list, so see if it
5010 -- is at the start of declarations of a subprogram body.
5014 if Nkind
(PO
) = N_Subprogram_Body
5015 and then List_Containing
(N
) = Declarations
(PO
)
5017 -- This is only allowed if there is no separate specification
5019 if Present
(Corresponding_Spec
(PO
)) then
5021 ("pragma% must apply to subprogram specification");
5028 --------------------------------------
5029 -- Check_Precondition_Postcondition --
5030 --------------------------------------
5032 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
5036 procedure Chain_PPC
(PO
: Node_Id
);
5037 -- If PO is an entry or a [generic] subprogram declaration node, then
5038 -- the precondition/postcondition applies to this subprogram and the
5039 -- processing for the pragma is completed. Otherwise the pragma is
5046 procedure Chain_PPC
(PO
: Node_Id
) is
5050 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5051 if not From_Aspect_Specification
(N
) then
5053 ("pragma% cannot be applied to abstract subprogram");
5055 elsif Class_Present
(N
) then
5060 ("aspect % requires ''Class for abstract subprogram");
5063 -- AI05-0230: The same restriction applies to null procedures. For
5064 -- compatibility with earlier uses of the Ada pragma, apply this
5065 -- rule only to aspect specifications.
5067 -- The above discrepency needs documentation. Robert is dubious
5068 -- about whether it is a good idea ???
5070 elsif Nkind
(PO
) = N_Subprogram_Declaration
5071 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
5072 and then Null_Present
(Specification
(PO
))
5073 and then From_Aspect_Specification
(N
)
5074 and then not Class_Present
(N
)
5077 ("aspect % requires ''Class for null procedure");
5079 -- Pre/postconditions are legal on a subprogram body if it is not
5080 -- a completion of a declaration. They are also legal on a stub
5081 -- with no previous declarations (this is checked when processing
5082 -- the corresponding aspects).
5084 elsif Nkind
(PO
) = N_Subprogram_Body
5085 and then Acts_As_Spec
(PO
)
5089 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
5092 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5093 N_Expression_Function
,
5094 N_Generic_Subprogram_Declaration
,
5095 N_Entry_Declaration
)
5100 -- Here if we have [generic] subprogram or entry declaration
5102 if Nkind
(PO
) = N_Entry_Declaration
then
5103 S
:= Defining_Entity
(PO
);
5105 S
:= Defining_Unit_Name
(Specification
(PO
));
5107 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5108 S
:= Defining_Identifier
(S
);
5112 -- Note: we do not analyze the pragma at this point. Instead we
5113 -- delay this analysis until the end of the declarative part in
5114 -- which the pragma appears. This implements the required delay
5115 -- in this analysis, allowing forward references. The analysis
5116 -- happens at the end of Analyze_Declarations.
5118 -- Chain spec PPC pragma to list for subprogram
5120 Add_Contract_Item
(N
, S
);
5122 -- Return indicating spec case
5128 -- Start of processing for Check_Precondition_Postcondition
5131 if not Is_List_Member
(N
) then
5135 -- Preanalyze message argument if present. Visibility in this
5136 -- argument is established at the point of pragma occurrence.
5138 if Arg_Count
= 2 then
5139 Check_Optional_Identifier
(Arg2
, Name_Message
);
5140 Preanalyze_Spec_Expression
5141 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5144 -- For a pragma PPC in the extended main source unit, record enabled
5147 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5148 Set_SCO_Pragma_Enabled
(Loc
);
5151 -- If we are within an inlined body, the legality of the pragma
5152 -- has been checked already.
5154 if In_Inlined_Body
then
5159 -- Search prior declarations
5162 while Present
(Prev
(P
)) loop
5165 -- If the previous node is a generic subprogram, do not go to to
5166 -- the original node, which is the unanalyzed tree: we need to
5167 -- attach the pre/postconditions to the analyzed version at this
5168 -- point. They get propagated to the original tree when analyzing
5169 -- the corresponding body.
5171 if Nkind
(P
) not in N_Generic_Declaration
then
5172 PO
:= Original_Node
(P
);
5177 -- Skip past prior pragma
5179 if Nkind
(PO
) = N_Pragma
then
5182 -- Skip stuff not coming from source
5184 elsif not Comes_From_Source
(PO
) then
5186 -- The condition may apply to a subprogram instantiation
5188 if Nkind
(PO
) = N_Subprogram_Declaration
5189 and then Present
(Generic_Parent
(Specification
(PO
)))
5194 elsif Nkind
(PO
) = N_Subprogram_Declaration
5195 and then In_Instance
5200 -- For all other cases of non source code, do nothing
5206 -- Only remaining possibility is subprogram declaration
5214 -- If we fall through loop, pragma is at start of list, so see if it
5215 -- is at the start of declarations of a subprogram body.
5219 if Nkind
(PO
) = N_Subprogram_Body
5220 and then List_Containing
(N
) = Declarations
(PO
)
5222 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5224 -- Analyze pragma expression for correctness and for ASIS use
5226 Preanalyze_Assert_Expression
5227 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5229 -- In ASIS mode, for a pragma generated from a source aspect,
5230 -- also analyze the original aspect expression.
5232 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5233 Preanalyze_Assert_Expression
5234 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5238 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5239 -- The copy is needed because the pragma is expanded into other
5240 -- constructs which are not acceptable in the N_Contract node.
5242 if Acts_As_Spec
(PO
) and then GNATprove_Mode
then
5244 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5247 -- Preanalyze the pragma
5249 Preanalyze_Assert_Expression
5251 (First
(Pragma_Argument_Associations
(Prag
))),
5254 -- Preanalyze the corresponding aspect (if any)
5256 if Present
(Corresponding_Aspect
(Prag
)) then
5257 Preanalyze_Assert_Expression
5258 (Expression
(Corresponding_Aspect
(Prag
)),
5262 -- Chain the copy on the contract of the body
5265 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5272 -- See if it is in the pragmas after a library level subprogram
5274 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5276 -- In GNATprove mode, analyze pragma expression for correctness,
5277 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5278 -- no later point at which the aspect will be analyzed.
5280 if GNATprove_Mode
or ASIS_Mode
then
5281 Analyze_Pre_Post_Condition_In_Decl_Part
5282 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5285 Chain_PPC
(Unit
(Parent
(PO
)));
5289 -- If we fall through, pragma was misplaced
5292 end Check_Precondition_Postcondition
;
5294 -----------------------------
5295 -- Check_Static_Constraint --
5296 -----------------------------
5298 -- Note: for convenience in writing this procedure, in addition to
5299 -- the officially (i.e. by spec) allowed argument which is always a
5300 -- constraint, it also allows ranges and discriminant associations.
5301 -- Above is not clear ???
5303 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5305 procedure Require_Static
(E
: Node_Id
);
5306 -- Require given expression to be static expression
5308 --------------------
5309 -- Require_Static --
5310 --------------------
5312 procedure Require_Static
(E
: Node_Id
) is
5314 if not Is_OK_Static_Expression
(E
) then
5315 Flag_Non_Static_Expr
5316 ("non-static constraint not allowed in Unchecked_Union!", E
);
5321 -- Start of processing for Check_Static_Constraint
5324 case Nkind
(Constr
) is
5325 when N_Discriminant_Association
=>
5326 Require_Static
(Expression
(Constr
));
5329 Require_Static
(Low_Bound
(Constr
));
5330 Require_Static
(High_Bound
(Constr
));
5332 when N_Attribute_Reference
=>
5333 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5334 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5336 when N_Range_Constraint
=>
5337 Check_Static_Constraint
(Range_Expression
(Constr
));
5339 when N_Index_Or_Discriminant_Constraint
=>
5343 IDC
:= First
(Constraints
(Constr
));
5344 while Present
(IDC
) loop
5345 Check_Static_Constraint
(IDC
);
5353 end Check_Static_Constraint
;
5355 ---------------------
5356 -- Check_Test_Case --
5357 ---------------------
5359 procedure Check_Test_Case
is
5363 procedure Chain_CTC
(PO
: Node_Id
);
5364 -- If PO is a [generic] subprogram declaration node, then the
5365 -- test-case applies to this subprogram and the processing for
5366 -- the pragma is completed. Otherwise the pragma is misplaced.
5372 procedure Chain_CTC
(PO
: Node_Id
) is
5373 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5378 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5380 ("pragma% cannot be applied to abstract subprogram");
5382 elsif Nkind
(PO
) = N_Entry_Declaration
then
5383 Error_Pragma
("pragma% cannot be applied to entry");
5385 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5386 N_Generic_Subprogram_Declaration
)
5391 -- Here if we have [generic] subprogram declaration
5393 S
:= Defining_Unit_Name
(Specification
(PO
));
5395 -- Note: we do not analyze the pragma at this point. Instead we
5396 -- delay this analysis until the end of the declarative part in
5397 -- which the pragma appears. This implements the required delay
5398 -- in this analysis, allowing forward references. The analysis
5399 -- happens at the end of Analyze_Declarations.
5401 -- There should not be another test-case with the same name
5402 -- associated to this subprogram.
5404 CTC
:= Contract_Test_Cases
(Contract
(S
));
5405 while Present
(CTC
) loop
5407 -- Omit pragma Contract_Cases because it does not introduce
5408 -- a unique case name and it does not follow the syntax of
5411 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5414 elsif String_Equal
(Name
, Get_Name_From_CTC_Pragma
(CTC
)) then
5415 Error_Msg_Sloc
:= Sloc
(CTC
);
5416 Error_Pragma
("name for pragma% is already used#");
5419 CTC
:= Next_Pragma
(CTC
);
5422 -- Chain spec CTC pragma to list for subprogram
5424 Add_Contract_Item
(N
, S
);
5427 -- Start of processing for Check_Test_Case
5430 -- First check pragma arguments
5432 Check_At_Least_N_Arguments
(2);
5433 Check_At_Most_N_Arguments
(4);
5435 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5437 Check_Optional_Identifier
(Arg1
, Name_Name
);
5438 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
5440 -- In ASIS mode, for a pragma generated from a source aspect, also
5441 -- analyze the original aspect expression.
5443 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5444 Check_Expr_Is_OK_Static_Expression
5445 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5448 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5449 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5451 if Arg_Count
= 4 then
5452 Check_Identifier
(Arg3
, Name_Requires
);
5453 Check_Identifier
(Arg4
, Name_Ensures
);
5455 elsif Arg_Count
= 3 then
5456 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5459 -- Check pragma placement
5461 if not Is_List_Member
(N
) then
5465 -- Test-case should only appear in package spec unit
5467 if Get_Source_Unit
(N
) = No_Unit
5468 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Current_Sem_Unit
)),
5469 N_Package_Declaration
,
5470 N_Generic_Package_Declaration
)
5475 -- Search prior declarations
5478 while Present
(Prev
(P
)) loop
5481 -- If the previous node is a generic subprogram, do not go to to
5482 -- the original node, which is the unanalyzed tree: we need to
5483 -- attach the test-case to the analyzed version at this point.
5484 -- They get propagated to the original tree when analyzing the
5485 -- corresponding body.
5487 if Nkind
(P
) not in N_Generic_Declaration
then
5488 PO
:= Original_Node
(P
);
5493 -- Skip past prior pragma
5495 if Nkind
(PO
) = N_Pragma
then
5498 -- Skip stuff not coming from source
5500 elsif not Comes_From_Source
(PO
) then
5503 -- Only remaining possibility is subprogram declaration. First
5504 -- check that it is declared directly in a package declaration.
5505 -- This may be either the package declaration for the current unit
5506 -- being defined or a local package declaration.
5508 elsif not Present
(Parent
(Parent
(PO
)))
5509 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5510 or else not Nkind_In
(Parent
(Parent
(PO
)),
5511 N_Package_Declaration
,
5512 N_Generic_Package_Declaration
)
5522 -- If we fall through, pragma was misplaced
5525 end Check_Test_Case
;
5527 --------------------------------------
5528 -- Check_Valid_Configuration_Pragma --
5529 --------------------------------------
5531 -- A configuration pragma must appear in the context clause of a
5532 -- compilation unit, and only other pragmas may precede it. Note that
5533 -- the test also allows use in a configuration pragma file.
5535 procedure Check_Valid_Configuration_Pragma
is
5537 if not Is_Configuration_Pragma
then
5538 Error_Pragma
("incorrect placement for configuration pragma%");
5540 end Check_Valid_Configuration_Pragma
;
5542 -------------------------------------
5543 -- Check_Valid_Library_Unit_Pragma --
5544 -------------------------------------
5546 procedure Check_Valid_Library_Unit_Pragma
is
5548 Parent_Node
: Node_Id
;
5549 Unit_Name
: Entity_Id
;
5550 Unit_Kind
: Node_Kind
;
5551 Unit_Node
: Node_Id
;
5552 Sindex
: Source_File_Index
;
5555 if not Is_List_Member
(N
) then
5559 Plist
:= List_Containing
(N
);
5560 Parent_Node
:= Parent
(Plist
);
5562 if Parent_Node
= Empty
then
5565 -- Case of pragma appearing after a compilation unit. In this case
5566 -- it must have an argument with the corresponding name and must
5567 -- be part of the following pragmas of its parent.
5569 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5570 if Plist
/= Pragmas_After
(Parent_Node
) then
5573 elsif Arg_Count
= 0 then
5575 ("argument required if outside compilation unit");
5578 Check_No_Identifiers
;
5579 Check_Arg_Count
(1);
5580 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5581 Unit_Kind
:= Nkind
(Unit_Node
);
5583 Analyze
(Get_Pragma_Arg
(Arg1
));
5585 if Unit_Kind
= N_Generic_Subprogram_Declaration
5586 or else Unit_Kind
= N_Subprogram_Declaration
5588 Unit_Name
:= Defining_Entity
(Unit_Node
);
5590 elsif Unit_Kind
in N_Generic_Instantiation
then
5591 Unit_Name
:= Defining_Entity
(Unit_Node
);
5594 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5597 if Chars
(Unit_Name
) /=
5598 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5601 ("pragma% argument is not current unit name", Arg1
);
5604 if Ekind
(Unit_Name
) = E_Package
5605 and then Present
(Renamed_Entity
(Unit_Name
))
5607 Error_Pragma
("pragma% not allowed for renamed package");
5611 -- Pragma appears other than after a compilation unit
5614 -- Here we check for the generic instantiation case and also
5615 -- for the case of processing a generic formal package. We
5616 -- detect these cases by noting that the Sloc on the node
5617 -- does not belong to the current compilation unit.
5619 Sindex
:= Source_Index
(Current_Sem_Unit
);
5621 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5622 Rewrite
(N
, Make_Null_Statement
(Loc
));
5625 -- If before first declaration, the pragma applies to the
5626 -- enclosing unit, and the name if present must be this name.
5628 elsif Is_Before_First_Decl
(N
, Plist
) then
5629 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5630 Unit_Kind
:= Nkind
(Unit_Node
);
5632 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5635 elsif Unit_Kind
= N_Subprogram_Body
5636 and then not Acts_As_Spec
(Unit_Node
)
5640 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5643 elsif Nkind
(Parent_Node
) = N_Package_Specification
5644 and then Plist
= Private_Declarations
(Parent_Node
)
5648 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5649 or else Nkind
(Parent_Node
) =
5650 N_Generic_Subprogram_Declaration
)
5651 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5655 elsif Arg_Count
> 0 then
5656 Analyze
(Get_Pragma_Arg
(Arg1
));
5658 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5660 ("name in pragma% must be enclosing unit", Arg1
);
5663 -- It is legal to have no argument in this context
5669 -- Error if not before first declaration. This is because a
5670 -- library unit pragma argument must be the name of a library
5671 -- unit (RM 10.1.5(7)), but the only names permitted in this
5672 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5673 -- generic subprogram declarations or generic instantiations.
5677 ("pragma% misplaced, must be before first declaration");
5681 end Check_Valid_Library_Unit_Pragma
;
5687 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5688 Clist
: constant Node_Id
:= Component_List
(Variant
);
5692 Comp
:= First
(Component_Items
(Clist
));
5693 while Present
(Comp
) loop
5694 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5699 ---------------------------
5700 -- Ensure_Aggregate_Form --
5701 ---------------------------
5703 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5704 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5705 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5706 Nam
: constant Name_Id
:= Chars
(Arg
);
5707 Comps
: List_Id
:= No_List
;
5708 Exprs
: List_Id
:= No_List
;
5710 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5711 -- Used to restore Comes_From_Source_Default
5714 -- The argument is already in aggregate form, but the presence of a
5715 -- name causes this to be interpreted as a named association which in
5716 -- turn must be converted into an aggregate.
5718 -- pragma Global (In_Out => (A, B, C))
5722 -- pragma Global ((In_Out => (A, B, C)))
5724 -- aggregate aggregate
5726 if Nkind
(Expr
) = N_Aggregate
then
5727 if Nam
= No_Name
then
5731 -- Do not transform a null argument into an aggregate as N_Null has
5732 -- special meaning in formal verification pragmas.
5734 elsif Nkind
(Expr
) = N_Null
then
5738 -- Everything comes from source if the original comes from source
5740 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5742 -- Positional argument is transformed into an aggregate with an
5743 -- Expressions list.
5745 if Nam
= No_Name
then
5746 Exprs
:= New_List
(Relocate_Node
(Expr
));
5748 -- An associative argument is transformed into an aggregate with
5749 -- Component_Associations.
5753 Make_Component_Association
(Loc
,
5754 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5755 Expression
=> Relocate_Node
(Expr
)));
5758 -- Remove the pragma argument name as this information has been
5759 -- captured in the aggregate.
5761 Set_Chars
(Arg
, No_Name
);
5763 Set_Expression
(Arg
,
5764 Make_Aggregate
(Loc
,
5765 Component_Associations
=> Comps
,
5766 Expressions
=> Exprs
));
5768 -- Restore Comes_From_Source default
5770 Set_Comes_From_Source_Default
(CFSD
);
5771 end Ensure_Aggregate_Form
;
5777 procedure Error_Pragma
(Msg
: String) is
5779 Error_Msg_Name_1
:= Pname
;
5780 Error_Msg_N
(Fix_Error
(Msg
), N
);
5784 ----------------------
5785 -- Error_Pragma_Arg --
5786 ----------------------
5788 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5790 Error_Msg_Name_1
:= Pname
;
5791 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5793 end Error_Pragma_Arg
;
5795 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5797 Error_Msg_Name_1
:= Pname
;
5798 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5799 Error_Pragma_Arg
(Msg2
, Arg
);
5800 end Error_Pragma_Arg
;
5802 ----------------------------
5803 -- Error_Pragma_Arg_Ident --
5804 ----------------------------
5806 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5808 Error_Msg_Name_1
:= Pname
;
5809 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5811 end Error_Pragma_Arg_Ident
;
5813 ----------------------
5814 -- Error_Pragma_Ref --
5815 ----------------------
5817 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5819 Error_Msg_Name_1
:= Pname
;
5820 Error_Msg_Sloc
:= Sloc
(Ref
);
5821 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5823 end Error_Pragma_Ref
;
5825 ------------------------
5826 -- Find_Lib_Unit_Name --
5827 ------------------------
5829 function Find_Lib_Unit_Name
return Entity_Id
is
5831 -- Return inner compilation unit entity, for case of nested
5832 -- categorization pragmas. This happens in generic unit.
5834 if Nkind
(Parent
(N
)) = N_Package_Specification
5835 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5837 return Defining_Entity
(Parent
(N
));
5839 return Current_Scope
;
5841 end Find_Lib_Unit_Name
;
5843 ----------------------------
5844 -- Find_Program_Unit_Name --
5845 ----------------------------
5847 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5848 Unit_Name
: Entity_Id
;
5849 Unit_Kind
: Node_Kind
;
5850 P
: constant Node_Id
:= Parent
(N
);
5853 if Nkind
(P
) = N_Compilation_Unit
then
5854 Unit_Kind
:= Nkind
(Unit
(P
));
5856 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5857 N_Package_Declaration
)
5858 or else Unit_Kind
in N_Generic_Declaration
5860 Unit_Name
:= Defining_Entity
(Unit
(P
));
5862 if Chars
(Id
) = Chars
(Unit_Name
) then
5863 Set_Entity
(Id
, Unit_Name
);
5864 Set_Etype
(Id
, Etype
(Unit_Name
));
5866 Set_Etype
(Id
, Any_Type
);
5868 ("cannot find program unit referenced by pragma%");
5872 Set_Etype
(Id
, Any_Type
);
5873 Error_Pragma
("pragma% inapplicable to this unit");
5879 end Find_Program_Unit_Name
;
5881 -----------------------------------------
5882 -- Find_Unique_Parameterless_Procedure --
5883 -----------------------------------------
5885 function Find_Unique_Parameterless_Procedure
5887 Arg
: Node_Id
) return Entity_Id
5889 Proc
: Entity_Id
:= Empty
;
5892 -- The body of this procedure needs some comments ???
5894 if not Is_Entity_Name
(Name
) then
5896 ("argument of pragma% must be entity name", Arg
);
5898 elsif not Is_Overloaded
(Name
) then
5899 Proc
:= Entity
(Name
);
5901 if Ekind
(Proc
) /= E_Procedure
5902 or else Present
(First_Formal
(Proc
))
5905 ("argument of pragma% must be parameterless procedure", Arg
);
5910 Found
: Boolean := False;
5912 Index
: Interp_Index
;
5915 Get_First_Interp
(Name
, Index
, It
);
5916 while Present
(It
.Nam
) loop
5919 if Ekind
(Proc
) = E_Procedure
5920 and then No
(First_Formal
(Proc
))
5924 Set_Entity
(Name
, Proc
);
5925 Set_Is_Overloaded
(Name
, False);
5928 ("ambiguous handler name for pragma% ", Arg
);
5932 Get_Next_Interp
(Index
, It
);
5937 ("argument of pragma% must be parameterless procedure",
5940 Proc
:= Entity
(Name
);
5946 end Find_Unique_Parameterless_Procedure
;
5952 function Fix_Error
(Msg
: String) return String is
5953 Res
: String (Msg
'Range) := Msg
;
5954 Res_Last
: Natural := Msg
'Last;
5958 -- If we have a rewriting of another pragma, go to that pragma
5960 if Is_Rewrite_Substitution
(N
)
5961 and then Nkind
(Original_Node
(N
)) = N_Pragma
5963 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5966 -- Case where pragma comes from an aspect specification
5968 if From_Aspect_Specification
(N
) then
5970 -- Change appearence of "pragma" in message to "aspect"
5973 while J
<= Res_Last
- 5 loop
5974 if Res
(J
.. J
+ 5) = "pragma" then
5975 Res
(J
.. J
+ 5) := "aspect";
5983 -- Change "argument of" at start of message to "entity for"
5986 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5988 Res
(Res
'First .. Res
'First + 9) := "entity for";
5989 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5990 Res
(Res
'First + 11 .. Res_Last
);
5991 Res_Last
:= Res_Last
- 1;
5994 -- Change "argument" at start of message to "entity"
5997 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5999 Res
(Res
'First .. Res
'First + 5) := "entity";
6000 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6001 Res
(Res
'First + 8 .. Res_Last
);
6002 Res_Last
:= Res_Last
- 2;
6005 -- Get name from corresponding aspect
6007 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
6010 -- Return possibly modified message
6012 return Res
(Res
'First .. Res_Last
);
6015 -------------------------
6016 -- Gather_Associations --
6017 -------------------------
6019 procedure Gather_Associations
6021 Args
: out Args_List
)
6026 -- Initialize all parameters to Empty
6028 for J
in Args
'Range loop
6032 -- That's all we have to do if there are no argument associations
6034 if No
(Pragma_Argument_Associations
(N
)) then
6038 -- Otherwise first deal with any positional parameters present
6040 Arg
:= First
(Pragma_Argument_Associations
(N
));
6041 for Index
in Args
'Range loop
6042 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6043 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6047 -- Positional parameters all processed, if any left, then we
6048 -- have too many positional parameters.
6050 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6052 ("too many positional associations for pragma%", Arg
);
6055 -- Process named parameters if any are present
6057 while Present
(Arg
) loop
6058 if Chars
(Arg
) = No_Name
then
6060 ("positional association cannot follow named association",
6064 for Index
in Names
'Range loop
6065 if Names
(Index
) = Chars
(Arg
) then
6066 if Present
(Args
(Index
)) then
6068 ("duplicate argument association for pragma%", Arg
);
6070 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6075 if Index
= Names
'Last then
6076 Error_Msg_Name_1
:= Pname
;
6077 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6079 -- Check for possible misspelling
6081 for Index1
in Names
'Range loop
6082 if Is_Bad_Spelling_Of
6083 (Chars
(Arg
), Names
(Index1
))
6085 Error_Msg_Name_1
:= Names
(Index1
);
6086 Error_Msg_N
-- CODEFIX
6087 ("\possible misspelling of%", Arg
);
6099 end Gather_Associations
;
6105 procedure GNAT_Pragma
is
6107 -- We need to check the No_Implementation_Pragmas restriction for
6108 -- the case of a pragma from source. Note that the case of aspects
6109 -- generating corresponding pragmas marks these pragmas as not being
6110 -- from source, so this test also catches that case.
6112 if Comes_From_Source
(N
) then
6113 Check_Restriction
(No_Implementation_Pragmas
, N
);
6117 --------------------------
6118 -- Is_Before_First_Decl --
6119 --------------------------
6121 function Is_Before_First_Decl
6122 (Pragma_Node
: Node_Id
;
6123 Decls
: List_Id
) return Boolean
6125 Item
: Node_Id
:= First
(Decls
);
6128 -- Only other pragmas can come before this pragma
6131 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6134 elsif Item
= Pragma_Node
then
6140 end Is_Before_First_Decl
;
6142 -----------------------------
6143 -- Is_Configuration_Pragma --
6144 -----------------------------
6146 -- A configuration pragma must appear in the context clause of a
6147 -- compilation unit, and only other pragmas may precede it. Note that
6148 -- the test below also permits use in a configuration pragma file.
6150 function Is_Configuration_Pragma
return Boolean is
6151 Lis
: constant List_Id
:= List_Containing
(N
);
6152 Par
: constant Node_Id
:= Parent
(N
);
6156 -- If no parent, then we are in the configuration pragma file,
6157 -- so the placement is definitely appropriate.
6162 -- Otherwise we must be in the context clause of a compilation unit
6163 -- and the only thing allowed before us in the context list is more
6164 -- configuration pragmas.
6166 elsif Nkind
(Par
) = N_Compilation_Unit
6167 and then Context_Items
(Par
) = Lis
6174 elsif Nkind
(Prg
) /= N_Pragma
then
6184 end Is_Configuration_Pragma
;
6186 --------------------------
6187 -- Is_In_Context_Clause --
6188 --------------------------
6190 function Is_In_Context_Clause
return Boolean is
6192 Parent_Node
: Node_Id
;
6195 if not Is_List_Member
(N
) then
6199 Plist
:= List_Containing
(N
);
6200 Parent_Node
:= Parent
(Plist
);
6202 if Parent_Node
= Empty
6203 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6204 or else Context_Items
(Parent_Node
) /= Plist
6211 end Is_In_Context_Clause
;
6213 ---------------------------------
6214 -- Is_Static_String_Expression --
6215 ---------------------------------
6217 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6218 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6219 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6222 Analyze_And_Resolve
(Argx
);
6224 -- Special case Ada 83, where the expression will never be static,
6225 -- but we will return true if we had a string literal to start with.
6227 if Ada_Version
= Ada_83
then
6230 -- Normal case, true only if we end up with a string literal that
6231 -- is marked as being the result of evaluating a static expression.
6234 return Is_OK_Static_Expression
(Argx
)
6235 and then Nkind
(Argx
) = N_String_Literal
;
6238 end Is_Static_String_Expression
;
6240 ----------------------
6241 -- Pragma_Misplaced --
6242 ----------------------
6244 procedure Pragma_Misplaced
is
6246 Error_Pragma
("incorrect placement of pragma%");
6247 end Pragma_Misplaced
;
6249 ------------------------------------
6250 -- Process_Atomic_Shared_Volatile --
6251 ------------------------------------
6253 procedure Process_Atomic_Shared_Volatile
is
6260 procedure Set_Atomic
(E
: Entity_Id
);
6261 -- Set given type as atomic, and if no explicit alignment was given,
6262 -- set alignment to unknown, since back end knows what the alignment
6263 -- requirements are for atomic arrays. Note: this step is necessary
6264 -- for derived types.
6270 procedure Set_Atomic
(E
: Entity_Id
) is
6274 if not Has_Alignment_Clause
(E
) then
6275 Set_Alignment
(E
, Uint_0
);
6279 -- Start of processing for Process_Atomic_Shared_Volatile
6282 Check_Ada_83_Warning
;
6283 Check_No_Identifiers
;
6284 Check_Arg_Count
(1);
6285 Check_Arg_Is_Local_Name
(Arg1
);
6286 E_Id
:= Get_Pragma_Arg
(Arg1
);
6288 if Etype
(E_Id
) = Any_Type
then
6293 D
:= Declaration_Node
(E
);
6296 -- Check duplicate before we chain ourselves
6298 Check_Duplicate_Pragma
(E
);
6300 -- Now check appropriateness of the entity
6303 if Rep_Item_Too_Early
(E
, N
)
6305 Rep_Item_Too_Late
(E
, N
)
6309 Check_First_Subtype
(Arg1
);
6312 if Prag_Id
/= Pragma_Volatile
then
6314 Set_Atomic
(Underlying_Type
(E
));
6315 Set_Atomic
(Base_Type
(E
));
6318 -- Attribute belongs on the base type. If the view of the type is
6319 -- currently private, it also belongs on the underlying type.
6321 Set_Is_Volatile
(Base_Type
(E
));
6322 Set_Is_Volatile
(Underlying_Type
(E
));
6324 Set_Treat_As_Volatile
(E
);
6325 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6327 elsif K
= N_Object_Declaration
6328 or else (K
= N_Component_Declaration
6329 and then Original_Record_Component
(E
) = E
)
6331 if Rep_Item_Too_Late
(E
, N
) then
6335 if Prag_Id
/= Pragma_Volatile
then
6338 -- If the object declaration has an explicit initialization, a
6339 -- temporary may have to be created to hold the expression, to
6340 -- ensure that access to the object remain atomic.
6342 if Nkind
(Parent
(E
)) = N_Object_Declaration
6343 and then Present
(Expression
(Parent
(E
)))
6345 Set_Has_Delayed_Freeze
(E
);
6348 -- An interesting improvement here. If an object of composite
6349 -- type X is declared atomic, and the type X isn't, that's a
6350 -- pity, since it may not have appropriate alignment etc. We
6351 -- can rescue this in the special case where the object and
6352 -- type are in the same unit by just setting the type as
6353 -- atomic, so that the back end will process it as atomic.
6355 -- Note: we used to do this for elementary types as well,
6356 -- but that turns out to be a bad idea and can have unwanted
6357 -- effects, most notably if the type is elementary, the object
6358 -- a simple component within a record, and both are in a spec:
6359 -- every object of this type in the entire program will be
6360 -- treated as atomic, thus incurring a potentially costly
6361 -- synchronization operation for every access.
6363 -- Of course it would be best if the back end could just adjust
6364 -- the alignment etc for the specific object, but that's not
6365 -- something we are capable of doing at this point.
6367 Utyp
:= Underlying_Type
(Etype
(E
));
6370 and then Is_Composite_Type
(Utyp
)
6371 and then Sloc
(E
) > No_Location
6372 and then Sloc
(Utyp
) > No_Location
6374 Get_Source_File_Index
(Sloc
(E
)) =
6375 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6377 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6381 Set_Is_Volatile
(E
);
6382 Set_Treat_As_Volatile
(E
);
6385 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6388 -- The following check is only relevant when SPARK_Mode is on as
6389 -- this is not a standard Ada legality rule. Pragma Volatile can
6390 -- only apply to a full type declaration or an object declaration
6391 -- (SPARK RM C.6(1)).
6394 and then Prag_Id
= Pragma_Volatile
6395 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6396 N_Object_Declaration
)
6399 ("argument of pragma % must denote a full type or object "
6400 & "declaration", Arg1
);
6402 end Process_Atomic_Shared_Volatile
;
6404 -------------------------------------------
6405 -- Process_Compile_Time_Warning_Or_Error --
6406 -------------------------------------------
6408 procedure Process_Compile_Time_Warning_Or_Error
is
6409 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6412 Check_Arg_Count
(2);
6413 Check_No_Identifiers
;
6414 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6415 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6417 if Compile_Time_Known_Value
(Arg1x
) then
6418 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6420 Str
: constant String_Id
:=
6421 Strval
(Get_Pragma_Arg
(Arg2
));
6422 Len
: constant Int
:= String_Length
(Str
);
6427 Cent
: constant Entity_Id
:=
6428 Cunit_Entity
(Current_Sem_Unit
);
6430 Force
: constant Boolean :=
6431 Prag_Id
= Pragma_Compile_Time_Warning
6433 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6434 and then (Ekind
(Cent
) /= E_Package
6435 or else not In_Private_Part
(Cent
));
6436 -- Set True if this is the warning case, and we are in the
6437 -- visible part of a package spec, or in a subprogram spec,
6438 -- in which case we want to force the client to see the
6439 -- warning, even though it is not in the main unit.
6442 -- Loop through segments of message separated by line feeds.
6443 -- We output these segments as separate messages with
6444 -- continuation marks for all but the first.
6449 Error_Msg_Strlen
:= 0;
6451 -- Loop to copy characters from argument to error message
6455 exit when Ptr
> Len
;
6456 CC
:= Get_String_Char
(Str
, Ptr
);
6459 -- Ignore wide chars ??? else store character
6461 if In_Character_Range
(CC
) then
6462 C
:= Get_Character
(CC
);
6463 exit when C
= ASCII
.LF
;
6464 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6465 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6469 -- Here with one line ready to go
6471 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6473 -- If this is a warning in a spec, then we want clients
6474 -- to see the warning, so mark the message with the
6475 -- special sequence !! to force the warning. In the case
6476 -- of a package spec, we do not force this if we are in
6477 -- the private part of the spec.
6480 if Cont
= False then
6481 Error_Msg_N
("<<~!!", Arg1
);
6484 Error_Msg_N
("\<<~!!", Arg1
);
6487 -- Error, rather than warning, or in a body, so we do not
6488 -- need to force visibility for client (error will be
6489 -- output in any case, and this is the situation in which
6490 -- we do not want a client to get a warning, since the
6491 -- warning is in the body or the spec private part).
6494 if Cont
= False then
6495 Error_Msg_N
("<<~", Arg1
);
6498 Error_Msg_N
("\<<~", Arg1
);
6502 exit when Ptr
> Len
;
6507 end Process_Compile_Time_Warning_Or_Error
;
6509 ------------------------
6510 -- Process_Convention --
6511 ------------------------
6513 procedure Process_Convention
6514 (C
: out Convention_Id
;
6515 Ent
: out Entity_Id
)
6519 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6520 -- Called if we have more than one Export/Import/Convention pragma.
6521 -- This is generally illegal, but we have a special case of allowing
6522 -- Import and Interface to coexist if they specify the convention in
6523 -- a consistent manner. We are allowed to do this, since Interface is
6524 -- an implementation defined pragma, and we choose to do it since we
6525 -- know Rational allows this combination. S is the entity id of the
6526 -- subprogram in question. This procedure also sets the special flag
6527 -- Import_Interface_Present in both pragmas in the case where we do
6528 -- have matching Import and Interface pragmas.
6530 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6531 -- Set convention in entity E, and also flag that the entity has a
6532 -- convention pragma. If entity is for a private or incomplete type,
6533 -- also set convention and flag on underlying type. This procedure
6534 -- also deals with the special case of C_Pass_By_Copy convention,
6535 -- and error checks for inappropriate convention specification.
6537 -------------------------------
6538 -- Diagnose_Multiple_Pragmas --
6539 -------------------------------
6541 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6542 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6546 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6547 -- Decl is a pragma node. This function returns True if this
6548 -- pragma has a first argument that is an identifier with a
6549 -- Chars field corresponding to the Convention_Id C.
6551 function Same_Name
(Decl
: Node_Id
) return Boolean;
6552 -- Decl is a pragma node. This function returns True if this
6553 -- pragma has a second argument that is an identifier with a
6554 -- Chars field that matches the Chars of the current subprogram.
6556 ---------------------
6557 -- Same_Convention --
6558 ---------------------
6560 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6561 Arg1
: constant Node_Id
:=
6562 First
(Pragma_Argument_Associations
(Decl
));
6565 if Present
(Arg1
) then
6567 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6569 if Nkind
(Arg
) = N_Identifier
6570 and then Is_Convention_Name
(Chars
(Arg
))
6571 and then Get_Convention_Id
(Chars
(Arg
)) = C
6579 end Same_Convention
;
6585 function Same_Name
(Decl
: Node_Id
) return Boolean is
6586 Arg1
: constant Node_Id
:=
6587 First
(Pragma_Argument_Associations
(Decl
));
6595 Arg2
:= Next
(Arg1
);
6602 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6604 if Nkind
(Arg
) = N_Identifier
6605 and then Chars
(Arg
) = Chars
(S
)
6614 -- Start of processing for Diagnose_Multiple_Pragmas
6619 -- Definitely give message if we have Convention/Export here
6621 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6624 -- If we have an Import or Export, scan back from pragma to
6625 -- find any previous pragma applying to the same procedure.
6626 -- The scan will be terminated by the start of the list, or
6627 -- hitting the subprogram declaration. This won't allow one
6628 -- pragma to appear in the public part and one in the private
6629 -- part, but that seems very unlikely in practice.
6633 while Present
(Decl
) and then Decl
/= Pdec
loop
6635 -- Look for pragma with same name as us
6637 if Nkind
(Decl
) = N_Pragma
6638 and then Same_Name
(Decl
)
6640 -- Give error if same as our pragma or Export/Convention
6642 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6648 -- Case of Import/Interface or the other way round
6650 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6653 -- Here we know that we have Import and Interface. It
6654 -- doesn't matter which way round they are. See if
6655 -- they specify the same convention. If so, all OK,
6656 -- and set special flags to stop other messages
6658 if Same_Convention
(Decl
) then
6659 Set_Import_Interface_Present
(N
);
6660 Set_Import_Interface_Present
(Decl
);
6663 -- If different conventions, special message
6666 Error_Msg_Sloc
:= Sloc
(Decl
);
6668 ("convention differs from that given#", Arg1
);
6678 -- Give message if needed if we fall through those tests
6679 -- except on Relaxed_RM_Semantics where we let go: either this
6680 -- is a case accepted/ignored by other Ada compilers (e.g.
6681 -- a mix of Convention and Import), or another error will be
6682 -- generated later (e.g. using both Import and Export).
6684 if Err
and not Relaxed_RM_Semantics
then
6686 ("at most one Convention/Export/Import pragma is allowed",
6689 end Diagnose_Multiple_Pragmas
;
6691 --------------------------------
6692 -- Set_Convention_From_Pragma --
6693 --------------------------------
6695 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6697 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6698 -- for an overridden dispatching operation. Technically this is
6699 -- an amendment and should only be done in Ada 2005 mode. However,
6700 -- this is clearly a mistake, since the problem that is addressed
6701 -- by this AI is that there is a clear gap in the RM.
6703 if Is_Dispatching_Operation
(E
)
6704 and then Present
(Overridden_Operation
(E
))
6705 and then C
/= Convention
(Overridden_Operation
(E
))
6708 ("cannot change convention for overridden dispatching "
6709 & "operation", Arg1
);
6712 -- Special checks for Convention_Stdcall
6714 if C
= Convention_Stdcall
then
6716 -- A dispatching call is not allowed. A dispatching subprogram
6717 -- cannot be used to interface to the Win32 API, so in fact
6718 -- this check does not impose any effective restriction.
6720 if Is_Dispatching_Operation
(E
) then
6721 Error_Msg_Sloc
:= Sloc
(E
);
6723 -- Note: make this unconditional so that if there is more
6724 -- than one call to which the pragma applies, we get a
6725 -- message for each call. Also don't use Error_Pragma,
6726 -- so that we get multiple messages.
6729 ("dispatching subprogram# cannot use Stdcall convention!",
6732 -- Subprograms are not allowed
6734 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6738 and then Ekind
(E
) /= E_Variable
6740 -- An access to subprogram is also allowed
6744 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6746 -- Allow internal call to set convention of subprogram type
6748 and then not (Ekind
(E
) = E_Subprogram_Type
)
6751 ("second argument of pragma% must be subprogram (type)",
6756 -- Set the convention
6758 Set_Convention
(E
, C
);
6759 Set_Has_Convention_Pragma
(E
);
6761 -- For the case of a record base type, also set the convention of
6762 -- any anonymous access types declared in the record which do not
6763 -- currently have a specified convention.
6765 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6770 Comp
:= First_Component
(E
);
6771 while Present
(Comp
) loop
6772 if Present
(Etype
(Comp
))
6773 and then Ekind_In
(Etype
(Comp
),
6774 E_Anonymous_Access_Type
,
6775 E_Anonymous_Access_Subprogram_Type
)
6776 and then not Has_Convention_Pragma
(Comp
)
6778 Set_Convention
(Comp
, C
);
6781 Next_Component
(Comp
);
6786 -- Deal with incomplete/private type case, where underlying type
6787 -- is available, so set convention of that underlying type.
6789 if Is_Incomplete_Or_Private_Type
(E
)
6790 and then Present
(Underlying_Type
(E
))
6792 Set_Convention
(Underlying_Type
(E
), C
);
6793 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6796 -- A class-wide type should inherit the convention of the specific
6797 -- root type (although this isn't specified clearly by the RM).
6799 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6800 Set_Convention
(Class_Wide_Type
(E
), C
);
6803 -- If the entity is a record type, then check for special case of
6804 -- C_Pass_By_Copy, which is treated the same as C except that the
6805 -- special record flag is set. This convention is only permitted
6806 -- on record types (see AI95-00131).
6808 if Cname
= Name_C_Pass_By_Copy
then
6809 if Is_Record_Type
(E
) then
6810 Set_C_Pass_By_Copy
(Base_Type
(E
));
6811 elsif Is_Incomplete_Or_Private_Type
(E
)
6812 and then Is_Record_Type
(Underlying_Type
(E
))
6814 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6817 ("C_Pass_By_Copy convention allowed only for record type",
6822 -- If the entity is a derived boolean type, check for the special
6823 -- case of convention C, C++, or Fortran, where we consider any
6824 -- nonzero value to represent true.
6826 if Is_Discrete_Type
(E
)
6827 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6833 C
= Convention_Fortran
)
6835 Set_Nonzero_Is_True
(Base_Type
(E
));
6837 end Set_Convention_From_Pragma
;
6841 Comp_Unit
: Unit_Number_Type
;
6846 -- Start of processing for Process_Convention
6849 Check_At_Least_N_Arguments
(2);
6850 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6851 Check_Arg_Is_Identifier
(Arg1
);
6852 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6854 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6855 -- tested again below to set the critical flag).
6857 if Cname
= Name_C_Pass_By_Copy
then
6860 -- Otherwise we must have something in the standard convention list
6862 elsif Is_Convention_Name
(Cname
) then
6863 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6865 -- Otherwise warn on unrecognized convention
6868 if Warn_On_Export_Import
then
6870 ("??unrecognized convention name, C assumed",
6871 Get_Pragma_Arg
(Arg1
));
6877 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6878 Check_Arg_Is_Local_Name
(Arg2
);
6880 Id
:= Get_Pragma_Arg
(Arg2
);
6883 if not Is_Entity_Name
(Id
) then
6884 Error_Pragma_Arg
("entity name required", Arg2
);
6889 -- Set entity to return
6893 -- Ada_Pass_By_Copy special checking
6895 if C
= Convention_Ada_Pass_By_Copy
then
6896 if not Is_First_Subtype
(E
) then
6898 ("convention `Ada_Pass_By_Copy` only allowed for types",
6902 if Is_By_Reference_Type
(E
) then
6904 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6908 -- Ada_Pass_By_Reference special checking
6910 elsif C
= Convention_Ada_Pass_By_Reference
then
6911 if not Is_First_Subtype
(E
) then
6913 ("convention `Ada_Pass_By_Reference` only allowed for types",
6917 if Is_By_Copy_Type
(E
) then
6919 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6924 -- Go to renamed subprogram if present, since convention applies to
6925 -- the actual renamed entity, not to the renaming entity. If the
6926 -- subprogram is inherited, go to parent subprogram.
6928 if Is_Subprogram
(E
)
6929 and then Present
(Alias
(E
))
6931 if Nkind
(Parent
(Declaration_Node
(E
))) =
6932 N_Subprogram_Renaming_Declaration
6934 if Scope
(E
) /= Scope
(Alias
(E
)) then
6936 ("cannot apply pragma% to non-local entity&#", E
);
6941 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6942 N_Private_Extension_Declaration
)
6943 and then Scope
(E
) = Scope
(Alias
(E
))
6947 -- Return the parent subprogram the entity was inherited from
6953 -- Check that we are not applying this to a specless body. Relax this
6954 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6956 if Is_Subprogram
(E
)
6957 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6958 and then not Relaxed_RM_Semantics
6961 ("pragma% requires separate spec and must come before body");
6964 -- Check that we are not applying this to a named constant
6966 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6967 Error_Msg_Name_1
:= Pname
;
6969 ("cannot apply pragma% to named constant!",
6970 Get_Pragma_Arg
(Arg2
));
6972 ("\supply appropriate type for&!", Arg2
);
6975 if Ekind
(E
) = E_Enumeration_Literal
then
6976 Error_Pragma
("enumeration literal not allowed for pragma%");
6979 -- Check for rep item appearing too early or too late
6981 if Etype
(E
) = Any_Type
6982 or else Rep_Item_Too_Early
(E
, N
)
6986 elsif Present
(Underlying_Type
(E
)) then
6987 E
:= Underlying_Type
(E
);
6990 if Rep_Item_Too_Late
(E
, N
) then
6994 if Has_Convention_Pragma
(E
) then
6995 Diagnose_Multiple_Pragmas
(E
);
6997 elsif Convention
(E
) = Convention_Protected
6998 or else Ekind
(Scope
(E
)) = E_Protected_Type
7001 ("a protected operation cannot be given a different convention",
7005 -- For Intrinsic, a subprogram is required
7007 if C
= Convention_Intrinsic
7008 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7011 ("second argument of pragma% must be a subprogram", Arg2
);
7014 -- Deal with non-subprogram cases
7016 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7017 Set_Convention_From_Pragma
(E
);
7020 Check_First_Subtype
(Arg2
);
7021 Set_Convention_From_Pragma
(Base_Type
(E
));
7023 -- For access subprograms, we must set the convention on the
7024 -- internally generated directly designated type as well.
7026 if Ekind
(E
) = E_Access_Subprogram_Type
then
7027 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7031 -- For the subprogram case, set proper convention for all homonyms
7032 -- in same scope and the same declarative part, i.e. the same
7033 -- compilation unit.
7036 Comp_Unit
:= Get_Source_Unit
(E
);
7037 Set_Convention_From_Pragma
(E
);
7039 -- Treat a pragma Import as an implicit body, and pragma import
7040 -- as implicit reference (for navigation in GPS).
7042 if Prag_Id
= Pragma_Import
then
7043 Generate_Reference
(E
, Id
, 'b');
7045 -- For exported entities we restrict the generation of references
7046 -- to entities exported to foreign languages since entities
7047 -- exported to Ada do not provide further information to GPS and
7048 -- add undesired references to the output of the gnatxref tool.
7050 elsif Prag_Id
= Pragma_Export
7051 and then Convention
(E
) /= Convention_Ada
7053 Generate_Reference
(E
, Id
, 'i');
7056 -- If the pragma comes from from an aspect, it only applies to the
7057 -- given entity, not its homonyms.
7059 if From_Aspect_Specification
(N
) then
7063 -- Otherwise Loop through the homonyms of the pragma argument's
7064 -- entity, an apply convention to those in the current scope.
7070 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7072 -- Ignore entry for which convention is already set
7074 if Has_Convention_Pragma
(E1
) then
7078 -- Do not set the pragma on inherited operations or on formal
7081 if Comes_From_Source
(E1
)
7082 and then Comp_Unit
= Get_Source_Unit
(E1
)
7083 and then not Is_Formal_Subprogram
(E1
)
7084 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7085 N_Full_Type_Declaration
7087 if Present
(Alias
(E1
))
7088 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7091 ("cannot apply pragma% to non-local entity& declared#",
7095 Set_Convention_From_Pragma
(E1
);
7097 if Prag_Id
= Pragma_Import
then
7098 Generate_Reference
(E1
, Id
, 'b');
7106 end Process_Convention
;
7108 ----------------------------------------
7109 -- Process_Disable_Enable_Atomic_Sync --
7110 ----------------------------------------
7112 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7114 Check_No_Identifiers
;
7115 Check_At_Most_N_Arguments
(1);
7117 -- Modeled internally as
7118 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7122 Pragma_Identifier
=>
7123 Make_Identifier
(Loc
, Nam
),
7124 Pragma_Argument_Associations
=> New_List
(
7125 Make_Pragma_Argument_Association
(Loc
,
7127 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7129 if Present
(Arg1
) then
7130 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7134 end Process_Disable_Enable_Atomic_Sync
;
7136 -------------------------------------------------
7137 -- Process_Extended_Import_Export_Internal_Arg --
7138 -------------------------------------------------
7140 procedure Process_Extended_Import_Export_Internal_Arg
7141 (Arg_Internal
: Node_Id
:= Empty
)
7144 if No
(Arg_Internal
) then
7145 Error_Pragma
("Internal parameter required for pragma%");
7148 if Nkind
(Arg_Internal
) = N_Identifier
then
7151 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7152 and then (Prag_Id
= Pragma_Import_Function
7154 Prag_Id
= Pragma_Export_Function
)
7160 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7163 Check_Arg_Is_Local_Name
(Arg_Internal
);
7164 end Process_Extended_Import_Export_Internal_Arg
;
7166 --------------------------------------------------
7167 -- Process_Extended_Import_Export_Object_Pragma --
7168 --------------------------------------------------
7170 procedure Process_Extended_Import_Export_Object_Pragma
7171 (Arg_Internal
: Node_Id
;
7172 Arg_External
: Node_Id
;
7178 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7179 Def_Id
:= Entity
(Arg_Internal
);
7181 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7183 ("pragma% must designate an object", Arg_Internal
);
7186 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7188 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7191 ("previous Common/Psect_Object applies, pragma % not permitted",
7195 if Rep_Item_Too_Late
(Def_Id
, N
) then
7199 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7201 if Present
(Arg_Size
) then
7202 Check_Arg_Is_External_Name
(Arg_Size
);
7205 -- Export_Object case
7207 if Prag_Id
= Pragma_Export_Object
then
7208 if not Is_Library_Level_Entity
(Def_Id
) then
7210 ("argument for pragma% must be library level entity",
7214 if Ekind
(Current_Scope
) = E_Generic_Package
then
7215 Error_Pragma
("pragma& cannot appear in a generic unit");
7218 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7220 ("exported object must have compile time known size",
7224 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7225 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7227 Set_Exported
(Def_Id
, Arg_Internal
);
7230 -- Import_Object case
7233 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7235 ("cannot use pragma% for task/protected object",
7239 if Ekind
(Def_Id
) = E_Constant
then
7241 ("cannot import a constant", Arg_Internal
);
7244 if Warn_On_Export_Import
7245 and then Has_Discriminants
(Etype
(Def_Id
))
7248 ("imported value must be initialized??", Arg_Internal
);
7251 if Warn_On_Export_Import
7252 and then Is_Access_Type
(Etype
(Def_Id
))
7255 ("cannot import object of an access type??", Arg_Internal
);
7258 if Warn_On_Export_Import
7259 and then Is_Imported
(Def_Id
)
7261 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7263 -- Check for explicit initialization present. Note that an
7264 -- initialization generated by the code generator, e.g. for an
7265 -- access type, does not count here.
7267 elsif Present
(Expression
(Parent
(Def_Id
)))
7270 (Original_Node
(Expression
(Parent
(Def_Id
))))
7272 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7274 ("imported entities cannot be initialized (RM B.1(24))",
7275 "\no initialization allowed for & declared#", Arg1
);
7277 Set_Imported
(Def_Id
);
7278 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7281 end Process_Extended_Import_Export_Object_Pragma
;
7283 ------------------------------------------------------
7284 -- Process_Extended_Import_Export_Subprogram_Pragma --
7285 ------------------------------------------------------
7287 procedure Process_Extended_Import_Export_Subprogram_Pragma
7288 (Arg_Internal
: Node_Id
;
7289 Arg_External
: Node_Id
;
7290 Arg_Parameter_Types
: Node_Id
;
7291 Arg_Result_Type
: Node_Id
:= Empty
;
7292 Arg_Mechanism
: Node_Id
;
7293 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7299 Ambiguous
: Boolean;
7302 function Same_Base_Type
7304 Formal
: Entity_Id
) return Boolean;
7305 -- Determines if Ptype references the type of Formal. Note that only
7306 -- the base types need to match according to the spec. Ptype here is
7307 -- the argument from the pragma, which is either a type name, or an
7308 -- access attribute.
7310 --------------------
7311 -- Same_Base_Type --
7312 --------------------
7314 function Same_Base_Type
7316 Formal
: Entity_Id
) return Boolean
7318 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7322 -- Case where pragma argument is typ'Access
7324 if Nkind
(Ptype
) = N_Attribute_Reference
7325 and then Attribute_Name
(Ptype
) = Name_Access
7327 Pref
:= Prefix
(Ptype
);
7330 if not Is_Entity_Name
(Pref
)
7331 or else Entity
(Pref
) = Any_Type
7336 -- We have a match if the corresponding argument is of an
7337 -- anonymous access type, and its designated type matches the
7338 -- type of the prefix of the access attribute
7340 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7341 and then Base_Type
(Entity
(Pref
)) =
7342 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7344 -- Case where pragma argument is a type name
7349 if not Is_Entity_Name
(Ptype
)
7350 or else Entity
(Ptype
) = Any_Type
7355 -- We have a match if the corresponding argument is of the type
7356 -- given in the pragma (comparing base types)
7358 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7362 -- Start of processing for
7363 -- Process_Extended_Import_Export_Subprogram_Pragma
7366 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7370 -- Loop through homonyms (overloadings) of the entity
7372 Hom_Id
:= Entity
(Arg_Internal
);
7373 while Present
(Hom_Id
) loop
7374 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7376 -- We need a subprogram in the current scope
7378 if not Is_Subprogram
(Def_Id
)
7379 or else Scope
(Def_Id
) /= Current_Scope
7386 -- Pragma cannot apply to subprogram body
7388 if Is_Subprogram
(Def_Id
)
7389 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7393 ("pragma% requires separate spec"
7394 & " and must come before body");
7397 -- Test result type if given, note that the result type
7398 -- parameter can only be present for the function cases.
7400 if Present
(Arg_Result_Type
)
7401 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7405 elsif Etype
(Def_Id
) /= Standard_Void_Type
7407 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7411 -- Test parameter types if given. Note that this parameter
7412 -- has not been analyzed (and must not be, since it is
7413 -- semantic nonsense), so we get it as the parser left it.
7415 elsif Present
(Arg_Parameter_Types
) then
7416 Check_Matching_Types
: declare
7421 Formal
:= First_Formal
(Def_Id
);
7423 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7424 if Present
(Formal
) then
7428 -- A list of one type, e.g. (List) is parsed as
7429 -- a parenthesized expression.
7431 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7432 and then Paren_Count
(Arg_Parameter_Types
) = 1
7435 or else Present
(Next_Formal
(Formal
))
7440 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7443 -- A list of more than one type is parsed as a aggregate
7445 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7446 and then Paren_Count
(Arg_Parameter_Types
) = 0
7448 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7449 while Present
(Ptype
) or else Present
(Formal
) loop
7452 or else not Same_Base_Type
(Ptype
, Formal
)
7457 Next_Formal
(Formal
);
7462 -- Anything else is of the wrong form
7466 ("wrong form for Parameter_Types parameter",
7467 Arg_Parameter_Types
);
7469 end Check_Matching_Types
;
7472 -- Match is now False if the entry we found did not match
7473 -- either a supplied Parameter_Types or Result_Types argument
7479 -- Ambiguous case, the flag Ambiguous shows if we already
7480 -- detected this and output the initial messages.
7483 if not Ambiguous
then
7485 Error_Msg_Name_1
:= Pname
;
7487 ("pragma% does not uniquely identify subprogram!",
7489 Error_Msg_Sloc
:= Sloc
(Ent
);
7490 Error_Msg_N
("matching subprogram #!", N
);
7494 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7495 Error_Msg_N
("matching subprogram #!", N
);
7500 Hom_Id
:= Homonym
(Hom_Id
);
7503 -- See if we found an entry
7506 if not Ambiguous
then
7507 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7509 ("pragma% cannot be given for generic subprogram");
7512 ("pragma% does not identify local subprogram");
7519 -- Import pragmas must be for imported entities
7521 if Prag_Id
= Pragma_Import_Function
7523 Prag_Id
= Pragma_Import_Procedure
7525 Prag_Id
= Pragma_Import_Valued_Procedure
7527 if not Is_Imported
(Ent
) then
7529 ("pragma Import or Interface must precede pragma%");
7532 -- Here we have the Export case which can set the entity as exported
7534 -- But does not do so if the specified external name is null, since
7535 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7536 -- compatible) to request no external name.
7538 elsif Nkind
(Arg_External
) = N_String_Literal
7539 and then String_Length
(Strval
(Arg_External
)) = 0
7543 -- In all other cases, set entity as exported
7546 Set_Exported
(Ent
, Arg_Internal
);
7549 -- Special processing for Valued_Procedure cases
7551 if Prag_Id
= Pragma_Import_Valued_Procedure
7553 Prag_Id
= Pragma_Export_Valued_Procedure
7555 Formal
:= First_Formal
(Ent
);
7558 Error_Pragma
("at least one parameter required for pragma%");
7560 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7561 Error_Pragma
("first parameter must have mode out for pragma%");
7564 Set_Is_Valued_Procedure
(Ent
);
7568 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7570 -- Process Result_Mechanism argument if present. We have already
7571 -- checked that this is only allowed for the function case.
7573 if Present
(Arg_Result_Mechanism
) then
7574 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7577 -- Process Mechanism parameter if present. Note that this parameter
7578 -- is not analyzed, and must not be analyzed since it is semantic
7579 -- nonsense, so we get it in exactly as the parser left it.
7581 if Present
(Arg_Mechanism
) then
7589 -- A single mechanism association without a formal parameter
7590 -- name is parsed as a parenthesized expression. All other
7591 -- cases are parsed as aggregates, so we rewrite the single
7592 -- parameter case as an aggregate for consistency.
7594 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7595 and then Paren_Count
(Arg_Mechanism
) = 1
7597 Rewrite
(Arg_Mechanism
,
7598 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7599 Expressions
=> New_List
(
7600 Relocate_Node
(Arg_Mechanism
))));
7603 -- Case of only mechanism name given, applies to all formals
7605 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7606 Formal
:= First_Formal
(Ent
);
7607 while Present
(Formal
) loop
7608 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7609 Next_Formal
(Formal
);
7612 -- Case of list of mechanism associations given
7615 if Null_Record_Present
(Arg_Mechanism
) then
7617 ("inappropriate form for Mechanism parameter",
7621 -- Deal with positional ones first
7623 Formal
:= First_Formal
(Ent
);
7625 if Present
(Expressions
(Arg_Mechanism
)) then
7626 Mname
:= First
(Expressions
(Arg_Mechanism
));
7627 while Present
(Mname
) loop
7630 ("too many mechanism associations", Mname
);
7633 Set_Mechanism_Value
(Formal
, Mname
);
7634 Next_Formal
(Formal
);
7639 -- Deal with named entries
7641 if Present
(Component_Associations
(Arg_Mechanism
)) then
7642 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7643 while Present
(Massoc
) loop
7644 Choice
:= First
(Choices
(Massoc
));
7646 if Nkind
(Choice
) /= N_Identifier
7647 or else Present
(Next
(Choice
))
7650 ("incorrect form for mechanism association",
7654 Formal
:= First_Formal
(Ent
);
7658 ("parameter name & not present", Choice
);
7661 if Chars
(Choice
) = Chars
(Formal
) then
7663 (Formal
, Expression
(Massoc
));
7665 -- Set entity on identifier (needed by ASIS)
7667 Set_Entity
(Choice
, Formal
);
7672 Next_Formal
(Formal
);
7681 end Process_Extended_Import_Export_Subprogram_Pragma
;
7683 --------------------------
7684 -- Process_Generic_List --
7685 --------------------------
7687 procedure Process_Generic_List
is
7692 Check_No_Identifiers
;
7693 Check_At_Least_N_Arguments
(1);
7695 -- Check all arguments are names of generic units or instances
7698 while Present
(Arg
) loop
7699 Exp
:= Get_Pragma_Arg
(Arg
);
7702 if not Is_Entity_Name
(Exp
)
7704 (not Is_Generic_Instance
(Entity
(Exp
))
7706 not Is_Generic_Unit
(Entity
(Exp
)))
7709 ("pragma% argument must be name of generic unit/instance",
7715 end Process_Generic_List
;
7717 ------------------------------------
7718 -- Process_Import_Predefined_Type --
7719 ------------------------------------
7721 procedure Process_Import_Predefined_Type
is
7722 Loc
: constant Source_Ptr
:= Sloc
(N
);
7724 Ftyp
: Node_Id
:= Empty
;
7730 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7733 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7734 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7738 Ftyp
:= Node
(Elmt
);
7740 if Present
(Ftyp
) then
7742 -- Don't build a derived type declaration, because predefined C
7743 -- types have no declaration anywhere, so cannot really be named.
7744 -- Instead build a full type declaration, starting with an
7745 -- appropriate type definition is built
7747 if Is_Floating_Point_Type
(Ftyp
) then
7748 Def
:= Make_Floating_Point_Definition
(Loc
,
7749 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7750 Make_Real_Range_Specification
(Loc
,
7751 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7752 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7754 -- Should never have a predefined type we cannot handle
7757 raise Program_Error
;
7760 -- Build and insert a Full_Type_Declaration, which will be
7761 -- analyzed as soon as this list entry has been analyzed.
7763 Decl
:= Make_Full_Type_Declaration
(Loc
,
7764 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7765 Type_Definition
=> Def
);
7767 Insert_After
(N
, Decl
);
7768 Mark_Rewrite_Insertion
(Decl
);
7771 Error_Pragma_Arg
("no matching type found for pragma%",
7774 end Process_Import_Predefined_Type
;
7776 ---------------------------------
7777 -- Process_Import_Or_Interface --
7778 ---------------------------------
7780 procedure Process_Import_Or_Interface
is
7786 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7787 -- pragma Import (Entity, "external name");
7789 if Relaxed_RM_Semantics
7790 and then Arg_Count
= 2
7791 and then Prag_Id
= Pragma_Import
7792 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7795 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7798 if not Is_Entity_Name
(Def_Id
) then
7799 Error_Pragma_Arg
("entity name required", Arg1
);
7802 Def_Id
:= Entity
(Def_Id
);
7803 Kill_Size_Check_Code
(Def_Id
);
7804 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7807 Process_Convention
(C
, Def_Id
);
7808 Kill_Size_Check_Code
(Def_Id
);
7809 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7812 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7814 -- We do not permit Import to apply to a renaming declaration
7816 if Present
(Renamed_Object
(Def_Id
)) then
7818 ("pragma% not allowed for object renaming", Arg2
);
7820 -- User initialization is not allowed for imported object, but
7821 -- the object declaration may contain a default initialization,
7822 -- that will be discarded. Note that an explicit initialization
7823 -- only counts if it comes from source, otherwise it is simply
7824 -- the code generator making an implicit initialization explicit.
7826 elsif Present
(Expression
(Parent
(Def_Id
)))
7827 and then Comes_From_Source
7828 (Original_Node
(Expression
(Parent
(Def_Id
))))
7830 -- Set imported flag to prevent cascaded errors
7832 Set_Is_Imported
(Def_Id
);
7834 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7836 ("no initialization allowed for declaration of& #",
7837 "\imported entities cannot be initialized (RM B.1(24))",
7841 -- If the pragma comes from an aspect specification the
7842 -- Is_Imported flag has already been set.
7844 if not From_Aspect_Specification
(N
) then
7845 Set_Imported
(Def_Id
);
7848 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7850 -- Note that we do not set Is_Public here. That's because we
7851 -- only want to set it if there is no address clause, and we
7852 -- don't know that yet, so we delay that processing till
7855 -- pragma Import completes deferred constants
7857 if Ekind
(Def_Id
) = E_Constant
then
7858 Set_Has_Completion
(Def_Id
);
7861 -- It is not possible to import a constant of an unconstrained
7862 -- array type (e.g. string) because there is no simple way to
7863 -- write a meaningful subtype for it.
7865 if Is_Array_Type
(Etype
(Def_Id
))
7866 and then not Is_Constrained
(Etype
(Def_Id
))
7869 ("imported constant& must have a constrained subtype",
7874 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7876 -- If the name is overloaded, pragma applies to all of the denoted
7877 -- entities in the same declarative part, unless the pragma comes
7878 -- from an aspect specification or was generated by the compiler
7879 -- (such as for pragma Provide_Shift_Operators).
7882 while Present
(Hom_Id
) loop
7884 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7886 -- Ignore inherited subprograms because the pragma will apply
7887 -- to the parent operation, which is the one called.
7889 if Is_Overloadable
(Def_Id
)
7890 and then Present
(Alias
(Def_Id
))
7894 -- If it is not a subprogram, it must be in an outer scope and
7895 -- pragma does not apply.
7897 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7900 -- The pragma does not apply to primitives of interfaces
7902 elsif Is_Dispatching_Operation
(Def_Id
)
7903 and then Present
(Find_Dispatching_Type
(Def_Id
))
7904 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7908 -- Verify that the homonym is in the same declarative part (not
7909 -- just the same scope). If the pragma comes from an aspect
7910 -- specification we know that it is part of the declaration.
7912 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7913 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7914 and then not From_Aspect_Specification
(N
)
7919 -- If the pragma comes from an aspect specification the
7920 -- Is_Imported flag has already been set.
7922 if not From_Aspect_Specification
(N
) then
7923 Set_Imported
(Def_Id
);
7926 -- Reject an Import applied to an abstract subprogram
7928 if Is_Subprogram
(Def_Id
)
7929 and then Is_Abstract_Subprogram
(Def_Id
)
7931 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7933 ("cannot import abstract subprogram& declared#",
7937 -- Special processing for Convention_Intrinsic
7939 if C
= Convention_Intrinsic
then
7941 -- Link_Name argument not allowed for intrinsic
7945 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7947 -- If no external name is present, then check that this
7948 -- is a valid intrinsic subprogram. If an external name
7949 -- is present, then this is handled by the back end.
7952 Check_Intrinsic_Subprogram
7953 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7957 -- Verify that the subprogram does not have a completion
7958 -- through a renaming declaration. For other completions the
7959 -- pragma appears as a too late representation.
7962 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7966 and then Nkind
(Decl
) = N_Subprogram_Declaration
7967 and then Present
(Corresponding_Body
(Decl
))
7968 and then Nkind
(Unit_Declaration_Node
7969 (Corresponding_Body
(Decl
))) =
7970 N_Subprogram_Renaming_Declaration
7972 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7974 ("cannot import&, renaming already provided for "
7975 & "declaration #", N
, Def_Id
);
7979 -- If the pragma comes from an aspect specification, there
7980 -- must be an Import aspect specified as well. In the rare
7981 -- case where Import is set to False, the suprogram needs to
7982 -- have a local completion.
7985 Imp_Aspect
: constant Node_Id
:=
7986 Find_Aspect
(Def_Id
, Aspect_Import
);
7990 if Present
(Imp_Aspect
)
7991 and then Present
(Expression
(Imp_Aspect
))
7993 Expr
:= Expression
(Imp_Aspect
);
7994 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7996 if Is_Entity_Name
(Expr
)
7997 and then Entity
(Expr
) = Standard_True
7999 Set_Has_Completion
(Def_Id
);
8002 -- If there is no expression, the default is True, as for
8003 -- all boolean aspects. Same for the older pragma.
8006 Set_Has_Completion
(Def_Id
);
8010 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8013 if Is_Compilation_Unit
(Hom_Id
) then
8015 -- Its possible homonyms are not affected by the pragma.
8016 -- Such homonyms might be present in the context of other
8017 -- units being compiled.
8021 elsif From_Aspect_Specification
(N
) then
8024 -- If the pragma was created by the compiler, then we don't
8025 -- want it to apply to other homonyms. This kind of case can
8026 -- occur when using pragma Provide_Shift_Operators, which
8027 -- generates implicit shift and rotate operators with Import
8028 -- pragmas that might apply to earlier explicit or implicit
8029 -- declarations marked with Import (for example, coming from
8030 -- an earlier pragma Provide_Shift_Operators for another type),
8031 -- and we don't generally want other homonyms being treated
8032 -- as imported or the pragma flagged as an illegal duplicate.
8034 elsif not Comes_From_Source
(N
) then
8038 Hom_Id
:= Homonym
(Hom_Id
);
8042 -- When the convention is Java or CIL, we also allow Import to
8043 -- be given for packages, generic packages, exceptions, record
8044 -- components, and access to subprograms.
8046 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
8048 (Is_Package_Or_Generic_Package
(Def_Id
)
8049 or else Ekind
(Def_Id
) = E_Exception
8050 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
8051 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
8053 Set_Imported
(Def_Id
);
8054 Set_Is_Public
(Def_Id
);
8055 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8057 -- Import a CPP class
8059 elsif C
= Convention_CPP
8060 and then (Is_Record_Type
(Def_Id
)
8061 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8063 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8064 if Present
(Full_View
(Def_Id
)) then
8065 Def_Id
:= Full_View
(Def_Id
);
8069 ("cannot import 'C'P'P type before full declaration seen",
8070 Get_Pragma_Arg
(Arg2
));
8072 -- Although we have reported the error we decorate it as
8073 -- CPP_Class to avoid reporting spurious errors
8075 Set_Is_CPP_Class
(Def_Id
);
8080 -- Types treated as CPP classes must be declared limited (note:
8081 -- this used to be a warning but there is no real benefit to it
8082 -- since we did effectively intend to treat the type as limited
8085 if not Is_Limited_Type
(Def_Id
) then
8087 ("imported 'C'P'P type must be limited",
8088 Get_Pragma_Arg
(Arg2
));
8091 if Etype
(Def_Id
) /= Def_Id
8092 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8094 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8097 Set_Is_CPP_Class
(Def_Id
);
8099 -- Imported CPP types must not have discriminants (because C++
8100 -- classes do not have discriminants).
8102 if Has_Discriminants
(Def_Id
) then
8104 ("imported 'C'P'P type cannot have discriminants",
8105 First
(Discriminant_Specifications
8106 (Declaration_Node
(Def_Id
))));
8109 -- Check that components of imported CPP types do not have default
8110 -- expressions. For private types this check is performed when the
8111 -- full view is analyzed (see Process_Full_View).
8113 if not Is_Private_Type
(Def_Id
) then
8114 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8117 -- Import a CPP exception
8119 elsif C
= Convention_CPP
8120 and then Ekind
(Def_Id
) = E_Exception
8124 ("'External_'Name arguments is required for 'Cpp exception",
8127 -- As only a string is allowed, Check_Arg_Is_External_Name
8130 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8133 if Present
(Arg4
) then
8135 ("Link_Name argument not allowed for imported Cpp exception",
8139 -- Do not call Set_Interface_Name as the name of the exception
8140 -- shouldn't be modified (and in particular it shouldn't be
8141 -- the External_Name). For exceptions, the External_Name is the
8142 -- name of the RTTI structure.
8144 -- ??? Emit an error if pragma Import/Export_Exception is present
8146 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8148 Check_Arg_Count
(3);
8149 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8151 Process_Import_Predefined_Type
;
8155 ("second argument of pragma% must be object, subprogram "
8156 & "or incomplete type",
8160 -- If this pragma applies to a compilation unit, then the unit, which
8161 -- is a subprogram, does not require (or allow) a body. We also do
8162 -- not need to elaborate imported procedures.
8164 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8166 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8168 Set_Body_Required
(Cunit
, False);
8171 end Process_Import_Or_Interface
;
8173 --------------------
8174 -- Process_Inline --
8175 --------------------
8177 procedure Process_Inline
(Status
: Inline_Status
) is
8184 Effective
: Boolean := False;
8185 -- Set True if inline has some effect, i.e. if there is at least one
8186 -- subprogram set as inlined as a result of the use of the pragma.
8188 procedure Make_Inline
(Subp
: Entity_Id
);
8189 -- Subp is the defining unit name of the subprogram declaration. Set
8190 -- the flag, as well as the flag in the corresponding body, if there
8193 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8194 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8195 -- Has_Pragma_Inline_Always for the Inline_Always case.
8197 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8198 -- Returns True if it can be determined at this stage that inlining
8199 -- is not possible, for example if the body is available and contains
8200 -- exception handlers, we prevent inlining, since otherwise we can
8201 -- get undefined symbols at link time. This function also emits a
8202 -- warning if front-end inlining is enabled and the pragma appears
8205 -- ??? is business with link symbols still valid, or does it relate
8206 -- to front end ZCX which is being phased out ???
8208 ---------------------------
8209 -- Inlining_Not_Possible --
8210 ---------------------------
8212 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8213 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8217 if Nkind
(Decl
) = N_Subprogram_Body
then
8218 Stats
:= Handled_Statement_Sequence
(Decl
);
8219 return Present
(Exception_Handlers
(Stats
))
8220 or else Present
(At_End_Proc
(Stats
));
8222 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8223 and then Present
(Corresponding_Body
(Decl
))
8225 if Front_End_Inlining
8226 and then Analyzed
(Corresponding_Body
(Decl
))
8228 Error_Msg_N
("pragma appears too late, ignored??", N
);
8231 -- If the subprogram is a renaming as body, the body is just a
8232 -- call to the renamed subprogram, and inlining is trivially
8236 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8237 N_Subprogram_Renaming_Declaration
8243 Handled_Statement_Sequence
8244 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8247 Present
(Exception_Handlers
(Stats
))
8248 or else Present
(At_End_Proc
(Stats
));
8252 -- If body is not available, assume the best, the check is
8253 -- performed again when compiling enclosing package bodies.
8257 end Inlining_Not_Possible
;
8263 procedure Make_Inline
(Subp
: Entity_Id
) is
8264 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8265 Inner_Subp
: Entity_Id
:= Subp
;
8268 -- Ignore if bad type, avoid cascaded error
8270 if Etype
(Subp
) = Any_Type
then
8274 -- Ignore if all inlining is suppressed
8276 elsif Suppress_All_Inlining
then
8280 -- If inlining is not possible, for now do not treat as an error
8282 elsif Status
/= Suppressed
8283 and then Inlining_Not_Possible
(Subp
)
8288 -- Here we have a candidate for inlining, but we must exclude
8289 -- derived operations. Otherwise we would end up trying to inline
8290 -- a phantom declaration, and the result would be to drag in a
8291 -- body which has no direct inlining associated with it. That
8292 -- would not only be inefficient but would also result in the
8293 -- backend doing cross-unit inlining in cases where it was
8294 -- definitely inappropriate to do so.
8296 -- However, a simple Comes_From_Source test is insufficient, since
8297 -- we do want to allow inlining of generic instances which also do
8298 -- not come from source. We also need to recognize specs generated
8299 -- by the front-end for bodies that carry the pragma. Finally,
8300 -- predefined operators do not come from source but are not
8301 -- inlineable either.
8303 elsif Is_Generic_Instance
(Subp
)
8304 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8308 elsif not Comes_From_Source
(Subp
)
8309 and then Scope
(Subp
) /= Standard_Standard
8315 -- The referenced entity must either be the enclosing entity, or
8316 -- an entity declared within the current open scope.
8318 if Present
(Scope
(Subp
))
8319 and then Scope
(Subp
) /= Current_Scope
8320 and then Subp
/= Current_Scope
8323 ("argument of% must be entity in current scope", Assoc
);
8327 -- Processing for procedure, operator or function. If subprogram
8328 -- is aliased (as for an instance) indicate that the renamed
8329 -- entity (if declared in the same unit) is inlined.
8331 if Is_Subprogram
(Subp
) then
8332 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8334 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8335 Set_Inline_Flags
(Inner_Subp
);
8337 Decl
:= Parent
(Parent
(Inner_Subp
));
8339 if Nkind
(Decl
) = N_Subprogram_Declaration
8340 and then Present
(Corresponding_Body
(Decl
))
8342 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8344 elsif Is_Generic_Instance
(Subp
) then
8346 -- Indicate that the body needs to be created for
8347 -- inlining subsequent calls. The instantiation node
8348 -- follows the declaration of the wrapper package
8351 if Scope
(Subp
) /= Standard_Standard
8353 Need_Subprogram_Instance_Body
8354 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8360 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8361 -- appear in a formal part to apply to a formal subprogram.
8362 -- Do not apply check within an instance or a formal package
8363 -- the test will have been applied to the original generic.
8365 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8366 and then List_Containing
(Decl
) = List_Containing
(N
)
8367 and then not In_Instance
8370 ("Inline cannot apply to a formal subprogram", N
);
8372 -- If Subp is a renaming, it is the renamed entity that
8373 -- will appear in any call, and be inlined. However, for
8374 -- ASIS uses it is convenient to indicate that the renaming
8375 -- itself is an inlined subprogram, so that some gnatcheck
8376 -- rules can be applied in the absence of expansion.
8378 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8379 Set_Inline_Flags
(Subp
);
8385 -- For a generic subprogram set flag as well, for use at the point
8386 -- of instantiation, to determine whether the body should be
8389 elsif Is_Generic_Subprogram
(Subp
) then
8390 Set_Inline_Flags
(Subp
);
8393 -- Literals are by definition inlined
8395 elsif Kind
= E_Enumeration_Literal
then
8398 -- Anything else is an error
8402 ("expect subprogram name for pragma%", Assoc
);
8406 ----------------------
8407 -- Set_Inline_Flags --
8408 ----------------------
8410 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8412 -- First set the Has_Pragma_XXX flags and issue the appropriate
8413 -- errors and warnings for suspicious combinations.
8415 if Prag_Id
= Pragma_No_Inline
then
8416 if Has_Pragma_Inline_Always
(Subp
) then
8418 ("Inline_Always and No_Inline are mutually exclusive", N
);
8419 elsif Has_Pragma_Inline
(Subp
) then
8421 ("Inline and No_Inline both specified for& ??",
8422 N
, Entity
(Subp_Id
));
8425 Set_Has_Pragma_No_Inline
(Subp
);
8427 if Prag_Id
= Pragma_Inline_Always
then
8428 if Has_Pragma_No_Inline
(Subp
) then
8430 ("Inline_Always and No_Inline are mutually exclusive",
8434 Set_Has_Pragma_Inline_Always
(Subp
);
8436 if Has_Pragma_No_Inline
(Subp
) then
8438 ("Inline and No_Inline both specified for& ??",
8439 N
, Entity
(Subp_Id
));
8443 if not Has_Pragma_Inline
(Subp
) then
8444 Set_Has_Pragma_Inline
(Subp
);
8449 -- Then adjust the Is_Inlined flag. It can never be set if the
8450 -- subprogram is subject to pragma No_Inline.
8454 Set_Is_Inlined
(Subp
, False);
8458 if not Has_Pragma_No_Inline
(Subp
) then
8459 Set_Is_Inlined
(Subp
, True);
8462 end Set_Inline_Flags
;
8464 -- Start of processing for Process_Inline
8467 Check_No_Identifiers
;
8468 Check_At_Least_N_Arguments
(1);
8470 if Status
= Enabled
then
8471 Inline_Processing_Required
:= True;
8475 while Present
(Assoc
) loop
8476 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8480 if Is_Entity_Name
(Subp_Id
) then
8481 Subp
:= Entity
(Subp_Id
);
8483 if Subp
= Any_Id
then
8485 -- If previous error, avoid cascaded errors
8487 Check_Error_Detected
;
8494 -- For the pragma case, climb homonym chain. This is
8495 -- what implements allowing the pragma in the renaming
8496 -- case, with the result applying to the ancestors, and
8497 -- also allows Inline to apply to all previous homonyms.
8499 if not From_Aspect_Specification
(N
) then
8500 while Present
(Homonym
(Subp
))
8501 and then Scope
(Homonym
(Subp
)) = Current_Scope
8503 Make_Inline
(Homonym
(Subp
));
8504 Subp
:= Homonym
(Subp
);
8512 ("inappropriate argument for pragma%", Assoc
);
8515 and then Warn_On_Redundant_Constructs
8516 and then not (Status
= Suppressed
or else Suppress_All_Inlining
)
8518 if Inlining_Not_Possible
(Subp
) then
8520 ("pragma Inline for& is ignored?r?",
8521 N
, Entity
(Subp_Id
));
8524 ("pragma Inline for& is redundant?r?",
8525 N
, Entity
(Subp_Id
));
8533 ----------------------------
8534 -- Process_Interface_Name --
8535 ----------------------------
8537 procedure Process_Interface_Name
8538 (Subprogram_Def
: Entity_Id
;
8544 String_Val
: String_Id
;
8546 procedure Check_Form_Of_Interface_Name
8548 Ext_Name_Case
: Boolean);
8549 -- SN is a string literal node for an interface name. This routine
8550 -- performs some minimal checks that the name is reasonable. In
8551 -- particular that no spaces or other obviously incorrect characters
8552 -- appear. This is only a warning, since any characters are allowed.
8553 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8555 ----------------------------------
8556 -- Check_Form_Of_Interface_Name --
8557 ----------------------------------
8559 procedure Check_Form_Of_Interface_Name
8561 Ext_Name_Case
: Boolean)
8563 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8564 SL
: constant Nat
:= String_Length
(S
);
8569 Error_Msg_N
("interface name cannot be null string", SN
);
8572 for J
in 1 .. SL
loop
8573 C
:= Get_String_Char
(S
, J
);
8575 -- Look for dubious character and issue unconditional warning.
8576 -- Definitely dubious if not in character range.
8578 if not In_Character_Range
(C
)
8580 -- For all cases except CLI target,
8581 -- commas, spaces and slashes are dubious (in CLI, we use
8582 -- commas and backslashes in external names to specify
8583 -- assembly version and public key, while slashes and spaces
8584 -- can be used in names to mark nested classes and
8587 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8588 and then (Get_Character
(C
) = ','
8590 Get_Character
(C
) = '\'))
8591 or else (VM_Target
/= CLI_Target
8592 and then (Get_Character
(C
) = ' '
8594 Get_Character
(C
) = '/'))
8597 ("??interface name contains illegal character",
8598 Sloc
(SN
) + Source_Ptr
(J
));
8601 end Check_Form_Of_Interface_Name
;
8603 -- Start of processing for Process_Interface_Name
8606 if No
(Link_Arg
) then
8607 if No
(Ext_Arg
) then
8608 if VM_Target
= CLI_Target
8609 and then Ekind
(Subprogram_Def
) = E_Package
8610 and then Nkind
(Parent
(Subprogram_Def
)) =
8611 N_Package_Specification
8612 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8617 (Generic_Parent
(Parent
(Subprogram_Def
))));
8622 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8624 Link_Nam
:= Expression
(Ext_Arg
);
8627 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8628 Ext_Nam
:= Expression
(Ext_Arg
);
8633 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8634 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8635 Ext_Nam
:= Expression
(Ext_Arg
);
8636 Link_Nam
:= Expression
(Link_Arg
);
8639 -- Check expressions for external name and link name are static
8641 if Present
(Ext_Nam
) then
8642 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8643 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8645 -- Verify that external name is not the name of a local entity,
8646 -- which would hide the imported one and could lead to run-time
8647 -- surprises. The problem can only arise for entities declared in
8648 -- a package body (otherwise the external name is fully qualified
8649 -- and will not conflict).
8657 if Prag_Id
= Pragma_Import
then
8658 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8660 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
8662 if Nam
/= Chars
(Subprogram_Def
)
8663 and then Present
(E
)
8664 and then not Is_Overloadable
(E
)
8665 and then Is_Immediately_Visible
(E
)
8666 and then not Is_Imported
(E
)
8667 and then Ekind
(Scope
(E
)) = E_Package
8670 while Present
(Par
) loop
8671 if Nkind
(Par
) = N_Package_Body
then
8672 Error_Msg_Sloc
:= Sloc
(E
);
8674 ("imported entity is hidden by & declared#",
8679 Par
:= Parent
(Par
);
8686 if Present
(Link_Nam
) then
8687 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8688 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8691 -- If there is no link name, just set the external name
8693 if No
(Link_Nam
) then
8694 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8696 -- For the Link_Name case, the given literal is preceded by an
8697 -- asterisk, which indicates to GCC that the given name should be
8698 -- taken literally, and in particular that no prepending of
8699 -- underlines should occur, even in systems where this is the
8705 if VM_Target
= No_VM
then
8706 Store_String_Char
(Get_Char_Code
('*'));
8709 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8710 Store_String_Chars
(String_Val
);
8712 Make_String_Literal
(Sloc
(Link_Nam
),
8713 Strval
=> End_String
);
8716 -- Set the interface name. If the entity is a generic instance, use
8717 -- its alias, which is the callable entity.
8719 if Is_Generic_Instance
(Subprogram_Def
) then
8720 Set_Encoded_Interface_Name
8721 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8723 Set_Encoded_Interface_Name
8724 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8727 -- We allow duplicated export names in CIL/Java, as they are always
8728 -- enclosed in a namespace that differentiates them, and overloaded
8729 -- entities are supported by the VM.
8731 if Convention
(Subprogram_Def
) /= Convention_CIL
8733 Convention
(Subprogram_Def
) /= Convention_Java
8735 Check_Duplicated_Export_Name
(Link_Nam
);
8737 end Process_Interface_Name
;
8739 -----------------------------------------
8740 -- Process_Interrupt_Or_Attach_Handler --
8741 -----------------------------------------
8743 procedure Process_Interrupt_Or_Attach_Handler
is
8744 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8745 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8746 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8749 Set_Is_Interrupt_Handler
(Handler_Proc
);
8751 -- If the pragma is not associated with a handler procedure within a
8752 -- protected type, then it must be for a nonprotected procedure for
8753 -- the AAMP target, in which case we don't associate a representation
8754 -- item with the procedure's scope.
8756 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8757 if Prag_Id
= Pragma_Interrupt_Handler
8759 Prag_Id
= Pragma_Attach_Handler
8761 Record_Rep_Item
(Proc_Scope
, N
);
8764 end Process_Interrupt_Or_Attach_Handler
;
8766 --------------------------------------------------
8767 -- Process_Restrictions_Or_Restriction_Warnings --
8768 --------------------------------------------------
8770 -- Note: some of the simple identifier cases were handled in par-prag,
8771 -- but it is harmless (and more straightforward) to simply handle all
8772 -- cases here, even if it means we repeat a bit of work in some cases.
8774 procedure Process_Restrictions_Or_Restriction_Warnings
8778 R_Id
: Restriction_Id
;
8784 -- Ignore all Restrictions pragmas in CodePeer mode
8786 if CodePeer_Mode
then
8790 Check_Ada_83_Warning
;
8791 Check_At_Least_N_Arguments
(1);
8792 Check_Valid_Configuration_Pragma
;
8795 while Present
(Arg
) loop
8797 Expr
:= Get_Pragma_Arg
(Arg
);
8799 -- Case of no restriction identifier present
8801 if Id
= No_Name
then
8802 if Nkind
(Expr
) /= N_Identifier
then
8804 ("invalid form for restriction", Arg
);
8809 (Process_Restriction_Synonyms
(Expr
));
8811 if R_Id
not in All_Boolean_Restrictions
then
8812 Error_Msg_Name_1
:= Pname
;
8814 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8816 -- Check for possible misspelling
8818 for J
in Restriction_Id
loop
8820 Rnm
: constant String := Restriction_Id
'Image (J
);
8823 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8824 Name_Len
:= Rnm
'Length;
8825 Set_Casing
(All_Lower_Case
);
8827 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8829 (Identifier_Casing
(Current_Source_File
));
8830 Error_Msg_String
(1 .. Rnm
'Length) :=
8831 Name_Buffer
(1 .. Name_Len
);
8832 Error_Msg_Strlen
:= Rnm
'Length;
8833 Error_Msg_N
-- CODEFIX
8834 ("\possible misspelling of ""~""",
8835 Get_Pragma_Arg
(Arg
));
8844 if Implementation_Restriction
(R_Id
) then
8845 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8848 -- Special processing for No_Elaboration_Code restriction
8850 if R_Id
= No_Elaboration_Code
then
8852 -- Restriction is only recognized within a configuration
8853 -- pragma file, or within a unit of the main extended
8854 -- program. Note: the test for Main_Unit is needed to
8855 -- properly include the case of configuration pragma files.
8857 if not (Current_Sem_Unit
= Main_Unit
8858 or else In_Extended_Main_Source_Unit
(N
))
8862 -- Don't allow in a subunit unless already specified in
8865 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8866 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8867 and then not Restriction_Active
(No_Elaboration_Code
)
8870 ("invalid specification of ""No_Elaboration_Code""",
8873 ("\restriction cannot be specified in a subunit", N
);
8875 ("\unless also specified in body or spec", N
);
8878 -- If we accept a No_Elaboration_Code restriction, then it
8879 -- needs to be added to the configuration restriction set so
8880 -- that we get proper application to other units in the main
8881 -- extended source as required.
8884 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8888 -- If this is a warning, then set the warning unless we already
8889 -- have a real restriction active (we never want a warning to
8890 -- override a real restriction).
8893 if not Restriction_Active
(R_Id
) then
8894 Set_Restriction
(R_Id
, N
);
8895 Restriction_Warnings
(R_Id
) := True;
8898 -- If real restriction case, then set it and make sure that the
8899 -- restriction warning flag is off, since a real restriction
8900 -- always overrides a warning.
8903 Set_Restriction
(R_Id
, N
);
8904 Restriction_Warnings
(R_Id
) := False;
8907 -- Check for obsolescent restrictions in Ada 2005 mode
8910 and then Ada_Version
>= Ada_2005
8911 and then (R_Id
= No_Asynchronous_Control
8913 R_Id
= No_Unchecked_Deallocation
8915 R_Id
= No_Unchecked_Conversion
)
8917 Check_Restriction
(No_Obsolescent_Features
, N
);
8920 -- A very special case that must be processed here: pragma
8921 -- Restrictions (No_Exceptions) turns off all run-time
8922 -- checking. This is a bit dubious in terms of the formal
8923 -- language definition, but it is what is intended by RM
8924 -- H.4(12). Restriction_Warnings never affects generated code
8925 -- so this is done only in the real restriction case.
8927 -- Atomic_Synchronization is not a real check, so it is not
8928 -- affected by this processing).
8930 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8931 -- run-time checks in CodePeer and GNATprove modes: we want to
8932 -- generate checks for analysis purposes, as set respectively
8933 -- by -gnatC and -gnatd.F
8936 and then not (CodePeer_Mode
or GNATprove_Mode
)
8937 and then R_Id
= No_Exceptions
8939 for J
in Scope_Suppress
.Suppress
'Range loop
8940 if J
/= Atomic_Synchronization
then
8941 Scope_Suppress
.Suppress
(J
) := True;
8946 -- Case of No_Dependence => unit-name. Note that the parser
8947 -- already made the necessary entry in the No_Dependence table.
8949 elsif Id
= Name_No_Dependence
then
8950 if not OK_No_Dependence_Unit_Name
(Expr
) then
8954 -- Case of No_Specification_Of_Aspect => Identifier.
8956 elsif Id
= Name_No_Specification_Of_Aspect
then
8961 if Nkind
(Expr
) /= N_Identifier
then
8964 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8967 if A_Id
= No_Aspect
then
8968 Error_Pragma_Arg
("invalid restriction name", Arg
);
8970 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8974 elsif Id
= Name_No_Use_Of_Attribute
then
8975 if Nkind
(Expr
) /= N_Identifier
8976 or else not Is_Attribute_Name
(Chars
(Expr
))
8978 Error_Msg_N
("unknown attribute name??", Expr
);
8981 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8984 elsif Id
= Name_No_Use_Of_Pragma
then
8985 if Nkind
(Expr
) /= N_Identifier
8986 or else not Is_Pragma_Name
(Chars
(Expr
))
8988 Error_Msg_N
("unknown pragma name??", Expr
);
8991 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8994 -- All other cases of restriction identifier present
8997 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8998 Analyze_And_Resolve
(Expr
, Any_Integer
);
9000 if R_Id
not in All_Parameter_Restrictions
then
9002 ("invalid restriction parameter identifier", Arg
);
9004 elsif not Is_OK_Static_Expression
(Expr
) then
9005 Flag_Non_Static_Expr
9006 ("value must be static expression!", Expr
);
9009 elsif not Is_Integer_Type
(Etype
(Expr
))
9010 or else Expr_Value
(Expr
) < 0
9013 ("value must be non-negative integer", Arg
);
9016 -- Restriction pragma is active
9018 Val
:= Expr_Value
(Expr
);
9020 if not UI_Is_In_Int_Range
(Val
) then
9022 ("pragma ignored, value too large??", Arg
);
9025 -- Warning case. If the real restriction is active, then we
9026 -- ignore the request, since warning never overrides a real
9027 -- restriction. Otherwise we set the proper warning. Note that
9028 -- this circuit sets the warning again if it is already set,
9029 -- which is what we want, since the constant may have changed.
9032 if not Restriction_Active
(R_Id
) then
9034 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9035 Restriction_Warnings
(R_Id
) := True;
9038 -- Real restriction case, set restriction and make sure warning
9039 -- flag is off since real restriction always overrides warning.
9042 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9043 Restriction_Warnings
(R_Id
) := False;
9049 end Process_Restrictions_Or_Restriction_Warnings
;
9051 ---------------------------------
9052 -- Process_Suppress_Unsuppress --
9053 ---------------------------------
9055 -- Note: this procedure makes entries in the check suppress data
9056 -- structures managed by Sem. See spec of package Sem for full
9057 -- details on how we handle recording of check suppression.
9059 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9064 In_Package_Spec
: constant Boolean :=
9065 Is_Package_Or_Generic_Package
(Current_Scope
)
9066 and then not In_Package_Body
(Current_Scope
);
9068 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9069 -- Used to suppress a single check on the given entity
9071 --------------------------------
9072 -- Suppress_Unsuppress_Echeck --
9073 --------------------------------
9075 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9077 -- Check for error of trying to set atomic synchronization for
9078 -- a non-atomic variable.
9080 if C
= Atomic_Synchronization
9081 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9084 ("pragma & requires atomic type or variable",
9085 Pragma_Identifier
(Original_Node
(N
)));
9088 Set_Checks_May_Be_Suppressed
(E
);
9090 if In_Package_Spec
then
9091 Push_Global_Suppress_Stack_Entry
9094 Suppress
=> Suppress_Case
);
9096 Push_Local_Suppress_Stack_Entry
9099 Suppress
=> Suppress_Case
);
9102 -- If this is a first subtype, and the base type is distinct,
9103 -- then also set the suppress flags on the base type.
9105 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9106 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9108 end Suppress_Unsuppress_Echeck
;
9110 -- Start of processing for Process_Suppress_Unsuppress
9113 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9114 -- on user code: we want to generate checks for analysis purposes, as
9115 -- set respectively by -gnatC and -gnatd.F
9117 if (CodePeer_Mode
or GNATprove_Mode
)
9118 and then Comes_From_Source
(N
)
9123 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9124 -- declarative part or a package spec (RM 11.5(5)).
9126 if not Is_Configuration_Pragma
then
9127 Check_Is_In_Decl_Part_Or_Package_Spec
;
9130 Check_At_Least_N_Arguments
(1);
9131 Check_At_Most_N_Arguments
(2);
9132 Check_No_Identifier
(Arg1
);
9133 Check_Arg_Is_Identifier
(Arg1
);
9135 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9137 if C
= No_Check_Id
then
9139 ("argument of pragma% is not valid check name", Arg1
);
9142 if Arg_Count
= 1 then
9144 -- Make an entry in the local scope suppress table. This is the
9145 -- table that directly shows the current value of the scope
9146 -- suppress check for any check id value.
9148 if C
= All_Checks
then
9150 -- For All_Checks, we set all specific predefined checks with
9151 -- the exception of Elaboration_Check, which is handled
9152 -- specially because of not wanting All_Checks to have the
9153 -- effect of deactivating static elaboration order processing.
9154 -- Atomic_Synchronization is also not affected, since this is
9155 -- not a real check.
9157 for J
in Scope_Suppress
.Suppress
'Range loop
9158 if J
/= Elaboration_Check
9160 J
/= Atomic_Synchronization
9162 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9166 -- If not All_Checks, and predefined check, then set appropriate
9167 -- scope entry. Note that we will set Elaboration_Check if this
9168 -- is explicitly specified. Atomic_Synchronization is allowed
9169 -- only if internally generated and entity is atomic.
9171 elsif C
in Predefined_Check_Id
9172 and then (not Comes_From_Source
(N
)
9173 or else C
/= Atomic_Synchronization
)
9175 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9178 -- Also make an entry in the Local_Entity_Suppress table
9180 Push_Local_Suppress_Stack_Entry
9183 Suppress
=> Suppress_Case
);
9185 -- Case of two arguments present, where the check is suppressed for
9186 -- a specified entity (given as the second argument of the pragma)
9189 -- This is obsolescent in Ada 2005 mode
9191 if Ada_Version
>= Ada_2005
then
9192 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9195 Check_Optional_Identifier
(Arg2
, Name_On
);
9196 E_Id
:= Get_Pragma_Arg
(Arg2
);
9199 if not Is_Entity_Name
(E_Id
) then
9201 ("second argument of pragma% must be entity name", Arg2
);
9210 -- Enforce RM 11.5(7) which requires that for a pragma that
9211 -- appears within a package spec, the named entity must be
9212 -- within the package spec. We allow the package name itself
9213 -- to be mentioned since that makes sense, although it is not
9214 -- strictly allowed by 11.5(7).
9217 and then E
/= Current_Scope
9218 and then Scope
(E
) /= Current_Scope
9221 ("entity in pragma% is not in package spec (RM 11.5(7))",
9225 -- Loop through homonyms. As noted below, in the case of a package
9226 -- spec, only homonyms within the package spec are considered.
9229 Suppress_Unsuppress_Echeck
(E
, C
);
9231 if Is_Generic_Instance
(E
)
9232 and then Is_Subprogram
(E
)
9233 and then Present
(Alias
(E
))
9235 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9238 -- Move to next homonym if not aspect spec case
9240 exit when From_Aspect_Specification
(N
);
9244 -- If we are within a package specification, the pragma only
9245 -- applies to homonyms in the same scope.
9247 exit when In_Package_Spec
9248 and then Scope
(E
) /= Current_Scope
;
9251 end Process_Suppress_Unsuppress
;
9257 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9259 if Is_Imported
(E
) then
9261 ("cannot export entity& that was previously imported", Arg
);
9263 elsif Present
(Address_Clause
(E
))
9264 and then not Relaxed_RM_Semantics
9267 ("cannot export entity& that has an address clause", Arg
);
9270 Set_Is_Exported
(E
);
9272 -- Generate a reference for entity explicitly, because the
9273 -- identifier may be overloaded and name resolution will not
9276 Generate_Reference
(E
, Arg
);
9278 -- Deal with exporting non-library level entity
9280 if not Is_Library_Level_Entity
(E
) then
9282 -- Not allowed at all for subprograms
9284 if Is_Subprogram
(E
) then
9285 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9287 -- Otherwise set public and statically allocated
9291 Set_Is_Statically_Allocated
(E
);
9293 -- Warn if the corresponding W flag is set
9295 if Warn_On_Export_Import
9297 -- Only do this for something that was in the source. Not
9298 -- clear if this can be False now (there used for sure to be
9299 -- cases on some systems where it was False), but anyway the
9300 -- test is harmless if not needed, so it is retained.
9302 and then Comes_From_Source
(Arg
)
9305 ("?x?& has been made static as a result of Export",
9308 ("\?x?this usage is non-standard and non-portable",
9314 if Warn_On_Export_Import
and then Is_Type
(E
) then
9315 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9318 if Warn_On_Export_Import
and Inside_A_Generic
then
9320 ("all instances of& will have the same external name?x?",
9325 ----------------------------------------------
9326 -- Set_Extended_Import_Export_External_Name --
9327 ----------------------------------------------
9329 procedure Set_Extended_Import_Export_External_Name
9330 (Internal_Ent
: Entity_Id
;
9331 Arg_External
: Node_Id
)
9333 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9337 if No
(Arg_External
) then
9341 Check_Arg_Is_External_Name
(Arg_External
);
9343 if Nkind
(Arg_External
) = N_String_Literal
then
9344 if String_Length
(Strval
(Arg_External
)) = 0 then
9347 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9350 elsif Nkind
(Arg_External
) = N_Identifier
then
9351 New_Name
:= Get_Default_External_Name
(Arg_External
);
9353 -- Check_Arg_Is_External_Name should let through only identifiers and
9354 -- string literals or static string expressions (which are folded to
9355 -- string literals).
9358 raise Program_Error
;
9361 -- If we already have an external name set (by a prior normal Import
9362 -- or Export pragma), then the external names must match
9364 if Present
(Interface_Name
(Internal_Ent
)) then
9366 -- Ignore mismatching names in CodePeer mode, to support some
9367 -- old compilers which would export the same procedure under
9368 -- different names, e.g:
9370 -- pragma Export_Procedure (P, "a");
9371 -- pragma Export_Procedure (P, "b");
9373 if CodePeer_Mode
then
9377 Check_Matching_Internal_Names
: declare
9378 S1
: constant String_Id
:= Strval
(Old_Name
);
9379 S2
: constant String_Id
:= Strval
(New_Name
);
9382 pragma No_Return
(Mismatch
);
9383 -- Called if names do not match
9389 procedure Mismatch
is
9391 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9393 ("external name does not match that given #",
9397 -- Start of processing for Check_Matching_Internal_Names
9400 if String_Length
(S1
) /= String_Length
(S2
) then
9404 for J
in 1 .. String_Length
(S1
) loop
9405 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9410 end Check_Matching_Internal_Names
;
9412 -- Otherwise set the given name
9415 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9416 Check_Duplicated_Export_Name
(New_Name
);
9418 end Set_Extended_Import_Export_External_Name
;
9424 procedure Set_Imported
(E
: Entity_Id
) is
9426 -- Error message if already imported or exported
9428 if Is_Exported
(E
) or else Is_Imported
(E
) then
9430 -- Error if being set Exported twice
9432 if Is_Exported
(E
) then
9433 Error_Msg_NE
("entity& was previously exported", N
, E
);
9435 -- Ignore error in CodePeer mode where we treat all imported
9436 -- subprograms as unknown.
9438 elsif CodePeer_Mode
then
9441 -- OK if Import/Interface case
9443 elsif Import_Interface_Present
(N
) then
9446 -- Error if being set Imported twice
9449 Error_Msg_NE
("entity& was previously imported", N
, E
);
9452 Error_Msg_Name_1
:= Pname
;
9454 ("\(pragma% applies to all previous entities)", N
);
9456 Error_Msg_Sloc
:= Sloc
(E
);
9457 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9459 -- Here if not previously imported or exported, OK to import
9462 Set_Is_Imported
(E
);
9464 -- For subprogram, set Import_Pragma field
9466 if Is_Subprogram
(E
) then
9467 Set_Import_Pragma
(E
, N
);
9470 -- If the entity is an object that is not at the library level,
9471 -- then it is statically allocated. We do not worry about objects
9472 -- with address clauses in this context since they are not really
9473 -- imported in the linker sense.
9476 and then not Is_Library_Level_Entity
(E
)
9477 and then No
(Address_Clause
(E
))
9479 Set_Is_Statically_Allocated
(E
);
9486 -------------------------
9487 -- Set_Mechanism_Value --
9488 -------------------------
9490 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9491 -- analyzed, since it is semantic nonsense), so we get it in the exact
9492 -- form created by the parser.
9494 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9495 procedure Bad_Mechanism
;
9496 pragma No_Return
(Bad_Mechanism
);
9497 -- Signal bad mechanism name
9499 -------------------------
9500 -- Bad_Mechanism_Value --
9501 -------------------------
9503 procedure Bad_Mechanism
is
9505 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9508 -- Start of processing for Set_Mechanism_Value
9511 if Mechanism
(Ent
) /= Default_Mechanism
then
9513 ("mechanism for & has already been set", Mech_Name
, Ent
);
9516 -- MECHANISM_NAME ::= value | reference
9518 if Nkind
(Mech_Name
) = N_Identifier
then
9519 if Chars
(Mech_Name
) = Name_Value
then
9520 Set_Mechanism
(Ent
, By_Copy
);
9523 elsif Chars
(Mech_Name
) = Name_Reference
then
9524 Set_Mechanism
(Ent
, By_Reference
);
9527 elsif Chars
(Mech_Name
) = Name_Copy
then
9529 ("bad mechanism name, Value assumed", Mech_Name
);
9538 end Set_Mechanism_Value
;
9540 --------------------------
9541 -- Set_Rational_Profile --
9542 --------------------------
9544 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9545 -- and extension to the semantics of renaming declarations.
9547 procedure Set_Rational_Profile
is
9549 Implicit_Packing
:= True;
9550 Overriding_Renamings
:= True;
9551 Use_VADS_Size
:= True;
9552 end Set_Rational_Profile
;
9554 ---------------------------
9555 -- Set_Ravenscar_Profile --
9556 ---------------------------
9558 -- The tasks to be done here are
9560 -- Set required policies
9562 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9563 -- pragma Locking_Policy (Ceiling_Locking)
9565 -- Set Detect_Blocking mode
9567 -- Set required restrictions (see System.Rident for detailed list)
9569 -- Set the No_Dependence rules
9570 -- No_Dependence => Ada.Asynchronous_Task_Control
9571 -- No_Dependence => Ada.Calendar
9572 -- No_Dependence => Ada.Execution_Time.Group_Budget
9573 -- No_Dependence => Ada.Execution_Time.Timers
9574 -- No_Dependence => Ada.Task_Attributes
9575 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9577 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9578 Prefix_Entity
: Entity_Id
;
9579 Selector_Entity
: Entity_Id
;
9580 Prefix_Node
: Node_Id
;
9584 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9586 if Task_Dispatching_Policy
/= ' '
9587 and then Task_Dispatching_Policy
/= 'F'
9589 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9590 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9592 -- Set the FIFO_Within_Priorities policy, but always preserve
9593 -- System_Location since we like the error message with the run time
9597 Task_Dispatching_Policy
:= 'F';
9599 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9600 Task_Dispatching_Policy_Sloc
:= Loc
;
9604 -- pragma Locking_Policy (Ceiling_Locking)
9606 if Locking_Policy
/= ' '
9607 and then Locking_Policy
/= 'C'
9609 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9610 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9612 -- Set the Ceiling_Locking policy, but preserve System_Location since
9613 -- we like the error message with the run time name.
9616 Locking_Policy
:= 'C';
9618 if Locking_Policy_Sloc
/= System_Location
then
9619 Locking_Policy_Sloc
:= Loc
;
9623 -- pragma Detect_Blocking
9625 Detect_Blocking
:= True;
9627 -- Set the corresponding restrictions
9629 Set_Profile_Restrictions
9630 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9632 -- Set the No_Dependence restrictions
9634 -- The following No_Dependence restrictions:
9635 -- No_Dependence => Ada.Asynchronous_Task_Control
9636 -- No_Dependence => Ada.Calendar
9637 -- No_Dependence => Ada.Task_Attributes
9638 -- are already set by previous call to Set_Profile_Restrictions.
9640 -- Set the following restrictions which were added to Ada 2005:
9641 -- No_Dependence => Ada.Execution_Time.Group_Budget
9642 -- No_Dependence => Ada.Execution_Time.Timers
9644 if Ada_Version
>= Ada_2005
then
9645 Name_Buffer
(1 .. 3) := "ada";
9648 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9650 Name_Buffer
(1 .. 14) := "execution_time";
9653 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9656 Make_Selected_Component
9658 Prefix
=> Prefix_Entity
,
9659 Selector_Name
=> Selector_Entity
);
9661 Name_Buffer
(1 .. 13) := "group_budgets";
9664 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9667 Make_Selected_Component
9669 Prefix
=> Prefix_Node
,
9670 Selector_Name
=> Selector_Entity
);
9672 Set_Restriction_No_Dependence
9674 Warn
=> Treat_Restrictions_As_Warnings
,
9675 Profile
=> Ravenscar
);
9677 Name_Buffer
(1 .. 6) := "timers";
9680 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9683 Make_Selected_Component
9685 Prefix
=> Prefix_Node
,
9686 Selector_Name
=> Selector_Entity
);
9688 Set_Restriction_No_Dependence
9690 Warn
=> Treat_Restrictions_As_Warnings
,
9691 Profile
=> Ravenscar
);
9694 -- Set the following restrictions which was added to Ada 2012 (see
9696 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9698 if Ada_Version
>= Ada_2012
then
9699 Name_Buffer
(1 .. 6) := "system";
9702 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9704 Name_Buffer
(1 .. 15) := "multiprocessors";
9707 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9710 Make_Selected_Component
9712 Prefix
=> Prefix_Entity
,
9713 Selector_Name
=> Selector_Entity
);
9715 Name_Buffer
(1 .. 19) := "dispatching_domains";
9718 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9721 Make_Selected_Component
9723 Prefix
=> Prefix_Node
,
9724 Selector_Name
=> Selector_Entity
);
9726 Set_Restriction_No_Dependence
9728 Warn
=> Treat_Restrictions_As_Warnings
,
9729 Profile
=> Ravenscar
);
9731 end Set_Ravenscar_Profile
;
9733 -- Start of processing for Analyze_Pragma
9736 -- The following code is a defense against recursion. Not clear that
9737 -- this can happen legitimately, but perhaps some error situations
9738 -- can cause it, and we did see this recursion during testing.
9740 if Analyzed
(N
) then
9743 Set_Analyzed
(N
, True);
9746 -- Deal with unrecognized pragma
9748 Pname
:= Pragma_Name
(N
);
9750 if not Is_Pragma_Name
(Pname
) then
9751 if Warn_On_Unrecognized_Pragma
then
9752 Error_Msg_Name_1
:= Pname
;
9753 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9755 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9756 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9757 Error_Msg_Name_1
:= PN
;
9758 Error_Msg_N
-- CODEFIX
9759 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9768 -- Here to start processing for recognized pragma
9770 Prag_Id
:= Get_Pragma_Id
(Pname
);
9771 Pname
:= Original_Aspect_Name
(N
);
9773 -- Capture setting of Opt.Uneval_Old
9775 case Opt
.Uneval_Old
is
9777 Set_Uneval_Old_Accept
(N
);
9781 Set_Uneval_Old_Warn
(N
);
9783 raise Program_Error
;
9786 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9787 -- is already set, indicating that we have already checked the policy
9788 -- at the right point. This happens for example in the case of a pragma
9789 -- that is derived from an Aspect.
9791 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9794 -- For a pragma that is a rewriting of another pragma, copy the
9795 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9797 elsif Is_Rewrite_Substitution
(N
)
9798 and then Nkind
(Original_Node
(N
)) = N_Pragma
9799 and then Original_Node
(N
) /= N
9801 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9802 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9804 -- Otherwise query the applicable policy at this point
9807 Check_Applicable_Policy
(N
);
9809 -- If pragma is disabled, rewrite as NULL and skip analysis
9811 if Is_Disabled
(N
) then
9812 Rewrite
(N
, Make_Null_Statement
(Loc
));
9826 if Present
(Pragma_Argument_Associations
(N
)) then
9827 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9828 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9830 if Present
(Arg1
) then
9831 Arg2
:= Next
(Arg1
);
9833 if Present
(Arg2
) then
9834 Arg3
:= Next
(Arg2
);
9836 if Present
(Arg3
) then
9837 Arg4
:= Next
(Arg3
);
9843 Check_Restriction_No_Use_Of_Pragma
(N
);
9845 -- An enumeration type defines the pragmas that are supported by the
9846 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9847 -- into the corresponding enumeration value for the following case.
9855 -- pragma Abort_Defer;
9857 when Pragma_Abort_Defer
=>
9859 Check_Arg_Count
(0);
9861 -- The only required semantic processing is to check the
9862 -- placement. This pragma must appear at the start of the
9863 -- statement sequence of a handled sequence of statements.
9865 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9866 or else N
/= First
(Statements
(Parent
(N
)))
9871 --------------------
9872 -- Abstract_State --
9873 --------------------
9875 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9877 -- ABSTRACT_STATE_LIST ::=
9879 -- | STATE_NAME_WITH_OPTIONS
9880 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9882 -- STATE_NAME_WITH_OPTIONS ::=
9884 -- | (STATE_NAME with OPTION_LIST)
9886 -- OPTION_LIST ::= OPTION {, OPTION}
9890 -- | NAME_VALUE_OPTION
9892 -- SIMPLE_OPTION ::= Ghost
9894 -- NAME_VALUE_OPTION ::=
9895 -- Part_Of => ABSTRACT_STATE
9896 -- | External [=> EXTERNAL_PROPERTY_LIST]
9898 -- EXTERNAL_PROPERTY_LIST ::=
9899 -- EXTERNAL_PROPERTY
9900 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9902 -- EXTERNAL_PROPERTY ::=
9903 -- Async_Readers [=> boolean_EXPRESSION]
9904 -- | Async_Writers [=> boolean_EXPRESSION]
9905 -- | Effective_Reads [=> boolean_EXPRESSION]
9906 -- | Effective_Writes [=> boolean_EXPRESSION]
9907 -- others => boolean_EXPRESSION
9909 -- STATE_NAME ::= defining_identifier
9911 -- ABSTRACT_STATE ::= name
9913 when Pragma_Abstract_State
=> Abstract_State
: declare
9914 Missing_Parentheses
: Boolean := False;
9915 -- Flag set when a state declaration with options is not properly
9918 -- Flags used to verify the consistency of states
9920 Non_Null_Seen
: Boolean := False;
9921 Null_Seen
: Boolean := False;
9923 procedure Analyze_Abstract_State
9925 Pack_Id
: Entity_Id
);
9926 -- Verify the legality of a single state declaration. Create and
9927 -- decorate a state abstraction entity and introduce it into the
9928 -- visibility chain. Pack_Id denotes the entity or the related
9929 -- package where pragma Abstract_State appears.
9931 ----------------------------
9932 -- Analyze_Abstract_State --
9933 ----------------------------
9935 procedure Analyze_Abstract_State
9937 Pack_Id
: Entity_Id
)
9939 -- Flags used to verify the consistency of options
9941 AR_Seen
: Boolean := False;
9942 AW_Seen
: Boolean := False;
9943 ER_Seen
: Boolean := False;
9944 EW_Seen
: Boolean := False;
9945 External_Seen
: Boolean := False;
9946 Others_Seen
: Boolean := False;
9947 Part_Of_Seen
: Boolean := False;
9949 -- Flags used to store the static value of all external states'
9952 AR_Val
: Boolean := False;
9953 AW_Val
: Boolean := False;
9954 ER_Val
: Boolean := False;
9955 EW_Val
: Boolean := False;
9957 State_Id
: Entity_Id
:= Empty
;
9958 -- The entity to be generated for the current state declaration
9960 procedure Analyze_External_Option
(Opt
: Node_Id
);
9961 -- Verify the legality of option External
9963 procedure Analyze_External_Property
9965 Expr
: Node_Id
:= Empty
);
9966 -- Verify the legailty of a single external property. Prop
9967 -- denotes the external property. Expr is the expression used
9968 -- to set the property.
9970 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9971 -- Verify the legality of option Part_Of
9973 procedure Check_Duplicate_Option
9975 Status
: in out Boolean);
9976 -- Flag Status denotes whether a particular option has been
9977 -- seen while processing a state. This routine verifies that
9978 -- Opt is not a duplicate option and sets the flag Status
9979 -- (SPARK RM 7.1.4(1)).
9981 procedure Check_Duplicate_Property
9983 Status
: in out Boolean);
9984 -- Flag Status denotes whether a particular property has been
9985 -- seen while processing option External. This routine verifies
9986 -- that Prop is not a duplicate property and sets flag Status.
9987 -- Opt is not a duplicate property and sets the flag Status.
9988 -- (SPARK RM 7.1.4(2))
9990 procedure Create_Abstract_State
9995 -- Generate an abstract state entity with name Nam and enter it
9996 -- into visibility. Decl is the "declaration" of the state as
9997 -- it appears in pragma Abstract_State. Loc is the location of
9998 -- the related state "declaration". Flag Is_Null should be set
9999 -- when the associated Abstract_State pragma defines a null
10002 -----------------------------
10003 -- Analyze_External_Option --
10004 -----------------------------
10006 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10007 Errors
: constant Nat
:= Serious_Errors_Detected
;
10009 Props
: Node_Id
:= Empty
;
10012 Check_Duplicate_Option
(Opt
, External_Seen
);
10014 if Nkind
(Opt
) = N_Component_Association
then
10015 Props
:= Expression
(Opt
);
10018 -- External state with properties
10020 if Present
(Props
) then
10022 -- Multiple properties appear as an aggregate
10024 if Nkind
(Props
) = N_Aggregate
then
10026 -- Simple property form
10028 Prop
:= First
(Expressions
(Props
));
10029 while Present
(Prop
) loop
10030 Analyze_External_Property
(Prop
);
10034 -- Property with expression form
10036 Prop
:= First
(Component_Associations
(Props
));
10037 while Present
(Prop
) loop
10038 Analyze_External_Property
10039 (Prop
=> First
(Choices
(Prop
)),
10040 Expr
=> Expression
(Prop
));
10048 Analyze_External_Property
(Props
);
10051 -- An external state defined without any properties defaults
10052 -- all properties to True.
10061 -- Once all external properties have been processed, verify
10062 -- their mutual interaction. Do not perform the check when
10063 -- at least one of the properties is illegal as this will
10064 -- produce a bogus error.
10066 if Errors
= Serious_Errors_Detected
then
10067 Check_External_Properties
10068 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10070 end Analyze_External_Option
;
10072 -------------------------------
10073 -- Analyze_External_Property --
10074 -------------------------------
10076 procedure Analyze_External_Property
10078 Expr
: Node_Id
:= Empty
)
10080 Expr_Val
: Boolean;
10083 -- Check the placement of "others" (if available)
10085 if Nkind
(Prop
) = N_Others_Choice
then
10086 if Others_Seen
then
10088 ("only one others choice allowed in option External",
10091 Others_Seen
:= True;
10094 elsif Others_Seen
then
10096 ("others must be the last property in option External",
10099 -- The only remaining legal options are the four predefined
10100 -- external properties.
10102 elsif Nkind
(Prop
) = N_Identifier
10103 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10104 Name_Async_Writers
,
10105 Name_Effective_Reads
,
10106 Name_Effective_Writes
)
10110 -- Otherwise the construct is not a valid property
10113 SPARK_Msg_N
("invalid external state property", Prop
);
10117 -- Ensure that the expression of the external state property
10118 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10120 if Present
(Expr
) then
10121 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10123 if Is_OK_Static_Expression
(Expr
) then
10124 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10127 ("expression of external state property must be "
10131 -- The lack of expression defaults the property to True
10137 -- Named properties
10139 if Nkind
(Prop
) = N_Identifier
then
10140 if Chars
(Prop
) = Name_Async_Readers
then
10141 Check_Duplicate_Property
(Prop
, AR_Seen
);
10142 AR_Val
:= Expr_Val
;
10144 elsif Chars
(Prop
) = Name_Async_Writers
then
10145 Check_Duplicate_Property
(Prop
, AW_Seen
);
10146 AW_Val
:= Expr_Val
;
10148 elsif Chars
(Prop
) = Name_Effective_Reads
then
10149 Check_Duplicate_Property
(Prop
, ER_Seen
);
10150 ER_Val
:= Expr_Val
;
10153 Check_Duplicate_Property
(Prop
, EW_Seen
);
10154 EW_Val
:= Expr_Val
;
10157 -- The handling of property "others" must take into account
10158 -- all other named properties that have been encountered so
10159 -- far. Only those that have not been seen are affected by
10163 if not AR_Seen
then
10164 AR_Val
:= Expr_Val
;
10167 if not AW_Seen
then
10168 AW_Val
:= Expr_Val
;
10171 if not ER_Seen
then
10172 ER_Val
:= Expr_Val
;
10175 if not EW_Seen
then
10176 EW_Val
:= Expr_Val
;
10179 end Analyze_External_Property
;
10181 ----------------------------
10182 -- Analyze_Part_Of_Option --
10183 ----------------------------
10185 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10186 Encaps
: constant Node_Id
:= Expression
(Opt
);
10187 Encaps_Id
: Entity_Id
;
10191 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10194 (Item_Id
=> State_Id
,
10196 Indic
=> First
(Choices
(Opt
)),
10199 -- The Part_Of indicator turns an abstract state into a
10200 -- constituent of the encapsulating state.
10203 Encaps_Id
:= Entity
(Encaps
);
10205 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10206 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10208 end Analyze_Part_Of_Option
;
10210 ----------------------------
10211 -- Check_Duplicate_Option --
10212 ----------------------------
10214 procedure Check_Duplicate_Option
10216 Status
: in out Boolean)
10220 SPARK_Msg_N
("duplicate state option", Opt
);
10224 end Check_Duplicate_Option
;
10226 ------------------------------
10227 -- Check_Duplicate_Property --
10228 ------------------------------
10230 procedure Check_Duplicate_Property
10232 Status
: in out Boolean)
10236 SPARK_Msg_N
("duplicate external property", Prop
);
10240 end Check_Duplicate_Property
;
10242 ---------------------------
10243 -- Create_Abstract_State --
10244 ---------------------------
10246 procedure Create_Abstract_State
10253 -- The abstract state may be semi-declared when the related
10254 -- package was withed through a limited with clause. In that
10255 -- case reuse the entity to fully declare the state.
10257 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10258 State_Id
:= Entity
(Decl
);
10260 -- Otherwise the elaboration of pragma Abstract_State
10261 -- declares the state.
10264 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10266 if Present
(Decl
) then
10267 Set_Entity
(Decl
, State_Id
);
10271 -- Null states never come from source
10273 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10274 Set_Parent
(State_Id
, State
);
10275 Set_Ekind
(State_Id
, E_Abstract_State
);
10276 Set_Etype
(State_Id
, Standard_Void_Type
);
10277 Set_Encapsulating_State
(State_Id
, Empty
);
10278 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10279 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10281 -- An abstract state declared within a Ghost scope becomes
10282 -- Ghost (SPARK RM 6.9(2)).
10284 if Within_Ghost_Scope
then
10285 Set_Is_Ghost_Entity
(State_Id
);
10288 -- Establish a link between the state declaration and the
10289 -- abstract state entity. Note that a null state remains as
10290 -- N_Null and does not carry any linkages.
10292 if not Is_Null
then
10293 if Present
(Decl
) then
10294 Set_Entity
(Decl
, State_Id
);
10295 Set_Etype
(Decl
, Standard_Void_Type
);
10298 -- Every non-null state must be defined, nameable and
10301 Push_Scope
(Pack_Id
);
10302 Generate_Definition
(State_Id
);
10303 Enter_Name
(State_Id
);
10306 end Create_Abstract_State
;
10313 -- Start of processing for Analyze_Abstract_State
10316 -- A package with a null abstract state is not allowed to
10317 -- declare additional states.
10321 ("package & has null abstract state", State
, Pack_Id
);
10323 -- Null states appear as internally generated entities
10325 elsif Nkind
(State
) = N_Null
then
10326 Create_Abstract_State
10327 (Nam
=> New_Internal_Name
('S'),
10329 Loc
=> Sloc
(State
),
10333 -- Catch a case where a null state appears in a list of
10334 -- non-null states.
10336 if Non_Null_Seen
then
10338 ("package & has non-null abstract state",
10342 -- Simple state declaration
10344 elsif Nkind
(State
) = N_Identifier
then
10345 Create_Abstract_State
10346 (Nam
=> Chars
(State
),
10348 Loc
=> Sloc
(State
),
10350 Non_Null_Seen
:= True;
10352 -- State declaration with various options. This construct
10353 -- appears as an extension aggregate in the tree.
10355 elsif Nkind
(State
) = N_Extension_Aggregate
then
10356 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10357 Create_Abstract_State
10358 (Nam
=> Chars
(Ancestor_Part
(State
)),
10359 Decl
=> Ancestor_Part
(State
),
10360 Loc
=> Sloc
(Ancestor_Part
(State
)),
10362 Non_Null_Seen
:= True;
10365 ("state name must be an identifier",
10366 Ancestor_Part
(State
));
10369 -- Options External and Ghost appear as expressions
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 elsif Chars
(Opt
) = Name_Ghost
then
10378 if Present
(State_Id
) then
10379 Set_Is_Ghost_Entity
(State_Id
);
10382 -- Option Part_Of without an encapsulating state is
10383 -- illegal. (SPARK RM 7.1.4(9)).
10385 elsif Chars
(Opt
) = Name_Part_Of
then
10387 ("indicator Part_Of must denote an abstract "
10390 -- Do not emit an error message when a previous state
10391 -- declaration with options was not parenthesized as
10392 -- the option is actually another state declaration.
10394 -- with Abstract_State
10395 -- (State_1 with ..., -- missing parentheses
10396 -- (State_2 with ...),
10397 -- State_3) -- ok state declaration
10399 elsif Missing_Parentheses
then
10402 -- Otherwise the option is not allowed. Note that it
10403 -- is not possible to distinguish between an option
10404 -- and a state declaration when a previous state with
10405 -- options not properly parentheses.
10407 -- with Abstract_State
10408 -- (State_1 with ..., -- missing parentheses
10409 -- State_2); -- could be an option
10413 ("simple option not allowed in state declaration",
10417 -- Catch a case where missing parentheses around a state
10418 -- declaration with options cause a subsequent state
10419 -- declaration with options to be treated as an option.
10421 -- with Abstract_State
10422 -- (State_1 with ..., -- missing parentheses
10423 -- (State_2 with ...))
10425 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10426 Missing_Parentheses
:= True;
10428 ("state declaration must be parenthesized",
10429 Ancestor_Part
(State
));
10431 -- Otherwise the option is malformed
10434 SPARK_Msg_N
("malformed option", Opt
);
10440 -- Options External and Part_Of appear as component
10443 Opt
:= First
(Component_Associations
(State
));
10444 while Present
(Opt
) loop
10445 Opt_Nam
:= First
(Choices
(Opt
));
10447 if Nkind
(Opt_Nam
) = N_Identifier
then
10448 if Chars
(Opt_Nam
) = Name_External
then
10449 Analyze_External_Option
(Opt
);
10451 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10452 Analyze_Part_Of_Option
(Opt
);
10455 SPARK_Msg_N
("invalid state option", Opt
);
10458 SPARK_Msg_N
("invalid state option", Opt
);
10464 -- Any other attempt to declare a state is illegal. This is a
10465 -- syntax error, always report.
10468 Error_Msg_N
("malformed abstract state declaration", State
);
10472 -- Guard against a junk state. In such cases no entity is
10473 -- generated and the subsequent checks cannot be applied.
10475 if Present
(State_Id
) then
10477 -- Verify whether the state does not introduce an illegal
10478 -- hidden state within a package subject to a null abstract
10481 Check_No_Hidden_State
(State_Id
);
10483 -- Check whether the lack of option Part_Of agrees with the
10484 -- placement of the abstract state with respect to the state
10487 if not Part_Of_Seen
then
10488 Check_Missing_Part_Of
(State_Id
);
10491 -- Associate the state with its related package
10493 if No
(Abstract_States
(Pack_Id
)) then
10494 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10497 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10499 end Analyze_Abstract_State
;
10503 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10504 Pack_Id
: Entity_Id
;
10507 -- Start of processing for Abstract_State
10511 Check_No_Identifiers
;
10512 Check_Arg_Count
(1);
10513 Ensure_Aggregate_Form
(Arg1
);
10515 -- Ensure the proper placement of the pragma. Abstract states must
10516 -- be associated with a package declaration.
10518 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10519 N_Package_Declaration
)
10525 State
:= Expression
(Arg1
);
10526 Pack_Id
:= Defining_Entity
(Context
);
10528 -- Mark the associated package as Ghost if it is subject to aspect
10529 -- or pragma Ghost as this affects the declaration of an abstract
10532 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10533 Set_Is_Ghost_Entity
(Pack_Id
);
10536 -- Multiple non-null abstract states appear as an aggregate
10538 if Nkind
(State
) = N_Aggregate
then
10539 State
:= First
(Expressions
(State
));
10540 while Present
(State
) loop
10541 Analyze_Abstract_State
(State
, Pack_Id
);
10545 -- Various forms of a single abstract state. Note that these may
10546 -- include malformed state declarations.
10549 Analyze_Abstract_State
(State
, Pack_Id
);
10552 -- Save the pragma for retrieval by other tools
10554 Add_Contract_Item
(N
, Pack_Id
);
10556 -- Verify the declaration order of pragmas Abstract_State and
10559 Check_Declaration_Order
10561 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10562 end Abstract_State
;
10570 -- Note: this pragma also has some specific processing in Par.Prag
10571 -- because we want to set the Ada version mode during parsing.
10573 when Pragma_Ada_83
=>
10575 Check_Arg_Count
(0);
10577 -- We really should check unconditionally for proper configuration
10578 -- pragma placement, since we really don't want mixed Ada modes
10579 -- within a single unit, and the GNAT reference manual has always
10580 -- said this was a configuration pragma, but we did not check and
10581 -- are hesitant to add the check now.
10583 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10584 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10585 -- or Ada 2012 mode.
10587 if Ada_Version
>= Ada_2005
then
10588 Check_Valid_Configuration_Pragma
;
10591 -- Now set Ada 83 mode
10593 Ada_Version
:= Ada_83
;
10594 Ada_Version_Explicit
:= Ada_83
;
10595 Ada_Version_Pragma
:= N
;
10603 -- Note: this pragma also has some specific processing in Par.Prag
10604 -- because we want to set the Ada 83 version mode during parsing.
10606 when Pragma_Ada_95
=>
10608 Check_Arg_Count
(0);
10610 -- We really should check unconditionally for proper configuration
10611 -- pragma placement, since we really don't want mixed Ada modes
10612 -- within a single unit, and the GNAT reference manual has always
10613 -- said this was a configuration pragma, but we did not check and
10614 -- are hesitant to add the check now.
10616 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10617 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10619 if Ada_Version
>= Ada_2005
then
10620 Check_Valid_Configuration_Pragma
;
10623 -- Now set Ada 95 mode
10625 Ada_Version
:= Ada_95
;
10626 Ada_Version_Explicit
:= Ada_95
;
10627 Ada_Version_Pragma
:= N
;
10629 ---------------------
10630 -- Ada_05/Ada_2005 --
10631 ---------------------
10634 -- pragma Ada_05 (LOCAL_NAME);
10636 -- pragma Ada_2005;
10637 -- pragma Ada_2005 (LOCAL_NAME):
10639 -- Note: these pragmas also have some specific processing in Par.Prag
10640 -- because we want to set the Ada 2005 version mode during parsing.
10642 -- The one argument form is used for managing the transition from
10643 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10644 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10645 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10646 -- mode, a preference rule is established which does not choose
10647 -- such an entity unless it is unambiguously specified. This avoids
10648 -- extra subprograms marked this way from generating ambiguities in
10649 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10650 -- intended for exclusive use in the GNAT run-time library.
10652 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10658 if Arg_Count
= 1 then
10659 Check_Arg_Is_Local_Name
(Arg1
);
10660 E_Id
:= Get_Pragma_Arg
(Arg1
);
10662 if Etype
(E_Id
) = Any_Type
then
10666 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10667 Record_Rep_Item
(Entity
(E_Id
), N
);
10670 Check_Arg_Count
(0);
10672 -- For Ada_2005 we unconditionally enforce the documented
10673 -- configuration pragma placement, since we do not want to
10674 -- tolerate mixed modes in a unit involving Ada 2005. That
10675 -- would cause real difficulties for those cases where there
10676 -- are incompatibilities between Ada 95 and Ada 2005.
10678 Check_Valid_Configuration_Pragma
;
10680 -- Now set appropriate Ada mode
10682 Ada_Version
:= Ada_2005
;
10683 Ada_Version_Explicit
:= Ada_2005
;
10684 Ada_Version_Pragma
:= N
;
10688 ---------------------
10689 -- Ada_12/Ada_2012 --
10690 ---------------------
10693 -- pragma Ada_12 (LOCAL_NAME);
10695 -- pragma Ada_2012;
10696 -- pragma Ada_2012 (LOCAL_NAME):
10698 -- Note: these pragmas also have some specific processing in Par.Prag
10699 -- because we want to set the Ada 2012 version mode during parsing.
10701 -- The one argument form is used for managing the transition from Ada
10702 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10703 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10704 -- mode will generate a warning. In addition, in any pre-Ada_2012
10705 -- mode, a preference rule is established which does not choose
10706 -- such an entity unless it is unambiguously specified. This avoids
10707 -- extra subprograms marked this way from generating ambiguities in
10708 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10709 -- intended for exclusive use in the GNAT run-time library.
10711 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10717 if Arg_Count
= 1 then
10718 Check_Arg_Is_Local_Name
(Arg1
);
10719 E_Id
:= Get_Pragma_Arg
(Arg1
);
10721 if Etype
(E_Id
) = Any_Type
then
10725 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10726 Record_Rep_Item
(Entity
(E_Id
), N
);
10729 Check_Arg_Count
(0);
10731 -- For Ada_2012 we unconditionally enforce the documented
10732 -- configuration pragma placement, since we do not want to
10733 -- tolerate mixed modes in a unit involving Ada 2012. That
10734 -- would cause real difficulties for those cases where there
10735 -- are incompatibilities between Ada 95 and Ada 2012. We could
10736 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10738 Check_Valid_Configuration_Pragma
;
10740 -- Now set appropriate Ada mode
10742 Ada_Version
:= Ada_2012
;
10743 Ada_Version_Explicit
:= Ada_2012
;
10744 Ada_Version_Pragma
:= N
;
10748 ----------------------
10749 -- All_Calls_Remote --
10750 ----------------------
10752 -- pragma All_Calls_Remote [(library_package_NAME)];
10754 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10755 Lib_Entity
: Entity_Id
;
10758 Check_Ada_83_Warning
;
10759 Check_Valid_Library_Unit_Pragma
;
10761 if Nkind
(N
) = N_Null_Statement
then
10765 Lib_Entity
:= Find_Lib_Unit_Name
;
10767 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10769 if Present
(Lib_Entity
)
10770 and then not Debug_Flag_U
10772 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10773 Error_Pragma
("pragma% only apply to rci unit");
10775 -- Set flag for entity of the library unit
10778 Set_Has_All_Calls_Remote
(Lib_Entity
);
10782 end All_Calls_Remote
;
10784 ---------------------------
10785 -- Allow_Integer_Address --
10786 ---------------------------
10788 -- pragma Allow_Integer_Address;
10790 when Pragma_Allow_Integer_Address
=>
10792 Check_Valid_Configuration_Pragma
;
10793 Check_Arg_Count
(0);
10795 -- If Address is a private type, then set the flag to allow
10796 -- integer address values. If Address is not private, then this
10797 -- pragma has no purpose, so it is simply ignored. Not clear if
10798 -- there are any such targets now.
10800 if Opt
.Address_Is_Private
then
10801 Opt
.Allow_Integer_Address
:= True;
10809 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10810 -- ARG ::= NAME | EXPRESSION
10812 -- The first two arguments are by convention intended to refer to an
10813 -- external tool and a tool-specific function. These arguments are
10816 when Pragma_Annotate
=> Annotate
: declare
10822 Check_At_Least_N_Arguments
(1);
10824 -- See if last argument is Entity => local_Name, and if so process
10825 -- and then remove it for remaining processing.
10828 Last_Arg
: constant Node_Id
:=
10829 Last
(Pragma_Argument_Associations
(N
));
10832 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10833 and then Chars
(Last_Arg
) = Name_Entity
10835 Check_Arg_Is_Local_Name
(Last_Arg
);
10836 Arg_Count
:= Arg_Count
- 1;
10838 -- Not allowed in compiler units (bootstrap issues)
10840 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10844 -- Continue processing with last argument removed for now
10846 Check_Arg_Is_Identifier
(Arg1
);
10847 Check_No_Identifiers
;
10850 -- Second parameter is optional, it is never analyzed
10855 -- Here if we have a second parameter
10858 -- Second parameter must be identifier
10860 Check_Arg_Is_Identifier
(Arg2
);
10862 -- Process remaining parameters if any
10864 Arg
:= Next
(Arg2
);
10865 while Present
(Arg
) loop
10866 Exp
:= Get_Pragma_Arg
(Arg
);
10869 if Is_Entity_Name
(Exp
) then
10872 -- For string literals, we assume Standard_String as the
10873 -- type, unless the string contains wide or wide_wide
10876 elsif Nkind
(Exp
) = N_String_Literal
then
10877 if Has_Wide_Wide_Character
(Exp
) then
10878 Resolve
(Exp
, Standard_Wide_Wide_String
);
10879 elsif Has_Wide_Character
(Exp
) then
10880 Resolve
(Exp
, Standard_Wide_String
);
10882 Resolve
(Exp
, Standard_String
);
10885 elsif Is_Overloaded
(Exp
) then
10887 ("ambiguous argument for pragma%", Exp
);
10898 -------------------------------------------------
10899 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10900 -------------------------------------------------
10903 -- ( [Check => ] Boolean_EXPRESSION
10904 -- [, [Message =>] Static_String_EXPRESSION]);
10906 -- pragma Assert_And_Cut
10907 -- ( [Check => ] Boolean_EXPRESSION
10908 -- [, [Message =>] Static_String_EXPRESSION]);
10911 -- ( [Check => ] Boolean_EXPRESSION
10912 -- [, [Message =>] Static_String_EXPRESSION]);
10914 -- pragma Loop_Invariant
10915 -- ( [Check => ] Boolean_EXPRESSION
10916 -- [, [Message =>] Static_String_EXPRESSION]);
10918 when Pragma_Assert |
10919 Pragma_Assert_And_Cut |
10921 Pragma_Loop_Invariant
=>
10923 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10924 -- Determine whether expression Expr contains a Loop_Entry
10925 -- attribute reference.
10927 -------------------------
10928 -- Contains_Loop_Entry --
10929 -------------------------
10931 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10932 Has_Loop_Entry
: Boolean := False;
10934 function Process
(N
: Node_Id
) return Traverse_Result
;
10935 -- Process function for traversal to look for Loop_Entry
10941 function Process
(N
: Node_Id
) return Traverse_Result
is
10943 if Nkind
(N
) = N_Attribute_Reference
10944 and then Attribute_Name
(N
) = Name_Loop_Entry
10946 Has_Loop_Entry
:= True;
10953 procedure Traverse
is new Traverse_Proc
(Process
);
10955 -- Start of processing for Contains_Loop_Entry
10959 return Has_Loop_Entry
;
10960 end Contains_Loop_Entry
;
10967 -- Start of processing for Assert
10970 -- Assert is an Ada 2005 RM-defined pragma
10972 if Prag_Id
= Pragma_Assert
then
10975 -- The remaining ones are GNAT pragmas
10981 Check_At_Least_N_Arguments
(1);
10982 Check_At_Most_N_Arguments
(2);
10983 Check_Arg_Order
((Name_Check
, Name_Message
));
10984 Check_Optional_Identifier
(Arg1
, Name_Check
);
10985 Expr
:= Get_Pragma_Arg
(Arg1
);
10987 -- Special processing for Loop_Invariant, Loop_Variant or for
10988 -- other cases where a Loop_Entry attribute is present. If the
10989 -- assertion pragma contains attribute Loop_Entry, ensure that
10990 -- the related pragma is within a loop.
10992 if Prag_Id
= Pragma_Loop_Invariant
10993 or else Prag_Id
= Pragma_Loop_Variant
10994 or else Contains_Loop_Entry
(Expr
)
10996 Check_Loop_Pragma_Placement
;
10998 -- Perform preanalysis to deal with embedded Loop_Entry
11001 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
11004 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11005 -- a corresponding Check pragma:
11007 -- pragma Check (name, condition [, msg]);
11009 -- Where name is the identifier matching the pragma name. So
11010 -- rewrite pragma in this manner, transfer the message argument
11011 -- if present, and analyze the result
11013 -- Note: When dealing with a semantically analyzed tree, the
11014 -- information that a Check node N corresponds to a source Assert,
11015 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11016 -- pragma kind of Original_Node(N).
11019 Make_Pragma_Argument_Association
(Loc
,
11020 Expression
=> Make_Identifier
(Loc
, Pname
)),
11021 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11022 Expression
=> Expr
));
11024 if Arg_Count
> 1 then
11025 Check_Optional_Identifier
(Arg2
, Name_Message
);
11027 -- Provide semantic annnotations for optional argument, for
11028 -- ASIS use, before rewriting.
11030 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11031 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
11034 -- Rewrite as Check pragma
11038 Chars
=> Name_Check
,
11039 Pragma_Argument_Associations
=> Newa
));
11043 ----------------------
11044 -- Assertion_Policy --
11045 ----------------------
11047 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11049 -- The following form is Ada 2012 only, but we allow it in all modes
11051 -- Pragma Assertion_Policy (
11052 -- ASSERTION_KIND => POLICY_IDENTIFIER
11053 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11055 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11057 -- RM_ASSERTION_KIND ::= Assert |
11058 -- Static_Predicate |
11059 -- Dynamic_Predicate |
11064 -- Type_Invariant |
11065 -- Type_Invariant'Class
11067 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11069 -- Contract_Cases |
11071 -- Default_Initial_Condition |
11073 -- Initial_Condition |
11074 -- Loop_Invariant |
11080 -- Statement_Assertions
11082 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11083 -- ID_ASSERTION_KIND list contains implementation-defined additions
11084 -- recognized by GNAT. The effect is to control the behavior of
11085 -- identically named aspects and pragmas, depending on the specified
11086 -- policy identifier:
11088 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11090 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11091 -- implementation defined addition that results in totally ignoring
11092 -- the corresponding assertion. If Disable is specified, then the
11093 -- argument of the assertion is not even analyzed. This is useful
11094 -- when the aspect/pragma argument references entities in a with'ed
11095 -- package that is replaced by a dummy package in the final build.
11097 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11098 -- and Type_Invariant'Class were recognized by the parser and
11099 -- transformed into references to the special internal identifiers
11100 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11101 -- processing is required here.
11103 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11112 -- This can always appear as a configuration pragma
11114 if Is_Configuration_Pragma
then
11117 -- It can also appear in a declarative part or package spec in Ada
11118 -- 2012 mode. We allow this in other modes, but in that case we
11119 -- consider that we have an Ada 2012 pragma on our hands.
11122 Check_Is_In_Decl_Part_Or_Package_Spec
;
11126 -- One argument case with no identifier (first form above)
11129 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11130 or else Chars
(Arg1
) = No_Name
)
11132 Check_Arg_Is_One_Of
11133 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11135 -- Treat one argument Assertion_Policy as equivalent to:
11137 -- pragma Check_Policy (Assertion, policy)
11139 -- So rewrite pragma in that manner and link on to the chain
11140 -- of Check_Policy pragmas, marking the pragma as analyzed.
11142 Policy
:= Get_Pragma_Arg
(Arg1
);
11146 Chars
=> Name_Check_Policy
,
11147 Pragma_Argument_Associations
=> New_List
(
11148 Make_Pragma_Argument_Association
(Loc
,
11149 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11151 Make_Pragma_Argument_Association
(Loc
,
11153 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11156 -- Here if we have two or more arguments
11159 Check_At_Least_N_Arguments
(1);
11162 -- Loop through arguments
11165 while Present
(Arg
) loop
11166 LocP
:= Sloc
(Arg
);
11168 -- Kind must be specified
11170 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11171 or else Chars
(Arg
) = No_Name
11174 ("missing assertion kind for pragma%", Arg
);
11177 -- Check Kind and Policy have allowed forms
11179 Kind
:= Chars
(Arg
);
11181 if not Is_Valid_Assertion_Kind
(Kind
) then
11183 ("invalid assertion kind for pragma%", Arg
);
11186 Check_Arg_Is_One_Of
11187 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11189 -- We rewrite the Assertion_Policy pragma as a series of
11190 -- Check_Policy pragmas:
11192 -- Check_Policy (Kind, Policy);
11196 Chars
=> Name_Check_Policy
,
11197 Pragma_Argument_Associations
=> New_List
(
11198 Make_Pragma_Argument_Association
(LocP
,
11199 Expression
=> Make_Identifier
(LocP
, Kind
)),
11200 Make_Pragma_Argument_Association
(LocP
,
11201 Expression
=> Get_Pragma_Arg
(Arg
)))));
11206 -- Rewrite the Assertion_Policy pragma as null since we have
11207 -- now inserted all the equivalent Check pragmas.
11209 Rewrite
(N
, Make_Null_Statement
(Loc
));
11212 end Assertion_Policy
;
11214 ------------------------------
11215 -- Assume_No_Invalid_Values --
11216 ------------------------------
11218 -- pragma Assume_No_Invalid_Values (On | Off);
11220 when Pragma_Assume_No_Invalid_Values
=>
11222 Check_Valid_Configuration_Pragma
;
11223 Check_Arg_Count
(1);
11224 Check_No_Identifiers
;
11225 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11227 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11228 Assume_No_Invalid_Values
:= True;
11230 Assume_No_Invalid_Values
:= False;
11233 --------------------------
11234 -- Attribute_Definition --
11235 --------------------------
11237 -- pragma Attribute_Definition
11238 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11239 -- [Entity =>] LOCAL_NAME,
11240 -- [Expression =>] EXPRESSION | NAME);
11242 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11243 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11248 Check_Arg_Count
(3);
11249 Check_Optional_Identifier
(Arg1
, "attribute");
11250 Check_Optional_Identifier
(Arg2
, "entity");
11251 Check_Optional_Identifier
(Arg3
, "expression");
11253 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11254 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11258 Check_Arg_Is_Local_Name
(Arg2
);
11260 -- If the attribute is not recognized, then issue a warning (not
11261 -- an error), and ignore the pragma.
11263 Aname
:= Chars
(Attribute_Designator
);
11265 if not Is_Attribute_Name
(Aname
) then
11266 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11270 -- Otherwise, rewrite the pragma as an attribute definition clause
11273 Make_Attribute_Definition_Clause
(Loc
,
11274 Name
=> Get_Pragma_Arg
(Arg2
),
11276 Expression
=> Get_Pragma_Arg
(Arg3
)));
11278 end Attribute_Definition
;
11280 ------------------------------------------------------------------
11281 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11282 ------------------------------------------------------------------
11284 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11285 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11286 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11287 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11289 -- FLAG ::= boolean_EXPRESSION
11291 when Pragma_Async_Readers |
11292 Pragma_Async_Writers |
11293 Pragma_Effective_Reads |
11294 Pragma_Effective_Writes
=>
11295 Async_Effective
: declare
11299 Obj_Id
: Entity_Id
;
11303 Check_No_Identifiers
;
11304 Check_At_Least_N_Arguments
(1);
11305 Check_At_Most_N_Arguments
(2);
11306 Check_Arg_Is_Local_Name
(Arg1
);
11307 Error_Msg_Name_1
:= Pname
;
11309 Obj
:= Get_Pragma_Arg
(Arg1
);
11310 Expr
:= Get_Pragma_Arg
(Arg2
);
11312 -- Perform minimal verification to ensure that the argument is at
11313 -- least a variable. Subsequent finer grained checks will be done
11314 -- at the end of the declarative region the contains the pragma.
11316 if Is_Entity_Name
(Obj
)
11317 and then Present
(Entity
(Obj
))
11318 and then Ekind
(Entity
(Obj
)) = E_Variable
11320 Obj_Id
:= Entity
(Obj
);
11322 -- Detect a duplicate pragma. Note that it is not efficient to
11323 -- examine preceding statements as Boolean aspects may appear
11324 -- anywhere between the related object declaration and its
11325 -- freeze point. As an alternative, inspect the contents of the
11326 -- variable contract.
11328 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11330 if Present
(Duplic
) then
11331 Error_Msg_Sloc
:= Sloc
(Duplic
);
11332 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11334 -- No duplicate detected
11337 if Present
(Expr
) then
11338 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11341 -- Chain the pragma on the contract for further processing
11343 Add_Contract_Item
(N
, Obj_Id
);
11346 Error_Pragma
("pragma % must apply to a volatile object");
11348 end Async_Effective
;
11354 -- pragma Asynchronous (LOCAL_NAME);
11356 when Pragma_Asynchronous
=> Asynchronous
: declare
11362 Formal
: Entity_Id
;
11364 procedure Process_Async_Pragma
;
11365 -- Common processing for procedure and access-to-procedure case
11367 --------------------------
11368 -- Process_Async_Pragma --
11369 --------------------------
11371 procedure Process_Async_Pragma
is
11374 Set_Is_Asynchronous
(Nm
);
11378 -- The formals should be of mode IN (RM E.4.1(6))
11381 while Present
(S
) loop
11382 Formal
:= Defining_Identifier
(S
);
11384 if Nkind
(Formal
) = N_Defining_Identifier
11385 and then Ekind
(Formal
) /= E_In_Parameter
11388 ("pragma% procedure can only have IN parameter",
11395 Set_Is_Asynchronous
(Nm
);
11396 end Process_Async_Pragma
;
11398 -- Start of processing for pragma Asynchronous
11401 Check_Ada_83_Warning
;
11402 Check_No_Identifiers
;
11403 Check_Arg_Count
(1);
11404 Check_Arg_Is_Local_Name
(Arg1
);
11406 if Debug_Flag_U
then
11410 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11411 Analyze
(Get_Pragma_Arg
(Arg1
));
11412 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11414 if not Is_Remote_Call_Interface
(C_Ent
)
11415 and then not Is_Remote_Types
(C_Ent
)
11417 -- This pragma should only appear in an RCI or Remote Types
11418 -- unit (RM E.4.1(4)).
11421 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11424 if Ekind
(Nm
) = E_Procedure
11425 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11427 if not Is_Remote_Call_Interface
(Nm
) then
11429 ("pragma% cannot be applied on non-remote procedure",
11433 L
:= Parameter_Specifications
(Parent
(Nm
));
11434 Process_Async_Pragma
;
11437 elsif Ekind
(Nm
) = E_Function
then
11439 ("pragma% cannot be applied to function", Arg1
);
11441 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11442 if Is_Record_Type
(Nm
) then
11444 -- A record type that is the Equivalent_Type for a remote
11445 -- access-to-subprogram type.
11447 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11450 -- A non-expanded RAS type (distribution is not enabled)
11452 N
:= Declaration_Node
(Nm
);
11455 if Nkind
(N
) = N_Full_Type_Declaration
11456 and then Nkind
(Type_Definition
(N
)) =
11457 N_Access_Procedure_Definition
11459 L
:= Parameter_Specifications
(Type_Definition
(N
));
11460 Process_Async_Pragma
;
11462 if Is_Asynchronous
(Nm
)
11463 and then Expander_Active
11464 and then Get_PCS_Name
/= Name_No_DSA
11466 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11471 ("pragma% cannot reference access-to-function type",
11475 -- Only other possibility is Access-to-class-wide type
11477 elsif Is_Access_Type
(Nm
)
11478 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11480 Check_First_Subtype
(Arg1
);
11481 Set_Is_Asynchronous
(Nm
);
11482 if Expander_Active
then
11483 RACW_Type_Is_Asynchronous
(Nm
);
11487 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11495 -- pragma Atomic (LOCAL_NAME);
11497 when Pragma_Atomic
=>
11498 Process_Atomic_Shared_Volatile
;
11500 -----------------------
11501 -- Atomic_Components --
11502 -----------------------
11504 -- pragma Atomic_Components (array_LOCAL_NAME);
11506 -- This processing is shared by Volatile_Components
11508 when Pragma_Atomic_Components |
11509 Pragma_Volatile_Components
=>
11511 Atomic_Components
: declare
11518 Check_Ada_83_Warning
;
11519 Check_No_Identifiers
;
11520 Check_Arg_Count
(1);
11521 Check_Arg_Is_Local_Name
(Arg1
);
11522 E_Id
:= Get_Pragma_Arg
(Arg1
);
11524 if Etype
(E_Id
) = Any_Type
then
11528 E
:= Entity
(E_Id
);
11530 Check_Duplicate_Pragma
(E
);
11532 if Rep_Item_Too_Early
(E
, N
)
11534 Rep_Item_Too_Late
(E
, N
)
11539 D
:= Declaration_Node
(E
);
11542 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11544 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11545 and then Nkind
(D
) = N_Object_Declaration
11546 and then Nkind
(Object_Definition
(D
)) =
11547 N_Constrained_Array_Definition
)
11549 -- The flag is set on the object, or on the base type
11551 if Nkind
(D
) /= N_Object_Declaration
then
11552 E
:= Base_Type
(E
);
11555 Set_Has_Volatile_Components
(E
);
11557 if Prag_Id
= Pragma_Atomic_Components
then
11558 Set_Has_Atomic_Components
(E
);
11562 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11564 end Atomic_Components
;
11566 --------------------
11567 -- Attach_Handler --
11568 --------------------
11570 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11572 when Pragma_Attach_Handler
=>
11573 Check_Ada_83_Warning
;
11574 Check_No_Identifiers
;
11575 Check_Arg_Count
(2);
11577 if No_Run_Time_Mode
then
11578 Error_Msg_CRT
("Attach_Handler pragma", N
);
11580 Check_Interrupt_Or_Attach_Handler
;
11582 -- The expression that designates the attribute may depend on a
11583 -- discriminant, and is therefore a per-object expression, to
11584 -- be expanded in the init proc. If expansion is enabled, then
11585 -- perform semantic checks on a copy only.
11590 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11593 -- In Relaxed_RM_Semantics mode, we allow any static
11594 -- integer value, for compatibility with other compilers.
11596 if Relaxed_RM_Semantics
11597 and then Nkind
(Parg2
) = N_Integer_Literal
11599 Typ
:= Standard_Integer
;
11601 Typ
:= RTE
(RE_Interrupt_ID
);
11604 if Expander_Active
then
11605 Temp
:= New_Copy_Tree
(Parg2
);
11606 Set_Parent
(Temp
, N
);
11607 Preanalyze_And_Resolve
(Temp
, Typ
);
11610 Resolve
(Parg2
, Typ
);
11614 Process_Interrupt_Or_Attach_Handler
;
11617 --------------------
11618 -- C_Pass_By_Copy --
11619 --------------------
11621 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11623 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11629 Check_Valid_Configuration_Pragma
;
11630 Check_Arg_Count
(1);
11631 Check_Optional_Identifier
(Arg1
, "max_size");
11633 Arg
:= Get_Pragma_Arg
(Arg1
);
11634 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11636 Val
:= Expr_Value
(Arg
);
11640 ("maximum size for pragma% must be positive", Arg1
);
11642 elsif UI_Is_In_Int_Range
(Val
) then
11643 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11645 -- If a giant value is given, Int'Last will do well enough.
11646 -- If sometime someone complains that a record larger than
11647 -- two gigabytes is not copied, we will worry about it then.
11650 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11652 end C_Pass_By_Copy
;
11658 -- pragma Check ([Name =>] CHECK_KIND,
11659 -- [Check =>] Boolean_EXPRESSION
11660 -- [,[Message =>] String_EXPRESSION]);
11662 -- CHECK_KIND ::= IDENTIFIER |
11665 -- Invariant'Class |
11666 -- Type_Invariant'Class
11668 -- The identifiers Assertions and Statement_Assertions are not
11669 -- allowed, since they have special meaning for Check_Policy.
11671 when Pragma_Check
=> Check
: declare
11679 Check_At_Least_N_Arguments
(2);
11680 Check_At_Most_N_Arguments
(3);
11681 Check_Optional_Identifier
(Arg1
, Name_Name
);
11682 Check_Optional_Identifier
(Arg2
, Name_Check
);
11684 if Arg_Count
= 3 then
11685 Check_Optional_Identifier
(Arg3
, Name_Message
);
11686 Str
:= Get_Pragma_Arg
(Arg3
);
11689 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11690 Check_Arg_Is_Identifier
(Arg1
);
11691 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11693 -- Check forbidden name Assertions or Statement_Assertions
11696 when Name_Assertions
=>
11698 ("""Assertions"" is not allowed as a check kind "
11699 & "for pragma%", Arg1
);
11701 when Name_Statement_Assertions
=>
11703 ("""Statement_Assertions"" is not allowed as a check kind "
11704 & "for pragma%", Arg1
);
11710 -- Check applicable policy. We skip this if Checked/Ignored status
11711 -- is already set (e.g. in the casse of a pragma from an aspect).
11713 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11716 -- For a non-source pragma that is a rewriting of another pragma,
11717 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11719 elsif Is_Rewrite_Substitution
(N
)
11720 and then Nkind
(Original_Node
(N
)) = N_Pragma
11721 and then Original_Node
(N
) /= N
11723 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11724 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11726 -- Otherwise query the applicable policy at this point
11729 case Check_Kind
(Cname
) is
11730 when Name_Ignore
=>
11731 Set_Is_Ignored
(N
, True);
11732 Set_Is_Checked
(N
, False);
11735 Set_Is_Ignored
(N
, False);
11736 Set_Is_Checked
(N
, True);
11738 -- For disable, rewrite pragma as null statement and skip
11739 -- rest of the analysis of the pragma.
11741 when Name_Disable
=>
11742 Rewrite
(N
, Make_Null_Statement
(Loc
));
11746 -- No other possibilities
11749 raise Program_Error
;
11753 -- If check kind was not Disable, then continue pragma analysis
11755 Expr
:= Get_Pragma_Arg
(Arg2
);
11757 -- Deal with SCO generation
11760 when Name_Predicate |
11763 -- Nothing to do: since checks occur in client units,
11764 -- the SCO for the aspect in the declaration unit is
11765 -- conservatively always enabled.
11771 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11773 -- Mark aspect/pragma SCO as enabled
11775 Set_SCO_Pragma_Enabled
(Loc
);
11779 -- Deal with analyzing the string argument.
11781 if Arg_Count
= 3 then
11783 -- If checks are not on we don't want any expansion (since
11784 -- such expansion would not get properly deleted) but
11785 -- we do want to analyze (to get proper references).
11786 -- The Preanalyze_And_Resolve routine does just what we want
11788 if Is_Ignored
(N
) then
11789 Preanalyze_And_Resolve
(Str
, Standard_String
);
11791 -- Otherwise we need a proper analysis and expansion
11794 Analyze_And_Resolve
(Str
, Standard_String
);
11798 -- Now you might think we could just do the same with the Boolean
11799 -- expression if checks are off (and expansion is on) and then
11800 -- rewrite the check as a null statement. This would work but we
11801 -- would lose the useful warnings about an assertion being bound
11802 -- to fail even if assertions are turned off.
11804 -- So instead we wrap the boolean expression in an if statement
11805 -- that looks like:
11807 -- if False and then condition then
11811 -- The reason we do this rewriting during semantic analysis rather
11812 -- than as part of normal expansion is that we cannot analyze and
11813 -- expand the code for the boolean expression directly, or it may
11814 -- cause insertion of actions that would escape the attempt to
11815 -- suppress the check code.
11817 -- Note that the Sloc for the if statement corresponds to the
11818 -- argument condition, not the pragma itself. The reason for
11819 -- this is that we may generate a warning if the condition is
11820 -- False at compile time, and we do not want to delete this
11821 -- warning when we delete the if statement.
11823 if Expander_Active
and Is_Ignored
(N
) then
11824 Eloc
:= Sloc
(Expr
);
11827 Make_If_Statement
(Eloc
,
11829 Make_And_Then
(Eloc
,
11830 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
11831 Right_Opnd
=> Expr
),
11832 Then_Statements
=> New_List
(
11833 Make_Null_Statement
(Eloc
))));
11835 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11837 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11839 -- Check is active or expansion not active. In these cases we can
11840 -- just go ahead and analyze the boolean with no worries.
11843 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11844 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11845 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11849 --------------------------
11850 -- Check_Float_Overflow --
11851 --------------------------
11853 -- pragma Check_Float_Overflow;
11855 when Pragma_Check_Float_Overflow
=>
11857 Check_Valid_Configuration_Pragma
;
11858 Check_Arg_Count
(0);
11859 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11865 -- pragma Check_Name (check_IDENTIFIER);
11867 when Pragma_Check_Name
=>
11869 Check_No_Identifiers
;
11870 Check_Valid_Configuration_Pragma
;
11871 Check_Arg_Count
(1);
11872 Check_Arg_Is_Identifier
(Arg1
);
11875 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11878 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11879 if Check_Names
.Table
(J
) = Nam
then
11884 Check_Names
.Append
(Nam
);
11891 -- This is the old style syntax, which is still allowed in all modes:
11893 -- pragma Check_Policy ([Name =>] CHECK_KIND
11894 -- [Policy =>] POLICY_IDENTIFIER);
11896 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11898 -- CHECK_KIND ::= IDENTIFIER |
11901 -- Type_Invariant'Class |
11904 -- This is the new style syntax, compatible with Assertion_Policy
11905 -- and also allowed in all modes.
11907 -- Pragma Check_Policy (
11908 -- CHECK_KIND => POLICY_IDENTIFIER
11909 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11911 -- Note: the identifiers Name and Policy are not allowed as
11912 -- Check_Kind values. This avoids ambiguities between the old and
11913 -- new form syntax.
11915 when Pragma_Check_Policy
=> Check_Policy
: declare
11921 Check_At_Least_N_Arguments
(1);
11923 -- A Check_Policy pragma can appear either as a configuration
11924 -- pragma, or in a declarative part or a package spec (see RM
11925 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11926 -- followed for Check_Policy).
11928 if not Is_Configuration_Pragma
then
11929 Check_Is_In_Decl_Part_Or_Package_Spec
;
11932 -- Figure out if we have the old or new syntax. We have the
11933 -- old syntax if the first argument has no identifier, or the
11934 -- identifier is Name.
11936 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11937 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11941 Check_Arg_Count
(2);
11942 Check_Optional_Identifier
(Arg1
, Name_Name
);
11943 Kind
:= Get_Pragma_Arg
(Arg1
);
11944 Rewrite_Assertion_Kind
(Kind
);
11945 Check_Arg_Is_Identifier
(Arg1
);
11947 -- Check forbidden check kind
11949 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11950 Error_Msg_Name_2
:= Chars
(Kind
);
11952 ("pragma% does not allow% as check name", Arg1
);
11957 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11958 Check_Arg_Is_One_Of
11960 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11961 Ident
:= Get_Pragma_Arg
(Arg2
);
11963 if Chars
(Kind
) = Name_Ghost
then
11965 -- Pragma Check_Policy specifying a Ghost policy cannot
11966 -- occur within a ghost subprogram or package.
11968 if Within_Ghost_Scope
then
11970 ("pragma % cannot appear within ghost subprogram or "
11973 -- The policy identifier of pragma Ghost must be either
11974 -- Check or Ignore (SPARK RM 6.9(7)).
11976 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11980 ("argument of pragma % Ghost must be Check or Ignore",
11985 -- And chain pragma on the Check_Policy_List for search
11987 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11988 Opt
.Check_Policy_List
:= N
;
11990 -- For the new syntax, what we do is to convert each argument to
11991 -- an old syntax equivalent. We do that because we want to chain
11992 -- old style Check_Policy pragmas for the search (we don't want
11993 -- to have to deal with multiple arguments in the search).
12003 while Present
(Arg
) loop
12004 LocP
:= Sloc
(Arg
);
12005 Argx
:= Get_Pragma_Arg
(Arg
);
12007 -- Kind must be specified
12009 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12010 or else Chars
(Arg
) = No_Name
12013 ("missing assertion kind for pragma%", Arg
);
12016 -- Construct equivalent old form syntax Check_Policy
12017 -- pragma and insert it to get remaining checks.
12021 Chars
=> Name_Check_Policy
,
12022 Pragma_Argument_Associations
=> New_List
(
12023 Make_Pragma_Argument_Association
(LocP
,
12025 Make_Identifier
(LocP
, Chars
(Arg
))),
12026 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12027 Expression
=> Argx
))));
12032 -- Rewrite original Check_Policy pragma to null, since we
12033 -- have converted it into a series of old syntax pragmas.
12035 Rewrite
(N
, Make_Null_Statement
(Loc
));
12041 ---------------------
12042 -- CIL_Constructor --
12043 ---------------------
12045 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12047 -- Processing for this pragma is shared with Java_Constructor
12053 -- pragma Comment (static_string_EXPRESSION)
12055 -- Processing for pragma Comment shares the circuitry for pragma
12056 -- Ident. The only differences are that Ident enforces a limit of 31
12057 -- characters on its argument, and also enforces limitations on
12058 -- placement for DEC compatibility. Pragma Comment shares neither of
12059 -- these restrictions.
12061 -------------------
12062 -- Common_Object --
12063 -------------------
12065 -- pragma Common_Object (
12066 -- [Internal =>] LOCAL_NAME
12067 -- [, [External =>] EXTERNAL_SYMBOL]
12068 -- [, [Size =>] EXTERNAL_SYMBOL]);
12070 -- Processing for this pragma is shared with Psect_Object
12072 ------------------------
12073 -- Compile_Time_Error --
12074 ------------------------
12076 -- pragma Compile_Time_Error
12077 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12079 when Pragma_Compile_Time_Error
=>
12081 Process_Compile_Time_Warning_Or_Error
;
12083 --------------------------
12084 -- Compile_Time_Warning --
12085 --------------------------
12087 -- pragma Compile_Time_Warning
12088 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12090 when Pragma_Compile_Time_Warning
=>
12092 Process_Compile_Time_Warning_Or_Error
;
12094 ---------------------------
12095 -- Compiler_Unit_Warning --
12096 ---------------------------
12098 -- pragma Compiler_Unit_Warning;
12102 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12103 -- errors not warnings. This means that we had introduced a big extra
12104 -- inertia to compiler changes, since even if we implemented a new
12105 -- feature, and even if all versions to be used for bootstrapping
12106 -- implemented this new feature, we could not use it, since old
12107 -- compilers would give errors for using this feature in units
12108 -- having Compiler_Unit pragmas.
12110 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12111 -- problem. We no longer have any units mentioning Compiler_Unit,
12112 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12113 -- and thus generates a warning which can be ignored. So that deals
12114 -- with the problem of old compilers not implementing the newer form
12117 -- Newer compilers recognize the new pragma, but generate warning
12118 -- messages instead of errors, which again can be ignored in the
12119 -- case of an old compiler which implements a wanted new feature
12120 -- but at the time felt like warning about it for older compilers.
12122 -- We retain Compiler_Unit so that new compilers can be used to build
12123 -- older run-times that use this pragma. That's an unusual case, but
12124 -- it's easy enough to handle, so why not?
12126 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12128 Check_Arg_Count
(0);
12130 -- Only recognized in main unit
12132 if Current_Sem_Unit
= Main_Unit
then
12133 Compiler_Unit
:= True;
12136 -----------------------------
12137 -- Complete_Representation --
12138 -----------------------------
12140 -- pragma Complete_Representation;
12142 when Pragma_Complete_Representation
=>
12144 Check_Arg_Count
(0);
12146 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12148 ("pragma & must appear within record representation clause");
12151 ----------------------------
12152 -- Complex_Representation --
12153 ----------------------------
12155 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12157 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12164 Check_Arg_Count
(1);
12165 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12166 Check_Arg_Is_Local_Name
(Arg1
);
12167 E_Id
:= Get_Pragma_Arg
(Arg1
);
12169 if Etype
(E_Id
) = Any_Type
then
12173 E
:= Entity
(E_Id
);
12175 if not Is_Record_Type
(E
) then
12177 ("argument for pragma% must be record type", Arg1
);
12180 Ent
:= First_Entity
(E
);
12183 or else No
(Next_Entity
(Ent
))
12184 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12185 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12186 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12189 ("record for pragma% must have two fields of the same "
12190 & "floating-point type", Arg1
);
12193 Set_Has_Complex_Representation
(Base_Type
(E
));
12195 -- We need to treat the type has having a non-standard
12196 -- representation, for back-end purposes, even though in
12197 -- general a complex will have the default representation
12198 -- of a record with two real components.
12200 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12202 end Complex_Representation
;
12204 -------------------------
12205 -- Component_Alignment --
12206 -------------------------
12208 -- pragma Component_Alignment (
12209 -- [Form =>] ALIGNMENT_CHOICE
12210 -- [, [Name =>] type_LOCAL_NAME]);
12212 -- ALIGNMENT_CHOICE ::=
12214 -- | Component_Size_4
12218 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12219 Args
: Args_List
(1 .. 2);
12220 Names
: constant Name_List
(1 .. 2) := (
12224 Form
: Node_Id
renames Args
(1);
12225 Name
: Node_Id
renames Args
(2);
12227 Atype
: Component_Alignment_Kind
;
12232 Gather_Associations
(Names
, Args
);
12235 Error_Pragma
("missing Form argument for pragma%");
12238 Check_Arg_Is_Identifier
(Form
);
12240 -- Get proper alignment, note that Default = Component_Size on all
12241 -- machines we have so far, and we want to set this value rather
12242 -- than the default value to indicate that it has been explicitly
12243 -- set (and thus will not get overridden by the default component
12244 -- alignment for the current scope)
12246 if Chars
(Form
) = Name_Component_Size
then
12247 Atype
:= Calign_Component_Size
;
12249 elsif Chars
(Form
) = Name_Component_Size_4
then
12250 Atype
:= Calign_Component_Size_4
;
12252 elsif Chars
(Form
) = Name_Default
then
12253 Atype
:= Calign_Component_Size
;
12255 elsif Chars
(Form
) = Name_Storage_Unit
then
12256 Atype
:= Calign_Storage_Unit
;
12260 ("invalid Form parameter for pragma%", Form
);
12263 -- Case with no name, supplied, affects scope table entry
12267 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12269 -- Case of name supplied
12272 Check_Arg_Is_Local_Name
(Name
);
12274 Typ
:= Entity
(Name
);
12277 or else Rep_Item_Too_Early
(Typ
, N
)
12281 Typ
:= Underlying_Type
(Typ
);
12284 if not Is_Record_Type
(Typ
)
12285 and then not Is_Array_Type
(Typ
)
12288 ("Name parameter of pragma% must identify record or "
12289 & "array type", Name
);
12292 -- An explicit Component_Alignment pragma overrides an
12293 -- implicit pragma Pack, but not an explicit one.
12295 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12296 Set_Is_Packed
(Base_Type
(Typ
), False);
12297 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12300 end Component_AlignmentP
;
12302 --------------------
12303 -- Contract_Cases --
12304 --------------------
12306 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12308 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12310 -- CASE_GUARD ::= boolean_EXPRESSION | others
12312 -- CONSEQUENCE ::= boolean_EXPRESSION
12314 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12315 Subp_Decl
: Node_Id
;
12319 Check_No_Identifiers
;
12320 Check_Arg_Count
(1);
12321 Ensure_Aggregate_Form
(Arg1
);
12323 -- The pragma is analyzed at the end of the declarative part which
12324 -- contains the related subprogram. Reset the analyzed flag.
12326 Set_Analyzed
(N
, False);
12328 -- Ensure the proper placement of the pragma. Contract_Cases must
12329 -- be associated with a subprogram declaration or a body that acts
12333 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12335 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12338 -- Body acts as spec
12340 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12341 and then No
(Corresponding_Spec
(Subp_Decl
))
12345 -- Body stub acts as spec
12347 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12348 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12357 -- When the pragma appears on a subprogram body, perform the full
12360 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12361 Analyze_Contract_Cases_In_Decl_Part
(N
);
12363 -- When Contract_Cases applies to a subprogram compilation unit,
12364 -- the corresponding pragma is placed after the unit's declaration
12365 -- node and needs to be analyzed immediately.
12367 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12368 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12370 Analyze_Contract_Cases_In_Decl_Part
(N
);
12373 -- Chain the pragma on the contract for further processing
12375 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12376 end Contract_Cases
;
12382 -- pragma Controlled (first_subtype_LOCAL_NAME);
12384 when Pragma_Controlled
=> Controlled
: declare
12388 Check_No_Identifiers
;
12389 Check_Arg_Count
(1);
12390 Check_Arg_Is_Local_Name
(Arg1
);
12391 Arg
:= Get_Pragma_Arg
(Arg1
);
12393 if not Is_Entity_Name
(Arg
)
12394 or else not Is_Access_Type
(Entity
(Arg
))
12396 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12398 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12406 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12407 -- [Entity =>] LOCAL_NAME);
12409 when Pragma_Convention
=> Convention
: declare
12412 pragma Warnings
(Off
, C
);
12413 pragma Warnings
(Off
, E
);
12415 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12416 Check_Ada_83_Warning
;
12417 Check_Arg_Count
(2);
12418 Process_Convention
(C
, E
);
12421 ---------------------------
12422 -- Convention_Identifier --
12423 ---------------------------
12425 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12426 -- [Convention =>] convention_IDENTIFIER);
12428 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12434 Check_Arg_Order
((Name_Name
, Name_Convention
));
12435 Check_Arg_Count
(2);
12436 Check_Optional_Identifier
(Arg1
, Name_Name
);
12437 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12438 Check_Arg_Is_Identifier
(Arg1
);
12439 Check_Arg_Is_Identifier
(Arg2
);
12440 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12441 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12443 if Is_Convention_Name
(Cname
) then
12444 Record_Convention_Identifier
12445 (Idnam
, Get_Convention_Id
(Cname
));
12448 ("second arg for % pragma must be convention", Arg2
);
12450 end Convention_Identifier
;
12456 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12458 when Pragma_CPP_Class
=> CPP_Class
: declare
12462 if Warn_On_Obsolescent_Feature
then
12464 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12465 & "effect; replace it by pragma import?j?", N
);
12468 Check_Arg_Count
(1);
12472 Chars
=> Name_Import
,
12473 Pragma_Argument_Associations
=> New_List
(
12474 Make_Pragma_Argument_Association
(Loc
,
12475 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12476 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12480 ---------------------
12481 -- CPP_Constructor --
12482 ---------------------
12484 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12485 -- [, [External_Name =>] static_string_EXPRESSION ]
12486 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12488 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12491 Def_Id
: Entity_Id
;
12492 Tag_Typ
: Entity_Id
;
12496 Check_At_Least_N_Arguments
(1);
12497 Check_At_Most_N_Arguments
(3);
12498 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12499 Check_Arg_Is_Local_Name
(Arg1
);
12501 Id
:= Get_Pragma_Arg
(Arg1
);
12502 Find_Program_Unit_Name
(Id
);
12504 -- If we did not find the name, we are done
12506 if Etype
(Id
) = Any_Type
then
12510 Def_Id
:= Entity
(Id
);
12512 -- Check if already defined as constructor
12514 if Is_Constructor
(Def_Id
) then
12516 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12520 if Ekind
(Def_Id
) = E_Function
12521 and then (Is_CPP_Class
(Etype
(Def_Id
))
12522 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12524 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12526 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12528 ("'C'P'P constructor must be defined in the scope of "
12529 & "its returned type", Arg1
);
12532 if Arg_Count
>= 2 then
12533 Set_Imported
(Def_Id
);
12534 Set_Is_Public
(Def_Id
);
12535 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12538 Set_Has_Completion
(Def_Id
);
12539 Set_Is_Constructor
(Def_Id
);
12540 Set_Convention
(Def_Id
, Convention_CPP
);
12542 -- Imported C++ constructors are not dispatching primitives
12543 -- because in C++ they don't have a dispatch table slot.
12544 -- However, in Ada the constructor has the profile of a
12545 -- function that returns a tagged type and therefore it has
12546 -- been treated as a primitive operation during semantic
12547 -- analysis. We now remove it from the list of primitive
12548 -- operations of the type.
12550 if Is_Tagged_Type
(Etype
(Def_Id
))
12551 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12552 and then Is_Dispatching_Operation
(Def_Id
)
12554 Tag_Typ
:= Etype
(Def_Id
);
12556 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12557 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12561 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12562 Set_Is_Dispatching_Operation
(Def_Id
, False);
12565 -- For backward compatibility, if the constructor returns a
12566 -- class wide type, and we internally change the return type to
12567 -- the corresponding root type.
12569 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12570 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12574 ("pragma% requires function returning a 'C'P'P_Class type",
12577 end CPP_Constructor
;
12583 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12587 if Warn_On_Obsolescent_Feature
then
12589 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12598 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12602 if Warn_On_Obsolescent_Feature
then
12604 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12613 -- pragma CPU (EXPRESSION);
12615 when Pragma_CPU
=> CPU
: declare
12616 P
: constant Node_Id
:= Parent
(N
);
12622 Check_No_Identifiers
;
12623 Check_Arg_Count
(1);
12627 if Nkind
(P
) = N_Subprogram_Body
then
12628 Check_In_Main_Program
;
12630 Arg
:= Get_Pragma_Arg
(Arg1
);
12631 Analyze_And_Resolve
(Arg
, Any_Integer
);
12633 Ent
:= Defining_Unit_Name
(Specification
(P
));
12635 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12636 Ent
:= Defining_Identifier
(Ent
);
12641 if not Is_OK_Static_Expression
(Arg
) then
12642 Flag_Non_Static_Expr
12643 ("main subprogram affinity is not static!", Arg
);
12646 -- If constraint error, then we already signalled an error
12648 elsif Raises_Constraint_Error
(Arg
) then
12651 -- Otherwise check in range
12655 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12656 -- This is the entity System.Multiprocessors.CPU_Range;
12658 Val
: constant Uint
:= Expr_Value
(Arg
);
12661 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12663 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12666 ("main subprogram CPU is out of range", Arg1
);
12672 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12676 elsif Nkind
(P
) = N_Task_Definition
then
12677 Arg
:= Get_Pragma_Arg
(Arg1
);
12678 Ent
:= Defining_Identifier
(Parent
(P
));
12680 -- The expression must be analyzed in the special manner
12681 -- described in "Handling of Default and Per-Object
12682 -- Expressions" in sem.ads.
12684 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12686 -- Anything else is incorrect
12692 -- Check duplicate pragma before we chain the pragma in the Rep
12693 -- Item chain of Ent.
12695 Check_Duplicate_Pragma
(Ent
);
12696 Record_Rep_Item
(Ent
, N
);
12703 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12705 when Pragma_Debug
=> Debug
: declare
12712 -- The condition for executing the call is that the expander
12713 -- is active and that we are not ignoring this debug pragma.
12718 (Expander_Active
and then not Is_Ignored
(N
)),
12721 if not Is_Ignored
(N
) then
12722 Set_SCO_Pragma_Enabled
(Loc
);
12725 if Arg_Count
= 2 then
12727 Make_And_Then
(Loc
,
12728 Left_Opnd
=> Relocate_Node
(Cond
),
12729 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12730 Call
:= Get_Pragma_Arg
(Arg2
);
12732 Call
:= Get_Pragma_Arg
(Arg1
);
12736 N_Indexed_Component
,
12740 N_Selected_Component
)
12742 -- If this pragma Debug comes from source, its argument was
12743 -- parsed as a name form (which is syntactically identical).
12744 -- In a generic context a parameterless call will be left as
12745 -- an expanded name (if global) or selected_component if local.
12746 -- Change it to a procedure call statement now.
12748 Change_Name_To_Procedure_Call_Statement
(Call
);
12750 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12752 -- Already in the form of a procedure call statement: nothing
12753 -- to do (could happen in case of an internally generated
12759 -- All other cases: diagnose error
12762 ("argument of pragma ""Debug"" is not procedure call",
12767 -- Rewrite into a conditional with an appropriate condition. We
12768 -- wrap the procedure call in a block so that overhead from e.g.
12769 -- use of the secondary stack does not generate execution overhead
12770 -- for suppressed conditions.
12772 -- Normally the analysis that follows will freeze the subprogram
12773 -- being called. However, if the call is to a null procedure,
12774 -- we want to freeze it before creating the block, because the
12775 -- analysis that follows may be done with expansion disabled, in
12776 -- which case the body will not be generated, leading to spurious
12779 if Nkind
(Call
) = N_Procedure_Call_Statement
12780 and then Is_Entity_Name
(Name
(Call
))
12782 Analyze
(Name
(Call
));
12783 Freeze_Before
(N
, Entity
(Name
(Call
)));
12787 Make_Implicit_If_Statement
(N
,
12789 Then_Statements
=> New_List
(
12790 Make_Block_Statement
(Loc
,
12791 Handled_Statement_Sequence
=>
12792 Make_Handled_Sequence_Of_Statements
(Loc
,
12793 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12796 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12797 -- after analysis of the normally rewritten node, to capture all
12798 -- references to entities, which avoids issuing wrong warnings
12799 -- about unused entities.
12801 if GNATprove_Mode
then
12802 Rewrite
(N
, Make_Null_Statement
(Loc
));
12810 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12812 when Pragma_Debug_Policy
=>
12814 Check_Arg_Count
(1);
12815 Check_No_Identifiers
;
12816 Check_Arg_Is_Identifier
(Arg1
);
12818 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12819 -- rewrite it that way, and let the rest of the checking come
12820 -- from analyzing the rewritten pragma.
12824 Chars
=> Name_Check_Policy
,
12825 Pragma_Argument_Associations
=> New_List
(
12826 Make_Pragma_Argument_Association
(Loc
,
12827 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12829 Make_Pragma_Argument_Association
(Loc
,
12830 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12833 -------------------------------
12834 -- Default_Initial_Condition --
12835 -------------------------------
12837 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12839 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12846 Check_No_Identifiers
;
12847 Check_At_Most_N_Arguments
(1);
12850 while Present
(Stmt
) loop
12852 -- Skip prior pragmas, but check for duplicates
12854 if Nkind
(Stmt
) = N_Pragma
then
12855 if Pragma_Name
(Stmt
) = Pname
then
12856 Error_Msg_Name_1
:= Pname
;
12857 Error_Msg_Sloc
:= Sloc
(Stmt
);
12858 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12861 -- Skip internally generated code
12863 elsif not Comes_From_Source
(Stmt
) then
12866 -- The associated private type [extension] has been found, stop
12869 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12870 N_Private_Type_Declaration
)
12872 Typ
:= Defining_Entity
(Stmt
);
12875 -- The pragma does not apply to a legal construct, issue an
12876 -- error and stop the analysis.
12883 Stmt
:= Prev
(Stmt
);
12886 Set_Has_Default_Init_Cond
(Typ
);
12887 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12889 -- Chain the pragma on the rep item chain for further processing
12891 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12892 end Default_Init_Cond
;
12894 ----------------------------------
12895 -- Default_Scalar_Storage_Order --
12896 ----------------------------------
12898 -- pragma Default_Scalar_Storage_Order
12899 -- (High_Order_First | Low_Order_First);
12901 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12902 Default
: Character;
12906 Check_Arg_Count
(1);
12908 -- Default_Scalar_Storage_Order can appear as a configuration
12909 -- pragma, or 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 Check_No_Identifiers
;
12916 Check_Arg_Is_One_Of
12917 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12918 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12919 Default
:= Fold_Upper
(Name_Buffer
(1));
12921 if not Support_Nondefault_SSO_On_Target
12922 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12924 if Warn_On_Unrecognized_Pragma
then
12926 ("non-default Scalar_Storage_Order not supported "
12927 & "on target?g?", N
);
12929 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12932 -- Here set the specified default
12935 Opt
.Default_SSO
:= Default
;
12939 --------------------------
12940 -- Default_Storage_Pool --
12941 --------------------------
12943 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12945 when Pragma_Default_Storage_Pool
=>
12947 Check_Arg_Count
(1);
12949 -- Default_Storage_Pool can appear as a configuration pragma, or
12950 -- in a declarative part of a package spec.
12952 if not Is_Configuration_Pragma
then
12953 Check_Is_In_Decl_Part_Or_Package_Spec
;
12956 -- Case of Default_Storage_Pool (null);
12958 if Nkind
(Expression
(Arg1
)) = N_Null
then
12959 Analyze
(Expression
(Arg1
));
12961 -- This is an odd case, this is not really an expression, so
12962 -- we don't have a type for it. So just set the type to Empty.
12964 Set_Etype
(Expression
(Arg1
), Empty
);
12966 -- Case of Default_Storage_Pool (storage_pool_NAME);
12969 -- If it's a configuration pragma, then the only allowed
12970 -- argument is "null".
12972 if Is_Configuration_Pragma
then
12973 Error_Pragma_Arg
("NULL expected", Arg1
);
12976 -- The expected type for a non-"null" argument is
12977 -- Root_Storage_Pool'Class, and the pool must be a variable.
12979 Analyze_And_Resolve
12980 (Get_Pragma_Arg
(Arg1
),
12981 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12983 if not Is_Variable
(Expression
(Arg1
)) then
12985 ("default storage pool must be a variable", Arg1
);
12989 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12990 -- for an access type will use this information to set the
12991 -- appropriate attributes of the access type.
12993 Default_Pool
:= Expression
(Arg1
);
12999 -- pragma Depends (DEPENDENCY_RELATION);
13001 -- DEPENDENCY_RELATION ::=
13003 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
13005 -- DEPENDENCY_CLAUSE ::=
13006 -- OUTPUT_LIST =>[+] INPUT_LIST
13007 -- | NULL_DEPENDENCY_CLAUSE
13009 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13011 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13013 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13015 -- OUTPUT ::= NAME | FUNCTION_RESULT
13018 -- where FUNCTION_RESULT is a function Result attribute_reference
13020 when Pragma_Depends
=> Depends
: declare
13021 Subp_Decl
: Node_Id
;
13025 Check_Arg_Count
(1);
13026 Ensure_Aggregate_Form
(Arg1
);
13028 -- Ensure the proper placement of the pragma. Depends must be
13029 -- associated with a subprogram declaration or a body that acts
13033 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
13035 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13038 -- Body acts as spec
13040 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13041 and then No
(Corresponding_Spec
(Subp_Decl
))
13045 -- Body stub acts as spec
13047 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13048 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13057 -- When the pragma appears on a subprogram body, perform the full
13060 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
13061 Analyze_Depends_In_Decl_Part
(N
);
13063 -- When Depends applies to a subprogram compilation unit, the
13064 -- corresponding pragma is placed after the unit's declaration
13065 -- node and needs to be analyzed immediately.
13067 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13068 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
13070 Analyze_Depends_In_Decl_Part
(N
);
13073 -- Chain the pragma on the contract for further processing
13075 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13078 ---------------------
13079 -- Detect_Blocking --
13080 ---------------------
13082 -- pragma Detect_Blocking;
13084 when Pragma_Detect_Blocking
=>
13086 Check_Arg_Count
(0);
13087 Check_Valid_Configuration_Pragma
;
13088 Detect_Blocking
:= True;
13090 ------------------------------------
13091 -- Disable_Atomic_Synchronization --
13092 ------------------------------------
13094 -- pragma Disable_Atomic_Synchronization [(Entity)];
13096 when Pragma_Disable_Atomic_Synchronization
=>
13098 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13100 -------------------
13101 -- Discard_Names --
13102 -------------------
13104 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13106 when Pragma_Discard_Names
=> Discard_Names
: declare
13111 Check_Ada_83_Warning
;
13113 -- Deal with configuration pragma case
13115 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13116 Global_Discard_Names
:= True;
13119 -- Otherwise, check correct appropriate context
13122 Check_Is_In_Decl_Part_Or_Package_Spec
;
13124 if Arg_Count
= 0 then
13126 -- If there is no parameter, then from now on this pragma
13127 -- applies to any enumeration, exception or tagged type
13128 -- defined in the current declarative part, and recursively
13129 -- to any nested scope.
13131 Set_Discard_Names
(Current_Scope
);
13135 Check_Arg_Count
(1);
13136 Check_Optional_Identifier
(Arg1
, Name_On
);
13137 Check_Arg_Is_Local_Name
(Arg1
);
13139 E_Id
:= Get_Pragma_Arg
(Arg1
);
13141 if Etype
(E_Id
) = Any_Type
then
13144 E
:= Entity
(E_Id
);
13147 if (Is_First_Subtype
(E
)
13149 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13150 or else Ekind
(E
) = E_Exception
13152 Set_Discard_Names
(E
);
13153 Record_Rep_Item
(E
, N
);
13157 ("inappropriate entity for pragma%", Arg1
);
13164 ------------------------
13165 -- Dispatching_Domain --
13166 ------------------------
13168 -- pragma Dispatching_Domain (EXPRESSION);
13170 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13171 P
: constant Node_Id
:= Parent
(N
);
13177 Check_No_Identifiers
;
13178 Check_Arg_Count
(1);
13180 -- This pragma is born obsolete, but not the aspect
13182 if not From_Aspect_Specification
(N
) then
13184 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13187 if Nkind
(P
) = N_Task_Definition
then
13188 Arg
:= Get_Pragma_Arg
(Arg1
);
13189 Ent
:= Defining_Identifier
(Parent
(P
));
13191 -- The expression must be analyzed in the special manner
13192 -- described in "Handling of Default and Per-Object
13193 -- Expressions" in sem.ads.
13195 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13197 -- Check duplicate pragma before we chain the pragma in the Rep
13198 -- Item chain of Ent.
13200 Check_Duplicate_Pragma
(Ent
);
13201 Record_Rep_Item
(Ent
, N
);
13203 -- Anything else is incorrect
13208 end Dispatching_Domain
;
13214 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13216 when Pragma_Elaborate
=> Elaborate
: declare
13221 -- Pragma must be in context items list of a compilation unit
13223 if not Is_In_Context_Clause
then
13227 -- Must be at least one argument
13229 if Arg_Count
= 0 then
13230 Error_Pragma
("pragma% requires at least one argument");
13233 -- In Ada 83 mode, there can be no items following it in the
13234 -- context list except other pragmas and implicit with clauses
13235 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13236 -- placement rule does not apply.
13238 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13240 while Present
(Citem
) loop
13241 if Nkind
(Citem
) = N_Pragma
13242 or else (Nkind
(Citem
) = N_With_Clause
13243 and then Implicit_With
(Citem
))
13248 ("(Ada 83) pragma% must be at end of context clause");
13255 -- Finally, the arguments must all be units mentioned in a with
13256 -- clause in the same context clause. Note we already checked (in
13257 -- Par.Prag) that the arguments are all identifiers or selected
13261 Outer
: while Present
(Arg
) loop
13262 Citem
:= First
(List_Containing
(N
));
13263 Inner
: while Citem
/= N
loop
13264 if Nkind
(Citem
) = N_With_Clause
13265 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13267 Set_Elaborate_Present
(Citem
, True);
13268 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13269 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
13271 -- With the pragma present, elaboration calls on
13272 -- subprograms from the named unit need no further
13273 -- checks, as long as the pragma appears in the current
13274 -- compilation unit. If the pragma appears in some unit
13275 -- in the context, there might still be a need for an
13276 -- Elaborate_All_Desirable from the current compilation
13277 -- to the named unit, so we keep the check enabled.
13279 if In_Extended_Main_Source_Unit
(N
) then
13280 Set_Suppress_Elaboration_Warnings
13281 (Entity
(Name
(Citem
)));
13292 ("argument of pragma% is not withed unit", Arg
);
13298 -- Give a warning if operating in static mode with one of the
13299 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13301 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
13303 ("?l?use of pragma Elaborate may not be safe", N
);
13305 ("?l?use pragma Elaborate_All instead if possible", N
);
13309 -------------------
13310 -- Elaborate_All --
13311 -------------------
13313 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13315 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13320 Check_Ada_83_Warning
;
13322 -- Pragma must be in context items list of a compilation unit
13324 if not Is_In_Context_Clause
then
13328 -- Must be at least one argument
13330 if Arg_Count
= 0 then
13331 Error_Pragma
("pragma% requires at least one argument");
13334 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13335 -- have to appear at the end of the context clause, but may
13336 -- appear mixed in with other items, even in Ada 83 mode.
13338 -- Final check: the arguments must all be units mentioned in
13339 -- a with clause in the same context clause. Note that we
13340 -- already checked (in Par.Prag) that all the arguments are
13341 -- either identifiers or selected components.
13344 Outr
: while Present
(Arg
) loop
13345 Citem
:= First
(List_Containing
(N
));
13346 Innr
: while Citem
/= N
loop
13347 if Nkind
(Citem
) = N_With_Clause
13348 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13350 Set_Elaborate_All_Present
(Citem
, True);
13351 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13353 -- Suppress warnings and elaboration checks on the named
13354 -- unit if the pragma is in the current compilation, as
13355 -- for pragma Elaborate.
13357 if In_Extended_Main_Source_Unit
(N
) then
13358 Set_Suppress_Elaboration_Warnings
13359 (Entity
(Name
(Citem
)));
13368 Set_Error_Posted
(N
);
13370 ("argument of pragma% is not withed unit", Arg
);
13377 --------------------
13378 -- Elaborate_Body --
13379 --------------------
13381 -- pragma Elaborate_Body [( library_unit_NAME )];
13383 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13384 Cunit_Node
: Node_Id
;
13385 Cunit_Ent
: Entity_Id
;
13388 Check_Ada_83_Warning
;
13389 Check_Valid_Library_Unit_Pragma
;
13391 if Nkind
(N
) = N_Null_Statement
then
13395 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13396 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13398 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13401 Error_Pragma
("pragma% must refer to a spec, not a body");
13403 Set_Body_Required
(Cunit_Node
, True);
13404 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13406 -- If we are in dynamic elaboration mode, then we suppress
13407 -- elaboration warnings for the unit, since it is definitely
13408 -- fine NOT to do dynamic checks at the first level (and such
13409 -- checks will be suppressed because no elaboration boolean
13410 -- is created for Elaborate_Body packages).
13412 -- But in the static model of elaboration, Elaborate_Body is
13413 -- definitely NOT good enough to ensure elaboration safety on
13414 -- its own, since the body may WITH other units that are not
13415 -- safe from an elaboration point of view, so a client must
13416 -- still do an Elaborate_All on such units.
13418 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13419 -- Elaborate_Body always suppressed elab warnings.
13421 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13422 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13425 end Elaborate_Body
;
13427 ------------------------
13428 -- Elaboration_Checks --
13429 ------------------------
13431 -- pragma Elaboration_Checks (Static | Dynamic);
13433 when Pragma_Elaboration_Checks
=>
13435 Check_Arg_Count
(1);
13436 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13437 Dynamic_Elaboration_Checks
:=
13438 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
13444 -- pragma Eliminate (
13445 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13446 -- [,[Entity =>] IDENTIFIER |
13447 -- SELECTED_COMPONENT |
13449 -- [, OVERLOADING_RESOLUTION]);
13451 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13454 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13455 -- FUNCTION_PROFILE
13457 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13459 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13460 -- Result_Type => result_SUBTYPE_NAME]
13462 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13463 -- SUBTYPE_NAME ::= STRING_LITERAL
13465 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13466 -- SOURCE_TRACE ::= STRING_LITERAL
13468 when Pragma_Eliminate
=> Eliminate
: declare
13469 Args
: Args_List
(1 .. 5);
13470 Names
: constant Name_List
(1 .. 5) := (
13473 Name_Parameter_Types
,
13475 Name_Source_Location
);
13477 Unit_Name
: Node_Id
renames Args
(1);
13478 Entity
: Node_Id
renames Args
(2);
13479 Parameter_Types
: Node_Id
renames Args
(3);
13480 Result_Type
: Node_Id
renames Args
(4);
13481 Source_Location
: Node_Id
renames Args
(5);
13485 Check_Valid_Configuration_Pragma
;
13486 Gather_Associations
(Names
, Args
);
13488 if No
(Unit_Name
) then
13489 Error_Pragma
("missing Unit_Name argument for pragma%");
13493 and then (Present
(Parameter_Types
)
13495 Present
(Result_Type
)
13497 Present
(Source_Location
))
13499 Error_Pragma
("missing Entity argument for pragma%");
13502 if (Present
(Parameter_Types
)
13504 Present
(Result_Type
))
13506 Present
(Source_Location
)
13509 ("parameter profile and source location cannot be used "
13510 & "together in pragma%");
13513 Process_Eliminate_Pragma
13522 -----------------------------------
13523 -- Enable_Atomic_Synchronization --
13524 -----------------------------------
13526 -- pragma Enable_Atomic_Synchronization [(Entity)];
13528 when Pragma_Enable_Atomic_Synchronization
=>
13530 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13537 -- [ Convention =>] convention_IDENTIFIER,
13538 -- [ Entity =>] LOCAL_NAME
13539 -- [, [External_Name =>] static_string_EXPRESSION ]
13540 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13542 when Pragma_Export
=> Export
: declare
13544 Def_Id
: Entity_Id
;
13546 pragma Warnings
(Off
, C
);
13549 Check_Ada_83_Warning
;
13553 Name_External_Name
,
13556 Check_At_Least_N_Arguments
(2);
13557 Check_At_Most_N_Arguments
(4);
13559 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13560 -- pragma Export (Entity, "external name");
13562 if Relaxed_RM_Semantics
13563 and then Arg_Count
= 2
13564 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13567 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13570 if not Is_Entity_Name
(Def_Id
) then
13571 Error_Pragma_Arg
("entity name required", Arg1
);
13574 Def_Id
:= Entity
(Def_Id
);
13575 Set_Exported
(Def_Id
, Arg1
);
13578 Process_Convention
(C
, Def_Id
);
13580 if Ekind
(Def_Id
) /= E_Constant
then
13581 Note_Possible_Modification
13582 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13585 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13586 Set_Exported
(Def_Id
, Arg2
);
13589 -- If the entity is a deferred constant, propagate the information
13590 -- to the full view, because gigi elaborates the full view only.
13592 if Ekind
(Def_Id
) = E_Constant
13593 and then Present
(Full_View
(Def_Id
))
13596 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13598 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13599 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13600 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13605 ---------------------
13606 -- Export_Function --
13607 ---------------------
13609 -- pragma Export_Function (
13610 -- [Internal =>] LOCAL_NAME
13611 -- [, [External =>] EXTERNAL_SYMBOL]
13612 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13613 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13614 -- [, [Mechanism =>] MECHANISM]
13615 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13617 -- EXTERNAL_SYMBOL ::=
13619 -- | static_string_EXPRESSION
13621 -- PARAMETER_TYPES ::=
13623 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13625 -- TYPE_DESIGNATOR ::=
13627 -- | subtype_Name ' Access
13631 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13633 -- MECHANISM_ASSOCIATION ::=
13634 -- [formal_parameter_NAME =>] MECHANISM_NAME
13636 -- MECHANISM_NAME ::=
13640 when Pragma_Export_Function
=> Export_Function
: declare
13641 Args
: Args_List
(1 .. 6);
13642 Names
: constant Name_List
(1 .. 6) := (
13645 Name_Parameter_Types
,
13648 Name_Result_Mechanism
);
13650 Internal
: Node_Id
renames Args
(1);
13651 External
: Node_Id
renames Args
(2);
13652 Parameter_Types
: Node_Id
renames Args
(3);
13653 Result_Type
: Node_Id
renames Args
(4);
13654 Mechanism
: Node_Id
renames Args
(5);
13655 Result_Mechanism
: Node_Id
renames Args
(6);
13659 Gather_Associations
(Names
, Args
);
13660 Process_Extended_Import_Export_Subprogram_Pragma
(
13661 Arg_Internal
=> Internal
,
13662 Arg_External
=> External
,
13663 Arg_Parameter_Types
=> Parameter_Types
,
13664 Arg_Result_Type
=> Result_Type
,
13665 Arg_Mechanism
=> Mechanism
,
13666 Arg_Result_Mechanism
=> Result_Mechanism
);
13667 end Export_Function
;
13669 -------------------
13670 -- Export_Object --
13671 -------------------
13673 -- pragma Export_Object (
13674 -- [Internal =>] LOCAL_NAME
13675 -- [, [External =>] EXTERNAL_SYMBOL]
13676 -- [, [Size =>] EXTERNAL_SYMBOL]);
13678 -- EXTERNAL_SYMBOL ::=
13680 -- | static_string_EXPRESSION
13682 -- PARAMETER_TYPES ::=
13684 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13686 -- TYPE_DESIGNATOR ::=
13688 -- | subtype_Name ' Access
13692 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13694 -- MECHANISM_ASSOCIATION ::=
13695 -- [formal_parameter_NAME =>] MECHANISM_NAME
13697 -- MECHANISM_NAME ::=
13701 when Pragma_Export_Object
=> Export_Object
: declare
13702 Args
: Args_List
(1 .. 3);
13703 Names
: constant Name_List
(1 .. 3) := (
13708 Internal
: Node_Id
renames Args
(1);
13709 External
: Node_Id
renames Args
(2);
13710 Size
: Node_Id
renames Args
(3);
13714 Gather_Associations
(Names
, Args
);
13715 Process_Extended_Import_Export_Object_Pragma
(
13716 Arg_Internal
=> Internal
,
13717 Arg_External
=> External
,
13721 ----------------------
13722 -- Export_Procedure --
13723 ----------------------
13725 -- pragma Export_Procedure (
13726 -- [Internal =>] LOCAL_NAME
13727 -- [, [External =>] EXTERNAL_SYMBOL]
13728 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13729 -- [, [Mechanism =>] MECHANISM]);
13731 -- EXTERNAL_SYMBOL ::=
13733 -- | static_string_EXPRESSION
13735 -- PARAMETER_TYPES ::=
13737 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13739 -- TYPE_DESIGNATOR ::=
13741 -- | subtype_Name ' Access
13745 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13747 -- MECHANISM_ASSOCIATION ::=
13748 -- [formal_parameter_NAME =>] MECHANISM_NAME
13750 -- MECHANISM_NAME ::=
13754 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13755 Args
: Args_List
(1 .. 4);
13756 Names
: constant Name_List
(1 .. 4) := (
13759 Name_Parameter_Types
,
13762 Internal
: Node_Id
renames Args
(1);
13763 External
: Node_Id
renames Args
(2);
13764 Parameter_Types
: Node_Id
renames Args
(3);
13765 Mechanism
: Node_Id
renames Args
(4);
13769 Gather_Associations
(Names
, Args
);
13770 Process_Extended_Import_Export_Subprogram_Pragma
(
13771 Arg_Internal
=> Internal
,
13772 Arg_External
=> External
,
13773 Arg_Parameter_Types
=> Parameter_Types
,
13774 Arg_Mechanism
=> Mechanism
);
13775 end Export_Procedure
;
13781 -- pragma Export_Value (
13782 -- [Value =>] static_integer_EXPRESSION,
13783 -- [Link_Name =>] static_string_EXPRESSION);
13785 when Pragma_Export_Value
=>
13787 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13788 Check_Arg_Count
(2);
13790 Check_Optional_Identifier
(Arg1
, Name_Value
);
13791 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13793 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13794 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13796 -----------------------------
13797 -- Export_Valued_Procedure --
13798 -----------------------------
13800 -- pragma Export_Valued_Procedure (
13801 -- [Internal =>] LOCAL_NAME
13802 -- [, [External =>] EXTERNAL_SYMBOL,]
13803 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13804 -- [, [Mechanism =>] MECHANISM]);
13806 -- EXTERNAL_SYMBOL ::=
13808 -- | static_string_EXPRESSION
13810 -- PARAMETER_TYPES ::=
13812 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13814 -- TYPE_DESIGNATOR ::=
13816 -- | subtype_Name ' Access
13820 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13822 -- MECHANISM_ASSOCIATION ::=
13823 -- [formal_parameter_NAME =>] MECHANISM_NAME
13825 -- MECHANISM_NAME ::=
13829 when Pragma_Export_Valued_Procedure
=>
13830 Export_Valued_Procedure
: declare
13831 Args
: Args_List
(1 .. 4);
13832 Names
: constant Name_List
(1 .. 4) := (
13835 Name_Parameter_Types
,
13838 Internal
: Node_Id
renames Args
(1);
13839 External
: Node_Id
renames Args
(2);
13840 Parameter_Types
: Node_Id
renames Args
(3);
13841 Mechanism
: Node_Id
renames Args
(4);
13845 Gather_Associations
(Names
, Args
);
13846 Process_Extended_Import_Export_Subprogram_Pragma
(
13847 Arg_Internal
=> Internal
,
13848 Arg_External
=> External
,
13849 Arg_Parameter_Types
=> Parameter_Types
,
13850 Arg_Mechanism
=> Mechanism
);
13851 end Export_Valued_Procedure
;
13853 -------------------
13854 -- Extend_System --
13855 -------------------
13857 -- pragma Extend_System ([Name =>] Identifier);
13859 when Pragma_Extend_System
=> Extend_System
: declare
13862 Check_Valid_Configuration_Pragma
;
13863 Check_Arg_Count
(1);
13864 Check_Optional_Identifier
(Arg1
, Name_Name
);
13865 Check_Arg_Is_Identifier
(Arg1
);
13867 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13870 and then Name_Buffer
(1 .. 4) = "aux_"
13872 if Present
(System_Extend_Pragma_Arg
) then
13873 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13874 Chars
(Expression
(System_Extend_Pragma_Arg
))
13878 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13879 Error_Pragma
("pragma% conflicts with that #");
13883 System_Extend_Pragma_Arg
:= Arg1
;
13885 if not GNAT_Mode
then
13886 System_Extend_Unit
:= Arg1
;
13890 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13894 ------------------------
13895 -- Extensions_Allowed --
13896 ------------------------
13898 -- pragma Extensions_Allowed (ON | OFF);
13900 when Pragma_Extensions_Allowed
=>
13902 Check_Arg_Count
(1);
13903 Check_No_Identifiers
;
13904 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13906 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13907 Extensions_Allowed
:= True;
13908 Ada_Version
:= Ada_Version_Type
'Last;
13911 Extensions_Allowed
:= False;
13912 Ada_Version
:= Ada_Version_Explicit
;
13913 Ada_Version_Pragma
:= Empty
;
13916 ------------------------
13917 -- Extensions_Visible --
13918 ------------------------
13920 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13922 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13923 Context
: constant Node_Id
:= Parent
(N
);
13925 Formal
: Entity_Id
;
13929 Has_OK_Formal
: Boolean := False;
13933 Check_No_Identifiers
;
13934 Check_At_Most_N_Arguments
(1);
13938 while Present
(Stmt
) loop
13940 -- Skip prior pragmas, but check for duplicates
13942 if Nkind
(Stmt
) = N_Pragma
then
13943 if Pragma_Name
(Stmt
) = Pname
then
13944 Error_Msg_Name_1
:= Pname
;
13945 Error_Msg_Sloc
:= Sloc
(Stmt
);
13946 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13949 -- Skip internally generated code
13951 elsif not Comes_From_Source
(Stmt
) then
13954 -- The associated [generic] subprogram declaration has been
13955 -- found, stop the search.
13957 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
13958 N_Subprogram_Declaration
)
13960 Subp
:= Defining_Entity
(Stmt
);
13963 -- The pragma does not apply to a legal construct, issue an
13964 -- error and stop the analysis.
13967 Error_Pragma
("pragma % must apply to a subprogram");
13971 Stmt
:= Prev
(Stmt
);
13974 -- When the pragma applies to a stand alone subprogram body, it
13975 -- appears within the declarations of the body. In that case the
13976 -- enclosing construct is the proper context. This check is done
13977 -- after the traversal above to allow for duplicate detection.
13980 and then Nkind
(Context
) = N_Subprogram_Body
13981 and then No
(Corresponding_Spec
(Context
))
13983 Subp
:= Defining_Entity
(Context
);
13987 Error_Pragma
("pragma % must apply to a subprogram");
13991 -- Examine the formals of the related subprogram
13993 Formal
:= First_Formal
(Subp
);
13994 while Present
(Formal
) loop
13996 -- At least one of the formals is of a specific tagged type,
13997 -- the pragma is legal.
13999 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
14000 Has_OK_Formal
:= True;
14003 -- A generic subprogram with at least one formal of a private
14004 -- type ensures the legality of the pragma because the actual
14005 -- may be specifically tagged. Note that this is verified by
14006 -- the check above at instantiation time.
14008 elsif Is_Private_Type
(Etype
(Formal
))
14009 and then Is_Generic_Type
(Etype
(Formal
))
14011 Has_OK_Formal
:= True;
14015 Next_Formal
(Formal
);
14018 if not Has_OK_Formal
then
14019 Error_Msg_Name_1
:= Pname
;
14020 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
14022 ("\subprogram & lacks parameter of specific tagged or "
14023 & "generic private type", N
, Subp
);
14027 -- Analyze the Boolean expression (if any)
14029 if Present
(Arg1
) then
14030 Expr
:= Get_Pragma_Arg
(Arg1
);
14032 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14034 if not Is_OK_Static_Expression
(Expr
) then
14036 ("expression of pragma % must be static", Expr
);
14041 -- Chain the pragma on the contract for further processing
14043 Add_Contract_Item
(N
, Subp
);
14044 end Extensions_Visible
;
14050 -- pragma External (
14051 -- [ Convention =>] convention_IDENTIFIER,
14052 -- [ Entity =>] LOCAL_NAME
14053 -- [, [External_Name =>] static_string_EXPRESSION ]
14054 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14056 when Pragma_External
=> External
: declare
14057 Def_Id
: Entity_Id
;
14060 pragma Warnings
(Off
, C
);
14067 Name_External_Name
,
14069 Check_At_Least_N_Arguments
(2);
14070 Check_At_Most_N_Arguments
(4);
14071 Process_Convention
(C
, Def_Id
);
14072 Note_Possible_Modification
14073 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14074 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14075 Set_Exported
(Def_Id
, Arg2
);
14078 --------------------------
14079 -- External_Name_Casing --
14080 --------------------------
14082 -- pragma External_Name_Casing (
14083 -- UPPERCASE | LOWERCASE
14084 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14086 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14089 Check_No_Identifiers
;
14091 if Arg_Count
= 2 then
14092 Check_Arg_Is_One_Of
14093 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14095 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14097 Opt
.External_Name_Exp_Casing
:= As_Is
;
14099 when Name_Uppercase
=>
14100 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14102 when Name_Lowercase
=>
14103 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14110 Check_Arg_Count
(1);
14113 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14115 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14116 when Name_Uppercase
=>
14117 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14119 when Name_Lowercase
=>
14120 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14125 end External_Name_Casing
;
14131 -- pragma Fast_Math;
14133 when Pragma_Fast_Math
=>
14135 Check_No_Identifiers
;
14136 Check_Valid_Configuration_Pragma
;
14139 --------------------------
14140 -- Favor_Top_Level --
14141 --------------------------
14143 -- pragma Favor_Top_Level (type_NAME);
14145 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14146 Named_Entity
: Entity_Id
;
14150 Check_No_Identifiers
;
14151 Check_Arg_Count
(1);
14152 Check_Arg_Is_Local_Name
(Arg1
);
14153 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14155 -- If it's an access-to-subprogram type (in particular, not a
14156 -- subtype), set the flag on that type.
14158 if Is_Access_Subprogram_Type
(Named_Entity
) then
14159 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14161 -- Otherwise it's an error (name denotes the wrong sort of entity)
14165 ("access-to-subprogram type expected",
14166 Get_Pragma_Arg
(Arg1
));
14168 end Favor_Top_Level
;
14170 ---------------------------
14171 -- Finalize_Storage_Only --
14172 ---------------------------
14174 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14176 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14177 Assoc
: constant Node_Id
:= Arg1
;
14178 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14183 Check_No_Identifiers
;
14184 Check_Arg_Count
(1);
14185 Check_Arg_Is_Local_Name
(Arg1
);
14187 Find_Type
(Type_Id
);
14188 Typ
:= Entity
(Type_Id
);
14191 or else Rep_Item_Too_Early
(Typ
, N
)
14195 Typ
:= Underlying_Type
(Typ
);
14198 if not Is_Controlled
(Typ
) then
14199 Error_Pragma
("pragma% must specify controlled type");
14202 Check_First_Subtype
(Arg1
);
14204 if Finalize_Storage_Only
(Typ
) then
14205 Error_Pragma
("duplicate pragma%, only one allowed");
14207 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14208 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14210 end Finalize_Storage
;
14216 -- pragma Ghost [ (boolean_EXPRESSION) ];
14218 when Pragma_Ghost
=> Ghost
: declare
14219 Context
: constant Node_Id
:= Parent
(N
);
14222 Orig_Stmt
: Node_Id
;
14223 Prev_Id
: Entity_Id
;
14228 Check_No_Identifiers
;
14229 Check_At_Most_N_Arguments
(1);
14233 while Present
(Stmt
) loop
14235 -- Skip prior pragmas, but check for duplicates
14237 if Nkind
(Stmt
) = N_Pragma
then
14238 if Pragma_Name
(Stmt
) = Pname
then
14239 Error_Msg_Name_1
:= Pname
;
14240 Error_Msg_Sloc
:= Sloc
(Stmt
);
14241 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14244 -- Protected and task types cannot be subject to pragma Ghost
14246 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
14247 Error_Pragma
("pragma % cannot apply to a protected type");
14250 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
14251 Error_Pragma
("pragma % cannot apply to a task type");
14254 -- Skip internally generated code
14256 elsif not Comes_From_Source
(Stmt
) then
14257 Orig_Stmt
:= Original_Node
(Stmt
);
14259 -- When pragma Ghost applies to an untagged derivation, the
14260 -- derivation is transformed into a [sub]type declaration.
14262 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14263 N_Subtype_Declaration
)
14264 and then Comes_From_Source
(Orig_Stmt
)
14265 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14266 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14267 N_Derived_Type_Definition
14269 Id
:= Defining_Entity
(Stmt
);
14272 -- When pragma Ghost applies to an expression function, the
14273 -- expression function is transformed into a subprogram.
14275 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14276 and then Comes_From_Source
(Orig_Stmt
)
14277 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14279 Id
:= Defining_Entity
(Stmt
);
14283 -- The pragma applies to a legal construct, stop the traversal
14285 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14286 N_Full_Type_Declaration
,
14287 N_Generic_Subprogram_Declaration
,
14288 N_Object_Declaration
,
14289 N_Private_Extension_Declaration
,
14290 N_Private_Type_Declaration
,
14291 N_Subprogram_Declaration
,
14292 N_Subtype_Declaration
)
14294 Id
:= Defining_Entity
(Stmt
);
14297 -- The pragma does not apply to a legal construct, issue an
14298 -- error and stop the analysis.
14302 ("pragma % must apply to an object, package, subprogram "
14307 Stmt
:= Prev
(Stmt
);
14312 -- When pragma Ghost is associated with a [generic] package, it
14313 -- appears in the visible declarations.
14315 if Nkind
(Context
) = N_Package_Specification
14316 and then Present
(Visible_Declarations
(Context
))
14317 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14319 Id
:= Defining_Entity
(Context
);
14321 -- Pragma Ghost applies to a stand alone subprogram body
14323 elsif Nkind
(Context
) = N_Subprogram_Body
14324 and then No
(Corresponding_Spec
(Context
))
14326 Id
:= Defining_Entity
(Context
);
14332 ("pragma % must apply to an object, package, subprogram or "
14337 -- A derived type or type extension cannot be subject to pragma
14338 -- Ghost if either the parent type or one of the progenitor types
14339 -- is not Ghost (SPARK RM 6.9(9)).
14341 if Is_Derived_Type
(Id
) then
14342 Check_Ghost_Derivation
(Id
);
14345 -- Handle completions of types and constants that are subject to
14348 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14349 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14351 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14352 Error_Msg_Name_1
:= Pname
;
14354 -- The full declaration of a deferred constant cannot be
14355 -- subject to pragma Ghost unless the deferred declaration
14356 -- is also Ghost (SPARK RM 6.9(10)).
14358 if Ekind
(Prev_Id
) = E_Constant
then
14359 Error_Msg_Name_1
:= Pname
;
14360 Error_Msg_NE
(Fix_Error
14361 ("pragma % must apply to declaration of deferred "
14362 & "constant &"), N
, Id
);
14365 -- Pragma Ghost may appear on the full view of an incomplete
14366 -- type because the incomplete declaration lacks aspects and
14367 -- cannot be subject to pragma Ghost.
14369 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14372 -- The full declaration of a type cannot be subject to
14373 -- pragma Ghost unless the partial view is also Ghost
14374 -- (SPARK RM 6.9(10)).
14377 Error_Msg_NE
(Fix_Error
14378 ("pragma % must apply to partial view of type &"),
14385 -- Analyze the Boolean expression (if any)
14387 if Present
(Arg1
) then
14388 Expr
:= Get_Pragma_Arg
(Arg1
);
14390 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14392 if Is_OK_Static_Expression
(Expr
) then
14394 -- "Ghostness" cannot be turned off once enabled within a
14395 -- region (SPARK RM 6.9(7)).
14397 if Is_False
(Expr_Value
(Expr
))
14398 and then Within_Ghost_Scope
14401 ("pragma % with value False cannot appear in enabled "
14406 -- Otherwie the expression is not static
14410 ("expression of pragma % must be static", Expr
);
14415 Set_Is_Ghost_Entity
(Id
);
14422 -- pragma Global (GLOBAL_SPECIFICATION);
14424 -- GLOBAL_SPECIFICATION ::=
14427 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14429 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14431 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14432 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14433 -- GLOBAL_ITEM ::= NAME
14435 when Pragma_Global
=> Global
: declare
14436 Subp_Decl
: Node_Id
;
14440 Check_Arg_Count
(1);
14441 Ensure_Aggregate_Form
(Arg1
);
14443 -- Ensure the proper placement of the pragma. Global must be
14444 -- associated with a subprogram declaration or a body that acts
14448 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14450 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14453 -- Body acts as spec
14455 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14456 and then No
(Corresponding_Spec
(Subp_Decl
))
14460 -- Body stub acts as spec
14462 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14463 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14472 -- When the pragma appears on a subprogram body, perform the full
14475 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14476 Analyze_Global_In_Decl_Part
(N
);
14478 -- When Global applies to a subprogram compilation unit, the
14479 -- corresponding pragma is placed after the unit's declaration
14480 -- node and needs to be analyzed immediately.
14482 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14483 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14485 Analyze_Global_In_Decl_Part
(N
);
14488 -- Chain the pragma on the contract for further processing
14490 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14497 -- pragma Ident (static_string_EXPRESSION)
14499 -- Note: pragma Comment shares this processing. Pragma Ident is
14500 -- identical in effect to pragma Commment.
14502 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14507 Check_Arg_Count
(1);
14508 Check_No_Identifiers
;
14509 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14512 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14519 GP
:= Parent
(Parent
(N
));
14521 if Nkind_In
(GP
, N_Package_Declaration
,
14522 N_Generic_Package_Declaration
)
14527 -- If we have a compilation unit, then record the ident value,
14528 -- checking for improper duplication.
14530 if Nkind
(GP
) = N_Compilation_Unit
then
14531 CS
:= Ident_String
(Current_Sem_Unit
);
14533 if Present
(CS
) then
14535 -- If we have multiple instances, concatenate them, but
14536 -- not in ASIS, where we want the original tree.
14538 if not ASIS_Mode
then
14539 Start_String
(Strval
(CS
));
14540 Store_String_Char
(' ');
14541 Store_String_Chars
(Strval
(Str
));
14542 Set_Strval
(CS
, End_String
);
14546 Set_Ident_String
(Current_Sem_Unit
, Str
);
14549 -- For subunits, we just ignore the Ident, since in GNAT these
14550 -- are not separate object files, and hence not separate units
14551 -- in the unit table.
14553 elsif Nkind
(GP
) = N_Subunit
then
14559 ----------------------------
14560 -- Implementation_Defined --
14561 ----------------------------
14563 -- pragma Implementation_Defined (LOCAL_NAME);
14565 -- Marks previously declared entity as implementation defined. For
14566 -- an overloaded entity, applies to the most recent homonym.
14568 -- pragma Implementation_Defined;
14570 -- The form with no arguments appears anywhere within a scope, most
14571 -- typically a package spec, and indicates that all entities that are
14572 -- defined within the package spec are Implementation_Defined.
14574 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14579 Check_No_Identifiers
;
14581 -- Form with no arguments
14583 if Arg_Count
= 0 then
14584 Set_Is_Implementation_Defined
(Current_Scope
);
14586 -- Form with one argument
14589 Check_Arg_Count
(1);
14590 Check_Arg_Is_Local_Name
(Arg1
);
14591 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14592 Set_Is_Implementation_Defined
(Ent
);
14594 end Implementation_Defined
;
14600 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14602 -- IMPLEMENTATION_KIND ::=
14603 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14605 -- "By_Any" and "Optional" are treated as synonyms in order to
14606 -- support Ada 2012 aspect Synchronization.
14608 when Pragma_Implemented
=> Implemented
: declare
14609 Proc_Id
: Entity_Id
;
14614 Check_Arg_Count
(2);
14615 Check_No_Identifiers
;
14616 Check_Arg_Is_Identifier
(Arg1
);
14617 Check_Arg_Is_Local_Name
(Arg1
);
14618 Check_Arg_Is_One_Of
(Arg2
,
14621 Name_By_Protected_Procedure
,
14624 -- Extract the name of the local procedure
14626 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14628 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14629 -- primitive procedure of a synchronized tagged type.
14631 if Ekind
(Proc_Id
) = E_Procedure
14632 and then Is_Primitive
(Proc_Id
)
14633 and then Present
(First_Formal
(Proc_Id
))
14635 Typ
:= Etype
(First_Formal
(Proc_Id
));
14637 if Is_Tagged_Type
(Typ
)
14640 -- Check for a protected, a synchronized or a task interface
14642 ((Is_Interface
(Typ
)
14643 and then Is_Synchronized_Interface
(Typ
))
14645 -- Check for a protected type or a task type that implements
14649 (Is_Concurrent_Record_Type
(Typ
)
14650 and then Present
(Interfaces
(Typ
)))
14652 -- Check for a private record extension with keyword
14656 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14657 E_Record_Subtype_With_Private
)
14658 and then Synchronized_Present
(Parent
(Typ
))))
14663 ("controlling formal must be of synchronized tagged type",
14668 -- Procedures declared inside a protected type must be accepted
14670 elsif Ekind
(Proc_Id
) = E_Procedure
14671 and then Is_Protected_Type
(Scope
(Proc_Id
))
14675 -- The first argument is not a primitive procedure
14679 ("pragma % must be applied to a primitive procedure", Arg1
);
14683 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14684 -- By_Protected_Procedure to the primitive procedure of a task
14687 if Chars
(Arg2
) = Name_By_Protected_Procedure
14688 and then Is_Interface
(Typ
)
14689 and then Is_Task_Interface
(Typ
)
14692 ("implementation kind By_Protected_Procedure cannot be "
14693 & "applied to a task interface primitive", Arg2
);
14697 Record_Rep_Item
(Proc_Id
, N
);
14700 ----------------------
14701 -- Implicit_Packing --
14702 ----------------------
14704 -- pragma Implicit_Packing;
14706 when Pragma_Implicit_Packing
=>
14708 Check_Arg_Count
(0);
14709 Implicit_Packing
:= True;
14716 -- [Convention =>] convention_IDENTIFIER,
14717 -- [Entity =>] LOCAL_NAME
14718 -- [, [External_Name =>] static_string_EXPRESSION ]
14719 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14721 when Pragma_Import
=>
14722 Check_Ada_83_Warning
;
14726 Name_External_Name
,
14729 Check_At_Least_N_Arguments
(2);
14730 Check_At_Most_N_Arguments
(4);
14731 Process_Import_Or_Interface
;
14733 ---------------------
14734 -- Import_Function --
14735 ---------------------
14737 -- pragma Import_Function (
14738 -- [Internal =>] LOCAL_NAME,
14739 -- [, [External =>] EXTERNAL_SYMBOL]
14740 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14741 -- [, [Result_Type =>] SUBTYPE_MARK]
14742 -- [, [Mechanism =>] MECHANISM]
14743 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14745 -- EXTERNAL_SYMBOL ::=
14747 -- | static_string_EXPRESSION
14749 -- PARAMETER_TYPES ::=
14751 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14753 -- TYPE_DESIGNATOR ::=
14755 -- | subtype_Name ' Access
14759 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14761 -- MECHANISM_ASSOCIATION ::=
14762 -- [formal_parameter_NAME =>] MECHANISM_NAME
14764 -- MECHANISM_NAME ::=
14768 when Pragma_Import_Function
=> Import_Function
: declare
14769 Args
: Args_List
(1 .. 6);
14770 Names
: constant Name_List
(1 .. 6) := (
14773 Name_Parameter_Types
,
14776 Name_Result_Mechanism
);
14778 Internal
: Node_Id
renames Args
(1);
14779 External
: Node_Id
renames Args
(2);
14780 Parameter_Types
: Node_Id
renames Args
(3);
14781 Result_Type
: Node_Id
renames Args
(4);
14782 Mechanism
: Node_Id
renames Args
(5);
14783 Result_Mechanism
: Node_Id
renames Args
(6);
14787 Gather_Associations
(Names
, Args
);
14788 Process_Extended_Import_Export_Subprogram_Pragma
(
14789 Arg_Internal
=> Internal
,
14790 Arg_External
=> External
,
14791 Arg_Parameter_Types
=> Parameter_Types
,
14792 Arg_Result_Type
=> Result_Type
,
14793 Arg_Mechanism
=> Mechanism
,
14794 Arg_Result_Mechanism
=> Result_Mechanism
);
14795 end Import_Function
;
14797 -------------------
14798 -- Import_Object --
14799 -------------------
14801 -- pragma Import_Object (
14802 -- [Internal =>] LOCAL_NAME
14803 -- [, [External =>] EXTERNAL_SYMBOL]
14804 -- [, [Size =>] EXTERNAL_SYMBOL]);
14806 -- EXTERNAL_SYMBOL ::=
14808 -- | static_string_EXPRESSION
14810 when Pragma_Import_Object
=> Import_Object
: declare
14811 Args
: Args_List
(1 .. 3);
14812 Names
: constant Name_List
(1 .. 3) := (
14817 Internal
: Node_Id
renames Args
(1);
14818 External
: Node_Id
renames Args
(2);
14819 Size
: Node_Id
renames Args
(3);
14823 Gather_Associations
(Names
, Args
);
14824 Process_Extended_Import_Export_Object_Pragma
(
14825 Arg_Internal
=> Internal
,
14826 Arg_External
=> External
,
14830 ----------------------
14831 -- Import_Procedure --
14832 ----------------------
14834 -- pragma Import_Procedure (
14835 -- [Internal =>] LOCAL_NAME
14836 -- [, [External =>] EXTERNAL_SYMBOL]
14837 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14838 -- [, [Mechanism =>] MECHANISM]);
14840 -- EXTERNAL_SYMBOL ::=
14842 -- | static_string_EXPRESSION
14844 -- PARAMETER_TYPES ::=
14846 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14848 -- TYPE_DESIGNATOR ::=
14850 -- | subtype_Name ' Access
14854 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14856 -- MECHANISM_ASSOCIATION ::=
14857 -- [formal_parameter_NAME =>] MECHANISM_NAME
14859 -- MECHANISM_NAME ::=
14863 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14864 Args
: Args_List
(1 .. 4);
14865 Names
: constant Name_List
(1 .. 4) := (
14868 Name_Parameter_Types
,
14871 Internal
: Node_Id
renames Args
(1);
14872 External
: Node_Id
renames Args
(2);
14873 Parameter_Types
: Node_Id
renames Args
(3);
14874 Mechanism
: Node_Id
renames Args
(4);
14878 Gather_Associations
(Names
, Args
);
14879 Process_Extended_Import_Export_Subprogram_Pragma
(
14880 Arg_Internal
=> Internal
,
14881 Arg_External
=> External
,
14882 Arg_Parameter_Types
=> Parameter_Types
,
14883 Arg_Mechanism
=> Mechanism
);
14884 end Import_Procedure
;
14886 -----------------------------
14887 -- Import_Valued_Procedure --
14888 -----------------------------
14890 -- pragma Import_Valued_Procedure (
14891 -- [Internal =>] LOCAL_NAME
14892 -- [, [External =>] EXTERNAL_SYMBOL]
14893 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14894 -- [, [Mechanism =>] MECHANISM]);
14896 -- EXTERNAL_SYMBOL ::=
14898 -- | static_string_EXPRESSION
14900 -- PARAMETER_TYPES ::=
14902 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14904 -- TYPE_DESIGNATOR ::=
14906 -- | subtype_Name ' Access
14910 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14912 -- MECHANISM_ASSOCIATION ::=
14913 -- [formal_parameter_NAME =>] MECHANISM_NAME
14915 -- MECHANISM_NAME ::=
14919 when Pragma_Import_Valued_Procedure
=>
14920 Import_Valued_Procedure
: declare
14921 Args
: Args_List
(1 .. 4);
14922 Names
: constant Name_List
(1 .. 4) := (
14925 Name_Parameter_Types
,
14928 Internal
: Node_Id
renames Args
(1);
14929 External
: Node_Id
renames Args
(2);
14930 Parameter_Types
: Node_Id
renames Args
(3);
14931 Mechanism
: Node_Id
renames Args
(4);
14935 Gather_Associations
(Names
, Args
);
14936 Process_Extended_Import_Export_Subprogram_Pragma
(
14937 Arg_Internal
=> Internal
,
14938 Arg_External
=> External
,
14939 Arg_Parameter_Types
=> Parameter_Types
,
14940 Arg_Mechanism
=> Mechanism
);
14941 end Import_Valued_Procedure
;
14947 -- pragma Independent (record_component_LOCAL_NAME);
14949 when Pragma_Independent
=> Independent
: declare
14954 Check_Ada_83_Warning
;
14956 Check_No_Identifiers
;
14957 Check_Arg_Count
(1);
14958 Check_Arg_Is_Local_Name
(Arg1
);
14959 E_Id
:= Get_Pragma_Arg
(Arg1
);
14961 if Etype
(E_Id
) = Any_Type
then
14965 E
:= Entity
(E_Id
);
14967 -- Check we have a record component. We have not yet setup
14968 -- components fully, so identify by syntactic structure.
14970 if Nkind
(Declaration_Node
(E
)) /= N_Component_Declaration
then
14972 ("argument for pragma% must be record component", Arg1
);
14975 -- Check duplicate before we chain ourselves
14977 Check_Duplicate_Pragma
(E
);
14981 if Rep_Item_Too_Early
(E
, N
)
14983 Rep_Item_Too_Late
(E
, N
)
14988 -- Set flag in component
14990 Set_Is_Independent
(E
);
14992 Independence_Checks
.Append
((N
, E
));
14995 ----------------------------
14996 -- Independent_Components --
14997 ----------------------------
14999 -- pragma Atomic_Components (array_LOCAL_NAME);
15001 -- This processing is shared by Volatile_Components
15003 when Pragma_Independent_Components
=> Independent_Components
: declare
15011 Check_Ada_83_Warning
;
15013 Check_No_Identifiers
;
15014 Check_Arg_Count
(1);
15015 Check_Arg_Is_Local_Name
(Arg1
);
15016 E_Id
:= Get_Pragma_Arg
(Arg1
);
15018 if Etype
(E_Id
) = Any_Type
then
15022 E
:= Entity
(E_Id
);
15024 -- Check duplicate before we chain ourselves
15026 Check_Duplicate_Pragma
(E
);
15028 -- Check appropriate entity
15030 if Rep_Item_Too_Early
(E
, N
)
15032 Rep_Item_Too_Late
(E
, N
)
15037 D
:= Declaration_Node
(E
);
15040 if K
= N_Full_Type_Declaration
15041 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15043 Independence_Checks
.Append
((N
, Base_Type
(E
)));
15044 Set_Has_Independent_Components
(Base_Type
(E
));
15046 -- For record type, set all components independent
15048 if Is_Record_Type
(E
) then
15049 C
:= First_Component
(E
);
15050 while Present
(C
) loop
15051 Set_Is_Independent
(C
);
15052 Next_Component
(C
);
15056 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15057 and then Nkind
(D
) = N_Object_Declaration
15058 and then Nkind
(Object_Definition
(D
)) =
15059 N_Constrained_Array_Definition
15061 Independence_Checks
.Append
((N
, Base_Type
(Etype
(E
))));
15062 Set_Has_Independent_Components
(Base_Type
(Etype
(E
)));
15065 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15067 end Independent_Components
;
15069 -----------------------
15070 -- Initial_Condition --
15071 -----------------------
15073 -- pragma Initial_Condition (boolean_EXPRESSION);
15075 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15076 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15077 Pack_Id
: Entity_Id
;
15082 Check_No_Identifiers
;
15083 Check_Arg_Count
(1);
15085 -- Ensure the proper placement of the pragma. Initial_Condition
15086 -- must be associated with a package declaration.
15088 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15089 N_Package_Declaration
)
15096 while Present
(Stmt
) loop
15098 -- Skip prior pragmas, but check for duplicates
15100 if Nkind
(Stmt
) = N_Pragma
then
15101 if Pragma_Name
(Stmt
) = Pname
then
15102 Error_Msg_Name_1
:= Pname
;
15103 Error_Msg_Sloc
:= Sloc
(Stmt
);
15104 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15107 -- Skip internally generated code
15109 elsif not Comes_From_Source
(Stmt
) then
15112 -- The pragma does not apply to a legal construct, issue an
15113 -- error and stop the analysis.
15120 Stmt
:= Prev
(Stmt
);
15123 -- The pragma must be analyzed at the end of the visible
15124 -- declarations of the related package. Save the pragma for later
15125 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15126 -- the contract of the package.
15128 Pack_Id
:= Defining_Entity
(Context
);
15129 Add_Contract_Item
(N
, Pack_Id
);
15131 -- Verify the declaration order of pragma Initial_Condition with
15132 -- respect to pragmas Abstract_State and Initializes when SPARK
15133 -- checks are enabled.
15135 if SPARK_Mode
/= Off
then
15136 Check_Declaration_Order
15137 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15140 Check_Declaration_Order
15141 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
15144 end Initial_Condition
;
15146 ------------------------
15147 -- Initialize_Scalars --
15148 ------------------------
15150 -- pragma Initialize_Scalars;
15152 when Pragma_Initialize_Scalars
=>
15154 Check_Arg_Count
(0);
15155 Check_Valid_Configuration_Pragma
;
15156 Check_Restriction
(No_Initialize_Scalars
, N
);
15158 -- Initialize_Scalars creates false positives in CodePeer, and
15159 -- incorrect negative results in GNATprove mode, so ignore this
15160 -- pragma in these modes.
15162 if not Restriction_Active
(No_Initialize_Scalars
)
15163 and then not (CodePeer_Mode
or GNATprove_Mode
)
15165 Init_Or_Norm_Scalars
:= True;
15166 Initialize_Scalars
:= True;
15173 -- pragma Initializes (INITIALIZATION_SPEC);
15175 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15177 -- INITIALIZATION_LIST ::=
15178 -- INITIALIZATION_ITEM
15179 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15181 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15186 -- | (INPUT {, INPUT})
15190 when Pragma_Initializes
=> Initializes
: declare
15191 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15192 Pack_Id
: Entity_Id
;
15197 Check_No_Identifiers
;
15198 Check_Arg_Count
(1);
15199 Ensure_Aggregate_Form
(Arg1
);
15201 -- Ensure the proper placement of the pragma. Initializes must be
15202 -- associated with a package declaration.
15204 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15205 N_Package_Declaration
)
15212 while Present
(Stmt
) loop
15214 -- Skip prior pragmas, but check for duplicates
15216 if Nkind
(Stmt
) = N_Pragma
then
15217 if Pragma_Name
(Stmt
) = Pname
then
15218 Error_Msg_Name_1
:= Pname
;
15219 Error_Msg_Sloc
:= Sloc
(Stmt
);
15220 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15223 -- Skip internally generated code
15225 elsif not Comes_From_Source
(Stmt
) then
15228 -- The pragma does not apply to a legal construct, issue an
15229 -- error and stop the analysis.
15236 Stmt
:= Prev
(Stmt
);
15239 -- The pragma must be analyzed at the end of the visible
15240 -- declarations of the related package. Save the pragma for later
15241 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15242 -- contract of the package.
15244 Pack_Id
:= Defining_Entity
(Context
);
15245 Add_Contract_Item
(N
, Pack_Id
);
15247 -- Verify the declaration order of pragmas Abstract_State and
15248 -- Initializes when SPARK checks are enabled.
15250 if SPARK_Mode
/= Off
then
15251 Check_Declaration_Order
15252 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15261 -- pragma Inline ( NAME {, NAME} );
15263 when Pragma_Inline
=>
15265 -- Pragma always active unless in GNATprove mode. It is disabled
15266 -- in GNATprove mode because frontend inlining is applied
15267 -- independently of pragmas Inline and Inline_Always for
15268 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15271 if not GNATprove_Mode
then
15273 -- Inline status is Enabled if inlining option is active
15275 if Inline_Active
then
15276 Process_Inline
(Enabled
);
15278 Process_Inline
(Disabled
);
15282 -------------------
15283 -- Inline_Always --
15284 -------------------
15286 -- pragma Inline_Always ( NAME {, NAME} );
15288 when Pragma_Inline_Always
=>
15291 -- Pragma always active unless in CodePeer mode or GNATprove
15292 -- mode. It is disabled in CodePeer mode because inlining is
15293 -- not helpful, and enabling it caused walk order issues. It
15294 -- is disabled in GNATprove mode because frontend inlining is
15295 -- applied independently of pragmas Inline and Inline_Always for
15296 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15299 if not CodePeer_Mode
and not GNATprove_Mode
then
15300 Process_Inline
(Enabled
);
15303 --------------------
15304 -- Inline_Generic --
15305 --------------------
15307 -- pragma Inline_Generic (NAME {, NAME});
15309 when Pragma_Inline_Generic
=>
15311 Process_Generic_List
;
15313 ----------------------
15314 -- Inspection_Point --
15315 ----------------------
15317 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15319 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15326 if Arg_Count
> 0 then
15329 Exp
:= Get_Pragma_Arg
(Arg
);
15332 if not Is_Entity_Name
(Exp
)
15333 or else not Is_Object
(Entity
(Exp
))
15335 Error_Pragma_Arg
("object name required", Arg
);
15339 exit when No
(Arg
);
15342 end Inspection_Point
;
15348 -- pragma Interface (
15349 -- [ Convention =>] convention_IDENTIFIER,
15350 -- [ Entity =>] LOCAL_NAME
15351 -- [, [External_Name =>] static_string_EXPRESSION ]
15352 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15354 when Pragma_Interface
=>
15359 Name_External_Name
,
15361 Check_At_Least_N_Arguments
(2);
15362 Check_At_Most_N_Arguments
(4);
15363 Process_Import_Or_Interface
;
15365 -- In Ada 2005, the permission to use Interface (a reserved word)
15366 -- as a pragma name is considered an obsolescent feature, and this
15367 -- pragma was already obsolescent in Ada 95.
15369 if Ada_Version
>= Ada_95
then
15371 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15373 if Warn_On_Obsolescent_Feature
then
15375 ("pragma Interface is an obsolescent feature?j?", N
);
15377 ("|use pragma Import instead?j?", N
);
15381 --------------------
15382 -- Interface_Name --
15383 --------------------
15385 -- pragma Interface_Name (
15386 -- [ Entity =>] LOCAL_NAME
15387 -- [,[External_Name =>] static_string_EXPRESSION ]
15388 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15390 when Pragma_Interface_Name
=> Interface_Name
: declare
15392 Def_Id
: Entity_Id
;
15393 Hom_Id
: Entity_Id
;
15399 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15400 Check_At_Least_N_Arguments
(2);
15401 Check_At_Most_N_Arguments
(3);
15402 Id
:= Get_Pragma_Arg
(Arg1
);
15405 -- This is obsolete from Ada 95 on, but it is an implementation
15406 -- defined pragma, so we do not consider that it violates the
15407 -- restriction (No_Obsolescent_Features).
15409 if Ada_Version
>= Ada_95
then
15410 if Warn_On_Obsolescent_Feature
then
15412 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15414 ("|use pragma Import instead?j?", N
);
15418 if not Is_Entity_Name
(Id
) then
15420 ("first argument for pragma% must be entity name", Arg1
);
15421 elsif Etype
(Id
) = Any_Type
then
15424 Def_Id
:= Entity
(Id
);
15427 -- Special DEC-compatible processing for the object case, forces
15428 -- object to be imported.
15430 if Ekind
(Def_Id
) = E_Variable
then
15431 Kill_Size_Check_Code
(Def_Id
);
15432 Note_Possible_Modification
(Id
, Sure
=> False);
15434 -- Initialization is not allowed for imported variable
15436 if Present
(Expression
(Parent
(Def_Id
)))
15437 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15439 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15441 ("no initialization allowed for declaration of& #",
15445 -- For compatibility, support VADS usage of providing both
15446 -- pragmas Interface and Interface_Name to obtain the effect
15447 -- of a single Import pragma.
15449 if Is_Imported
(Def_Id
)
15450 and then Present
(First_Rep_Item
(Def_Id
))
15451 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15453 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15457 Set_Imported
(Def_Id
);
15460 Set_Is_Public
(Def_Id
);
15461 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15464 -- Otherwise must be subprogram
15466 elsif not Is_Subprogram
(Def_Id
) then
15468 ("argument of pragma% is not subprogram", Arg1
);
15471 Check_At_Most_N_Arguments
(3);
15475 -- Loop through homonyms
15478 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15480 if Is_Imported
(Def_Id
) then
15481 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15485 exit when From_Aspect_Specification
(N
);
15486 Hom_Id
:= Homonym
(Hom_Id
);
15488 exit when No
(Hom_Id
)
15489 or else Scope
(Hom_Id
) /= Current_Scope
;
15494 ("argument of pragma% is not imported subprogram",
15498 end Interface_Name
;
15500 -----------------------
15501 -- Interrupt_Handler --
15502 -----------------------
15504 -- pragma Interrupt_Handler (handler_NAME);
15506 when Pragma_Interrupt_Handler
=>
15507 Check_Ada_83_Warning
;
15508 Check_Arg_Count
(1);
15509 Check_No_Identifiers
;
15511 if No_Run_Time_Mode
then
15512 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15514 Check_Interrupt_Or_Attach_Handler
;
15515 Process_Interrupt_Or_Attach_Handler
;
15518 ------------------------
15519 -- Interrupt_Priority --
15520 ------------------------
15522 -- pragma Interrupt_Priority [(EXPRESSION)];
15524 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15525 P
: constant Node_Id
:= Parent
(N
);
15530 Check_Ada_83_Warning
;
15532 if Arg_Count
/= 0 then
15533 Arg
:= Get_Pragma_Arg
(Arg1
);
15534 Check_Arg_Count
(1);
15535 Check_No_Identifiers
;
15537 -- The expression must be analyzed in the special manner
15538 -- described in "Handling of Default and Per-Object
15539 -- Expressions" in sem.ads.
15541 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15544 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15549 Ent
:= Defining_Identifier
(Parent
(P
));
15551 -- Check duplicate pragma before we chain the pragma in the Rep
15552 -- Item chain of Ent.
15554 Check_Duplicate_Pragma
(Ent
);
15555 Record_Rep_Item
(Ent
, N
);
15557 end Interrupt_Priority
;
15559 ---------------------
15560 -- Interrupt_State --
15561 ---------------------
15563 -- pragma Interrupt_State (
15564 -- [Name =>] INTERRUPT_ID,
15565 -- [State =>] INTERRUPT_STATE);
15567 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15568 -- INTERRUPT_STATE => System | Runtime | User
15570 -- Note: if the interrupt id is given as an identifier, then it must
15571 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15572 -- given as a static integer expression which must be in the range of
15573 -- Ada.Interrupts.Interrupt_ID.
15575 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15576 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15577 -- This is the entity Ada.Interrupts.Interrupt_ID;
15579 State_Type
: Character;
15580 -- Set to 's'/'r'/'u' for System/Runtime/User
15583 -- Index to entry in Interrupt_States table
15586 -- Value of interrupt
15588 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15589 -- The first argument to the pragma
15591 Int_Ent
: Entity_Id
;
15592 -- Interrupt entity in Ada.Interrupts.Names
15596 Check_Arg_Order
((Name_Name
, Name_State
));
15597 Check_Arg_Count
(2);
15599 Check_Optional_Identifier
(Arg1
, Name_Name
);
15600 Check_Optional_Identifier
(Arg2
, Name_State
);
15601 Check_Arg_Is_Identifier
(Arg2
);
15603 -- First argument is identifier
15605 if Nkind
(Arg1X
) = N_Identifier
then
15607 -- Search list of names in Ada.Interrupts.Names
15609 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15611 if No
(Int_Ent
) then
15612 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15614 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15615 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15619 Next_Entity
(Int_Ent
);
15622 -- First argument is not an identifier, so it must be a static
15623 -- expression of type Ada.Interrupts.Interrupt_ID.
15626 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15627 Int_Val
:= Expr_Value
(Arg1X
);
15629 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15631 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15634 ("value not in range of type "
15635 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15641 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15642 when Name_Runtime
=> State_Type
:= 'r';
15643 when Name_System
=> State_Type
:= 's';
15644 when Name_User
=> State_Type
:= 'u';
15647 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15650 -- Check if entry is already stored
15652 IST_Num
:= Interrupt_States
.First
;
15654 -- If entry not found, add it
15656 if IST_Num
> Interrupt_States
.Last
then
15657 Interrupt_States
.Append
15658 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15659 Interrupt_State
=> State_Type
,
15660 Pragma_Loc
=> Loc
));
15663 -- Case of entry for the same entry
15665 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15668 -- If state matches, done, no need to make redundant entry
15671 State_Type
= Interrupt_States
.Table
(IST_Num
).
15674 -- Otherwise if state does not match, error
15677 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15679 ("state conflicts with that given #", Arg2
);
15683 IST_Num
:= IST_Num
+ 1;
15685 end Interrupt_State
;
15691 -- pragma Invariant
15692 -- ([Entity =>] type_LOCAL_NAME,
15693 -- [Check =>] EXPRESSION
15694 -- [,[Message =>] String_Expression]);
15696 when Pragma_Invariant
=> Invariant
: declare
15703 Check_At_Least_N_Arguments
(2);
15704 Check_At_Most_N_Arguments
(3);
15705 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15706 Check_Optional_Identifier
(Arg2
, Name_Check
);
15708 if Arg_Count
= 3 then
15709 Check_Optional_Identifier
(Arg3
, Name_Message
);
15710 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15713 Check_Arg_Is_Local_Name
(Arg1
);
15715 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15716 Find_Type
(Type_Id
);
15717 Typ
:= Entity
(Type_Id
);
15719 if Typ
= Any_Type
then
15722 -- An invariant must apply to a private type, or appear in the
15723 -- private part of a package spec and apply to a completion.
15724 -- a class-wide invariant can only appear on a private declaration
15725 -- or private extension, not a completion.
15727 elsif Ekind_In
(Typ
, E_Private_Type
,
15728 E_Record_Type_With_Private
,
15729 E_Limited_Private_Type
)
15733 elsif In_Private_Part
(Current_Scope
)
15734 and then Has_Private_Declaration
(Typ
)
15735 and then not Class_Present
(N
)
15739 elsif In_Private_Part
(Current_Scope
) then
15741 ("pragma% only allowed for private type declared in "
15742 & "visible part", Arg1
);
15746 ("pragma% only allowed for private type", Arg1
);
15749 -- Note that the type has at least one invariant, and also that
15750 -- it has inheritable invariants if we have Invariant'Class
15751 -- or Type_Invariant'Class. Build the corresponding invariant
15752 -- procedure declaration, so that calls to it can be generated
15753 -- before the body is built (e.g. within an expression function).
15755 Insert_After_And_Analyze
15756 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15758 if Class_Present
(N
) then
15759 Set_Has_Inheritable_Invariants
(Typ
);
15762 -- The remaining processing is simply to link the pragma on to
15763 -- the rep item chain, for processing when the type is frozen.
15764 -- This is accomplished by a call to Rep_Item_Too_Late.
15766 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15769 ----------------------
15770 -- Java_Constructor --
15771 ----------------------
15773 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15775 -- Also handles pragma CIL_Constructor
15777 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15778 Java_Constructor
: declare
15779 Convention
: Convention_Id
;
15780 Def_Id
: Entity_Id
;
15781 Hom_Id
: Entity_Id
;
15783 This_Formal
: Entity_Id
;
15787 Check_Arg_Count
(1);
15788 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15789 Check_Arg_Is_Local_Name
(Arg1
);
15791 Id
:= Get_Pragma_Arg
(Arg1
);
15792 Find_Program_Unit_Name
(Id
);
15794 -- If we did not find the name, we are done
15796 if Etype
(Id
) = Any_Type
then
15800 -- Check wrong use of pragma in wrong VM target
15802 if VM_Target
= No_VM
then
15805 elsif VM_Target
= CLI_Target
15806 and then Prag_Id
= Pragma_Java_Constructor
15808 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15810 elsif VM_Target
= JVM_Target
15811 and then Prag_Id
= Pragma_CIL_Constructor
15813 Error_Pragma
("must use pragma 'Java_'Constructor");
15817 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15818 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15819 when others => null;
15822 Hom_Id
:= Entity
(Id
);
15824 -- Loop through homonyms
15827 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15829 -- The constructor is required to be a function
15831 if Ekind
(Def_Id
) /= E_Function
then
15832 if VM_Target
= JVM_Target
then
15834 ("pragma% requires function returning a 'Java access "
15838 ("pragma% requires function returning a 'C'I'L access "
15843 -- Check arguments: For tagged type the first formal must be
15844 -- named "this" and its type must be a named access type
15845 -- designating a class-wide tagged type that has convention
15846 -- CIL/Java. The first formal must also have a null default
15847 -- value. For example:
15849 -- type Typ is tagged ...
15850 -- type Ref is access all Typ;
15851 -- pragma Convention (CIL, Typ);
15853 -- function New_Typ (This : Ref) return Ref;
15854 -- function New_Typ (This : Ref; I : Integer) return Ref;
15855 -- pragma Cil_Constructor (New_Typ);
15857 -- Reason: The first formal must NOT be a primitive of the
15860 -- This rule also applies to constructors of delegates used
15861 -- to interface with standard target libraries. For example:
15863 -- type Delegate is access procedure ...
15864 -- pragma Import (CIL, Delegate, ...);
15866 -- function new_Delegate
15867 -- (This : Delegate := null; ... ) return Delegate;
15869 -- For value-types this rule does not apply.
15871 if not Is_Value_Type
(Etype
(Def_Id
)) then
15872 if No
(First_Formal
(Def_Id
)) then
15873 Error_Msg_Name_1
:= Pname
;
15874 Error_Msg_N
("% function must have parameters", Def_Id
);
15878 -- In the JRE library we have several occurrences in which
15879 -- the "this" parameter is not the first formal.
15881 This_Formal
:= First_Formal
(Def_Id
);
15883 -- In the JRE library we have several occurrences in which
15884 -- the "this" parameter is not the first formal. Search for
15887 if VM_Target
= JVM_Target
then
15888 while Present
(This_Formal
)
15889 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15891 Next_Formal
(This_Formal
);
15894 if No
(This_Formal
) then
15895 This_Formal
:= First_Formal
(Def_Id
);
15899 -- Warning: The first parameter should be named "this".
15900 -- We temporarily allow it because we have the following
15901 -- case in the Java runtime (file s-osinte.ads) ???
15903 -- function new_Thread
15904 -- (Self_Id : System.Address) return Thread_Id;
15905 -- pragma Java_Constructor (new_Thread);
15907 if VM_Target
= JVM_Target
15908 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15910 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15914 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15915 Error_Msg_Name_1
:= Pname
;
15917 ("first formal of % function must be named `this`",
15918 Parent
(This_Formal
));
15920 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15921 Error_Msg_Name_1
:= Pname
;
15923 ("first formal of % function must be an access type",
15924 Parameter_Type
(Parent
(This_Formal
)));
15926 -- For delegates the type of the first formal must be a
15927 -- named access-to-subprogram type (see previous example)
15929 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15930 and then Ekind
(Etype
(This_Formal
))
15931 /= E_Access_Subprogram_Type
15933 Error_Msg_Name_1
:= Pname
;
15935 ("first formal of % function must be a named access "
15936 & "to subprogram type",
15937 Parameter_Type
(Parent
(This_Formal
)));
15939 -- Warning: We should reject anonymous access types because
15940 -- the constructor must not be handled as a primitive of the
15941 -- tagged type. We temporarily allow it because this profile
15942 -- is currently generated by cil2ada???
15944 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15945 and then not Ekind_In
(Etype
(This_Formal
),
15947 E_General_Access_Type
,
15948 E_Anonymous_Access_Type
)
15950 Error_Msg_Name_1
:= Pname
;
15952 ("first formal of % function must be a named access "
15953 & "type", Parameter_Type
(Parent
(This_Formal
)));
15955 elsif Atree
.Convention
15956 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15958 Error_Msg_Name_1
:= Pname
;
15960 if Convention
= Convention_Java
then
15962 ("pragma% requires convention 'Cil in designated "
15963 & "type", Parameter_Type
(Parent
(This_Formal
)));
15966 ("pragma% requires convention 'Java in designated "
15967 & "type", Parameter_Type
(Parent
(This_Formal
)));
15970 elsif No
(Expression
(Parent
(This_Formal
)))
15971 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15973 Error_Msg_Name_1
:= Pname
;
15975 ("pragma% requires first formal with default `null`",
15976 Parameter_Type
(Parent
(This_Formal
)));
15980 -- Check result type: the constructor must be a function
15982 -- * a value type (only allowed in the CIL compiler)
15983 -- * an access-to-subprogram type with convention Java/CIL
15984 -- * an access-type designating a type that has convention
15987 if Is_Value_Type
(Etype
(Def_Id
)) then
15990 -- Access-to-subprogram type with convention Java/CIL
15992 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15993 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15994 if Convention
= Convention_Java
then
15996 ("pragma% requires function returning a 'Java "
15997 & "access type", Arg1
);
15999 pragma Assert
(Convention
= Convention_CIL
);
16001 ("pragma% requires function returning a 'C'I'L "
16002 & "access type", Arg1
);
16006 elsif Is_Access_Type
(Etype
(Def_Id
)) then
16007 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
16008 E_General_Access_Type
)
16011 (Designated_Type
(Etype
(Def_Id
))) /= Convention
16013 Error_Msg_Name_1
:= Pname
;
16015 if Convention
= Convention_Java
then
16017 ("pragma% requires function returning a named "
16018 & "'Java access type", Arg1
);
16021 ("pragma% requires function returning a named "
16022 & "'C'I'L access type", Arg1
);
16027 Set_Is_Constructor
(Def_Id
);
16028 Set_Convention
(Def_Id
, Convention
);
16029 Set_Is_Imported
(Def_Id
);
16031 exit when From_Aspect_Specification
(N
);
16032 Hom_Id
:= Homonym
(Hom_Id
);
16034 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
16036 end Java_Constructor
;
16038 ----------------------
16039 -- Java_Interface --
16040 ----------------------
16042 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16044 when Pragma_Java_Interface
=> Java_Interface
: declare
16050 Check_Arg_Count
(1);
16051 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16052 Check_Arg_Is_Local_Name
(Arg1
);
16054 Arg
:= Get_Pragma_Arg
(Arg1
);
16057 if Etype
(Arg
) = Any_Type
then
16061 if not Is_Entity_Name
(Arg
)
16062 or else not Is_Type
(Entity
(Arg
))
16064 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
16067 Typ
:= Underlying_Type
(Entity
(Arg
));
16069 -- For now simply check some of the semantic constraints on the
16070 -- type. This currently leaves out some restrictions on interface
16071 -- types, namely that the parent type must be java.lang.Object.Typ
16072 -- and that all primitives of the type should be declared
16075 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
16077 ("pragma% requires an abstract tagged type", Arg1
);
16079 elsif not Has_Discriminants
(Typ
)
16080 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
16081 /= E_Anonymous_Access_Type
16083 not Is_Class_Wide_Type
16084 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
16087 ("type must have a class-wide access discriminant", Arg1
);
16089 end Java_Interface
;
16095 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16097 when Pragma_Keep_Names
=> Keep_Names
: declare
16102 Check_Arg_Count
(1);
16103 Check_Optional_Identifier
(Arg1
, Name_On
);
16104 Check_Arg_Is_Local_Name
(Arg1
);
16106 Arg
:= Get_Pragma_Arg
(Arg1
);
16109 if Etype
(Arg
) = Any_Type
then
16113 if not Is_Entity_Name
(Arg
)
16114 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16117 ("pragma% requires a local enumeration type", Arg1
);
16120 Set_Discard_Names
(Entity
(Arg
), False);
16127 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16129 when Pragma_License
=>
16132 -- Do not analyze pragma any further in CodePeer mode, to avoid
16133 -- extraneous errors in this implementation-dependent pragma,
16134 -- which has a different profile on other compilers.
16136 if CodePeer_Mode
then
16140 Check_Arg_Count
(1);
16141 Check_No_Identifiers
;
16142 Check_Valid_Configuration_Pragma
;
16143 Check_Arg_Is_Identifier
(Arg1
);
16146 Sind
: constant Source_File_Index
:=
16147 Source_Index
(Current_Sem_Unit
);
16150 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16152 Set_License
(Sind
, GPL
);
16154 when Name_Modified_GPL
=>
16155 Set_License
(Sind
, Modified_GPL
);
16157 when Name_Restricted
=>
16158 Set_License
(Sind
, Restricted
);
16160 when Name_Unrestricted
=>
16161 Set_License
(Sind
, Unrestricted
);
16164 Error_Pragma_Arg
("invalid license name", Arg1
);
16172 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16174 when Pragma_Link_With
=> Link_With
: declare
16180 if Operating_Mode
= Generate_Code
16181 and then In_Extended_Main_Source_Unit
(N
)
16183 Check_At_Least_N_Arguments
(1);
16184 Check_No_Identifiers
;
16185 Check_Is_In_Decl_Part_Or_Package_Spec
;
16186 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16190 while Present
(Arg
) loop
16191 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16193 -- Store argument, converting sequences of spaces to a
16194 -- single null character (this is one of the differences
16195 -- in processing between Link_With and Linker_Options).
16197 Arg_Store
: declare
16198 C
: constant Char_Code
:= Get_Char_Code
(' ');
16199 S
: constant String_Id
:=
16200 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16201 L
: constant Nat
:= String_Length
(S
);
16204 procedure Skip_Spaces
;
16205 -- Advance F past any spaces
16211 procedure Skip_Spaces
is
16213 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16218 -- Start of processing for Arg_Store
16221 Skip_Spaces
; -- skip leading spaces
16223 -- Loop through characters, changing any embedded
16224 -- sequence of spaces to a single null character (this
16225 -- is how Link_With/Linker_Options differ)
16228 if Get_String_Char
(S
, F
) = C
then
16231 Store_String_Char
(ASCII
.NUL
);
16234 Store_String_Char
(Get_String_Char
(S
, F
));
16242 if Present
(Arg
) then
16243 Store_String_Char
(ASCII
.NUL
);
16247 Store_Linker_Option_String
(End_String
);
16255 -- pragma Linker_Alias (
16256 -- [Entity =>] LOCAL_NAME
16257 -- [Target =>] static_string_EXPRESSION);
16259 when Pragma_Linker_Alias
=>
16261 Check_Arg_Order
((Name_Entity
, Name_Target
));
16262 Check_Arg_Count
(2);
16263 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16264 Check_Optional_Identifier
(Arg2
, Name_Target
);
16265 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16266 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16268 -- The only processing required is to link this item on to the
16269 -- list of rep items for the given entity. This is accomplished
16270 -- by the call to Rep_Item_Too_Late (when no error is detected
16271 -- and False is returned).
16273 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16276 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16279 ------------------------
16280 -- Linker_Constructor --
16281 ------------------------
16283 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16285 -- Code is shared with Linker_Destructor
16287 -----------------------
16288 -- Linker_Destructor --
16289 -----------------------
16291 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16293 when Pragma_Linker_Constructor |
16294 Pragma_Linker_Destructor
=>
16295 Linker_Constructor
: declare
16301 Check_Arg_Count
(1);
16302 Check_No_Identifiers
;
16303 Check_Arg_Is_Local_Name
(Arg1
);
16304 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16306 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16308 if not Is_Library_Level_Entity
(Proc
) then
16310 ("argument for pragma% must be library level entity", Arg1
);
16313 -- The only processing required is to link this item on to the
16314 -- list of rep items for the given entity. This is accomplished
16315 -- by the call to Rep_Item_Too_Late (when no error is detected
16316 -- and False is returned).
16318 if Rep_Item_Too_Late
(Proc
, N
) then
16321 Set_Has_Gigi_Rep_Item
(Proc
);
16323 end Linker_Constructor
;
16325 --------------------
16326 -- Linker_Options --
16327 --------------------
16329 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16331 when Pragma_Linker_Options
=> Linker_Options
: declare
16335 Check_Ada_83_Warning
;
16336 Check_No_Identifiers
;
16337 Check_Arg_Count
(1);
16338 Check_Is_In_Decl_Part_Or_Package_Spec
;
16339 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16340 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16343 while Present
(Arg
) loop
16344 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16345 Store_String_Char
(ASCII
.NUL
);
16347 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16351 if Operating_Mode
= Generate_Code
16352 and then In_Extended_Main_Source_Unit
(N
)
16354 Store_Linker_Option_String
(End_String
);
16356 end Linker_Options
;
16358 --------------------
16359 -- Linker_Section --
16360 --------------------
16362 -- pragma Linker_Section (
16363 -- [Entity =>] LOCAL_NAME
16364 -- [Section =>] static_string_EXPRESSION);
16366 when Pragma_Linker_Section
=> Linker_Section
: declare
16372 Check_Arg_Order
((Name_Entity
, Name_Section
));
16373 Check_Arg_Count
(2);
16374 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16375 Check_Optional_Identifier
(Arg2
, Name_Section
);
16376 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16377 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16379 -- Check kind of entity
16381 Arg
:= Get_Pragma_Arg
(Arg1
);
16382 Ent
:= Entity
(Arg
);
16384 case Ekind
(Ent
) is
16386 -- Objects (constants and variables) and types. For these cases
16387 -- all we need to do is to set the Linker_Section_pragma field.
16389 when E_Constant | E_Variable | Type_Kind
=>
16390 Set_Linker_Section_Pragma
(Ent
, N
);
16394 when Subprogram_Kind
=>
16396 -- Aspect case, entity already set
16398 if From_Aspect_Specification
(N
) then
16399 Set_Linker_Section_Pragma
16400 (Entity
(Corresponding_Aspect
(N
)), N
);
16402 -- Pragma case, we must climb the homonym chain, but skip
16403 -- any for which the linker section is already set.
16407 if No
(Linker_Section_Pragma
(Ent
)) then
16408 Set_Linker_Section_Pragma
(Ent
, N
);
16411 Ent
:= Homonym
(Ent
);
16413 or else Scope
(Ent
) /= Current_Scope
;
16417 -- All other cases are illegal
16421 ("pragma% applies only to objects, subprograms, and types",
16424 end Linker_Section
;
16430 -- pragma List (On | Off)
16432 -- There is nothing to do here, since we did all the processing for
16433 -- this pragma in Par.Prag (so that it works properly even in syntax
16436 when Pragma_List
=>
16443 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16445 when Pragma_Lock_Free
=> Lock_Free
: declare
16446 P
: constant Node_Id
:= Parent
(N
);
16452 Check_No_Identifiers
;
16453 Check_At_Most_N_Arguments
(1);
16455 -- Protected definition case
16457 if Nkind
(P
) = N_Protected_Definition
then
16458 Ent
:= Defining_Identifier
(Parent
(P
));
16462 if Arg_Count
= 1 then
16463 Arg
:= Get_Pragma_Arg
(Arg1
);
16464 Val
:= Is_True
(Static_Boolean
(Arg
));
16466 -- No arguments (expression is considered to be True)
16472 -- Check duplicate pragma before we chain the pragma in the Rep
16473 -- Item chain of Ent.
16475 Check_Duplicate_Pragma
(Ent
);
16476 Record_Rep_Item
(Ent
, N
);
16477 Set_Uses_Lock_Free
(Ent
, Val
);
16479 -- Anything else is incorrect placement
16486 --------------------
16487 -- Locking_Policy --
16488 --------------------
16490 -- pragma Locking_Policy (policy_IDENTIFIER);
16492 when Pragma_Locking_Policy
=> declare
16493 subtype LP_Range
is Name_Id
16494 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16499 Check_Ada_83_Warning
;
16500 Check_Arg_Count
(1);
16501 Check_No_Identifiers
;
16502 Check_Arg_Is_Locking_Policy
(Arg1
);
16503 Check_Valid_Configuration_Pragma
;
16504 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16507 when Name_Ceiling_Locking
=>
16509 when Name_Inheritance_Locking
=>
16511 when Name_Concurrent_Readers_Locking
=>
16515 if Locking_Policy
/= ' '
16516 and then Locking_Policy
/= LP
16518 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16519 Error_Pragma
("locking policy incompatible with policy#");
16521 -- Set new policy, but always preserve System_Location since we
16522 -- like the error message with the run time name.
16525 Locking_Policy
:= LP
;
16527 if Locking_Policy_Sloc
/= System_Location
then
16528 Locking_Policy_Sloc
:= Loc
;
16533 -------------------
16534 -- Loop_Optimize --
16535 -------------------
16537 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16539 -- OPTIMIZATION_HINT ::=
16540 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16542 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16547 Check_At_Least_N_Arguments
(1);
16548 Check_No_Identifiers
;
16550 Hint
:= First
(Pragma_Argument_Associations
(N
));
16551 while Present
(Hint
) loop
16552 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16560 Check_Loop_Pragma_Placement
;
16567 -- pragma Loop_Variant
16568 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16570 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16572 -- CHANGE_DIRECTION ::= Increases | Decreases
16574 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16579 Check_At_Least_N_Arguments
(1);
16580 Check_Loop_Pragma_Placement
;
16582 -- Process all increasing / decreasing expressions
16584 Variant
:= First
(Pragma_Argument_Associations
(N
));
16585 while Present
(Variant
) loop
16586 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16589 Error_Pragma_Arg
("wrong change modifier", Variant
);
16592 Preanalyze_Assert_Expression
16593 (Expression
(Variant
), Any_Discrete
);
16599 -----------------------
16600 -- Machine_Attribute --
16601 -----------------------
16603 -- pragma Machine_Attribute (
16604 -- [Entity =>] LOCAL_NAME,
16605 -- [Attribute_Name =>] static_string_EXPRESSION
16606 -- [, [Info =>] static_EXPRESSION] );
16608 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16609 Def_Id
: Entity_Id
;
16613 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16615 if Arg_Count
= 3 then
16616 Check_Optional_Identifier
(Arg3
, Name_Info
);
16617 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16619 Check_Arg_Count
(2);
16622 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16623 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16624 Check_Arg_Is_Local_Name
(Arg1
);
16625 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16626 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16628 if Is_Access_Type
(Def_Id
) then
16629 Def_Id
:= Designated_Type
(Def_Id
);
16632 if Rep_Item_Too_Early
(Def_Id
, N
) then
16636 Def_Id
:= Underlying_Type
(Def_Id
);
16638 -- The only processing required is to link this item on to the
16639 -- list of rep items for the given entity. This is accomplished
16640 -- by the call to Rep_Item_Too_Late (when no error is detected
16641 -- and False is returned).
16643 if Rep_Item_Too_Late
(Def_Id
, N
) then
16646 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16648 end Machine_Attribute
;
16655 -- (MAIN_OPTION [, MAIN_OPTION]);
16658 -- [STACK_SIZE =>] static_integer_EXPRESSION
16659 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16660 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16662 when Pragma_Main
=> Main
: declare
16663 Args
: Args_List
(1 .. 3);
16664 Names
: constant Name_List
(1 .. 3) := (
16666 Name_Task_Stack_Size_Default
,
16667 Name_Time_Slicing_Enabled
);
16673 Gather_Associations
(Names
, Args
);
16675 for J
in 1 .. 2 loop
16676 if Present
(Args
(J
)) then
16677 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16681 if Present
(Args
(3)) then
16682 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16686 while Present
(Nod
) loop
16687 if Nkind
(Nod
) = N_Pragma
16688 and then Pragma_Name
(Nod
) = Name_Main
16690 Error_Msg_Name_1
:= Pname
;
16691 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16702 -- pragma Main_Storage
16703 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16705 -- MAIN_STORAGE_OPTION ::=
16706 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16707 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16709 when Pragma_Main_Storage
=> Main_Storage
: declare
16710 Args
: Args_List
(1 .. 2);
16711 Names
: constant Name_List
(1 .. 2) := (
16712 Name_Working_Storage
,
16719 Gather_Associations
(Names
, Args
);
16721 for J
in 1 .. 2 loop
16722 if Present
(Args
(J
)) then
16723 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16727 Check_In_Main_Program
;
16730 while Present
(Nod
) loop
16731 if Nkind
(Nod
) = N_Pragma
16732 and then Pragma_Name
(Nod
) = Name_Main_Storage
16734 Error_Msg_Name_1
:= Pname
;
16735 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16746 -- pragma Memory_Size (NUMERIC_LITERAL)
16748 when Pragma_Memory_Size
=>
16751 -- Memory size is simply ignored
16753 Check_No_Identifiers
;
16754 Check_Arg_Count
(1);
16755 Check_Arg_Is_Integer_Literal
(Arg1
);
16763 -- The only correct use of this pragma is on its own in a file, in
16764 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16765 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16766 -- check for a file containing nothing but a No_Body pragma). If we
16767 -- attempt to process it during normal semantics processing, it means
16768 -- it was misplaced.
16770 when Pragma_No_Body
=>
16774 -----------------------------
16775 -- No_Elaboration_Code_All --
16776 -----------------------------
16778 -- pragma No_Elaboration_Code_All;
16780 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16783 Check_Valid_Library_Unit_Pragma
;
16785 if Nkind
(N
) = N_Null_Statement
then
16789 -- Must appear for a spec
16791 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16792 N_Package_Declaration
,
16793 N_Subprogram_Declaration
)
16797 ("pragma% can only occur for package "
16798 & "or subprogram spec"));
16801 -- Set flag in unit table
16803 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16805 -- Set restriction No_Elaboration_Code
16807 Set_Restriction
(No_Elaboration_Code
, N
);
16809 -- If we are in the main unit or in an extended main source unit,
16810 -- then we also add it to the configuration restrictions so that
16811 -- it will apply to all units in the extended main source.
16813 if Current_Sem_Unit
= Main_Unit
16814 or else In_Extended_Main_Source_Unit
(N
)
16816 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16819 -- If in main extended unit, activate transitive with test
16821 if In_Extended_Main_Source_Unit
(N
) then
16822 Opt
.No_Elab_Code_All_Pragma
:= N
;
16830 -- pragma No_Inline ( NAME {, NAME} );
16832 when Pragma_No_Inline
=>
16834 Process_Inline
(Suppressed
);
16840 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16842 when Pragma_No_Return
=> No_Return
: declare
16850 Check_At_Least_N_Arguments
(1);
16852 -- Loop through arguments of pragma
16855 while Present
(Arg
) loop
16856 Check_Arg_Is_Local_Name
(Arg
);
16857 Id
:= Get_Pragma_Arg
(Arg
);
16860 if not Is_Entity_Name
(Id
) then
16861 Error_Pragma_Arg
("entity name required", Arg
);
16864 if Etype
(Id
) = Any_Type
then
16868 -- Loop to find matching procedures
16873 and then Scope
(E
) = Current_Scope
16875 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16878 -- Set flag on any alias as well
16880 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16881 Set_No_Return
(Alias
(E
));
16887 exit when From_Aspect_Specification
(N
);
16891 -- If entity in not in current scope it may be the enclosing
16892 -- suprogram body to which the aspect applies.
16895 if Entity
(Id
) = Current_Scope
16896 and then From_Aspect_Specification
(N
)
16898 Set_No_Return
(Entity
(Id
));
16900 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16912 -- pragma No_Run_Time;
16914 -- Note: this pragma is retained for backwards compatibility. See
16915 -- body of Rtsfind for full details on its handling.
16917 when Pragma_No_Run_Time
=>
16919 Check_Valid_Configuration_Pragma
;
16920 Check_Arg_Count
(0);
16922 No_Run_Time_Mode
:= True;
16923 Configurable_Run_Time_Mode
:= True;
16925 -- Set Duration to 32 bits if word size is 32
16927 if Ttypes
.System_Word_Size
= 32 then
16928 Duration_32_Bits_On_Target
:= True;
16931 -- Set appropriate restrictions
16933 Set_Restriction
(No_Finalization
, N
);
16934 Set_Restriction
(No_Exception_Handlers
, N
);
16935 Set_Restriction
(Max_Tasks
, N
, 0);
16936 Set_Restriction
(No_Tasking
, N
);
16938 -----------------------
16939 -- No_Tagged_Streams --
16940 -----------------------
16942 -- pragma No_Tagged_Streams;
16943 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16945 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16951 Check_At_Most_N_Arguments
(1);
16953 -- One argument case
16955 if Arg_Count
= 1 then
16956 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16957 Check_Arg_Is_Local_Name
(Arg1
);
16958 E_Id
:= Get_Pragma_Arg
(Arg1
);
16960 if Etype
(E_Id
) = Any_Type
then
16964 E
:= Entity
(E_Id
);
16966 Check_Duplicate_Pragma
(E
);
16968 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16970 ("argument for pragma% must be root tagged type", Arg1
);
16973 if Rep_Item_Too_Early
(E
, N
)
16975 Rep_Item_Too_Late
(E
, N
)
16979 Set_No_Tagged_Streams_Pragma
(E
, N
);
16982 -- Zero argument case
16985 Check_Is_In_Decl_Part_Or_Package_Spec
;
16986 No_Tagged_Streams
:= N
;
16988 end No_Tagged_Strms
;
16990 ------------------------
16991 -- No_Strict_Aliasing --
16992 ------------------------
16994 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16996 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
17001 Check_At_Most_N_Arguments
(1);
17003 if Arg_Count
= 0 then
17004 Check_Valid_Configuration_Pragma
;
17005 Opt
.No_Strict_Aliasing
:= True;
17008 Check_Optional_Identifier
(Arg2
, Name_Entity
);
17009 Check_Arg_Is_Local_Name
(Arg1
);
17010 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17012 if E_Id
= Any_Type
then
17014 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
17015 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
17018 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
17020 end No_Strict_Aliasing
;
17022 -----------------------
17023 -- Normalize_Scalars --
17024 -----------------------
17026 -- pragma Normalize_Scalars;
17028 when Pragma_Normalize_Scalars
=>
17029 Check_Ada_83_Warning
;
17030 Check_Arg_Count
(0);
17031 Check_Valid_Configuration_Pragma
;
17033 -- Normalize_Scalars creates false positives in CodePeer, and
17034 -- incorrect negative results in GNATprove mode, so ignore this
17035 -- pragma in these modes.
17037 if not (CodePeer_Mode
or GNATprove_Mode
) then
17038 Normalize_Scalars
:= True;
17039 Init_Or_Norm_Scalars
:= True;
17046 -- pragma Obsolescent;
17048 -- pragma Obsolescent (
17049 -- [Message =>] static_string_EXPRESSION
17050 -- [,[Version =>] Ada_05]]);
17052 -- pragma Obsolescent (
17053 -- [Entity =>] NAME
17054 -- [,[Message =>] static_string_EXPRESSION
17055 -- [,[Version =>] Ada_05]] );
17057 when Pragma_Obsolescent
=> Obsolescent
: declare
17061 procedure Set_Obsolescent
(E
: Entity_Id
);
17062 -- Given an entity Ent, mark it as obsolescent if appropriate
17064 ---------------------
17065 -- Set_Obsolescent --
17066 ---------------------
17068 procedure Set_Obsolescent
(E
: Entity_Id
) is
17077 -- Entity name was given
17079 if Present
(Ename
) then
17081 -- If entity name matches, we are fine. Save entity in
17082 -- pragma argument, for ASIS use.
17084 if Chars
(Ename
) = Chars
(Ent
) then
17085 Set_Entity
(Ename
, Ent
);
17086 Generate_Reference
(Ent
, Ename
);
17088 -- If entity name does not match, only possibility is an
17089 -- enumeration literal from an enumeration type declaration.
17091 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17093 ("pragma % entity name does not match declaration");
17096 Ent
:= First_Literal
(E
);
17100 ("pragma % entity name does not match any "
17101 & "enumeration literal");
17103 elsif Chars
(Ent
) = Chars
(Ename
) then
17104 Set_Entity
(Ename
, Ent
);
17105 Generate_Reference
(Ent
, Ename
);
17109 Ent
:= Next_Literal
(Ent
);
17115 -- Ent points to entity to be marked
17117 if Arg_Count
>= 1 then
17119 -- Deal with static string argument
17121 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17122 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17124 for J
in 1 .. String_Length
(S
) loop
17125 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17127 ("pragma% argument does not allow wide characters",
17132 Obsolescent_Warnings
.Append
17133 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17135 -- Check for Ada_05 parameter
17137 if Arg_Count
/= 1 then
17138 Check_Arg_Count
(2);
17141 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17144 Check_Arg_Is_Identifier
(Argx
);
17146 if Chars
(Argx
) /= Name_Ada_05
then
17147 Error_Msg_Name_2
:= Name_Ada_05
;
17149 ("only allowed argument for pragma% is %", Argx
);
17152 if Ada_Version_Explicit
< Ada_2005
17153 or else not Warn_On_Ada_2005_Compatibility
17161 -- Set flag if pragma active
17164 Set_Is_Obsolescent
(Ent
);
17168 end Set_Obsolescent
;
17170 -- Start of processing for pragma Obsolescent
17175 Check_At_Most_N_Arguments
(3);
17177 -- See if first argument specifies an entity name
17181 (Chars
(Arg1
) = Name_Entity
17183 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17185 N_Operator_Symbol
))
17187 Ename
:= Get_Pragma_Arg
(Arg1
);
17189 -- Eliminate first argument, so we can share processing
17193 Arg_Count
:= Arg_Count
- 1;
17195 -- No Entity name argument given
17201 if Arg_Count
>= 1 then
17202 Check_Optional_Identifier
(Arg1
, Name_Message
);
17204 if Arg_Count
= 2 then
17205 Check_Optional_Identifier
(Arg2
, Name_Version
);
17209 -- Get immediately preceding declaration
17212 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17216 -- Cases where we do not follow anything other than another pragma
17220 -- First case: library level compilation unit declaration with
17221 -- the pragma immediately following the declaration.
17223 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17225 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17228 -- Case 2: library unit placement for package
17232 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17234 if Is_Package_Or_Generic_Package
(Ent
) then
17235 Set_Obsolescent
(Ent
);
17241 -- Cases where we must follow a declaration
17244 if Nkind
(Decl
) not in N_Declaration
17245 and then Nkind
(Decl
) not in N_Later_Decl_Item
17246 and then Nkind
(Decl
) not in N_Generic_Declaration
17247 and then Nkind
(Decl
) not in N_Renaming_Declaration
17250 ("pragma% misplaced, "
17251 & "must immediately follow a declaration");
17254 Set_Obsolescent
(Defining_Entity
(Decl
));
17264 -- pragma Optimize (Time | Space | Off);
17266 -- The actual check for optimize is done in Gigi. Note that this
17267 -- pragma does not actually change the optimization setting, it
17268 -- simply checks that it is consistent with the pragma.
17270 when Pragma_Optimize
=>
17271 Check_No_Identifiers
;
17272 Check_Arg_Count
(1);
17273 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17275 ------------------------
17276 -- Optimize_Alignment --
17277 ------------------------
17279 -- pragma Optimize_Alignment (Time | Space | Off);
17281 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17283 Check_No_Identifiers
;
17284 Check_Arg_Count
(1);
17285 Check_Valid_Configuration_Pragma
;
17288 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17292 Opt
.Optimize_Alignment
:= 'T';
17294 Opt
.Optimize_Alignment
:= 'S';
17296 Opt
.Optimize_Alignment
:= 'O';
17298 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17302 -- Set indication that mode is set locally. If we are in fact in a
17303 -- configuration pragma file, this setting is harmless since the
17304 -- switch will get reset anyway at the start of each unit.
17306 Optimize_Alignment_Local
:= True;
17307 end Optimize_Alignment
;
17313 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17315 when Pragma_Ordered
=> Ordered
: declare
17316 Assoc
: constant Node_Id
:= Arg1
;
17322 Check_No_Identifiers
;
17323 Check_Arg_Count
(1);
17324 Check_Arg_Is_Local_Name
(Arg1
);
17326 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17327 Find_Type
(Type_Id
);
17328 Typ
:= Entity
(Type_Id
);
17330 if Typ
= Any_Type
then
17333 Typ
:= Underlying_Type
(Typ
);
17336 if not Is_Enumeration_Type
(Typ
) then
17337 Error_Pragma
("pragma% must specify enumeration type");
17340 Check_First_Subtype
(Arg1
);
17341 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17344 -------------------
17345 -- Overflow_Mode --
17346 -------------------
17348 -- pragma Overflow_Mode
17349 -- ([General => ] MODE [, [Assertions => ] MODE]);
17351 -- MODE := STRICT | MINIMIZED | ELIMINATED
17353 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17354 -- since System.Bignums makes this assumption. This is true of nearly
17355 -- all (all?) targets.
17357 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17358 function Get_Overflow_Mode
17360 Arg
: Node_Id
) return Overflow_Mode_Type
;
17361 -- Function to process one pragma argument, Arg. If an identifier
17362 -- is present, it must be Name. Mode type is returned if a valid
17363 -- argument exists, otherwise an error is signalled.
17365 -----------------------
17366 -- Get_Overflow_Mode --
17367 -----------------------
17369 function Get_Overflow_Mode
17371 Arg
: Node_Id
) return Overflow_Mode_Type
17373 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17376 Check_Optional_Identifier
(Arg
, Name
);
17377 Check_Arg_Is_Identifier
(Argx
);
17379 if Chars
(Argx
) = Name_Strict
then
17382 elsif Chars
(Argx
) = Name_Minimized
then
17385 elsif Chars
(Argx
) = Name_Eliminated
then
17386 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17388 ("Eliminated not implemented on this target", Argx
);
17394 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17396 end Get_Overflow_Mode
;
17398 -- Start of processing for Overflow_Mode
17402 Check_At_Least_N_Arguments
(1);
17403 Check_At_Most_N_Arguments
(2);
17405 -- Process first argument
17407 Scope_Suppress
.Overflow_Mode_General
:=
17408 Get_Overflow_Mode
(Name_General
, Arg1
);
17410 -- Case of only one argument
17412 if Arg_Count
= 1 then
17413 Scope_Suppress
.Overflow_Mode_Assertions
:=
17414 Scope_Suppress
.Overflow_Mode_General
;
17416 -- Case of two arguments present
17419 Scope_Suppress
.Overflow_Mode_Assertions
:=
17420 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17424 --------------------------
17425 -- Overriding Renamings --
17426 --------------------------
17428 -- pragma Overriding_Renamings;
17430 when Pragma_Overriding_Renamings
=>
17432 Check_Arg_Count
(0);
17433 Check_Valid_Configuration_Pragma
;
17434 Overriding_Renamings
:= True;
17440 -- pragma Pack (first_subtype_LOCAL_NAME);
17442 when Pragma_Pack
=> Pack
: declare
17443 Assoc
: constant Node_Id
:= Arg1
;
17447 Ignore
: Boolean := False;
17450 Check_No_Identifiers
;
17451 Check_Arg_Count
(1);
17452 Check_Arg_Is_Local_Name
(Arg1
);
17453 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17455 if not Is_Entity_Name
(Type_Id
)
17456 or else not Is_Type
(Entity
(Type_Id
))
17459 ("argument for pragma% must be type or subtype", Arg1
);
17462 Find_Type
(Type_Id
);
17463 Typ
:= Entity
(Type_Id
);
17466 or else Rep_Item_Too_Early
(Typ
, N
)
17470 Typ
:= Underlying_Type
(Typ
);
17473 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17474 Error_Pragma
("pragma% must specify array or record type");
17477 Check_First_Subtype
(Arg1
);
17478 Check_Duplicate_Pragma
(Typ
);
17482 if Is_Array_Type
(Typ
) then
17483 Ctyp
:= Component_Type
(Typ
);
17485 -- Ignore pack that does nothing
17487 if Known_Static_Esize
(Ctyp
)
17488 and then Known_Static_RM_Size
(Ctyp
)
17489 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17490 and then Addressable
(Esize
(Ctyp
))
17495 -- Process OK pragma Pack. Note that if there is a separate
17496 -- component clause present, the Pack will be cancelled. This
17497 -- processing is in Freeze.
17499 if not Rep_Item_Too_Late
(Typ
, N
) then
17501 -- In CodePeer mode, we do not need complex front-end
17502 -- expansions related to pragma Pack, so disable handling
17505 if CodePeer_Mode
then
17508 -- Don't attempt any packing for VM targets. We possibly
17509 -- could deal with some cases of array bit-packing, but we
17510 -- don't bother, since this is not a typical kind of
17511 -- representation in the VM context anyway (and would not
17512 -- for example work nicely with the debugger).
17514 elsif VM_Target
/= No_VM
then
17515 if not GNAT_Mode
then
17517 ("??pragma% ignored in this configuration");
17520 -- Normal case where we do the pack action
17524 Set_Is_Packed
(Base_Type
(Typ
));
17525 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17528 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17532 -- For record types, the pack is always effective
17534 else pragma Assert
(Is_Record_Type
(Typ
));
17535 if not Rep_Item_Too_Late
(Typ
, N
) then
17537 -- Ignore pack request with warning in VM mode (skip warning
17538 -- if we are compiling GNAT run time library).
17540 if VM_Target
/= No_VM
then
17541 if not GNAT_Mode
then
17543 ("??pragma% ignored in this configuration");
17546 -- Normal case of pack request active
17549 Set_Is_Packed
(Base_Type
(Typ
));
17550 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17551 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17563 -- There is nothing to do here, since we did all the processing for
17564 -- this pragma in Par.Prag (so that it works properly even in syntax
17567 when Pragma_Page
=>
17574 -- pragma Part_Of (ABSTRACT_STATE);
17576 -- ABSTRACT_STATE ::= NAME
17578 when Pragma_Part_Of
=> Part_Of
: declare
17579 procedure Propagate_Part_Of
17580 (Pack_Id
: Entity_Id
;
17581 State_Id
: Entity_Id
;
17582 Instance
: Node_Id
);
17583 -- Propagate the Part_Of indicator to all abstract states and
17584 -- variables declared in the visible state space of a package
17585 -- denoted by Pack_Id. State_Id is the encapsulating state.
17586 -- Instance is the package instantiation node.
17588 -----------------------
17589 -- Propagate_Part_Of --
17590 -----------------------
17592 procedure Propagate_Part_Of
17593 (Pack_Id
: Entity_Id
;
17594 State_Id
: Entity_Id
;
17595 Instance
: Node_Id
)
17597 Has_Item
: Boolean := False;
17598 -- Flag set when the visible state space contains at least one
17599 -- abstract state or variable.
17601 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17602 -- Propagate the Part_Of indicator to all abstract states and
17603 -- variables declared in the visible state space of a package
17604 -- denoted by Pack_Id.
17606 -----------------------
17607 -- Propagate_Part_Of --
17608 -----------------------
17610 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17611 Item_Id
: Entity_Id
;
17614 -- Traverse the entity chain of the package and set relevant
17615 -- attributes of abstract states and variables declared in
17616 -- the visible state space of the package.
17618 Item_Id
:= First_Entity
(Pack_Id
);
17619 while Present
(Item_Id
)
17620 and then not In_Private_Part
(Item_Id
)
17622 -- Do not consider internally generated items
17624 if not Comes_From_Source
(Item_Id
) then
17627 -- The Part_Of indicator turns an abstract state or
17628 -- variable into a constituent of the encapsulating
17631 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17636 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17637 Set_Encapsulating_State
(Item_Id
, State_Id
);
17639 -- Recursively handle nested packages and instantiations
17641 elsif Ekind
(Item_Id
) = E_Package
then
17642 Propagate_Part_Of
(Item_Id
);
17645 Next_Entity
(Item_Id
);
17647 end Propagate_Part_Of
;
17649 -- Start of processing for Propagate_Part_Of
17652 Propagate_Part_Of
(Pack_Id
);
17654 -- Detect a package instantiation that is subject to a Part_Of
17655 -- indicator, but has no visible state.
17657 if not Has_Item
then
17659 ("package instantiation & has Part_Of indicator but "
17660 & "lacks visible state", Instance
, Pack_Id
);
17662 end Propagate_Part_Of
;
17666 Item_Id
: Entity_Id
;
17669 State_Id
: Entity_Id
;
17672 -- Start of processing for Part_Of
17676 Check_No_Identifiers
;
17677 Check_Arg_Count
(1);
17679 -- Ensure the proper placement of the pragma. Part_Of must appear
17680 -- on a variable declaration or a package instantiation.
17683 while Present
(Stmt
) loop
17685 -- Skip prior pragmas, but check for duplicates
17687 if Nkind
(Stmt
) = N_Pragma
then
17688 if Pragma_Name
(Stmt
) = Pname
then
17689 Error_Msg_Name_1
:= Pname
;
17690 Error_Msg_Sloc
:= Sloc
(Stmt
);
17691 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17694 -- Skip internally generated code
17696 elsif not Comes_From_Source
(Stmt
) then
17699 -- The pragma applies to an object declaration (possibly a
17700 -- variable) or a package instantiation. Stop the traversal
17701 -- and continue the analysis.
17703 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17704 N_Package_Instantiation
)
17708 -- The pragma does not apply to a legal construct, issue an
17709 -- error and stop the analysis.
17716 Stmt
:= Prev
(Stmt
);
17719 -- When the context is an object declaration, ensure that we are
17720 -- dealing with a variable.
17722 if Nkind
(Stmt
) = N_Object_Declaration
17723 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17725 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17729 -- Extract the entity of the related object declaration or package
17730 -- instantiation. In the case of the instantiation, use the entity
17731 -- of the instance spec.
17733 if Nkind
(Stmt
) = N_Package_Instantiation
then
17734 Stmt
:= Instance_Spec
(Stmt
);
17737 Item_Id
:= Defining_Entity
(Stmt
);
17738 State
:= Get_Pragma_Arg
(Arg1
);
17740 -- Detect any discrepancies between the placement of the object
17741 -- or package instantiation with respect to state space and the
17742 -- encapsulating state.
17745 (Item_Id
=> Item_Id
,
17751 State_Id
:= Entity
(State
);
17753 -- Add the pragma to the contract of the item. This aids with
17754 -- the detection of a missing but required Part_Of indicator.
17756 Add_Contract_Item
(N
, Item_Id
);
17758 -- The Part_Of indicator turns a variable into a constituent
17759 -- of the encapsulating state.
17761 if Ekind
(Item_Id
) = E_Variable
then
17762 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17763 Set_Encapsulating_State
(Item_Id
, State_Id
);
17765 -- Propagate the Part_Of indicator to the visible state space
17766 -- of the package instantiation.
17770 (Pack_Id
=> Item_Id
,
17771 State_Id
=> State_Id
,
17777 ----------------------------------
17778 -- Partition_Elaboration_Policy --
17779 ----------------------------------
17781 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17783 when Pragma_Partition_Elaboration_Policy
=> declare
17784 subtype PEP_Range
is Name_Id
17785 range First_Partition_Elaboration_Policy_Name
17786 .. Last_Partition_Elaboration_Policy_Name
;
17787 PEP_Val
: PEP_Range
;
17792 Check_Arg_Count
(1);
17793 Check_No_Identifiers
;
17794 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17795 Check_Valid_Configuration_Pragma
;
17796 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17799 when Name_Concurrent
=>
17801 when Name_Sequential
=>
17805 if Partition_Elaboration_Policy
/= ' '
17806 and then Partition_Elaboration_Policy
/= PEP
17808 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17810 ("partition elaboration policy incompatible with policy#");
17812 -- Set new policy, but always preserve System_Location since we
17813 -- like the error message with the run time name.
17816 Partition_Elaboration_Policy
:= PEP
;
17818 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17819 Partition_Elaboration_Policy_Sloc
:= Loc
;
17828 -- pragma Passive [(PASSIVE_FORM)];
17830 -- PASSIVE_FORM ::= Semaphore | No
17832 when Pragma_Passive
=>
17835 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17836 Error_Pragma
("pragma% must be within task definition");
17839 if Arg_Count
/= 0 then
17840 Check_Arg_Count
(1);
17841 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17844 ----------------------------------
17845 -- Preelaborable_Initialization --
17846 ----------------------------------
17848 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17850 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17855 Check_Arg_Count
(1);
17856 Check_No_Identifiers
;
17857 Check_Arg_Is_Identifier
(Arg1
);
17858 Check_Arg_Is_Local_Name
(Arg1
);
17859 Check_First_Subtype
(Arg1
);
17860 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17862 -- The pragma may come from an aspect on a private declaration,
17863 -- even if the freeze point at which this is analyzed in the
17864 -- private part after the full view.
17866 if Has_Private_Declaration
(Ent
)
17867 and then From_Aspect_Specification
(N
)
17871 elsif Is_Private_Type
(Ent
)
17872 or else Is_Protected_Type
(Ent
)
17873 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17879 ("pragma % can only be applied to private, formal derived or "
17880 & "protected type",
17884 -- Give an error if the pragma is applied to a protected type that
17885 -- does not qualify (due to having entries, or due to components
17886 -- that do not qualify).
17888 if Is_Protected_Type
(Ent
)
17889 and then not Has_Preelaborable_Initialization
(Ent
)
17892 ("protected type & does not have preelaborable "
17893 & "initialization", Ent
);
17895 -- Otherwise mark the type as definitely having preelaborable
17899 Set_Known_To_Have_Preelab_Init
(Ent
);
17902 if Has_Pragma_Preelab_Init
(Ent
)
17903 and then Warn_On_Redundant_Constructs
17905 Error_Pragma
("?r?duplicate pragma%!");
17907 Set_Has_Pragma_Preelab_Init
(Ent
);
17911 --------------------
17912 -- Persistent_BSS --
17913 --------------------
17915 -- pragma Persistent_BSS [(object_NAME)];
17917 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17924 Check_At_Most_N_Arguments
(1);
17926 -- Case of application to specific object (one argument)
17928 if Arg_Count
= 1 then
17929 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17931 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17933 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17936 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17939 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17940 Decl
:= Parent
(Ent
);
17942 -- Check for duplication before inserting in list of
17943 -- representation items.
17945 Check_Duplicate_Pragma
(Ent
);
17947 if Rep_Item_Too_Late
(Ent
, N
) then
17951 if Present
(Expression
(Decl
)) then
17953 ("object for pragma% cannot have initialization", Arg1
);
17956 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17958 ("object type for pragma% is not potentially persistent",
17963 Make_Linker_Section_Pragma
17964 (Ent
, Sloc
(N
), ".persistent.bss");
17965 Insert_After
(N
, Prag
);
17968 -- Case of use as configuration pragma with no arguments
17971 Check_Valid_Configuration_Pragma
;
17972 Persistent_BSS_Mode
:= True;
17974 end Persistent_BSS
;
17980 -- pragma Polling (ON | OFF);
17982 when Pragma_Polling
=>
17984 Check_Arg_Count
(1);
17985 Check_No_Identifiers
;
17986 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17987 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17993 -- pragma Post (Boolean_EXPRESSION);
17994 -- pragma Post_Class (Boolean_EXPRESSION);
17996 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
17997 PC_Pragma
: Node_Id
;
18001 Check_Arg_Count
(1);
18002 Check_No_Identifiers
;
18005 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
18006 -- flag Class_Present to True for the Post_Class case.
18008 Set_Class_Present
(N
, Prag_Id
= Pragma_Post_Class
);
18009 PC_Pragma
:= New_Copy
(N
);
18010 Set_Pragma_Identifier
18011 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
18012 Rewrite
(N
, PC_Pragma
);
18013 Set_Analyzed
(N
, False);
18017 -------------------
18018 -- Postcondition --
18019 -------------------
18021 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18022 -- [,[Message =>] String_EXPRESSION]);
18024 when Pragma_Postcondition
=> Postcondition
: declare
18029 Check_At_Least_N_Arguments
(1);
18030 Check_At_Most_N_Arguments
(2);
18031 Check_Optional_Identifier
(Arg1
, Name_Check
);
18033 -- Verify the proper placement of the pragma. The remainder of the
18034 -- processing is found in Sem_Ch6/Sem_Ch7.
18036 Check_Precondition_Postcondition
(In_Body
);
18038 -- When the pragma is a source construct appearing inside a body,
18039 -- preanalyze the boolean_expression to detect illegal forward
18043 -- pragma Postcondition (X'Old ...);
18046 if Comes_From_Source
(N
) and then In_Body
then
18047 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
18055 -- pragma Pre (Boolean_EXPRESSION);
18056 -- pragma Pre_Class (Boolean_EXPRESSION);
18058 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
18059 PC_Pragma
: Node_Id
;
18063 Check_Arg_Count
(1);
18064 Check_No_Identifiers
;
18067 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
18068 -- flag Class_Present to True for the Pre_Class case.
18070 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
18071 PC_Pragma
:= New_Copy
(N
);
18072 Set_Pragma_Identifier
18073 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
18074 Rewrite
(N
, PC_Pragma
);
18075 Set_Analyzed
(N
, False);
18083 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18084 -- [,[Message =>] String_EXPRESSION]);
18086 when Pragma_Precondition
=> Precondition
: declare
18091 Check_At_Least_N_Arguments
(1);
18092 Check_At_Most_N_Arguments
(2);
18093 Check_Optional_Identifier
(Arg1
, Name_Check
);
18094 Check_Precondition_Postcondition
(In_Body
);
18096 -- If in spec, nothing more to do. If in body, then we convert
18097 -- the pragma to an equivalent pragma Check. That works fine since
18098 -- pragma Check will analyze the condition in the proper context.
18100 -- The form of the pragma Check is either:
18102 -- pragma Check (Precondition, cond [, msg])
18104 -- pragma Check (Pre, cond [, msg])
18106 -- We use the Pre form if this pragma derived from a Pre aspect.
18107 -- This is needed to make sure that the right set of Policy
18108 -- pragmas are checked.
18112 -- Rewrite as Check pragma
18116 Chars
=> Name_Check
,
18117 Pragma_Argument_Associations
=> New_List
(
18118 Make_Pragma_Argument_Association
(Loc
,
18119 Expression
=> Make_Identifier
(Loc
, Pname
)),
18121 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
18123 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
18125 if Arg_Count
= 2 then
18126 Append_To
(Pragma_Argument_Associations
(N
),
18127 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
18129 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
18140 -- pragma Predicate
18141 -- ([Entity =>] type_LOCAL_NAME,
18142 -- [Check =>] boolean_EXPRESSION);
18144 when Pragma_Predicate
=> Predicate
: declare
18151 Check_Arg_Count
(2);
18152 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18153 Check_Optional_Identifier
(Arg2
, Name_Check
);
18155 Check_Arg_Is_Local_Name
(Arg1
);
18157 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18158 Find_Type
(Type_Id
);
18159 Typ
:= Entity
(Type_Id
);
18161 if Typ
= Any_Type
then
18165 -- The remaining processing is simply to link the pragma on to
18166 -- the rep item chain, for processing when the type is frozen.
18167 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18168 -- mark the type as having predicates.
18170 Set_Has_Predicates
(Typ
);
18171 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18178 -- pragma Preelaborate [(library_unit_NAME)];
18180 -- Set the flag Is_Preelaborated of program unit name entity
18182 when Pragma_Preelaborate
=> Preelaborate
: declare
18183 Pa
: constant Node_Id
:= Parent
(N
);
18184 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18188 Check_Ada_83_Warning
;
18189 Check_Valid_Library_Unit_Pragma
;
18191 if Nkind
(N
) = N_Null_Statement
then
18195 Ent
:= Find_Lib_Unit_Name
;
18196 Check_Duplicate_Pragma
(Ent
);
18198 -- This filters out pragmas inside generic parents that show up
18199 -- inside instantiations. Pragmas that come from aspects in the
18200 -- unit are not ignored.
18202 if Present
(Ent
) then
18203 if Pk
= N_Package_Specification
18204 and then Present
(Generic_Parent
(Pa
))
18205 and then not From_Aspect_Specification
(N
)
18210 if not Debug_Flag_U
then
18211 Set_Is_Preelaborated
(Ent
);
18212 Set_Suppress_Elaboration_Warnings
(Ent
);
18218 -------------------------------
18219 -- Prefix_Exception_Messages --
18220 -------------------------------
18222 -- pragma Prefix_Exception_Messages;
18224 when Pragma_Prefix_Exception_Messages
=>
18226 Check_Valid_Configuration_Pragma
;
18227 Check_Arg_Count
(0);
18228 Prefix_Exception_Messages
:= True;
18234 -- pragma Priority (EXPRESSION);
18236 when Pragma_Priority
=> Priority
: declare
18237 P
: constant Node_Id
:= Parent
(N
);
18242 Check_No_Identifiers
;
18243 Check_Arg_Count
(1);
18247 if Nkind
(P
) = N_Subprogram_Body
then
18248 Check_In_Main_Program
;
18250 Ent
:= Defining_Unit_Name
(Specification
(P
));
18252 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18253 Ent
:= Defining_Identifier
(Ent
);
18256 Arg
:= Get_Pragma_Arg
(Arg1
);
18257 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18261 if not Is_OK_Static_Expression
(Arg
) then
18262 Flag_Non_Static_Expr
18263 ("main subprogram priority is not static!", Arg
);
18266 -- If constraint error, then we already signalled an error
18268 elsif Raises_Constraint_Error
(Arg
) then
18271 -- Otherwise check in range except if Relaxed_RM_Semantics
18272 -- where we ignore the value if out of range.
18276 Val
: constant Uint
:= Expr_Value
(Arg
);
18278 if not Relaxed_RM_Semantics
18281 or else Val
> Expr_Value
(Expression
18282 (Parent
(RTE
(RE_Max_Priority
)))))
18285 ("main subprogram priority is out of range", Arg1
);
18288 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18293 -- Load an arbitrary entity from System.Tasking.Stages or
18294 -- System.Tasking.Restricted.Stages (depending on the
18295 -- supported profile) to make sure that one of these packages
18296 -- is implicitly with'ed, since we need to have the tasking
18297 -- run time active for the pragma Priority to have any effect.
18298 -- Previously we with'ed the package System.Tasking, but this
18299 -- package does not trigger the required initialization of the
18300 -- run-time library.
18303 Discard
: Entity_Id
;
18304 pragma Warnings
(Off
, Discard
);
18306 if Restricted_Profile
then
18307 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18309 Discard
:= RTE
(RE_Activate_Tasks
);
18313 -- Task or Protected, must be of type Integer
18315 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18316 Arg
:= Get_Pragma_Arg
(Arg1
);
18317 Ent
:= Defining_Identifier
(Parent
(P
));
18319 -- The expression must be analyzed in the special manner
18320 -- described in "Handling of Default and Per-Object
18321 -- Expressions" in sem.ads.
18323 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18325 if not Is_OK_Static_Expression
(Arg
) then
18326 Check_Restriction
(Static_Priorities
, Arg
);
18329 -- Anything else is incorrect
18335 -- Check duplicate pragma before we chain the pragma in the Rep
18336 -- Item chain of Ent.
18338 Check_Duplicate_Pragma
(Ent
);
18339 Record_Rep_Item
(Ent
, N
);
18342 -----------------------------------
18343 -- Priority_Specific_Dispatching --
18344 -----------------------------------
18346 -- pragma Priority_Specific_Dispatching (
18347 -- policy_IDENTIFIER,
18348 -- first_priority_EXPRESSION,
18349 -- last_priority_EXPRESSION);
18351 when Pragma_Priority_Specific_Dispatching
=>
18352 Priority_Specific_Dispatching
: declare
18353 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18354 -- This is the entity System.Any_Priority;
18357 Lower_Bound
: Node_Id
;
18358 Upper_Bound
: Node_Id
;
18364 Check_Arg_Count
(3);
18365 Check_No_Identifiers
;
18366 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18367 Check_Valid_Configuration_Pragma
;
18368 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18369 DP
:= Fold_Upper
(Name_Buffer
(1));
18371 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18372 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18373 Lower_Val
:= Expr_Value
(Lower_Bound
);
18375 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18376 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18377 Upper_Val
:= Expr_Value
(Upper_Bound
);
18379 -- It is not allowed to use Task_Dispatching_Policy and
18380 -- Priority_Specific_Dispatching in the same partition.
18382 if Task_Dispatching_Policy
/= ' ' then
18383 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18385 ("pragma% incompatible with Task_Dispatching_Policy#");
18387 -- Check lower bound in range
18389 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18391 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18394 ("first_priority is out of range", Arg2
);
18396 -- Check upper bound in range
18398 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18400 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18403 ("last_priority is out of range", Arg3
);
18405 -- Check that the priority range is valid
18407 elsif Lower_Val
> Upper_Val
then
18409 ("last_priority_expression must be greater than or equal to "
18410 & "first_priority_expression");
18412 -- Store the new policy, but always preserve System_Location since
18413 -- we like the error message with the run-time name.
18416 -- Check overlapping in the priority ranges specified in other
18417 -- Priority_Specific_Dispatching pragmas within the same
18418 -- partition. We can only check those we know about.
18421 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18423 if Specific_Dispatching
.Table
(J
).First_Priority
in
18424 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18425 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18426 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18429 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18431 ("priority range overlaps with "
18432 & "Priority_Specific_Dispatching#");
18436 -- The use of Priority_Specific_Dispatching is incompatible
18437 -- with Task_Dispatching_Policy.
18439 if Task_Dispatching_Policy
/= ' ' then
18440 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18442 ("Priority_Specific_Dispatching incompatible "
18443 & "with Task_Dispatching_Policy#");
18446 -- The use of Priority_Specific_Dispatching forces ceiling
18449 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18450 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18452 ("Priority_Specific_Dispatching incompatible "
18453 & "with Locking_Policy#");
18455 -- Set the Ceiling_Locking policy, but preserve System_Location
18456 -- since we like the error message with the run time name.
18459 Locking_Policy
:= 'C';
18461 if Locking_Policy_Sloc
/= System_Location
then
18462 Locking_Policy_Sloc
:= Loc
;
18466 -- Add entry in the table
18468 Specific_Dispatching
.Append
18469 ((Dispatching_Policy
=> DP
,
18470 First_Priority
=> UI_To_Int
(Lower_Val
),
18471 Last_Priority
=> UI_To_Int
(Upper_Val
),
18472 Pragma_Loc
=> Loc
));
18474 end Priority_Specific_Dispatching
;
18480 -- pragma Profile (profile_IDENTIFIER);
18482 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18484 when Pragma_Profile
=>
18486 Check_Arg_Count
(1);
18487 Check_Valid_Configuration_Pragma
;
18488 Check_No_Identifiers
;
18491 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18494 if Chars
(Argx
) = Name_Ravenscar
then
18495 Set_Ravenscar_Profile
(N
);
18497 elsif Chars
(Argx
) = Name_Restricted
then
18498 Set_Profile_Restrictions
18500 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18502 elsif Chars
(Argx
) = Name_Rational
then
18503 Set_Rational_Profile
;
18505 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18506 Set_Profile_Restrictions
18507 (No_Implementation_Extensions
,
18508 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18511 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18515 ----------------------
18516 -- Profile_Warnings --
18517 ----------------------
18519 -- pragma Profile_Warnings (profile_IDENTIFIER);
18521 -- profile_IDENTIFIER => Restricted | Ravenscar
18523 when Pragma_Profile_Warnings
=>
18525 Check_Arg_Count
(1);
18526 Check_Valid_Configuration_Pragma
;
18527 Check_No_Identifiers
;
18530 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18533 if Chars
(Argx
) = Name_Ravenscar
then
18534 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18536 elsif Chars
(Argx
) = Name_Restricted
then
18537 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18539 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18540 Set_Profile_Restrictions
18541 (No_Implementation_Extensions
, N
, Warn
=> True);
18544 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18548 --------------------------
18549 -- Propagate_Exceptions --
18550 --------------------------
18552 -- pragma Propagate_Exceptions;
18554 -- Note: this pragma is obsolete and has no effect
18556 when Pragma_Propagate_Exceptions
=>
18558 Check_Arg_Count
(0);
18560 if Warn_On_Obsolescent_Feature
then
18562 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18563 "and has no effect?j?", N
);
18566 -----------------------------
18567 -- Provide_Shift_Operators --
18568 -----------------------------
18570 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18572 when Pragma_Provide_Shift_Operators
=>
18573 Provide_Shift_Operators
: declare
18576 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18577 -- Insert declaration and pragma Instrinsic for named shift op
18579 ----------------------------
18580 -- Declare_Shift_Operator --
18581 ----------------------------
18583 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18589 Make_Subprogram_Declaration
(Loc
,
18590 Make_Function_Specification
(Loc
,
18591 Defining_Unit_Name
=>
18592 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18594 Result_Definition
=>
18595 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18597 Parameter_Specifications
=> New_List
(
18598 Make_Parameter_Specification
(Loc
,
18599 Defining_Identifier
=>
18600 Make_Defining_Identifier
(Loc
, Name_Value
),
18602 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18604 Make_Parameter_Specification
(Loc
,
18605 Defining_Identifier
=>
18606 Make_Defining_Identifier
(Loc
, Name_Amount
),
18608 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18612 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18613 Pragma_Argument_Associations
=> New_List
(
18614 Make_Pragma_Argument_Association
(Loc
,
18615 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18616 Make_Pragma_Argument_Association
(Loc
,
18617 Expression
=> Make_Identifier
(Loc
, Nam
))));
18619 Insert_After
(N
, Import
);
18620 Insert_After
(N
, Func
);
18621 end Declare_Shift_Operator
;
18623 -- Start of processing for Provide_Shift_Operators
18627 Check_Arg_Count
(1);
18628 Check_Arg_Is_Local_Name
(Arg1
);
18630 Arg1
:= Get_Pragma_Arg
(Arg1
);
18632 -- We must have an entity name
18634 if not Is_Entity_Name
(Arg1
) then
18636 ("pragma % must apply to integer first subtype", Arg1
);
18639 -- If no Entity, means there was a prior error so ignore
18641 if Present
(Entity
(Arg1
)) then
18642 Ent
:= Entity
(Arg1
);
18644 -- Apply error checks
18646 if not Is_First_Subtype
(Ent
) then
18648 ("cannot apply pragma %",
18649 "\& is not a first subtype",
18652 elsif not Is_Integer_Type
(Ent
) then
18654 ("cannot apply pragma %",
18655 "\& is not an integer type",
18658 elsif Has_Shift_Operator
(Ent
) then
18660 ("cannot apply pragma %",
18661 "\& already has declared shift operators",
18664 elsif Is_Frozen
(Ent
) then
18666 ("pragma % appears too late",
18667 "\& is already frozen",
18671 -- Now declare the operators. We do this during analysis rather
18672 -- than expansion, since we want the operators available if we
18673 -- are operating in -gnatc or ASIS mode.
18675 Declare_Shift_Operator
(Name_Rotate_Left
);
18676 Declare_Shift_Operator
(Name_Rotate_Right
);
18677 Declare_Shift_Operator
(Name_Shift_Left
);
18678 Declare_Shift_Operator
(Name_Shift_Right
);
18679 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18681 end Provide_Shift_Operators
;
18687 -- pragma Psect_Object (
18688 -- [Internal =>] LOCAL_NAME,
18689 -- [, [External =>] EXTERNAL_SYMBOL]
18690 -- [, [Size =>] EXTERNAL_SYMBOL]);
18692 when Pragma_Psect_Object | Pragma_Common_Object
=>
18693 Psect_Object
: declare
18694 Args
: Args_List
(1 .. 3);
18695 Names
: constant Name_List
(1 .. 3) := (
18700 Internal
: Node_Id
renames Args
(1);
18701 External
: Node_Id
renames Args
(2);
18702 Size
: Node_Id
renames Args
(3);
18704 Def_Id
: Entity_Id
;
18706 procedure Check_Arg
(Arg
: Node_Id
);
18707 -- Checks that argument is either a string literal or an
18708 -- identifier, and posts error message if not.
18714 procedure Check_Arg
(Arg
: Node_Id
) is
18716 if not Nkind_In
(Original_Node
(Arg
),
18721 ("inappropriate argument for pragma %", Arg
);
18725 -- Start of processing for Common_Object/Psect_Object
18729 Gather_Associations
(Names
, Args
);
18730 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18732 Def_Id
:= Entity
(Internal
);
18734 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18736 ("pragma% must designate an object", Internal
);
18739 Check_Arg
(Internal
);
18741 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18743 ("cannot use pragma% for imported/exported object",
18747 if Is_Concurrent_Type
(Etype
(Internal
)) then
18749 ("cannot specify pragma % for task/protected object",
18753 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18755 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18757 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18760 if Ekind
(Def_Id
) = E_Constant
then
18762 ("cannot specify pragma % for a constant", Internal
);
18765 if Is_Record_Type
(Etype
(Internal
)) then
18771 Ent
:= First_Entity
(Etype
(Internal
));
18772 while Present
(Ent
) loop
18773 Decl
:= Declaration_Node
(Ent
);
18775 if Ekind
(Ent
) = E_Component
18776 and then Nkind
(Decl
) = N_Component_Declaration
18777 and then Present
(Expression
(Decl
))
18778 and then Warn_On_Export_Import
18781 ("?x?object for pragma % has defaults", Internal
);
18791 if Present
(Size
) then
18795 if Present
(External
) then
18796 Check_Arg_Is_External_Name
(External
);
18799 -- If all error tests pass, link pragma on to the rep item chain
18801 Record_Rep_Item
(Def_Id
, N
);
18808 -- pragma Pure [(library_unit_NAME)];
18810 when Pragma_Pure
=> Pure
: declare
18814 Check_Ada_83_Warning
;
18815 Check_Valid_Library_Unit_Pragma
;
18817 if Nkind
(N
) = N_Null_Statement
then
18821 Ent
:= Find_Lib_Unit_Name
;
18823 Set_Has_Pragma_Pure
(Ent
);
18824 Set_Suppress_Elaboration_Warnings
(Ent
);
18827 -------------------
18828 -- Pure_Function --
18829 -------------------
18831 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18833 when Pragma_Pure_Function
=> Pure_Function
: declare
18836 Def_Id
: Entity_Id
;
18837 Effective
: Boolean := False;
18841 Check_Arg_Count
(1);
18842 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18843 Check_Arg_Is_Local_Name
(Arg1
);
18844 E_Id
:= Get_Pragma_Arg
(Arg1
);
18846 if Error_Posted
(E_Id
) then
18850 -- Loop through homonyms (overloadings) of referenced entity
18852 E
:= Entity
(E_Id
);
18854 if Present
(E
) then
18856 Def_Id
:= Get_Base_Subprogram
(E
);
18858 if not Ekind_In
(Def_Id
, E_Function
,
18859 E_Generic_Function
,
18863 ("pragma% requires a function name", Arg1
);
18866 Set_Is_Pure
(Def_Id
);
18868 if not Has_Pragma_Pure_Function
(Def_Id
) then
18869 Set_Has_Pragma_Pure_Function
(Def_Id
);
18873 exit when From_Aspect_Specification
(N
);
18875 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18879 and then Warn_On_Redundant_Constructs
18882 ("pragma Pure_Function on& is redundant?r?",
18888 --------------------
18889 -- Queuing_Policy --
18890 --------------------
18892 -- pragma Queuing_Policy (policy_IDENTIFIER);
18894 when Pragma_Queuing_Policy
=> declare
18898 Check_Ada_83_Warning
;
18899 Check_Arg_Count
(1);
18900 Check_No_Identifiers
;
18901 Check_Arg_Is_Queuing_Policy
(Arg1
);
18902 Check_Valid_Configuration_Pragma
;
18903 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18904 QP
:= Fold_Upper
(Name_Buffer
(1));
18906 if Queuing_Policy
/= ' '
18907 and then Queuing_Policy
/= QP
18909 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18910 Error_Pragma
("queuing policy incompatible with policy#");
18912 -- Set new policy, but always preserve System_Location since we
18913 -- like the error message with the run time name.
18916 Queuing_Policy
:= QP
;
18918 if Queuing_Policy_Sloc
/= System_Location
then
18919 Queuing_Policy_Sloc
:= Loc
;
18928 -- pragma Rational, for compatibility with foreign compiler
18930 when Pragma_Rational
=>
18931 Set_Rational_Profile
;
18933 ------------------------------------
18934 -- Refined_Depends/Refined_Global --
18935 ------------------------------------
18937 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18939 -- DEPENDENCY_RELATION ::=
18941 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18943 -- DEPENDENCY_CLAUSE ::=
18944 -- OUTPUT_LIST =>[+] INPUT_LIST
18945 -- | NULL_DEPENDENCY_CLAUSE
18947 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18949 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18951 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18953 -- OUTPUT ::= NAME | FUNCTION_RESULT
18956 -- where FUNCTION_RESULT is a function Result attribute_reference
18958 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18960 -- GLOBAL_SPECIFICATION ::=
18963 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18965 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18967 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18968 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18969 -- GLOBAL_ITEM ::= NAME
18971 when Pragma_Refined_Depends |
18972 Pragma_Refined_Global
=> Refined_Depends_Global
:
18974 Body_Id
: Entity_Id
;
18976 Spec_Id
: Entity_Id
;
18979 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18981 -- Save the pragma in the contract of the subprogram body. The
18982 -- remaining analysis is performed at the end of the enclosing
18986 Add_Contract_Item
(N
, Body_Id
);
18988 end Refined_Depends_Global
;
18994 -- pragma Refined_Post (boolean_EXPRESSION);
18996 when Pragma_Refined_Post
=> Refined_Post
: declare
18997 Body_Id
: Entity_Id
;
18999 Result_Seen
: Boolean := False;
19000 Spec_Id
: Entity_Id
;
19003 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
19005 -- Analyze the boolean expression as a "spec expression"
19008 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
19010 -- Verify that the refined postcondition mentions attribute
19011 -- 'Result and its expression introduces a post-state.
19013 if Warn_On_Suspicious_Contract
19014 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
19016 Check_Result_And_Post_State
(N
, Result_Seen
);
19018 if not Result_Seen
then
19020 ("pragma % does not mention function result?T?");
19024 -- Chain the pragma on the contract for easy retrieval
19026 Add_Contract_Item
(N
, Body_Id
);
19030 -------------------
19031 -- Refined_State --
19032 -------------------
19034 -- pragma Refined_State (REFINEMENT_LIST);
19036 -- REFINEMENT_LIST ::=
19037 -- REFINEMENT_CLAUSE
19038 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19040 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19042 -- CONSTITUENT_LIST ::=
19045 -- | (CONSTITUENT {, CONSTITUENT})
19047 -- CONSTITUENT ::= object_NAME | state_NAME
19049 when Pragma_Refined_State
=> Refined_State
: declare
19050 Context
: constant Node_Id
:= Parent
(N
);
19051 Spec_Id
: Entity_Id
;
19056 Check_No_Identifiers
;
19057 Check_Arg_Count
(1);
19059 -- Ensure the proper placement of the pragma. Refined states must
19060 -- be associated with a package body.
19062 if Nkind
(Context
) /= N_Package_Body
then
19068 while Present
(Stmt
) loop
19070 -- Skip prior pragmas, but check for duplicates
19072 if Nkind
(Stmt
) = N_Pragma
then
19073 if Pragma_Name
(Stmt
) = Pname
then
19074 Error_Msg_Name_1
:= Pname
;
19075 Error_Msg_Sloc
:= Sloc
(Stmt
);
19076 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
19079 -- Skip internally generated code
19081 elsif not Comes_From_Source
(Stmt
) then
19084 -- The pragma does not apply to a legal construct, issue an
19085 -- error and stop the analysis.
19092 Stmt
:= Prev
(Stmt
);
19095 Spec_Id
:= Corresponding_Spec
(Context
);
19097 -- State refinement is allowed only when the corresponding package
19098 -- declaration has non-null pragma Abstract_State. Refinement not
19099 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19101 if SPARK_Mode
/= Off
19103 (No
(Abstract_States
(Spec_Id
))
19104 or else Has_Null_Abstract_State
(Spec_Id
))
19107 ("useless refinement, package & does not define abstract "
19108 & "states", N
, Spec_Id
);
19112 -- The pragma must be analyzed at the end of the declarations as
19113 -- it has visibility over the whole declarative region. Save the
19114 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19115 -- adding it to the contract of the package body.
19117 Add_Contract_Item
(N
, Defining_Entity
(Context
));
19120 -----------------------
19121 -- Relative_Deadline --
19122 -----------------------
19124 -- pragma Relative_Deadline (time_span_EXPRESSION);
19126 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19127 P
: constant Node_Id
:= Parent
(N
);
19132 Check_No_Identifiers
;
19133 Check_Arg_Count
(1);
19135 Arg
:= Get_Pragma_Arg
(Arg1
);
19137 -- The expression must be analyzed in the special manner described
19138 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19140 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19144 if Nkind
(P
) = N_Subprogram_Body
then
19145 Check_In_Main_Program
;
19147 -- Only Task and subprogram cases allowed
19149 elsif Nkind
(P
) /= N_Task_Definition
then
19153 -- Check duplicate pragma before we set the corresponding flag
19155 if Has_Relative_Deadline_Pragma
(P
) then
19156 Error_Pragma
("duplicate pragma% not allowed");
19159 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19160 -- Relative_Deadline pragma node cannot be inserted in the Rep
19161 -- Item chain of Ent since it is rewritten by the expander as a
19162 -- procedure call statement that will break the chain.
19164 Set_Has_Relative_Deadline_Pragma
(P
, True);
19165 end Relative_Deadline
;
19167 ------------------------
19168 -- Remote_Access_Type --
19169 ------------------------
19171 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19173 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19178 Check_Arg_Count
(1);
19179 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19180 Check_Arg_Is_Local_Name
(Arg1
);
19182 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19184 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19185 and then Ekind
(E
) = E_General_Access_Type
19186 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19187 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19189 and then Is_Valid_Remote_Object_Type
19190 (Root_Type
(Directly_Designated_Type
(E
)))
19192 Set_Is_Remote_Types
(E
);
19196 ("pragma% applies only to formal access to classwide types",
19199 end Remote_Access_Type
;
19201 ---------------------------
19202 -- Remote_Call_Interface --
19203 ---------------------------
19205 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19207 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19208 Cunit_Node
: Node_Id
;
19209 Cunit_Ent
: Entity_Id
;
19213 Check_Ada_83_Warning
;
19214 Check_Valid_Library_Unit_Pragma
;
19216 if Nkind
(N
) = N_Null_Statement
then
19220 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19221 K
:= Nkind
(Unit
(Cunit_Node
));
19222 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19224 if K
= N_Package_Declaration
19225 or else K
= N_Generic_Package_Declaration
19226 or else K
= N_Subprogram_Declaration
19227 or else K
= N_Generic_Subprogram_Declaration
19228 or else (K
= N_Subprogram_Body
19229 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19234 "pragma% must apply to package or subprogram declaration");
19237 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19238 end Remote_Call_Interface
;
19244 -- pragma Remote_Types [(library_unit_NAME)];
19246 when Pragma_Remote_Types
=> Remote_Types
: declare
19247 Cunit_Node
: Node_Id
;
19248 Cunit_Ent
: Entity_Id
;
19251 Check_Ada_83_Warning
;
19252 Check_Valid_Library_Unit_Pragma
;
19254 if Nkind
(N
) = N_Null_Statement
then
19258 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19259 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19261 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19262 N_Generic_Package_Declaration
)
19265 ("pragma% can only apply to a package declaration");
19268 Set_Is_Remote_Types
(Cunit_Ent
);
19275 -- pragma Ravenscar;
19277 when Pragma_Ravenscar
=>
19279 Check_Arg_Count
(0);
19280 Check_Valid_Configuration_Pragma
;
19281 Set_Ravenscar_Profile
(N
);
19283 if Warn_On_Obsolescent_Feature
then
19285 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19287 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19290 -------------------------
19291 -- Restricted_Run_Time --
19292 -------------------------
19294 -- pragma Restricted_Run_Time;
19296 when Pragma_Restricted_Run_Time
=>
19298 Check_Arg_Count
(0);
19299 Check_Valid_Configuration_Pragma
;
19300 Set_Profile_Restrictions
19301 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19303 if Warn_On_Obsolescent_Feature
then
19305 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19308 ("|use pragma Profile (Restricted) instead?j?", N
);
19315 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19318 -- restriction_IDENTIFIER
19319 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19321 when Pragma_Restrictions
=>
19322 Process_Restrictions_Or_Restriction_Warnings
19323 (Warn
=> Treat_Restrictions_As_Warnings
);
19325 --------------------------
19326 -- Restriction_Warnings --
19327 --------------------------
19329 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19332 -- restriction_IDENTIFIER
19333 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19335 when Pragma_Restriction_Warnings
=>
19337 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19343 -- pragma Reviewable;
19345 when Pragma_Reviewable
=>
19346 Check_Ada_83_Warning
;
19347 Check_Arg_Count
(0);
19349 -- Call dummy debugging function rv. This is done to assist front
19350 -- end debugging. By placing a Reviewable pragma in the source
19351 -- program, a breakpoint on rv catches this place in the source,
19352 -- allowing convenient stepping to the point of interest.
19356 --------------------------
19357 -- Short_Circuit_And_Or --
19358 --------------------------
19360 -- pragma Short_Circuit_And_Or;
19362 when Pragma_Short_Circuit_And_Or
=>
19364 Check_Arg_Count
(0);
19365 Check_Valid_Configuration_Pragma
;
19366 Short_Circuit_And_Or
:= True;
19368 -------------------
19369 -- Share_Generic --
19370 -------------------
19372 -- pragma Share_Generic (GNAME {, GNAME});
19374 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19376 when Pragma_Share_Generic
=>
19378 Process_Generic_List
;
19384 -- pragma Shared (LOCAL_NAME);
19386 when Pragma_Shared
=>
19388 Process_Atomic_Shared_Volatile
;
19390 --------------------
19391 -- Shared_Passive --
19392 --------------------
19394 -- pragma Shared_Passive [(library_unit_NAME)];
19396 -- Set the flag Is_Shared_Passive of program unit name entity
19398 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19399 Cunit_Node
: Node_Id
;
19400 Cunit_Ent
: Entity_Id
;
19403 Check_Ada_83_Warning
;
19404 Check_Valid_Library_Unit_Pragma
;
19406 if Nkind
(N
) = N_Null_Statement
then
19410 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19411 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19413 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19414 N_Generic_Package_Declaration
)
19417 ("pragma% can only apply to a package declaration");
19420 Set_Is_Shared_Passive
(Cunit_Ent
);
19421 end Shared_Passive
;
19423 -----------------------
19424 -- Short_Descriptors --
19425 -----------------------
19427 -- pragma Short_Descriptors;
19429 -- Recognize and validate, but otherwise ignore
19431 when Pragma_Short_Descriptors
=>
19433 Check_Arg_Count
(0);
19434 Check_Valid_Configuration_Pragma
;
19436 ------------------------------
19437 -- Simple_Storage_Pool_Type --
19438 ------------------------------
19440 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19442 when Pragma_Simple_Storage_Pool_Type
=>
19443 Simple_Storage_Pool_Type
: declare
19449 Check_Arg_Count
(1);
19450 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19452 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19453 Find_Type
(Type_Id
);
19454 Typ
:= Entity
(Type_Id
);
19456 if Typ
= Any_Type
then
19460 -- We require the pragma to apply to a type declared in a package
19461 -- declaration, but not (immediately) within a package body.
19463 if Ekind
(Current_Scope
) /= E_Package
19464 or else In_Package_Body
(Current_Scope
)
19467 ("pragma% can only apply to type declared immediately "
19468 & "within a package declaration");
19471 -- A simple storage pool type must be an immutably limited record
19472 -- or private type. If the pragma is given for a private type,
19473 -- the full type is similarly restricted (which is checked later
19474 -- in Freeze_Entity).
19476 if Is_Record_Type
(Typ
)
19477 and then not Is_Limited_View
(Typ
)
19480 ("pragma% can only apply to explicitly limited record type");
19482 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19484 ("pragma% can only apply to a private type that is limited");
19486 elsif not Is_Record_Type
(Typ
)
19487 and then not Is_Private_Type
(Typ
)
19490 ("pragma% can only apply to limited record or private type");
19493 Record_Rep_Item
(Typ
, N
);
19494 end Simple_Storage_Pool_Type
;
19496 ----------------------
19497 -- Source_File_Name --
19498 ----------------------
19500 -- There are five forms for this pragma:
19502 -- pragma Source_File_Name (
19503 -- [UNIT_NAME =>] unit_NAME,
19504 -- BODY_FILE_NAME => STRING_LITERAL
19505 -- [, [INDEX =>] INTEGER_LITERAL]);
19507 -- pragma Source_File_Name (
19508 -- [UNIT_NAME =>] unit_NAME,
19509 -- SPEC_FILE_NAME => STRING_LITERAL
19510 -- [, [INDEX =>] INTEGER_LITERAL]);
19512 -- pragma Source_File_Name (
19513 -- BODY_FILE_NAME => STRING_LITERAL
19514 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19515 -- [, CASING => CASING_SPEC]);
19517 -- pragma Source_File_Name (
19518 -- SPEC_FILE_NAME => STRING_LITERAL
19519 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19520 -- [, CASING => CASING_SPEC]);
19522 -- pragma Source_File_Name (
19523 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19524 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19525 -- [, CASING => CASING_SPEC]);
19527 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19529 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19530 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19531 -- only be used when no project file is used, while SFNP can only be
19532 -- used when a project file is used.
19534 -- No processing here. Processing was completed during parsing, since
19535 -- we need to have file names set as early as possible. Units are
19536 -- loaded well before semantic processing starts.
19538 -- The only processing we defer to this point is the check for
19539 -- correct placement.
19541 when Pragma_Source_File_Name
=>
19543 Check_Valid_Configuration_Pragma
;
19545 ------------------------------
19546 -- Source_File_Name_Project --
19547 ------------------------------
19549 -- See Source_File_Name for syntax
19551 -- No processing here. Processing was completed during parsing, since
19552 -- we need to have file names set as early as possible. Units are
19553 -- loaded well before semantic processing starts.
19555 -- The only processing we defer to this point is the check for
19556 -- correct placement.
19558 when Pragma_Source_File_Name_Project
=>
19560 Check_Valid_Configuration_Pragma
;
19562 -- Check that a pragma Source_File_Name_Project is used only in a
19563 -- configuration pragmas file.
19565 -- Pragmas Source_File_Name_Project should only be generated by
19566 -- the Project Manager in configuration pragmas files.
19568 -- This is really an ugly test. It seems to depend on some
19569 -- accidental and undocumented property. At the very least it
19570 -- needs to be documented, but it would be better to have a
19571 -- clean way of testing if we are in a configuration file???
19573 if Present
(Parent
(N
)) then
19575 ("pragma% can only appear in a configuration pragmas file");
19578 ----------------------
19579 -- Source_Reference --
19580 ----------------------
19582 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19584 -- Nothing to do, all processing completed in Par.Prag, since we need
19585 -- the information for possible parser messages that are output.
19587 when Pragma_Source_Reference
=>
19594 -- pragma SPARK_Mode [(On | Off)];
19596 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19597 procedure Check_Pragma_Conformance
19598 (Context_Pragma
: Node_Id
;
19599 Entity_Pragma
: Node_Id
;
19600 Entity
: Entity_Id
);
19601 -- If Context_Pragma is not Empty, verify that the new pragma N
19602 -- is compatible with the pragma Context_Pragma that was inherited
19603 -- from the context:
19604 -- . if Context_Pragma is ON, then the new mode can be anything
19605 -- . if Context_Pragma is OFF, then the only allowed new mode is
19608 -- If Entity is not Empty, verify that the new pragma N is
19609 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19610 -- for Entity (which may be Empty):
19611 -- . if Entity_Pragma is ON, then the new mode can be anything
19612 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19614 -- . if Entity_Pragma is Empty, we always issue an error, as this
19615 -- corresponds to a case where a previous section of Entity
19616 -- had no SPARK_Mode set.
19618 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19619 -- Verify that pragma is applied to library-level entity E
19621 ------------------------------
19622 -- Check_Pragma_Conformance --
19623 ------------------------------
19625 procedure Check_Pragma_Conformance
19626 (Context_Pragma
: Node_Id
;
19627 Entity_Pragma
: Node_Id
;
19628 Entity
: Entity_Id
)
19631 if Present
(Context_Pragma
) then
19632 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19634 -- New mode less restrictive than the established mode
19636 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19637 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19640 ("cannot change SPARK_Mode from Off to On", Arg1
);
19641 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19642 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg1
);
19647 if Present
(Entity
) then
19648 if Present
(Entity_Pragma
) then
19649 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19650 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19652 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19653 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19655 ("\value Off was set for SPARK_Mode on&#",
19661 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19662 Error_Msg_Sloc
:= Sloc
(Entity
);
19664 ("\no value was set for SPARK_Mode on&#",
19669 end Check_Pragma_Conformance
;
19671 --------------------------------
19672 -- Check_Library_Level_Entity --
19673 --------------------------------
19675 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19676 MsgF
: constant String := "incorrect placement of pragma%";
19679 if not Is_Library_Level_Entity
(E
) then
19680 Error_Msg_Name_1
:= Pname
;
19681 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19683 if Ekind_In
(E
, E_Generic_Package
,
19688 ("\& is not a library-level package", N
, E
);
19691 ("\& is not a library-level subprogram", N
, E
);
19696 end Check_Library_Level_Entity
;
19700 Body_Id
: Entity_Id
;
19703 Mode_Id
: SPARK_Mode_Type
;
19704 Spec_Id
: Entity_Id
;
19707 -- Start of processing for Do_SPARK_Mode
19710 -- When a SPARK_Mode pragma appears inside an instantiation whose
19711 -- enclosing context has SPARK_Mode set to "off", the pragma has
19712 -- no semantic effect.
19714 if Ignore_Pragma_SPARK_Mode
then
19715 Rewrite
(N
, Make_Null_Statement
(Loc
));
19721 Check_No_Identifiers
;
19722 Check_At_Most_N_Arguments
(1);
19724 -- Check the legality of the mode (no argument = ON)
19726 if Arg_Count
= 1 then
19727 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19728 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19733 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19734 Context
:= Parent
(N
);
19736 -- The pragma appears in a configuration pragmas file
19738 if No
(Context
) then
19739 Check_Valid_Configuration_Pragma
;
19741 if Present
(SPARK_Mode_Pragma
) then
19742 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19743 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19747 SPARK_Mode_Pragma
:= N
;
19748 SPARK_Mode
:= Mode_Id
;
19750 -- The pragma acts as a configuration pragma in a compilation unit
19752 -- pragma SPARK_Mode ...;
19753 -- package Pack is ...;
19755 elsif Nkind
(Context
) = N_Compilation_Unit
19756 and then List_Containing
(N
) = Context_Items
(Context
)
19758 Check_Valid_Configuration_Pragma
;
19759 SPARK_Mode_Pragma
:= N
;
19760 SPARK_Mode
:= Mode_Id
;
19762 -- Otherwise the placement of the pragma within the tree dictates
19763 -- its associated construct. Inspect the declarative list where
19764 -- the pragma resides to find a potential construct.
19768 while Present
(Stmt
) loop
19770 -- Skip prior pragmas, but check for duplicates
19772 if Nkind
(Stmt
) = N_Pragma
then
19773 if Pragma_Name
(Stmt
) = Pname
then
19774 Error_Msg_Name_1
:= Pname
;
19775 Error_Msg_Sloc
:= Sloc
(Stmt
);
19776 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19780 -- The pragma applies to a [generic] subprogram declaration.
19781 -- Note that this case covers an internally generated spec
19782 -- for a stand alone body.
19785 -- procedure Proc ...;
19786 -- pragma SPARK_Mode ..;
19788 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19789 N_Subprogram_Declaration
)
19791 Spec_Id
:= Defining_Entity
(Stmt
);
19792 Check_Library_Level_Entity
(Spec_Id
);
19793 Check_Pragma_Conformance
19794 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19795 Entity_Pragma
=> Empty
,
19798 Set_SPARK_Pragma
(Spec_Id
, N
);
19799 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19802 -- Skip internally generated code
19804 elsif not Comes_From_Source
(Stmt
) then
19807 -- Otherwise the pragma does not apply to a legal construct
19808 -- or it does not appear at the top of a declarative or a
19809 -- statement list. Issue an error and stop the analysis.
19819 -- The pragma applies to a package or a subprogram that acts as
19820 -- a compilation unit.
19822 -- procedure Proc ...;
19823 -- pragma SPARK_Mode ...;
19825 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19826 Context
:= Unit
(Parent
(Context
));
19829 -- The pragma appears within package declarations
19831 if Nkind
(Context
) = N_Package_Specification
then
19832 Spec_Id
:= Defining_Entity
(Context
);
19833 Check_Library_Level_Entity
(Spec_Id
);
19835 -- The pragma is at the top of the visible declarations
19838 -- pragma SPARK_Mode ...;
19840 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19841 Check_Pragma_Conformance
19842 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19843 Entity_Pragma
=> Empty
,
19845 SPARK_Mode_Pragma
:= N
;
19846 SPARK_Mode
:= Mode_Id
;
19848 Set_SPARK_Pragma
(Spec_Id
, N
);
19849 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19850 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19851 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19853 -- The pragma is at the top of the private declarations
19857 -- pragma SPARK_Mode ...;
19860 Check_Pragma_Conformance
19861 (Context_Pragma
=> Empty
,
19862 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19863 Entity
=> Spec_Id
);
19864 SPARK_Mode_Pragma
:= N
;
19865 SPARK_Mode
:= Mode_Id
;
19867 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19868 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19871 -- The pragma appears at the top of package body declarations
19873 -- package body Pack is
19874 -- pragma SPARK_Mode ...;
19876 elsif Nkind
(Context
) = N_Package_Body
then
19877 Spec_Id
:= Corresponding_Spec
(Context
);
19878 Body_Id
:= Defining_Entity
(Context
);
19879 Check_Library_Level_Entity
(Body_Id
);
19880 Check_Pragma_Conformance
19881 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19882 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19883 Entity
=> Spec_Id
);
19884 SPARK_Mode_Pragma
:= N
;
19885 SPARK_Mode
:= Mode_Id
;
19887 Set_SPARK_Pragma
(Body_Id
, N
);
19888 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19889 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19890 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19892 -- The pragma appears at the top of package body statements
19894 -- package body Pack is
19896 -- pragma SPARK_Mode;
19898 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19899 and then Nkind
(Parent
(Context
)) = N_Package_Body
19901 Context
:= Parent
(Context
);
19902 Spec_Id
:= Corresponding_Spec
(Context
);
19903 Body_Id
:= Defining_Entity
(Context
);
19904 Check_Library_Level_Entity
(Body_Id
);
19905 Check_Pragma_Conformance
19906 (Context_Pragma
=> Empty
,
19907 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19908 Entity
=> Body_Id
);
19909 SPARK_Mode_Pragma
:= N
;
19910 SPARK_Mode
:= Mode_Id
;
19912 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19913 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19915 -- The pragma appeared as an aspect of a [generic] subprogram
19916 -- declaration that acts as a compilation unit.
19919 -- procedure Proc ...;
19920 -- pragma SPARK_Mode ...;
19922 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19923 N_Subprogram_Declaration
)
19925 Spec_Id
:= Defining_Entity
(Context
);
19926 Check_Library_Level_Entity
(Spec_Id
);
19927 Check_Pragma_Conformance
19928 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19929 Entity_Pragma
=> Empty
,
19932 Set_SPARK_Pragma
(Spec_Id
, N
);
19933 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19935 -- The pragma appears at the top of subprogram body
19938 -- procedure Proc ... is
19939 -- pragma SPARK_Mode;
19941 elsif Nkind
(Context
) = N_Subprogram_Body
then
19942 Spec_Id
:= Corresponding_Spec
(Context
);
19943 Context
:= Specification
(Context
);
19944 Body_Id
:= Defining_Entity
(Context
);
19946 -- Ignore pragma when applied to the special body created
19947 -- for inlining, recognized by its internal name _Parent.
19949 if Chars
(Body_Id
) = Name_uParent
then
19953 Check_Library_Level_Entity
(Body_Id
);
19955 -- The body is a completion of a previous declaration
19957 if Present
(Spec_Id
) then
19958 Check_Pragma_Conformance
19959 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19960 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19961 Entity
=> Spec_Id
);
19963 -- The body acts as spec
19966 Check_Pragma_Conformance
19967 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19968 Entity_Pragma
=> Empty
,
19972 SPARK_Mode_Pragma
:= N
;
19973 SPARK_Mode
:= Mode_Id
;
19975 Set_SPARK_Pragma
(Body_Id
, N
);
19976 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19978 -- The pragma does not apply to a legal construct, issue error
19986 --------------------------------
19987 -- Static_Elaboration_Desired --
19988 --------------------------------
19990 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19992 when Pragma_Static_Elaboration_Desired
=>
19994 Check_At_Most_N_Arguments
(1);
19996 if Is_Compilation_Unit
(Current_Scope
)
19997 and then Ekind
(Current_Scope
) = E_Package
19999 Set_Static_Elaboration_Desired
(Current_Scope
, True);
20001 Error_Pragma
("pragma% must apply to a library-level package");
20008 -- pragma Storage_Size (EXPRESSION);
20010 when Pragma_Storage_Size
=> Storage_Size
: declare
20011 P
: constant Node_Id
:= Parent
(N
);
20015 Check_No_Identifiers
;
20016 Check_Arg_Count
(1);
20018 -- The expression must be analyzed in the special manner described
20019 -- in "Handling of Default Expressions" in sem.ads.
20021 Arg
:= Get_Pragma_Arg
(Arg1
);
20022 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20024 if not Is_OK_Static_Expression
(Arg
) then
20025 Check_Restriction
(Static_Storage_Size
, Arg
);
20028 if Nkind
(P
) /= N_Task_Definition
then
20033 if Has_Storage_Size_Pragma
(P
) then
20034 Error_Pragma
("duplicate pragma% not allowed");
20036 Set_Has_Storage_Size_Pragma
(P
, True);
20039 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20047 -- pragma Storage_Unit (NUMERIC_LITERAL);
20049 -- Only permitted argument is System'Storage_Unit value
20051 when Pragma_Storage_Unit
=>
20052 Check_No_Identifiers
;
20053 Check_Arg_Count
(1);
20054 Check_Arg_Is_Integer_Literal
(Arg1
);
20056 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20057 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20059 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20061 ("the only allowed argument for pragma% is ^", Arg1
);
20064 --------------------
20065 -- Stream_Convert --
20066 --------------------
20068 -- pragma Stream_Convert (
20069 -- [Entity =>] type_LOCAL_NAME,
20070 -- [Read =>] function_NAME,
20071 -- [Write =>] function NAME);
20073 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20075 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20076 -- Check that the given argument is the name of a local function
20077 -- of one argument that is not overloaded earlier in the current
20078 -- local scope. A check is also made that the argument is a
20079 -- function with one parameter.
20081 --------------------------------------
20082 -- Check_OK_Stream_Convert_Function --
20083 --------------------------------------
20085 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20089 Check_Arg_Is_Local_Name
(Arg
);
20090 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20092 if Has_Homonym
(Ent
) then
20094 ("argument for pragma% may not be overloaded", Arg
);
20097 if Ekind
(Ent
) /= E_Function
20098 or else No
(First_Formal
(Ent
))
20099 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20102 ("argument for pragma% must be function of one argument",
20105 end Check_OK_Stream_Convert_Function
;
20107 -- Start of processing for Stream_Convert
20111 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20112 Check_Arg_Count
(3);
20113 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20114 Check_Optional_Identifier
(Arg2
, Name_Read
);
20115 Check_Optional_Identifier
(Arg3
, Name_Write
);
20116 Check_Arg_Is_Local_Name
(Arg1
);
20117 Check_OK_Stream_Convert_Function
(Arg2
);
20118 Check_OK_Stream_Convert_Function
(Arg3
);
20121 Typ
: constant Entity_Id
:=
20122 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20123 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20124 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20127 Check_First_Subtype
(Arg1
);
20129 -- Check for too early or too late. Note that we don't enforce
20130 -- the rule about primitive operations in this case, since, as
20131 -- is the case for explicit stream attributes themselves, these
20132 -- restrictions are not appropriate. Note that the chaining of
20133 -- the pragma by Rep_Item_Too_Late is actually the critical
20134 -- processing done for this pragma.
20136 if Rep_Item_Too_Early
(Typ
, N
)
20138 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20143 -- Return if previous error
20145 if Etype
(Typ
) = Any_Type
20147 Etype
(Read
) = Any_Type
20149 Etype
(Write
) = Any_Type
20156 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20158 ("incorrect return type for function&", Arg2
);
20161 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20163 ("incorrect parameter type for function&", Arg3
);
20166 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20167 Underlying_Type
(Etype
(Write
))
20170 ("result type of & does not match Read parameter type",
20174 end Stream_Convert
;
20180 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20182 -- This is processed by the parser since some of the style checks
20183 -- take place during source scanning and parsing. This means that
20184 -- we don't need to issue error messages here.
20186 when Pragma_Style_Checks
=> Style_Checks
: declare
20187 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20193 Check_No_Identifiers
;
20195 -- Two argument form
20197 if Arg_Count
= 2 then
20198 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20205 E_Id
:= Get_Pragma_Arg
(Arg2
);
20208 if not Is_Entity_Name
(E_Id
) then
20210 ("second argument of pragma% must be entity name",
20214 E
:= Entity
(E_Id
);
20216 if not Ignore_Style_Checks_Pragmas
then
20221 Set_Suppress_Style_Checks
20222 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20223 exit when No
(Homonym
(E
));
20230 -- One argument form
20233 Check_Arg_Count
(1);
20235 if Nkind
(A
) = N_String_Literal
then
20239 Slen
: constant Natural := Natural (String_Length
(S
));
20240 Options
: String (1 .. Slen
);
20246 C
:= Get_String_Char
(S
, Int
(J
));
20247 exit when not In_Character_Range
(C
);
20248 Options
(J
) := Get_Character
(C
);
20250 -- If at end of string, set options. As per discussion
20251 -- above, no need to check for errors, since we issued
20252 -- them in the parser.
20255 if not Ignore_Style_Checks_Pragmas
then
20256 Set_Style_Check_Options
(Options
);
20266 elsif Nkind
(A
) = N_Identifier
then
20267 if Chars
(A
) = Name_All_Checks
then
20268 if not Ignore_Style_Checks_Pragmas
then
20270 Set_GNAT_Style_Check_Options
;
20272 Set_Default_Style_Check_Options
;
20276 elsif Chars
(A
) = Name_On
then
20277 if not Ignore_Style_Checks_Pragmas
then
20278 Style_Check
:= True;
20281 elsif Chars
(A
) = Name_Off
then
20282 if not Ignore_Style_Checks_Pragmas
then
20283 Style_Check
:= False;
20294 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20296 when Pragma_Subtitle
=>
20298 Check_Arg_Count
(1);
20299 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20300 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20307 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20309 when Pragma_Suppress
=>
20310 Process_Suppress_Unsuppress
(True);
20316 -- pragma Suppress_All;
20318 -- The only check made here is that the pragma has no arguments.
20319 -- There are no placement rules, and the processing required (setting
20320 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20321 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20322 -- then creates and inserts a pragma Suppress (All_Checks).
20324 when Pragma_Suppress_All
=>
20326 Check_Arg_Count
(0);
20328 -------------------------
20329 -- Suppress_Debug_Info --
20330 -------------------------
20332 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20334 when Pragma_Suppress_Debug_Info
=>
20336 Check_Arg_Count
(1);
20337 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20338 Check_Arg_Is_Local_Name
(Arg1
);
20339 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20341 ----------------------------------
20342 -- Suppress_Exception_Locations --
20343 ----------------------------------
20345 -- pragma Suppress_Exception_Locations;
20347 when Pragma_Suppress_Exception_Locations
=>
20349 Check_Arg_Count
(0);
20350 Check_Valid_Configuration_Pragma
;
20351 Exception_Locations_Suppressed
:= True;
20353 -----------------------------
20354 -- Suppress_Initialization --
20355 -----------------------------
20357 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20359 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20365 Check_Arg_Count
(1);
20366 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20367 Check_Arg_Is_Local_Name
(Arg1
);
20369 E_Id
:= Get_Pragma_Arg
(Arg1
);
20371 if Etype
(E_Id
) = Any_Type
then
20375 E
:= Entity
(E_Id
);
20377 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20379 ("pragma% requires variable, type or subtype", Arg1
);
20382 if Rep_Item_Too_Early
(E
, N
)
20384 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20389 -- For incomplete/private type, set flag on full view
20391 if Is_Incomplete_Or_Private_Type
(E
) then
20392 if No
(Full_View
(Base_Type
(E
))) then
20394 ("argument of pragma% cannot be an incomplete type", Arg1
);
20396 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20399 -- For first subtype, set flag on base type
20401 elsif Is_First_Subtype
(E
) then
20402 Set_Suppress_Initialization
(Base_Type
(E
));
20404 -- For other than first subtype, set flag on subtype or variable
20407 Set_Suppress_Initialization
(E
);
20415 -- pragma System_Name (DIRECT_NAME);
20417 -- Syntax check: one argument, which must be the identifier GNAT or
20418 -- the identifier GCC, no other identifiers are acceptable.
20420 when Pragma_System_Name
=>
20422 Check_No_Identifiers
;
20423 Check_Arg_Count
(1);
20424 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20426 -----------------------------
20427 -- Task_Dispatching_Policy --
20428 -----------------------------
20430 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20432 when Pragma_Task_Dispatching_Policy
=> declare
20436 Check_Ada_83_Warning
;
20437 Check_Arg_Count
(1);
20438 Check_No_Identifiers
;
20439 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20440 Check_Valid_Configuration_Pragma
;
20441 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20442 DP
:= Fold_Upper
(Name_Buffer
(1));
20444 if Task_Dispatching_Policy
/= ' '
20445 and then Task_Dispatching_Policy
/= DP
20447 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20449 ("task dispatching policy incompatible with policy#");
20451 -- Set new policy, but always preserve System_Location since we
20452 -- like the error message with the run time name.
20455 Task_Dispatching_Policy
:= DP
;
20457 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20458 Task_Dispatching_Policy_Sloc
:= Loc
;
20467 -- pragma Task_Info (EXPRESSION);
20469 when Pragma_Task_Info
=> Task_Info
: declare
20470 P
: constant Node_Id
:= Parent
(N
);
20476 if Warn_On_Obsolescent_Feature
then
20478 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20479 & "instead?j?", N
);
20482 if Nkind
(P
) /= N_Task_Definition
then
20483 Error_Pragma
("pragma% must appear in task definition");
20486 Check_No_Identifiers
;
20487 Check_Arg_Count
(1);
20489 Analyze_And_Resolve
20490 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20492 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20496 Ent
:= Defining_Identifier
(Parent
(P
));
20498 -- Check duplicate pragma before we chain the pragma in the Rep
20499 -- Item chain of Ent.
20502 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20504 Error_Pragma
("duplicate pragma% not allowed");
20507 Record_Rep_Item
(Ent
, N
);
20514 -- pragma Task_Name (string_EXPRESSION);
20516 when Pragma_Task_Name
=> Task_Name
: declare
20517 P
: constant Node_Id
:= Parent
(N
);
20522 Check_No_Identifiers
;
20523 Check_Arg_Count
(1);
20525 Arg
:= Get_Pragma_Arg
(Arg1
);
20527 -- The expression is used in the call to Create_Task, and must be
20528 -- expanded there, not in the context of the current spec. It must
20529 -- however be analyzed to capture global references, in case it
20530 -- appears in a generic context.
20532 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20534 if Nkind
(P
) /= N_Task_Definition
then
20538 Ent
:= Defining_Identifier
(Parent
(P
));
20540 -- Check duplicate pragma before we chain the pragma in the Rep
20541 -- Item chain of Ent.
20544 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20546 Error_Pragma
("duplicate pragma% not allowed");
20549 Record_Rep_Item
(Ent
, N
);
20556 -- pragma Task_Storage (
20557 -- [Task_Type =>] LOCAL_NAME,
20558 -- [Top_Guard =>] static_integer_EXPRESSION);
20560 when Pragma_Task_Storage
=> Task_Storage
: declare
20561 Args
: Args_List
(1 .. 2);
20562 Names
: constant Name_List
(1 .. 2) := (
20566 Task_Type
: Node_Id
renames Args
(1);
20567 Top_Guard
: Node_Id
renames Args
(2);
20573 Gather_Associations
(Names
, Args
);
20575 if No
(Task_Type
) then
20577 ("missing task_type argument for pragma%");
20580 Check_Arg_Is_Local_Name
(Task_Type
);
20582 Ent
:= Entity
(Task_Type
);
20584 if not Is_Task_Type
(Ent
) then
20586 ("argument for pragma% must be task type", Task_Type
);
20589 if No
(Top_Guard
) then
20591 ("pragma% takes two arguments", Task_Type
);
20593 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20596 Check_First_Subtype
(Task_Type
);
20598 if Rep_Item_Too_Late
(Ent
, N
) then
20607 -- pragma Test_Case
20608 -- ([Name =>] Static_String_EXPRESSION
20609 -- ,[Mode =>] MODE_TYPE
20610 -- [, Requires => Boolean_EXPRESSION]
20611 -- [, Ensures => Boolean_EXPRESSION]);
20613 -- MODE_TYPE ::= Nominal | Robustness
20615 when Pragma_Test_Case
=>
20619 --------------------------
20620 -- Thread_Local_Storage --
20621 --------------------------
20623 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20625 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20631 Check_Arg_Count
(1);
20632 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20633 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20635 Id
:= Get_Pragma_Arg
(Arg1
);
20638 if not Is_Entity_Name
(Id
)
20639 or else Ekind
(Entity
(Id
)) /= E_Variable
20641 Error_Pragma_Arg
("local variable name required", Arg1
);
20646 if Rep_Item_Too_Early
(E
, N
)
20647 or else Rep_Item_Too_Late
(E
, N
)
20652 Set_Has_Pragma_Thread_Local_Storage
(E
);
20653 Set_Has_Gigi_Rep_Item
(E
);
20654 end Thread_Local_Storage
;
20660 -- pragma Time_Slice (static_duration_EXPRESSION);
20662 when Pragma_Time_Slice
=> Time_Slice
: declare
20668 Check_Arg_Count
(1);
20669 Check_No_Identifiers
;
20670 Check_In_Main_Program
;
20671 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20673 if not Error_Posted
(Arg1
) then
20675 while Present
(Nod
) loop
20676 if Nkind
(Nod
) = N_Pragma
20677 and then Pragma_Name
(Nod
) = Name_Time_Slice
20679 Error_Msg_Name_1
:= Pname
;
20680 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20687 -- Process only if in main unit
20689 if Get_Source_Unit
(Loc
) = Main_Unit
then
20690 Opt
.Time_Slice_Set
:= True;
20691 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20693 if Val
<= Ureal_0
then
20694 Opt
.Time_Slice_Value
:= 0;
20696 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20697 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20700 Opt
.Time_Slice_Value
:=
20701 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20710 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20712 -- TITLING_OPTION ::=
20713 -- [Title =>] STRING_LITERAL
20714 -- | [Subtitle =>] STRING_LITERAL
20716 when Pragma_Title
=> Title
: declare
20717 Args
: Args_List
(1 .. 2);
20718 Names
: constant Name_List
(1 .. 2) := (
20724 Gather_Associations
(Names
, Args
);
20727 for J
in 1 .. 2 loop
20728 if Present
(Args
(J
)) then
20729 Check_Arg_Is_OK_Static_Expression
20730 (Args
(J
), Standard_String
);
20735 ----------------------------
20736 -- Type_Invariant[_Class] --
20737 ----------------------------
20739 -- pragma Type_Invariant[_Class]
20740 -- ([Entity =>] type_LOCAL_NAME,
20741 -- [Check =>] EXPRESSION);
20743 when Pragma_Type_Invariant |
20744 Pragma_Type_Invariant_Class
=>
20745 Type_Invariant
: declare
20746 I_Pragma
: Node_Id
;
20749 Check_Arg_Count
(2);
20751 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20752 -- setting Class_Present for the Type_Invariant_Class case.
20754 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20755 I_Pragma
:= New_Copy
(N
);
20756 Set_Pragma_Identifier
20757 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20758 Rewrite
(N
, I_Pragma
);
20759 Set_Analyzed
(N
, False);
20761 end Type_Invariant
;
20763 ---------------------
20764 -- Unchecked_Union --
20765 ---------------------
20767 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20769 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20770 Assoc
: constant Node_Id
:= Arg1
;
20771 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20781 Check_No_Identifiers
;
20782 Check_Arg_Count
(1);
20783 Check_Arg_Is_Local_Name
(Arg1
);
20785 Find_Type
(Type_Id
);
20787 Typ
:= Entity
(Type_Id
);
20790 or else Rep_Item_Too_Early
(Typ
, N
)
20794 Typ
:= Underlying_Type
(Typ
);
20797 if Rep_Item_Too_Late
(Typ
, N
) then
20801 Check_First_Subtype
(Arg1
);
20803 -- Note remaining cases are references to a type in the current
20804 -- declarative part. If we find an error, we post the error on
20805 -- the relevant type declaration at an appropriate point.
20807 if not Is_Record_Type
(Typ
) then
20808 Error_Msg_N
("unchecked union must be record type", Typ
);
20811 elsif Is_Tagged_Type
(Typ
) then
20812 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20815 elsif not Has_Discriminants
(Typ
) then
20817 ("unchecked union must have one discriminant", Typ
);
20820 -- Note: in previous versions of GNAT we used to check for limited
20821 -- types and give an error, but in fact the standard does allow
20822 -- Unchecked_Union on limited types, so this check was removed.
20824 -- Similarly, GNAT used to require that all discriminants have
20825 -- default values, but this is not mandated by the RM.
20827 -- Proceed with basic error checks completed
20830 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20831 Clist
:= Component_List
(Tdef
);
20833 -- Check presence of component list and variant part
20835 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20837 ("unchecked union must have variant part", Tdef
);
20841 -- Check components
20843 Comp
:= First
(Component_Items
(Clist
));
20844 while Present
(Comp
) loop
20845 Check_Component
(Comp
, Typ
);
20849 -- Check variant part
20851 Vpart
:= Variant_Part
(Clist
);
20853 Variant
:= First
(Variants
(Vpart
));
20854 while Present
(Variant
) loop
20855 Check_Variant
(Variant
, Typ
);
20860 Set_Is_Unchecked_Union
(Typ
);
20861 Set_Convention
(Typ
, Convention_C
);
20862 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20863 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20864 end Unchecked_Union
;
20866 ------------------------
20867 -- Unimplemented_Unit --
20868 ------------------------
20870 -- pragma Unimplemented_Unit;
20872 -- Note: this only gives an error if we are generating code, or if
20873 -- we are in a generic library unit (where the pragma appears in the
20874 -- body, not in the spec).
20876 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20877 Cunitent
: constant Entity_Id
:=
20878 Cunit_Entity
(Get_Source_Unit
(Loc
));
20879 Ent_Kind
: constant Entity_Kind
:=
20884 Check_Arg_Count
(0);
20886 if Operating_Mode
= Generate_Code
20887 or else Ent_Kind
= E_Generic_Function
20888 or else Ent_Kind
= E_Generic_Procedure
20889 or else Ent_Kind
= E_Generic_Package
20891 Get_Name_String
(Chars
(Cunitent
));
20892 Set_Casing
(Mixed_Case
);
20893 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20894 Write_Str
(" is not supported in this configuration");
20896 raise Unrecoverable_Error
;
20898 end Unimplemented_Unit
;
20900 ------------------------
20901 -- Universal_Aliasing --
20902 ------------------------
20904 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20906 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20911 Check_Arg_Count
(1);
20912 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20913 Check_Arg_Is_Local_Name
(Arg1
);
20914 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20916 if E_Id
= Any_Type
then
20918 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20919 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20922 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20923 Record_Rep_Item
(E_Id
, N
);
20924 end Universal_Alias
;
20926 --------------------
20927 -- Universal_Data --
20928 --------------------
20930 -- pragma Universal_Data [(library_unit_NAME)];
20932 when Pragma_Universal_Data
=>
20935 -- If this is a configuration pragma, then set the universal
20936 -- addressing option, otherwise confirm that the pragma satisfies
20937 -- the requirements of library unit pragma placement and leave it
20938 -- to the GNAAMP back end to detect the pragma (avoids transitive
20939 -- setting of the option due to withed units).
20941 if Is_Configuration_Pragma
then
20942 Universal_Addressing_On_AAMP
:= True;
20944 Check_Valid_Library_Unit_Pragma
;
20947 if not AAMP_On_Target
then
20948 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20955 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20957 when Pragma_Unmodified
=> Unmodified
: declare
20958 Arg_Node
: Node_Id
;
20959 Arg_Expr
: Node_Id
;
20960 Arg_Ent
: Entity_Id
;
20964 Check_At_Least_N_Arguments
(1);
20966 -- Loop through arguments
20969 while Present
(Arg_Node
) loop
20970 Check_No_Identifier
(Arg_Node
);
20972 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
20973 -- in fact generate reference, so that the entity will have a
20974 -- reference, which will inhibit any warnings about it not
20975 -- being referenced, and also properly show up in the ali file
20976 -- as a reference. But this reference is recorded before the
20977 -- Has_Pragma_Unreferenced flag is set, so that no warning is
20978 -- generated for this reference.
20980 Check_Arg_Is_Local_Name
(Arg_Node
);
20981 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20983 if Is_Entity_Name
(Arg_Expr
) then
20984 Arg_Ent
:= Entity
(Arg_Expr
);
20986 if not Is_Assignable
(Arg_Ent
) then
20988 ("pragma% can only be applied to a variable",
20991 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21003 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21005 -- or when used in a context clause:
21007 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21009 when Pragma_Unreferenced
=> Unreferenced
: declare
21010 Arg_Node
: Node_Id
;
21011 Arg_Expr
: Node_Id
;
21012 Arg_Ent
: Entity_Id
;
21017 Check_At_Least_N_Arguments
(1);
21019 -- Check case of appearing within context clause
21021 if Is_In_Context_Clause
then
21023 -- The arguments must all be units mentioned in a with clause
21024 -- in the same context clause. Note we already checked (in
21025 -- Par.Prag) that the arguments are either identifiers or
21026 -- selected components.
21029 while Present
(Arg_Node
) loop
21030 Citem
:= First
(List_Containing
(N
));
21031 while Citem
/= N
loop
21032 if Nkind
(Citem
) = N_With_Clause
21034 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21036 Set_Has_Pragma_Unreferenced
21039 (Library_Unit
(Citem
))));
21041 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21050 ("argument of pragma% is not withed unit", Arg_Node
);
21056 -- Case of not in list of context items
21060 while Present
(Arg_Node
) loop
21061 Check_No_Identifier
(Arg_Node
);
21063 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21064 -- will in fact generate reference, so that the entity will
21065 -- have a reference, which will inhibit any warnings about
21066 -- it not being referenced, and also properly show up in the
21067 -- ali file as a reference. But this reference is recorded
21068 -- before the Has_Pragma_Unreferenced flag is set, so that
21069 -- no warning is generated for this reference.
21071 Check_Arg_Is_Local_Name
(Arg_Node
);
21072 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21074 if Is_Entity_Name
(Arg_Expr
) then
21075 Arg_Ent
:= Entity
(Arg_Expr
);
21077 -- If the entity is overloaded, the pragma applies to the
21078 -- most recent overloading, as documented. In this case,
21079 -- name resolution does not generate a reference, so it
21080 -- must be done here explicitly.
21082 if Is_Overloaded
(Arg_Expr
) then
21083 Generate_Reference
(Arg_Ent
, N
);
21086 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21094 --------------------------
21095 -- Unreferenced_Objects --
21096 --------------------------
21098 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21100 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21101 Arg_Node
: Node_Id
;
21102 Arg_Expr
: Node_Id
;
21106 Check_At_Least_N_Arguments
(1);
21109 while Present
(Arg_Node
) loop
21110 Check_No_Identifier
(Arg_Node
);
21111 Check_Arg_Is_Local_Name
(Arg_Node
);
21112 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21114 if not Is_Entity_Name
(Arg_Expr
)
21115 or else not Is_Type
(Entity
(Arg_Expr
))
21118 ("argument for pragma% must be type or subtype", Arg_Node
);
21121 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21124 end Unreferenced_Objects
;
21126 ------------------------------
21127 -- Unreserve_All_Interrupts --
21128 ------------------------------
21130 -- pragma Unreserve_All_Interrupts;
21132 when Pragma_Unreserve_All_Interrupts
=>
21134 Check_Arg_Count
(0);
21136 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21137 Unreserve_All_Interrupts
:= True;
21144 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21146 when Pragma_Unsuppress
=>
21148 Process_Suppress_Unsuppress
(False);
21150 ----------------------------
21151 -- Unevaluated_Use_Of_Old --
21152 ----------------------------
21154 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21156 when Pragma_Unevaluated_Use_Of_Old
=>
21158 Check_Arg_Count
(1);
21159 Check_No_Identifiers
;
21160 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
21162 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21163 -- a declarative part or a package spec.
21165 if not Is_Configuration_Pragma
then
21166 Check_Is_In_Decl_Part_Or_Package_Spec
;
21169 -- Store proper setting of Uneval_Old
21171 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21172 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
21174 -------------------
21175 -- Use_VADS_Size --
21176 -------------------
21178 -- pragma Use_VADS_Size;
21180 when Pragma_Use_VADS_Size
=>
21182 Check_Arg_Count
(0);
21183 Check_Valid_Configuration_Pragma
;
21184 Use_VADS_Size
:= True;
21186 ---------------------
21187 -- Validity_Checks --
21188 ---------------------
21190 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21192 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21193 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21199 Check_Arg_Count
(1);
21200 Check_No_Identifiers
;
21202 -- Pragma always active unless in CodePeer or GNATprove modes,
21203 -- which use a fixed configuration of validity checks.
21205 if not (CodePeer_Mode
or GNATprove_Mode
) then
21206 if Nkind
(A
) = N_String_Literal
then
21210 Slen
: constant Natural := Natural (String_Length
(S
));
21211 Options
: String (1 .. Slen
);
21215 -- Couldn't we use a for loop here over Options'Range???
21219 C
:= Get_String_Char
(S
, Int
(J
));
21221 -- This is a weird test, it skips setting validity
21222 -- checks entirely if any element of S is out of
21223 -- range of Character, what is that about ???
21225 exit when not In_Character_Range
(C
);
21226 Options
(J
) := Get_Character
(C
);
21229 Set_Validity_Check_Options
(Options
);
21237 elsif Nkind
(A
) = N_Identifier
then
21238 if Chars
(A
) = Name_All_Checks
then
21239 Set_Validity_Check_Options
("a");
21240 elsif Chars
(A
) = Name_On
then
21241 Validity_Checks_On
:= True;
21242 elsif Chars
(A
) = Name_Off
then
21243 Validity_Checks_On
:= False;
21247 end Validity_Checks
;
21253 -- pragma Volatile (LOCAL_NAME);
21255 when Pragma_Volatile
=>
21256 Process_Atomic_Shared_Volatile
;
21258 -------------------------
21259 -- Volatile_Components --
21260 -------------------------
21262 -- pragma Volatile_Components (array_LOCAL_NAME);
21264 -- Volatile is handled by the same circuit as Atomic_Components
21266 ----------------------
21267 -- Warning_As_Error --
21268 ----------------------
21270 -- pragma Warning_As_Error (static_string_EXPRESSION);
21272 when Pragma_Warning_As_Error
=>
21274 Check_Arg_Count
(1);
21275 Check_No_Identifiers
;
21276 Check_Valid_Configuration_Pragma
;
21278 if not Is_Static_String_Expression
(Arg1
) then
21280 ("argument of pragma% must be static string expression",
21283 -- OK static string expression
21286 Acquire_Warning_Match_String
(Arg1
);
21287 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21288 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21289 new String'(Name_Buffer (1 .. Name_Len));
21296 -- pragma Warnings (On | Off [,REASON]);
21297 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
21298 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
21299 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
21301 -- REASON ::= Reason => Static_String_Expression
21303 when Pragma_Warnings => Warnings : declare
21304 Reason : String_Id;
21308 Check_At_Least_N_Arguments (1);
21310 -- See if last argument is labeled Reason. If so, make sure we
21311 -- have a static string expression, and acquire the REASON string.
21312 -- Then remove the REASON argument by decreasing Num_Args by one;
21313 -- Remaining processing looks only at first Num_Args arguments).
21316 Last_Arg : constant Node_Id :=
21317 Last (Pragma_Argument_Associations (N));
21320 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21321 and then Chars (Last_Arg) = Name_Reason
21324 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21325 Reason := End_String;
21326 Arg_Count := Arg_Count - 1;
21328 -- Not allowed in compiler units (bootstrap issues)
21330 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21332 -- No REASON string, set null string as reason
21335 Reason := Null_String_Id;
21339 -- Now proceed with REASON taken care of and eliminated
21341 Check_No_Identifiers;
21343 -- If debug flag -gnatd.i is set, pragma is ignored
21345 if Debug_Flag_Dot_I then
21349 -- Process various forms of the pragma
21352 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21355 -- One argument case
21357 if Arg_Count = 1 then
21359 -- On/Off one argument case was processed by parser
21361 if Nkind (Argx) = N_Identifier
21362 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21366 -- One argument case must be ON/OFF or static string expr
21368 elsif not Is_Static_String_Expression (Arg1) then
21370 ("argument of pragma% must be On/Off or static string "
21371 & "expression", Arg1);
21373 -- One argument string expression case
21377 Lit : constant Node_Id := Expr_Value_S (Argx);
21378 Str : constant String_Id := Strval (Lit);
21379 Len : constant Nat := String_Length (Str);
21387 while J <= Len loop
21388 C := Get_String_Char (Str, J);
21389 OK := In_Character_Range (C);
21392 Chr := Get_Character (C);
21394 -- Dash case: only -Wxxx is accepted
21401 C := Get_String_Char (Str, J);
21402 Chr := Get_Character (C);
21403 exit when Chr = 'W
';
21408 elsif J < Len and then Chr = '.' then
21410 C := Get_String_Char (Str, J);
21411 Chr := Get_Character (C);
21413 if not Set_Dot_Warning_Switch (Chr) then
21415 ("invalid warning switch character "
21416 & '.' & Chr, Arg1);
21422 OK := Set_Warning_Switch (Chr);
21428 ("invalid warning switch character " & Chr,
21437 -- Two or more arguments (must be two)
21440 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21441 Check_Arg_Count (2);
21449 E_Id := Get_Pragma_Arg (Arg2);
21452 -- In the expansion of an inlined body, a reference to
21453 -- the formal may be wrapped in a conversion if the
21454 -- actual is a conversion. Retrieve the real entity name.
21456 if (In_Instance_Body or In_Inlined_Body)
21457 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21459 E_Id := Expression (E_Id);
21462 -- Entity name case
21464 if Is_Entity_Name (E_Id) then
21465 E := Entity (E_Id);
21472 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21475 -- For OFF case, make entry in warnings off
21476 -- pragma table for later processing. But we do
21477 -- not do that within an instance, since these
21478 -- warnings are about what is needed in the
21479 -- template, not an instance of it.
21481 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21482 and then Warn_On_Warnings_Off
21483 and then not In_Instance
21485 Warnings_Off_Pragmas.Append ((N, E, Reason));
21488 if Is_Enumeration_Type (E) then
21492 Lit := First_Literal (E);
21493 while Present (Lit) loop
21494 Set_Warnings_Off (Lit);
21495 Next_Literal (Lit);
21500 exit when No (Homonym (E));
21505 -- Error if not entity or static string expression case
21507 elsif not Is_Static_String_Expression (Arg2) then
21509 ("second argument of pragma% must be entity name "
21510 & "or static string expression", Arg2);
21512 -- Static string expression case
21515 Acquire_Warning_Match_String (Arg2);
21517 -- Note on configuration pragma case: If this is a
21518 -- configuration pragma, then for an OFF pragma, we
21519 -- just set Config True in the call, which is all
21520 -- that needs to be done. For the case of ON, this
21521 -- is normally an error, unless it is canceling the
21522 -- effect of a previous OFF pragma in the same file.
21523 -- In any other case, an error will be signalled (ON
21524 -- with no matching OFF).
21526 -- Note: We set Used if we are inside a generic to
21527 -- disable the test that the non-config case actually
21528 -- cancels a warning. That's because we can't be sure
21529 -- there isn't an instantiation in some other unit
21530 -- where a warning is suppressed.
21532 -- We could do a little better here by checking if the
21533 -- generic unit we are inside is public, but for now
21534 -- we don't bother with that refinement.
21536 if Chars (Argx) = Name_Off then
21537 Set_Specific_Warning_Off
21538 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21539 Config => Is_Configuration_Pragma,
21540 Used => Inside_A_Generic or else In_Instance);
21542 elsif Chars (Argx) = Name_On then
21543 Set_Specific_Warning_On
21544 (Loc, Name_Buffer (1 .. Name_Len), Err);
21548 ("??pragma Warnings On with no matching "
21549 & "Warnings Off", Loc);
21558 -------------------
21559 -- Weak_External --
21560 -------------------
21562 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21564 when Pragma_Weak_External => Weak_External : declare
21569 Check_Arg_Count (1);
21570 Check_Optional_Identifier (Arg1, Name_Entity);
21571 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21572 Ent := Entity (Get_Pragma_Arg (Arg1));
21574 if Rep_Item_Too_Early (Ent, N) then
21577 Ent := Underlying_Type (Ent);
21580 -- The only processing required is to link this item on to the
21581 -- list of rep items for the given entity. This is accomplished
21582 -- by the call to Rep_Item_Too_Late (when no error is detected
21583 -- and False is returned).
21585 if Rep_Item_Too_Late (Ent, N) then
21588 Set_Has_Gigi_Rep_Item (Ent);
21592 -----------------------------
21593 -- Wide_Character_Encoding --
21594 -----------------------------
21596 -- pragma Wide_Character_Encoding (IDENTIFIER);
21598 when Pragma_Wide_Character_Encoding =>
21601 -- Nothing to do, handled in parser. Note that we do not enforce
21602 -- configuration pragma placement, this pragma can appear at any
21603 -- place in the source, allowing mixed encodings within a single
21608 --------------------
21609 -- Unknown_Pragma --
21610 --------------------
21612 -- Should be impossible, since the case of an unknown pragma is
21613 -- separately processed before the case statement is entered.
21615 when Unknown_Pragma =>
21616 raise Program_Error;
21619 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21620 -- until AI is formally approved.
21622 -- Check_Order_Dependence;
21625 when Pragma_Exit => null;
21626 end Analyze_Pragma;
21628 ---------------------------------------------
21629 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21630 ---------------------------------------------
21632 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21634 Subp_Id : Entity_Id)
21636 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21637 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21640 Restore_Scope : Boolean := False;
21641 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21644 -- Ensure that the subprogram and its formals are visible when analyzing
21645 -- the expression of the pragma.
21647 if not In_Open_Scopes (Subp_Id) then
21648 Restore_Scope := True;
21649 Push_Scope (Subp_Id);
21650 Install_Formals (Subp_Id);
21653 -- Preanalyze the boolean expression, we treat this as a spec expression
21654 -- (i.e. similar to a default expression).
21656 Expr := Get_Pragma_Arg (Arg1);
21658 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21659 -- the original aspect expression, which is shared with the generated
21662 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21663 Expr := Expression (Corresponding_Aspect (Prag));
21666 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21668 -- For a class-wide condition, a reference to a controlling formal must
21669 -- be interpreted as having the class-wide type (or an access to such)
21670 -- so that the inherited condition can be properly applied to any
21671 -- overriding operation (see ARM12 6.6.1 (7)).
21673 if Class_Present (Prag) then
21674 Class_Wide_Condition : declare
21675 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21677 ACW : Entity_Id := Empty;
21678 -- Access to T'class, created if there is a controlling formal
21679 -- that is an access parameter.
21681 function Get_ACW return Entity_Id;
21682 -- If the expression has a reference to an controlling access
21683 -- parameter, create an access to T'class for the necessary
21684 -- conversions if one does not exist.
21686 function Process (N : Node_Id) return Traverse_Result;
21687 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21688 -- aspect for a primitive subprogram of a tagged type T, a name
21689 -- that denotes a formal parameter of type T is interpreted as
21690 -- having type T'Class. Similarly, a name that denotes a formal
21691 -- accessparameter of type access-to-T is interpreted as having
21692 -- type access-to-T'Class. This ensures the expression is well-
21693 -- defined for a primitive subprogram of a type descended from T.
21694 -- Note that this replacement is not done for selector names in
21695 -- parameter associations. These carry an entity for reference
21696 -- purposes, but semantically they are just identifiers.
21702 function Get_ACW return Entity_Id is
21703 Loc : constant Source_Ptr := Sloc (Prag);
21709 Make_Full_Type_Declaration (Loc,
21710 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21712 Make_Access_To_Object_Definition (Loc,
21713 Subtype_Indication =>
21714 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21715 All_Present => True));
21717 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21719 ACW := Defining_Identifier (Decl);
21720 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21730 function Process (N : Node_Id) return Traverse_Result is
21731 Loc : constant Source_Ptr := Sloc (N);
21735 if Is_Entity_Name (N)
21736 and then Present (Entity (N))
21737 and then Is_Formal (Entity (N))
21738 and then Nkind (Parent (N)) /= N_Type_Conversion
21740 (Nkind (Parent (N)) /= N_Parameter_Association
21741 or else N /= Selector_Name (Parent (N)))
21743 if Etype (Entity (N)) = T then
21744 Typ := Class_Wide_Type (T);
21746 elsif Is_Access_Type (Etype (Entity (N)))
21747 and then Designated_Type (Etype (Entity (N))) = T
21754 if Present (Typ) then
21756 Make_Type_Conversion (Loc,
21758 New_Occurrence_Of (Typ, Loc),
21759 Expression => New_Occurrence_Of (Entity (N), Loc)));
21760 Set_Etype (N, Typ);
21767 procedure Replace_Type is new Traverse_Proc (Process);
21769 -- Start of processing for Class_Wide_Condition
21772 if not Present (T) then
21774 -- Pre'Class/Post'Class aspect cases
21776 if From_Aspect_Specification (Prag) then
21777 if Nam = Name_uPre then
21778 Error_Msg_Name_1 := Name_Pre;
21780 Error_Msg_Name_1 := Name_Post;
21783 Error_Msg_Name_2 := Name_Class;
21786 ("aspect `%''%` can only be specified for a primitive "
21787 & "operation of a tagged type",
21788 Corresponding_Aspect (Prag));
21790 -- Pre_Class, Post_Class pragma cases
21793 if Nam = Name_uPre then
21794 Error_Msg_Name_1 := Name_Pre_Class;
21796 Error_Msg_Name_1 := Name_Post_Class;
21800 ("pragma% can only be specified for a primitive "
21801 & "operation of a tagged type",
21802 Corresponding_Aspect (Prag));
21806 Replace_Type (Get_Pragma_Arg (Arg1));
21807 end Class_Wide_Condition;
21810 -- Remove the subprogram from the scope stack now that the pre-analysis
21811 -- of the precondition/postcondition is done.
21813 if Restore_Scope then
21816 end Analyze_Pre_Post_Condition_In_Decl_Part;
21818 ------------------------------------------
21819 -- Analyze_Refined_Depends_In_Decl_Part --
21820 ------------------------------------------
21822 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21823 Dependencies : List_Id := No_List;
21825 -- The corresponding Depends pragma along with its clauses
21827 Matched_Items : Elist_Id := No_Elist;
21828 -- A list containing the entities of all successfully matched items
21829 -- found in pragma Depends.
21831 Refinements : List_Id := No_List;
21832 -- The clauses of pragma Refined_Depends
21834 Spec_Id : Entity_Id;
21835 -- The entity of the subprogram subject to pragma Refined_Depends
21837 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21838 -- Try to match a single dependency clause Dep_Clause against one or
21839 -- more refinement clauses found in list Refinements. Each successful
21840 -- match eliminates at least one refinement clause from Refinements.
21842 procedure Normalize_Clauses (Clauses : List_Id);
21843 -- Given a list of dependence or refinement clauses Clauses, normalize
21844 -- each clause by creating multiple dependencies with exactly one input
21847 procedure Report_Extra_Clauses;
21848 -- Emit an error for each extra clause found in list Refinements
21850 -----------------------------
21851 -- Check_Dependency_Clause --
21852 -----------------------------
21854 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21855 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21856 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21858 function Is_In_Out_State_Clause return Boolean;
21859 -- Determine whether dependence clause Dep_Clause denotes an abstract
21860 -- state that depends on itself (State => State).
21862 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21863 -- Determine whether item Item denotes an abstract state with visible
21864 -- null refinement.
21866 procedure Match_Items
21867 (Dep_Item : Node_Id;
21868 Ref_Item : Node_Id;
21869 Matched : out Boolean);
21870 -- Try to match dependence item Dep_Item against refinement item
21871 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21872 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21873 -- the following conformance scenarios is in effect:
21874 -- 1) Both items denote null
21875 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21876 -- 3) Both items denote attribute 'Result
21877 -- 4) Both items denote the same formal parameter
21878 -- 5) Both items denote the same variable
21879 -- 6) Dep_Item is an abstract state with visible null refinement
21880 -- and Ref_Item denotes null.
21881 -- 7) Dep_Item is an abstract state with visible null refinement
21882 -- and Ref_Item is Empty (special case).
21883 -- 8) Dep_Item is an abstract state with visible non-null
21884 -- refinement and Ref_Item denotes one of its constituents.
21885 -- 9) Dep_Item is an abstract state without a visible refinement
21886 -- and Ref_Item denotes the same state.
21887 -- When scenario 8 is in effect, the entity of the abstract state
21888 -- denoted by Dep_Item is added to list Refined_States.
21890 procedure Record_Item
(Item_Id
: Entity_Id
);
21891 -- Store the entity of an item denoted by Item_Id in Matched_Items
21893 ----------------------------
21894 -- Is_In_Out_State_Clause --
21895 ----------------------------
21897 function Is_In_Out_State_Clause
return Boolean is
21898 Dep_Input_Id
: Entity_Id
;
21899 Dep_Output_Id
: Entity_Id
;
21902 -- Detect the following clause:
21905 if Is_Entity_Name
(Dep_Input
)
21906 and then Is_Entity_Name
(Dep_Output
)
21908 -- Handle abstract views generated for limited with clauses
21910 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
21911 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
21914 Ekind
(Dep_Input_Id
) = E_Abstract_State
21915 and then Dep_Input_Id
= Dep_Output_Id
;
21919 end Is_In_Out_State_Clause
;
21921 ---------------------------
21922 -- Is_Null_Refined_State --
21923 ---------------------------
21925 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
21926 Item_Id
: Entity_Id
;
21929 if Is_Entity_Name
(Item
) then
21931 -- Handle abstract views generated for limited with clauses
21933 Item_Id
:= Available_View
(Entity_Of
(Item
));
21935 return Ekind
(Item_Id
) = E_Abstract_State
21936 and then Has_Null_Refinement
(Item_Id
);
21941 end Is_Null_Refined_State
;
21947 procedure Match_Items
21948 (Dep_Item
: Node_Id
;
21949 Ref_Item
: Node_Id
;
21950 Matched
: out Boolean)
21952 Dep_Item_Id
: Entity_Id
;
21953 Ref_Item_Id
: Entity_Id
;
21956 -- Assume that the two items do not match
21960 -- A null matches null or Empty (special case)
21962 if Nkind
(Dep_Item
) = N_Null
21963 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21967 -- Attribute 'Result matches attribute 'Result
21969 elsif Is_Attribute_Result
(Dep_Item
)
21970 and then Is_Attribute_Result
(Dep_Item
)
21974 -- Abstract states, formal parameters and variables
21976 elsif Is_Entity_Name
(Dep_Item
) then
21978 -- Handle abstract views generated for limited with clauses
21980 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
21982 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
21984 -- An abstract state with visible null refinement matches
21985 -- null or Empty (special case).
21987 if Has_Null_Refinement
(Dep_Item_Id
)
21988 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21990 Record_Item
(Dep_Item_Id
);
21993 -- An abstract state with visible non-null refinement
21994 -- matches one of its constituents.
21996 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
21997 if Is_Entity_Name
(Ref_Item
) then
21998 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
22000 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
, E_Variable
)
22001 and then Present
(Encapsulating_State
(Ref_Item_Id
))
22002 and then Encapsulating_State
(Ref_Item_Id
) =
22005 Record_Item
(Dep_Item_Id
);
22010 -- An abstract state without a visible refinement matches
22013 elsif Is_Entity_Name
(Ref_Item
)
22014 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22016 Record_Item
(Dep_Item_Id
);
22020 -- A formal parameter or a variable matches itself
22022 elsif Is_Entity_Name
(Ref_Item
)
22023 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22025 Record_Item
(Dep_Item_Id
);
22035 procedure Record_Item
(Item_Id
: Entity_Id
) is
22037 if not Contains
(Matched_Items
, Item_Id
) then
22038 Add_Item
(Item_Id
, Matched_Items
);
22044 Clause_Matched
: Boolean := False;
22045 Dummy
: Boolean := False;
22046 Inputs_Match
: Boolean;
22047 Next_Ref_Clause
: Node_Id
;
22048 Outputs_Match
: Boolean;
22049 Ref_Clause
: Node_Id
;
22050 Ref_Input
: Node_Id
;
22051 Ref_Output
: Node_Id
;
22053 -- Start of processing for Check_Dependency_Clause
22056 -- Examine all refinement clauses and compare them against the
22057 -- dependence clause.
22059 Ref_Clause
:= First
(Refinements
);
22060 while Present
(Ref_Clause
) loop
22061 Next_Ref_Clause
:= Next
(Ref_Clause
);
22063 -- Obtain the attributes of the current refinement clause
22065 Ref_Input
:= Expression
(Ref_Clause
);
22066 Ref_Output
:= First
(Choices
(Ref_Clause
));
22068 -- The current refinement clause matches the dependence clause
22069 -- when both outputs match and both inputs match. See routine
22070 -- Match_Items for all possible conformance scenarios.
22072 -- Depends Dep_Output => Dep_Input
22076 -- Refined_Depends Ref_Output => Ref_Input
22079 (Dep_Item
=> Dep_Input
,
22080 Ref_Item
=> Ref_Input
,
22081 Matched
=> Inputs_Match
);
22084 (Dep_Item
=> Dep_Output
,
22085 Ref_Item
=> Ref_Output
,
22086 Matched
=> Outputs_Match
);
22088 -- An In_Out state clause may be matched against a refinement with
22089 -- a null input or null output as long as the non-null side of the
22090 -- relation contains a valid constituent of the In_Out_State.
22092 if Is_In_Out_State_Clause
then
22094 -- Depends => (State => State)
22095 -- Refined_Depends => (null => Constit) -- OK
22098 and then not Outputs_Match
22099 and then Nkind
(Ref_Output
) = N_Null
22101 Outputs_Match
:= True;
22104 -- Depends => (State => State)
22105 -- Refined_Depends => (Constit => null) -- OK
22107 if not Inputs_Match
22108 and then Outputs_Match
22109 and then Nkind
(Ref_Input
) = N_Null
22111 Inputs_Match
:= True;
22115 -- The current refinement clause is legally constructed following
22116 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22117 -- the pool of candidates. The seach continues because a single
22118 -- dependence clause may have multiple matching refinements.
22120 if Inputs_Match
and then Outputs_Match
then
22121 Clause_Matched
:= True;
22122 Remove
(Ref_Clause
);
22125 Ref_Clause
:= Next_Ref_Clause
;
22128 -- Depending on the order or composition of refinement clauses, an
22129 -- In_Out state clause may not be directly refinable.
22131 -- Depends => ((Output, State) => (Input, State))
22132 -- Refined_State => (State => (Constit_1, Constit_2))
22133 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22135 -- Matching normalized clause (State => State) fails because there is
22136 -- no direct refinement capable of satisfying this relation. Another
22137 -- similar case arises when clauses (Constit_1 => Input) and (Output
22138 -- => Constit_2) are matched first, leaving no candidates for clause
22139 -- (State => State). Both scenarios are legal as long as one of the
22140 -- previous clauses mentioned a valid constituent of State.
22142 if not Clause_Matched
22143 and then Is_In_Out_State_Clause
22145 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22147 Clause_Matched
:= True;
22150 -- A clause where the input is an abstract state with visible null
22151 -- refinement is implicitly matched when the output has already been
22152 -- matched in a previous clause.
22154 -- Depends => (Output => State) -- implicitly OK
22155 -- Refined_State => (State => null)
22156 -- Refined_Depends => (Output => ...)
22158 if not Clause_Matched
22159 and then Is_Null_Refined_State
(Dep_Input
)
22160 and then Is_Entity_Name
(Dep_Output
)
22162 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
22164 Clause_Matched
:= True;
22167 -- A clause where the output is an abstract state with visible null
22168 -- refinement is implicitly matched when the input has already been
22169 -- matched in a previous clause.
22171 -- Depends => (State => Input) -- implicitly OK
22172 -- Refined_State => (State => null)
22173 -- Refined_Depends => (... => Input)
22175 if not Clause_Matched
22176 and then Is_Null_Refined_State
(Dep_Output
)
22177 and then Is_Entity_Name
(Dep_Input
)
22179 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22181 Clause_Matched
:= True;
22184 -- At this point either all refinement clauses have been examined or
22185 -- pragma Refined_Depends contains a solitary null. Only an abstract
22186 -- state with null refinement can possibly match these cases.
22188 -- Depends => (State => null)
22189 -- Refined_State => (State => null)
22190 -- Refined_Depends => null -- OK
22192 if not Clause_Matched
then
22194 (Dep_Item
=> Dep_Input
,
22196 Matched
=> Inputs_Match
);
22199 (Dep_Item
=> Dep_Output
,
22201 Matched
=> Outputs_Match
);
22203 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
22206 -- If the contents of Refined_Depends are legal, then the current
22207 -- dependence clause should be satisfied either by an explicit match
22208 -- or by one of the special cases.
22210 if not Clause_Matched
then
22212 ("dependence clause of subprogram & has no matching refinement "
22213 & "in body", Dep_Clause
, Spec_Id
);
22215 end Check_Dependency_Clause
;
22217 -----------------------
22218 -- Normalize_Clauses --
22219 -----------------------
22221 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22222 procedure Normalize_Inputs
(Clause
: Node_Id
);
22223 -- Normalize clause Clause by creating multiple clauses for each
22224 -- input item of Clause. It is assumed that Clause has exactly one
22225 -- output. The transformation is as follows:
22227 -- Output => (Input_1, Input_2) -- original
22229 -- Output => Input_1 -- normalizations
22230 -- Output => Input_2
22232 ----------------------
22233 -- Normalize_Inputs --
22234 ----------------------
22236 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22237 Inputs
: constant Node_Id
:= Expression
(Clause
);
22238 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22239 Output
: constant List_Id
:= Choices
(Clause
);
22240 Last_Input
: Node_Id
;
22242 New_Clause
: Node_Id
;
22243 Next_Input
: Node_Id
;
22246 -- Normalization is performed only when the original clause has
22247 -- more than one input. Multiple inputs appear as an aggregate.
22249 if Nkind
(Inputs
) = N_Aggregate
then
22250 Last_Input
:= Last
(Expressions
(Inputs
));
22252 -- Create a new clause for each input
22254 Input
:= First
(Expressions
(Inputs
));
22255 while Present
(Input
) loop
22256 Next_Input
:= Next
(Input
);
22258 -- Unhook the current input from the original input list
22259 -- because it will be relocated to a new clause.
22263 -- Special processing for the last input. At this point the
22264 -- original aggregate has been stripped down to one element.
22265 -- Replace the aggregate by the element itself.
22267 if Input
= Last_Input
then
22268 Rewrite
(Inputs
, Input
);
22270 -- Generate a clause of the form:
22275 Make_Component_Association
(Loc
,
22276 Choices
=> New_Copy_List_Tree
(Output
),
22277 Expression
=> Input
);
22279 -- The new clause contains replicated content that has
22280 -- already been analyzed, mark the clause as analyzed.
22282 Set_Analyzed
(New_Clause
);
22283 Insert_After
(Clause
, New_Clause
);
22286 Input
:= Next_Input
;
22289 end Normalize_Inputs
;
22295 -- Start of processing for Normalize_Clauses
22298 Clause
:= First
(Clauses
);
22299 while Present
(Clause
) loop
22300 Normalize_Inputs
(Clause
);
22303 end Normalize_Clauses
;
22305 --------------------------
22306 -- Report_Extra_Clauses --
22307 --------------------------
22309 procedure Report_Extra_Clauses
is
22313 if Present
(Refinements
) then
22314 Clause
:= First
(Refinements
);
22315 while Present
(Clause
) loop
22317 -- Do not complain about a null input refinement, since a null
22318 -- input legitimately matches anything.
22320 if Nkind
(Clause
) /= N_Component_Association
22321 or else Nkind
(Expression
(Clause
)) /= N_Null
22324 ("unmatched or extra clause in dependence refinement",
22331 end Report_Extra_Clauses
;
22335 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22336 Errors
: constant Nat
:= Serious_Errors_Detected
;
22337 Refs
: constant Node_Id
:=
22338 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22342 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22345 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22346 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22348 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22351 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22353 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22354 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22356 if No
(Depends
) then
22358 ("useless refinement, declaration of subprogram & lacks aspect or "
22359 & "pragma Depends", N
, Spec_Id
);
22363 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
22365 -- A null dependency relation renders the refinement useless because it
22366 -- cannot possibly mention abstract states with visible refinement. Note
22367 -- that the inverse is not true as states may be refined to null
22368 -- (SPARK RM 7.2.5(2)).
22370 if Nkind
(Deps
) = N_Null
then
22372 ("useless refinement, subprogram & does not depend on abstract "
22373 & "state with visible refinement", N
, Spec_Id
);
22377 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22378 -- This ensures that the categorization of all refined dependency items
22379 -- is consistent with their role.
22381 Analyze_Depends_In_Decl_Part
(N
);
22383 -- Do not match dependencies against refinements if Refined_Depends is
22384 -- illegal to avoid emitting misleading error. Matching is disabled in
22385 -- ASIS because clauses are not normalized as this is a tree altering
22386 -- activity similar to expansion.
22388 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
22390 -- Multiple dependency clauses appear as component associations of an
22391 -- aggregate. Note that the clauses are copied because the algorithm
22392 -- modifies them and this should not be visible in Depends.
22394 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22395 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22396 Normalize_Clauses
(Dependencies
);
22398 if Nkind
(Refs
) = N_Null
then
22399 Refinements
:= No_List
;
22401 -- Multiple dependency clauses appear as component associations of an
22402 -- aggregate. Note that the clauses are copied because the algorithm
22403 -- modifies them and this should not be visible in Refined_Depends.
22405 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22406 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22407 Normalize_Clauses
(Refinements
);
22410 -- At this point the clauses of pragmas Depends and Refined_Depends
22411 -- have been normalized into simple dependencies between one output
22412 -- and one input. Examine all clauses of pragma Depends looking for
22413 -- matching clauses in pragma Refined_Depends.
22415 Clause
:= First
(Dependencies
);
22416 while Present
(Clause
) loop
22417 Check_Dependency_Clause
(Clause
);
22421 if Serious_Errors_Detected
= Errors
then
22422 Report_Extra_Clauses
;
22425 end Analyze_Refined_Depends_In_Decl_Part
;
22427 -----------------------------------------
22428 -- Analyze_Refined_Global_In_Decl_Part --
22429 -----------------------------------------
22431 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22433 -- The corresponding Global pragma
22435 Has_In_State
: Boolean := False;
22436 Has_In_Out_State
: Boolean := False;
22437 Has_Out_State
: Boolean := False;
22438 Has_Proof_In_State
: Boolean := False;
22439 -- These flags are set when the corresponding Global pragma has a state
22440 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22443 Has_Null_State
: Boolean := False;
22444 -- This flag is set when the corresponding Global pragma has at least
22445 -- one state with a null refinement.
22447 In_Constits
: Elist_Id
:= No_Elist
;
22448 In_Out_Constits
: Elist_Id
:= No_Elist
;
22449 Out_Constits
: Elist_Id
:= No_Elist
;
22450 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22451 -- These lists contain the entities of all Input, In_Out, Output and
22452 -- Proof_In constituents that appear in Refined_Global and participate
22453 -- in state refinement.
22455 In_Items
: Elist_Id
:= No_Elist
;
22456 In_Out_Items
: Elist_Id
:= No_Elist
;
22457 Out_Items
: Elist_Id
:= No_Elist
;
22458 Proof_In_Items
: Elist_Id
:= No_Elist
;
22459 -- These list contain the entities of all Input, In_Out, Output and
22460 -- Proof_In items defined in the corresponding Global pragma.
22462 procedure Check_In_Out_States
;
22463 -- Determine whether the corresponding Global pragma mentions In_Out
22464 -- states with visible refinement and if so, ensure that one of the
22465 -- following completions apply to the constituents of the state:
22466 -- 1) there is at least one constituent of mode In_Out
22467 -- 2) there is at least one Input and one Output constituent
22468 -- 3) not all constituents are present and one of them is of mode
22470 -- This routine may remove elements from In_Constits, In_Out_Constits,
22471 -- Out_Constits and Proof_In_Constits.
22473 procedure Check_Input_States
;
22474 -- Determine whether the corresponding Global pragma mentions Input
22475 -- states with visible refinement and if so, ensure that at least one of
22476 -- its constituents appears as an Input item in Refined_Global.
22477 -- This routine may remove elements from In_Constits, In_Out_Constits,
22478 -- Out_Constits and Proof_In_Constits.
22480 procedure Check_Output_States
;
22481 -- Determine whether the corresponding Global pragma mentions Output
22482 -- states with visible refinement and if so, ensure that all of its
22483 -- constituents appear as Output items in Refined_Global.
22484 -- This routine may remove elements from In_Constits, In_Out_Constits,
22485 -- Out_Constits and Proof_In_Constits.
22487 procedure Check_Proof_In_States
;
22488 -- Determine whether the corresponding Global pragma mentions Proof_In
22489 -- states with visible refinement and if so, ensure that at least one of
22490 -- its constituents appears as a Proof_In item in Refined_Global.
22491 -- This routine may remove elements from In_Constits, In_Out_Constits,
22492 -- Out_Constits and Proof_In_Constits.
22494 procedure Check_Refined_Global_List
22496 Global_Mode
: Name_Id
:= Name_Input
);
22497 -- Verify the legality of a single global list declaration. Global_Mode
22498 -- denotes the current mode in effect.
22500 function Present_Then_Remove
22502 Item
: Entity_Id
) return Boolean;
22503 -- Search List for a particular entity Item. If Item has been found,
22504 -- remove it from List. This routine is used to strip lists In_Constits,
22505 -- In_Out_Constits and Out_Constits of valid constituents.
22507 procedure Report_Extra_Constituents
;
22508 -- Emit an error for each constituent found in lists In_Constits,
22509 -- In_Out_Constits and Out_Constits.
22511 -------------------------
22512 -- Check_In_Out_States --
22513 -------------------------
22515 procedure Check_In_Out_States
is
22516 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22517 -- Determine whether one of the following coverage scenarios is in
22519 -- 1) there is at least one constituent of mode In_Out
22520 -- 2) there is at least one Input and one Output constituent
22521 -- 3) not all constituents are present and one of them is of mode
22523 -- If this is not the case, emit an error.
22525 -----------------------------
22526 -- Check_Constituent_Usage --
22527 -----------------------------
22529 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22530 Constit_Elmt
: Elmt_Id
;
22531 Constit_Id
: Entity_Id
;
22532 Has_Missing
: Boolean := False;
22533 In_Out_Seen
: Boolean := False;
22534 In_Seen
: Boolean := False;
22535 Out_Seen
: Boolean := False;
22538 -- Process all the constituents of the state and note their modes
22539 -- within the global refinement.
22541 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22542 while Present
(Constit_Elmt
) loop
22543 Constit_Id
:= Node
(Constit_Elmt
);
22545 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22548 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22549 In_Out_Seen
:= True;
22551 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22554 -- A Proof_In constituent cannot participate in the completion
22555 -- of an Output state (SPARK RM 7.2.4(5)).
22557 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22558 Error_Msg_Name_1
:= Chars
(State_Id
);
22560 ("constituent & of state % must have mode Input, In_Out "
22561 & "or Output in global refinement",
22565 Has_Missing
:= True;
22568 Next_Elmt
(Constit_Elmt
);
22571 -- A single In_Out constituent is a valid completion
22573 if In_Out_Seen
then
22576 -- A pair of one Input and one Output constituent is a valid
22579 elsif In_Seen
and then Out_Seen
then
22582 -- A single Output constituent is a valid completion only when
22583 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22585 elsif Has_Missing
and then Out_Seen
then
22590 ("global refinement of state & redefines the mode of its "
22591 & "constituents", N
, State_Id
);
22593 end Check_Constituent_Usage
;
22597 Item_Elmt
: Elmt_Id
;
22598 Item_Id
: Entity_Id
;
22600 -- Start of processing for Check_In_Out_States
22603 -- Inspect the In_Out items of the corresponding Global pragma
22604 -- looking for a state with a visible refinement.
22606 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22607 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22608 while Present
(Item_Elmt
) loop
22609 Item_Id
:= Node
(Item_Elmt
);
22611 -- Ensure that one of the three coverage variants is satisfied
22613 if Ekind
(Item_Id
) = E_Abstract_State
22614 and then Has_Non_Null_Refinement
(Item_Id
)
22616 Check_Constituent_Usage
(Item_Id
);
22619 Next_Elmt
(Item_Elmt
);
22622 end Check_In_Out_States
;
22624 ------------------------
22625 -- Check_Input_States --
22626 ------------------------
22628 procedure Check_Input_States
is
22629 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22630 -- Determine whether at least one constituent of state State_Id with
22631 -- visible refinement is used and has mode Input. Ensure that the
22632 -- remaining constituents do not have In_Out, Output or Proof_In
22635 -----------------------------
22636 -- Check_Constituent_Usage --
22637 -----------------------------
22639 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22640 Constit_Elmt
: Elmt_Id
;
22641 Constit_Id
: Entity_Id
;
22642 In_Seen
: Boolean := False;
22645 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22646 while Present
(Constit_Elmt
) loop
22647 Constit_Id
:= Node
(Constit_Elmt
);
22649 -- At least one of the constituents appears as an Input
22651 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22654 -- The constituent appears in the global refinement, but has
22655 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22657 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22658 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22659 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22661 Error_Msg_Name_1
:= Chars
(State_Id
);
22663 ("constituent & of state % must have mode Input in global "
22664 & "refinement", N
, Constit_Id
);
22667 Next_Elmt
(Constit_Elmt
);
22670 -- Not one of the constituents appeared as Input
22672 if not In_Seen
then
22674 ("global refinement of state & must include at least one "
22675 & "constituent of mode Input", N
, State_Id
);
22677 end Check_Constituent_Usage
;
22681 Item_Elmt
: Elmt_Id
;
22682 Item_Id
: Entity_Id
;
22684 -- Start of processing for Check_Input_States
22687 -- Inspect the Input items of the corresponding Global pragma
22688 -- looking for a state with a visible refinement.
22690 if Has_In_State
and then Present
(In_Items
) then
22691 Item_Elmt
:= First_Elmt
(In_Items
);
22692 while Present
(Item_Elmt
) loop
22693 Item_Id
:= Node
(Item_Elmt
);
22695 -- Ensure that at least one of the constituents is utilized and
22696 -- is of mode Input.
22698 if Ekind
(Item_Id
) = E_Abstract_State
22699 and then Has_Non_Null_Refinement
(Item_Id
)
22701 Check_Constituent_Usage
(Item_Id
);
22704 Next_Elmt
(Item_Elmt
);
22707 end Check_Input_States
;
22709 -------------------------
22710 -- Check_Output_States --
22711 -------------------------
22713 procedure Check_Output_States
is
22714 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22715 -- Determine whether all constituents of state State_Id with visible
22716 -- refinement are used and have mode Output. Emit an error if this is
22719 -----------------------------
22720 -- Check_Constituent_Usage --
22721 -----------------------------
22723 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22724 Constit_Elmt
: Elmt_Id
;
22725 Constit_Id
: Entity_Id
;
22726 Posted
: Boolean := False;
22729 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22730 while Present
(Constit_Elmt
) loop
22731 Constit_Id
:= Node
(Constit_Elmt
);
22733 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22736 -- The constituent appears in the global refinement, but has
22737 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22739 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22740 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22741 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22743 Error_Msg_Name_1
:= Chars
(State_Id
);
22745 ("constituent & of state % must have mode Output in "
22746 & "global refinement", N
, Constit_Id
);
22748 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22754 ("output state & must be replaced by all its "
22755 & "constituents in global refinement", N
, State_Id
);
22759 ("\constituent & is missing in output list",
22763 Next_Elmt
(Constit_Elmt
);
22765 end Check_Constituent_Usage
;
22769 Item_Elmt
: Elmt_Id
;
22770 Item_Id
: Entity_Id
;
22772 -- Start of processing for Check_Output_States
22775 -- Inspect the Output items of the corresponding Global pragma
22776 -- looking for a state with a visible refinement.
22778 if Has_Out_State
and then Present
(Out_Items
) then
22779 Item_Elmt
:= First_Elmt
(Out_Items
);
22780 while Present
(Item_Elmt
) loop
22781 Item_Id
:= Node
(Item_Elmt
);
22783 -- Ensure that all of the constituents are utilized and they
22784 -- have mode Output.
22786 if Ekind
(Item_Id
) = E_Abstract_State
22787 and then Has_Non_Null_Refinement
(Item_Id
)
22789 Check_Constituent_Usage
(Item_Id
);
22792 Next_Elmt
(Item_Elmt
);
22795 end Check_Output_States
;
22797 ---------------------------
22798 -- Check_Proof_In_States --
22799 ---------------------------
22801 procedure Check_Proof_In_States
is
22802 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22803 -- Determine whether at least one constituent of state State_Id with
22804 -- visible refinement is used and has mode Proof_In. Ensure that the
22805 -- remaining constituents do not have Input, In_Out or Output modes.
22807 -----------------------------
22808 -- Check_Constituent_Usage --
22809 -----------------------------
22811 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22812 Constit_Elmt
: Elmt_Id
;
22813 Constit_Id
: Entity_Id
;
22814 Proof_In_Seen
: Boolean := False;
22817 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22818 while Present
(Constit_Elmt
) loop
22819 Constit_Id
:= Node
(Constit_Elmt
);
22821 -- At least one of the constituents appears as Proof_In
22823 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22824 Proof_In_Seen
:= True;
22826 -- The constituent appears in the global refinement, but has
22827 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
22829 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22830 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22831 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22833 Error_Msg_Name_1
:= Chars
(State_Id
);
22835 ("constituent & of state % must have mode Proof_In in "
22836 & "global refinement", N
, Constit_Id
);
22839 Next_Elmt
(Constit_Elmt
);
22842 -- Not one of the constituents appeared as Proof_In
22844 if not Proof_In_Seen
then
22846 ("global refinement of state & must include at least one "
22847 & "constituent of mode Proof_In", N
, State_Id
);
22849 end Check_Constituent_Usage
;
22853 Item_Elmt
: Elmt_Id
;
22854 Item_Id
: Entity_Id
;
22856 -- Start of processing for Check_Proof_In_States
22859 -- Inspect the Proof_In items of the corresponding Global pragma
22860 -- looking for a state with a visible refinement.
22862 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
22863 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
22864 while Present
(Item_Elmt
) loop
22865 Item_Id
:= Node
(Item_Elmt
);
22867 -- Ensure that at least one of the constituents is utilized and
22868 -- is of mode Proof_In
22870 if Ekind
(Item_Id
) = E_Abstract_State
22871 and then Has_Non_Null_Refinement
(Item_Id
)
22873 Check_Constituent_Usage
(Item_Id
);
22876 Next_Elmt
(Item_Elmt
);
22879 end Check_Proof_In_States
;
22881 -------------------------------
22882 -- Check_Refined_Global_List --
22883 -------------------------------
22885 procedure Check_Refined_Global_List
22887 Global_Mode
: Name_Id
:= Name_Input
)
22889 procedure Check_Refined_Global_Item
22891 Global_Mode
: Name_Id
);
22892 -- Verify the legality of a single global item declaration. Parameter
22893 -- Global_Mode denotes the current mode in effect.
22895 -------------------------------
22896 -- Check_Refined_Global_Item --
22897 -------------------------------
22899 procedure Check_Refined_Global_Item
22901 Global_Mode
: Name_Id
)
22903 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
22905 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
22906 -- Issue a common error message for all mode mismatches. Expect
22907 -- denotes the expected mode.
22909 -----------------------------
22910 -- Inconsistent_Mode_Error --
22911 -----------------------------
22913 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
22916 ("global item & has inconsistent modes", Item
, Item_Id
);
22918 Error_Msg_Name_1
:= Global_Mode
;
22919 Error_Msg_Name_2
:= Expect
;
22920 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
22921 end Inconsistent_Mode_Error
;
22923 -- Start of processing for Check_Refined_Global_Item
22926 -- When the state or variable acts as a constituent of another
22927 -- state with a visible refinement, collect it for the state
22928 -- completeness checks performed later on.
22930 if Present
(Encapsulating_State
(Item_Id
))
22931 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
22933 if Global_Mode
= Name_Input
then
22934 Add_Item
(Item_Id
, In_Constits
);
22936 elsif Global_Mode
= Name_In_Out
then
22937 Add_Item
(Item_Id
, In_Out_Constits
);
22939 elsif Global_Mode
= Name_Output
then
22940 Add_Item
(Item_Id
, Out_Constits
);
22942 elsif Global_Mode
= Name_Proof_In
then
22943 Add_Item
(Item_Id
, Proof_In_Constits
);
22946 -- When not a constituent, ensure that both occurrences of the
22947 -- item in pragmas Global and Refined_Global match.
22949 elsif Contains
(In_Items
, Item_Id
) then
22950 if Global_Mode
/= Name_Input
then
22951 Inconsistent_Mode_Error
(Name_Input
);
22954 elsif Contains
(In_Out_Items
, Item_Id
) then
22955 if Global_Mode
/= Name_In_Out
then
22956 Inconsistent_Mode_Error
(Name_In_Out
);
22959 elsif Contains
(Out_Items
, Item_Id
) then
22960 if Global_Mode
/= Name_Output
then
22961 Inconsistent_Mode_Error
(Name_Output
);
22964 elsif Contains
(Proof_In_Items
, Item_Id
) then
22967 -- The item does not appear in the corresponding Global pragma,
22968 -- it must be an extra (SPARK RM 7.2.4(3)).
22971 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
22973 end Check_Refined_Global_Item
;
22979 -- Start of processing for Check_Refined_Global_List
22982 if Nkind
(List
) = N_Null
then
22985 -- Single global item declaration
22987 elsif Nkind_In
(List
, N_Expanded_Name
,
22989 N_Selected_Component
)
22991 Check_Refined_Global_Item
(List
, Global_Mode
);
22993 -- Simple global list or moded global list declaration
22995 elsif Nkind
(List
) = N_Aggregate
then
22997 -- The declaration of a simple global list appear as a collection
23000 if Present
(Expressions
(List
)) then
23001 Item
:= First
(Expressions
(List
));
23002 while Present
(Item
) loop
23003 Check_Refined_Global_Item
(Item
, Global_Mode
);
23008 -- The declaration of a moded global list appears as a collection
23009 -- of component associations where individual choices denote
23012 elsif Present
(Component_Associations
(List
)) then
23013 Item
:= First
(Component_Associations
(List
));
23014 while Present
(Item
) loop
23015 Check_Refined_Global_List
23016 (List
=> Expression
(Item
),
23017 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23025 raise Program_Error
;
23031 raise Program_Error
;
23033 end Check_Refined_Global_List
;
23035 -------------------------
23036 -- Present_Then_Remove --
23037 -------------------------
23039 function Present_Then_Remove
23041 Item
: Entity_Id
) return Boolean
23046 if Present
(List
) then
23047 Elmt
:= First_Elmt
(List
);
23048 while Present
(Elmt
) loop
23049 if Node
(Elmt
) = Item
then
23050 Remove_Elmt
(List
, Elmt
);
23059 end Present_Then_Remove
;
23061 -------------------------------
23062 -- Report_Extra_Constituents --
23063 -------------------------------
23065 procedure Report_Extra_Constituents
is
23066 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23067 -- Emit an error for every element of List
23069 ---------------------------------------
23070 -- Report_Extra_Constituents_In_List --
23071 ---------------------------------------
23073 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23074 Constit_Elmt
: Elmt_Id
;
23077 if Present
(List
) then
23078 Constit_Elmt
:= First_Elmt
(List
);
23079 while Present
(Constit_Elmt
) loop
23080 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23081 Next_Elmt
(Constit_Elmt
);
23084 end Report_Extra_Constituents_In_List
;
23086 -- Start of processing for Report_Extra_Constituents
23089 Report_Extra_Constituents_In_List
(In_Constits
);
23090 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23091 Report_Extra_Constituents_In_List
(Out_Constits
);
23092 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23093 end Report_Extra_Constituents
;
23097 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23098 Errors
: constant Nat
:= Serious_Errors_Detected
;
23099 Items
: constant Node_Id
:=
23100 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23101 Spec_Id
: Entity_Id
;
23103 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23106 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23107 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23109 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23112 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23114 -- The subprogram declaration lacks pragma Global. This renders
23115 -- Refined_Global useless as there is nothing to refine.
23117 if No
(Global
) then
23119 ("useless refinement, declaration of subprogram & lacks aspect or "
23120 & "pragma Global", N
, Spec_Id
);
23124 -- Extract all relevant items from the corresponding Global pragma
23126 Collect_Global_Items
23128 In_Items
=> In_Items
,
23129 In_Out_Items
=> In_Out_Items
,
23130 Out_Items
=> Out_Items
,
23131 Proof_In_Items
=> Proof_In_Items
,
23132 Has_In_State
=> Has_In_State
,
23133 Has_In_Out_State
=> Has_In_Out_State
,
23134 Has_Out_State
=> Has_Out_State
,
23135 Has_Proof_In_State
=> Has_Proof_In_State
,
23136 Has_Null_State
=> Has_Null_State
);
23138 -- Corresponding Global pragma must mention at least one state witha
23139 -- visible refinement at the point Refined_Global is processed. States
23140 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23142 if not Has_In_State
23143 and then not Has_In_Out_State
23144 and then not Has_Out_State
23145 and then not Has_Proof_In_State
23146 and then not Has_Null_State
23149 ("useless refinement, subprogram & does not depend on abstract "
23150 & "state with visible refinement", N
, Spec_Id
);
23154 -- The global refinement of inputs and outputs cannot be null when the
23155 -- corresponding Global pragma contains at least one item except in the
23156 -- case where we have states with null refinements.
23158 if Nkind
(Items
) = N_Null
23160 (Present
(In_Items
)
23161 or else Present
(In_Out_Items
)
23162 or else Present
(Out_Items
)
23163 or else Present
(Proof_In_Items
))
23164 and then not Has_Null_State
23167 ("refinement cannot be null, subprogram & has global items",
23172 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23173 -- This ensures that the categorization of all refined global items is
23174 -- consistent with their role.
23176 Analyze_Global_In_Decl_Part
(N
);
23178 -- Perform all refinement checks with respect to completeness and mode
23181 if Serious_Errors_Detected
= Errors
then
23182 Check_Refined_Global_List
(Items
);
23185 -- For Input states with visible refinement, at least one constituent
23186 -- must be used as an Input in the global refinement.
23188 if Serious_Errors_Detected
= Errors
then
23189 Check_Input_States
;
23192 -- Verify all possible completion variants for In_Out states with
23193 -- visible refinement.
23195 if Serious_Errors_Detected
= Errors
then
23196 Check_In_Out_States
;
23199 -- For Output states with visible refinement, all constituents must be
23200 -- used as Outputs in the global refinement.
23202 if Serious_Errors_Detected
= Errors
then
23203 Check_Output_States
;
23206 -- For Proof_In states with visible refinement, at least one constituent
23207 -- must be used as Proof_In in the global refinement.
23209 if Serious_Errors_Detected
= Errors
then
23210 Check_Proof_In_States
;
23213 -- Emit errors for all constituents that belong to other states with
23214 -- visible refinement that do not appear in Global.
23216 if Serious_Errors_Detected
= Errors
then
23217 Report_Extra_Constituents
;
23219 end Analyze_Refined_Global_In_Decl_Part
;
23221 ----------------------------------------
23222 -- Analyze_Refined_State_In_Decl_Part --
23223 ----------------------------------------
23225 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23226 Available_States
: Elist_Id
:= No_Elist
;
23227 -- A list of all abstract states defined in the package declaration that
23228 -- are available for refinement. The list is used to report unrefined
23231 Body_Id
: Entity_Id
;
23232 -- The body entity of the package subject to pragma Refined_State
23234 Body_States
: Elist_Id
:= No_Elist
;
23235 -- A list of all hidden states that appear in the body of the related
23236 -- package. The list is used to report unused hidden states.
23238 Constituents_Seen
: Elist_Id
:= No_Elist
;
23239 -- A list that contains all constituents processed so far. The list is
23240 -- used to detect multiple uses of the same constituent.
23242 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23243 -- A list that contains all refined states processed so far. The list is
23244 -- used to detect duplicate refinements.
23246 Spec_Id
: Entity_Id
;
23247 -- The spec entity of the package subject to pragma Refined_State
23249 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23250 -- Perform full analysis of a single refinement clause
23252 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23253 -- Gather the entities of all abstract states and variables declared in
23254 -- the body state space of package Pack_Id.
23256 procedure Report_Unrefined_States
(States
: Elist_Id
);
23257 -- Emit errors for all unrefined abstract states found in list States
23259 procedure Report_Unused_States
(States
: Elist_Id
);
23260 -- Emit errors for all unused states found in list States
23262 -------------------------------
23263 -- Analyze_Refinement_Clause --
23264 -------------------------------
23266 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23267 AR_Constit
: Entity_Id
:= Empty
;
23268 AW_Constit
: Entity_Id
:= Empty
;
23269 ER_Constit
: Entity_Id
:= Empty
;
23270 EW_Constit
: Entity_Id
:= Empty
;
23271 -- The entities of external constituents that contain one of the
23272 -- following enabled properties: Async_Readers, Async_Writers,
23273 -- Effective_Reads and Effective_Writes.
23275 External_Constit_Seen
: Boolean := False;
23276 -- Flag used to mark when at least one external constituent is part
23277 -- of the state refinement.
23279 Non_Null_Seen
: Boolean := False;
23280 Null_Seen
: Boolean := False;
23281 -- Flags used to detect multiple uses of null in a single clause or a
23282 -- mixture of null and non-null constituents.
23284 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23285 -- A list of all candidate constituents subject to indicator Part_Of
23286 -- where the encapsulating state is the current state.
23289 State_Id
: Entity_Id
;
23290 -- The current state being refined
23292 procedure Analyze_Constituent
(Constit
: Node_Id
);
23293 -- Perform full analysis of a single constituent
23295 procedure Check_External_Property
23296 (Prop_Nam
: Name_Id
;
23298 Constit
: Entity_Id
);
23299 -- Determine whether a property denoted by name Prop_Nam is present
23300 -- in both the refined state and constituent Constit. Flag Enabled
23301 -- should be set when the property applies to the refined state. If
23302 -- this is not the case, emit an error message.
23304 procedure Check_Matching_State
;
23305 -- Determine whether the state being refined appears in list
23306 -- Available_States. Emit an error when attempting to re-refine the
23307 -- state or when the state is not defined in the package declaration,
23308 -- otherwise remove the state from Available_States.
23310 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23311 -- Emit errors for all unused Part_Of constituents in list Constits
23313 -------------------------
23314 -- Analyze_Constituent --
23315 -------------------------
23317 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23318 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23319 -- Verify that the constituent Constit_Id is a Ghost entity if the
23320 -- abstract state being refined is also Ghost. If this is the case
23321 -- verify that the Ghost policy in effect at the point of state
23322 -- and constituent declaration is the same.
23324 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23325 -- Determine whether constituent Constit denoted by its entity
23326 -- Constit_Id appears in Hidden_States. Emit an error when the
23327 -- constituent is not a valid hidden state of the related package
23328 -- or when it is used more than once. Otherwise remove the
23329 -- constituent from Hidden_States.
23331 --------------------------------
23332 -- Check_Matching_Constituent --
23333 --------------------------------
23335 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23336 procedure Collect_Constituent
;
23337 -- Add constituent Constit_Id to the refinements of State_Id
23339 -------------------------
23340 -- Collect_Constituent --
23341 -------------------------
23343 procedure Collect_Constituent
is
23345 -- Add the constituent to the list of processed items to aid
23346 -- with the detection of duplicates.
23348 Add_Item
(Constit_Id
, Constituents_Seen
);
23350 -- Collect the constituent in the list of refinement items
23351 -- and establish a relation between the refined state and
23354 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23355 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23357 -- The state has at least one legal constituent, mark the
23358 -- start of the refinement region. The region ends when the
23359 -- body declarations end (see routine Analyze_Declarations).
23361 Set_Has_Visible_Refinement
(State_Id
);
23363 -- When the constituent is external, save its relevant
23364 -- property for further checks.
23366 if Async_Readers_Enabled
(Constit_Id
) then
23367 AR_Constit
:= Constit_Id
;
23368 External_Constit_Seen
:= True;
23371 if Async_Writers_Enabled
(Constit_Id
) then
23372 AW_Constit
:= Constit_Id
;
23373 External_Constit_Seen
:= True;
23376 if Effective_Reads_Enabled
(Constit_Id
) then
23377 ER_Constit
:= Constit_Id
;
23378 External_Constit_Seen
:= True;
23381 if Effective_Writes_Enabled
(Constit_Id
) then
23382 EW_Constit
:= Constit_Id
;
23383 External_Constit_Seen
:= True;
23385 end Collect_Constituent
;
23389 State_Elmt
: Elmt_Id
;
23391 -- Start of processing for Check_Matching_Constituent
23394 -- Detect a duplicate use of a constituent
23396 if Contains
(Constituents_Seen
, Constit_Id
) then
23398 ("duplicate use of constituent &", Constit
, Constit_Id
);
23402 -- The constituent is subject to a Part_Of indicator
23404 if Present
(Encapsulating_State
(Constit_Id
)) then
23405 if Encapsulating_State
(Constit_Id
) = State_Id
then
23406 Check_Ghost_Constituent
(Constit_Id
);
23407 Remove
(Part_Of_Constits
, Constit_Id
);
23408 Collect_Constituent
;
23410 -- The constituent is part of another state and is used
23411 -- incorrectly in the refinement of the current state.
23414 Error_Msg_Name_1
:= Chars
(State_Id
);
23416 ("& cannot act as constituent of state %",
23417 Constit
, Constit_Id
);
23419 ("\Part_Of indicator specifies & as encapsulating "
23420 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23423 -- The only other source of legal constituents is the body
23424 -- state space of the related package.
23427 if Present
(Body_States
) then
23428 State_Elmt
:= First_Elmt
(Body_States
);
23429 while Present
(State_Elmt
) loop
23431 -- Consume a valid constituent to signal that it has
23432 -- been encountered.
23434 if Node
(State_Elmt
) = Constit_Id
then
23435 Check_Ghost_Constituent
(Constit_Id
);
23437 Remove_Elmt
(Body_States
, State_Elmt
);
23438 Collect_Constituent
;
23442 Next_Elmt
(State_Elmt
);
23446 -- If we get here, then the constituent is not a hidden
23447 -- state of the related package and may not be used in a
23448 -- refinement (SPARK RM 7.2.2(9)).
23450 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23452 ("cannot use & in refinement, constituent is not a hidden "
23453 & "state of package %", Constit
, Constit_Id
);
23455 end Check_Matching_Constituent
;
23457 -----------------------------
23458 -- Check_Ghost_Constituent --
23459 -----------------------------
23461 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
23463 if Is_Ghost_Entity
(State_Id
) then
23464 if Is_Ghost_Entity
(Constit_Id
) then
23466 -- The Ghost policy in effect at the point of abstract
23467 -- state declaration and constituent must match
23468 -- (SPARK RM 6.9(15)).
23470 if Is_Checked_Ghost_Entity
(State_Id
)
23471 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
23473 Error_Msg_Sloc
:= Sloc
(Constit
);
23476 ("incompatible ghost policies in effect", State
);
23478 ("\abstract state & declared with ghost policy "
23479 & "Check", State
, State_Id
);
23481 ("\constituent & declared # with ghost policy "
23482 & "Ignore", State
, Constit_Id
);
23484 elsif Is_Ignored_Ghost_Entity
(State_Id
)
23485 and then Is_Checked_Ghost_Entity
(Constit_Id
)
23487 Error_Msg_Sloc
:= Sloc
(Constit
);
23490 ("incompatible ghost policies in effect", State
);
23492 ("\abstract state & declared with ghost policy "
23493 & "Ignore", State
, State_Id
);
23495 ("\constituent & declared # with ghost policy "
23496 & "Check", State
, Constit_Id
);
23499 -- A constituent of a Ghost abstract state must be a Ghost
23500 -- entity (SPARK RM 7.2.2(12)).
23504 ("constituent of ghost state & must be ghost",
23505 Constit
, State_Id
);
23508 end Check_Ghost_Constituent
;
23512 Constit_Id
: Entity_Id
;
23514 -- Start of processing for Analyze_Constituent
23517 -- Detect multiple uses of null in a single refinement clause or a
23518 -- mixture of null and non-null constituents.
23520 if Nkind
(Constit
) = N_Null
then
23523 ("multiple null constituents not allowed", Constit
);
23525 elsif Non_Null_Seen
then
23527 ("cannot mix null and non-null constituents", Constit
);
23532 -- Collect the constituent in the list of refinement items
23534 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23536 -- The state has at least one legal constituent, mark the
23537 -- start of the refinement region. The region ends when the
23538 -- body declarations end (see Analyze_Declarations).
23540 Set_Has_Visible_Refinement
(State_Id
);
23543 -- Non-null constituents
23546 Non_Null_Seen
:= True;
23550 ("cannot mix null and non-null constituents", Constit
);
23554 Resolve_State
(Constit
);
23556 -- Ensure that the constituent denotes a valid state or a
23559 if Is_Entity_Name
(Constit
) then
23560 Constit_Id
:= Entity_Of
(Constit
);
23562 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
23563 Check_Matching_Constituent
(Constit_Id
);
23567 ("constituent & must denote a variable or state (SPARK "
23568 & "RM 7.2.2(5))", Constit
, Constit_Id
);
23571 -- The constituent is illegal
23574 SPARK_Msg_N
("malformed constituent", Constit
);
23577 end Analyze_Constituent
;
23579 -----------------------------
23580 -- Check_External_Property --
23581 -----------------------------
23583 procedure Check_External_Property
23584 (Prop_Nam
: Name_Id
;
23586 Constit
: Entity_Id
)
23589 Error_Msg_Name_1
:= Prop_Nam
;
23591 -- The property is enabled in the related Abstract_State pragma
23592 -- that defines the state (SPARK RM 7.2.8(3)).
23595 if No
(Constit
) then
23597 ("external state & requires at least one constituent with "
23598 & "property %", State
, State_Id
);
23601 -- The property is missing in the declaration of the state, but
23602 -- a constituent is introducing it in the state refinement
23603 -- (SPARK RM 7.2.8(3)).
23605 elsif Present
(Constit
) then
23606 Error_Msg_Name_2
:= Chars
(Constit
);
23608 ("external state & lacks property % set by constituent %",
23611 end Check_External_Property
;
23613 --------------------------
23614 -- Check_Matching_State --
23615 --------------------------
23617 procedure Check_Matching_State
is
23618 State_Elmt
: Elmt_Id
;
23621 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23623 if Contains
(Refined_States_Seen
, State_Id
) then
23625 ("duplicate refinement of state &", State
, State_Id
);
23629 -- Inspect the abstract states defined in the package declaration
23630 -- looking for a match.
23632 State_Elmt
:= First_Elmt
(Available_States
);
23633 while Present
(State_Elmt
) loop
23635 -- A valid abstract state is being refined in the body. Add
23636 -- the state to the list of processed refined states to aid
23637 -- with the detection of duplicate refinements. Remove the
23638 -- state from Available_States to signal that it has already
23641 if Node
(State_Elmt
) = State_Id
then
23642 Add_Item
(State_Id
, Refined_States_Seen
);
23643 Remove_Elmt
(Available_States
, State_Elmt
);
23647 Next_Elmt
(State_Elmt
);
23650 -- If we get here, we are refining a state that is not defined in
23651 -- the package declaration.
23653 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23655 ("cannot refine state, & is not defined in package %",
23657 end Check_Matching_State
;
23659 --------------------------------
23660 -- Report_Unused_Constituents --
23661 --------------------------------
23663 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
23664 Constit_Elmt
: Elmt_Id
;
23665 Constit_Id
: Entity_Id
;
23666 Posted
: Boolean := False;
23669 if Present
(Constits
) then
23670 Constit_Elmt
:= First_Elmt
(Constits
);
23671 while Present
(Constit_Elmt
) loop
23672 Constit_Id
:= Node
(Constit_Elmt
);
23674 -- Generate an error message of the form:
23676 -- state ... has unused Part_Of constituents
23677 -- abstract state ... defined at ...
23678 -- variable ... defined at ...
23683 ("state & has unused Part_Of constituents",
23687 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
23689 if Ekind
(Constit_Id
) = E_Abstract_State
then
23691 ("\abstract state & defined #", State
, Constit_Id
);
23694 ("\variable & defined #", State
, Constit_Id
);
23697 Next_Elmt
(Constit_Elmt
);
23700 end Report_Unused_Constituents
;
23702 -- Local declarations
23704 Body_Ref
: Node_Id
;
23705 Body_Ref_Elmt
: Elmt_Id
;
23707 Extra_State
: Node_Id
;
23709 -- Start of processing for Analyze_Refinement_Clause
23712 -- A refinement clause appears as a component association where the
23713 -- sole choice is the state and the expressions are the constituents.
23714 -- This is a syntax error, always report.
23716 if Nkind
(Clause
) /= N_Component_Association
then
23717 Error_Msg_N
("malformed state refinement clause", Clause
);
23721 -- Analyze the state name of a refinement clause
23723 State
:= First
(Choices
(Clause
));
23726 Resolve_State
(State
);
23728 -- Ensure that the state name denotes a valid abstract state that is
23729 -- defined in the spec of the related package.
23731 if Is_Entity_Name
(State
) then
23732 State_Id
:= Entity_Of
(State
);
23734 -- Catch any attempts to re-refine a state or refine a state that
23735 -- is not defined in the package declaration.
23737 if Ekind
(State_Id
) = E_Abstract_State
then
23738 Check_Matching_State
;
23741 ("& must denote an abstract state", State
, State_Id
);
23745 -- References to a state with visible refinement are illegal.
23746 -- When nested packages are involved, detecting such references is
23747 -- tricky because pragma Refined_State is analyzed later than the
23748 -- offending pragma Depends or Global. References that occur in
23749 -- such nested context are stored in a list. Emit errors for all
23750 -- references found in Body_References (SPARK RM 6.1.4(8)).
23752 if Present
(Body_References
(State_Id
)) then
23753 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
23754 while Present
(Body_Ref_Elmt
) loop
23755 Body_Ref
:= Node
(Body_Ref_Elmt
);
23757 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
23758 Error_Msg_Sloc
:= Sloc
(State
);
23759 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
23761 Next_Elmt
(Body_Ref_Elmt
);
23765 -- The state name is illegal. This is a syntax error, always report.
23768 Error_Msg_N
("malformed state name in refinement clause", State
);
23772 -- A refinement clause may only refine one state at a time
23774 Extra_State
:= Next
(State
);
23776 if Present
(Extra_State
) then
23778 ("refinement clause cannot cover multiple states", Extra_State
);
23781 -- Replicate the Part_Of constituents of the refined state because
23782 -- the algorithm will consume items.
23784 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
23786 -- Analyze all constituents of the refinement. Multiple constituents
23787 -- appear as an aggregate.
23789 Constit
:= Expression
(Clause
);
23791 if Nkind
(Constit
) = N_Aggregate
then
23792 if Present
(Component_Associations
(Constit
)) then
23794 ("constituents of refinement clause must appear in "
23795 & "positional form", Constit
);
23797 else pragma Assert
(Present
(Expressions
(Constit
)));
23798 Constit
:= First
(Expressions
(Constit
));
23799 while Present
(Constit
) loop
23800 Analyze_Constituent
(Constit
);
23806 -- Various forms of a single constituent. Note that these may include
23807 -- malformed constituents.
23810 Analyze_Constituent
(Constit
);
23813 -- A refined external state is subject to special rules with respect
23814 -- to its properties and constituents.
23816 if Is_External_State
(State_Id
) then
23818 -- The set of properties that all external constituents yield must
23819 -- match that of the refined state. There are two cases to detect:
23820 -- the refined state lacks a property or has an extra property.
23822 if External_Constit_Seen
then
23823 Check_External_Property
23824 (Prop_Nam
=> Name_Async_Readers
,
23825 Enabled
=> Async_Readers_Enabled
(State_Id
),
23826 Constit
=> AR_Constit
);
23828 Check_External_Property
23829 (Prop_Nam
=> Name_Async_Writers
,
23830 Enabled
=> Async_Writers_Enabled
(State_Id
),
23831 Constit
=> AW_Constit
);
23833 Check_External_Property
23834 (Prop_Nam
=> Name_Effective_Reads
,
23835 Enabled
=> Effective_Reads_Enabled
(State_Id
),
23836 Constit
=> ER_Constit
);
23838 Check_External_Property
23839 (Prop_Nam
=> Name_Effective_Writes
,
23840 Enabled
=> Effective_Writes_Enabled
(State_Id
),
23841 Constit
=> EW_Constit
);
23843 -- An external state may be refined to null (SPARK RM 7.2.8(2))
23845 elsif Null_Seen
then
23848 -- The external state has constituents, but none of them are
23849 -- external (SPARK RM 7.2.8(2)).
23853 ("external state & requires at least one external "
23854 & "constituent or null refinement", State
, State_Id
);
23857 -- When a refined state is not external, it should not have external
23858 -- constituents (SPARK RM 7.2.8(1)).
23860 elsif External_Constit_Seen
then
23862 ("non-external state & cannot contain external constituents in "
23863 & "refinement", State
, State_Id
);
23866 -- Ensure that all Part_Of candidate constituents have been mentioned
23867 -- in the refinement clause.
23869 Report_Unused_Constituents
(Part_Of_Constits
);
23870 end Analyze_Refinement_Clause
;
23872 -------------------------
23873 -- Collect_Body_States --
23874 -------------------------
23876 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
23877 Result
: Elist_Id
:= No_Elist
;
23878 -- A list containing all body states of Pack_Id
23880 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
23881 -- Gather the entities of all abstract states and variables declared
23882 -- in the visible state space of package Pack_Id.
23884 ----------------------------
23885 -- Collect_Visible_States --
23886 ----------------------------
23888 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
23889 Item_Id
: Entity_Id
;
23892 -- Traverse the entity chain of the package and inspect all
23895 Item_Id
:= First_Entity
(Pack_Id
);
23896 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
23898 -- Do not consider internally generated items as those cannot
23899 -- be named and participate in refinement.
23901 if not Comes_From_Source
(Item_Id
) then
23904 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
23905 Add_Item
(Item_Id
, Result
);
23907 -- Recursively gather the visible states of a nested package
23909 elsif Ekind
(Item_Id
) = E_Package
then
23910 Collect_Visible_States
(Item_Id
);
23913 Next_Entity
(Item_Id
);
23915 end Collect_Visible_States
;
23919 Pack_Body
: constant Node_Id
:=
23920 Declaration_Node
(Body_Entity
(Pack_Id
));
23922 Item_Id
: Entity_Id
;
23924 -- Start of processing for Collect_Body_States
23927 -- Inspect the declarations of the body looking for source variables,
23928 -- packages and package instantiations.
23930 Decl
:= First
(Declarations
(Pack_Body
));
23931 while Present
(Decl
) loop
23932 if Nkind
(Decl
) = N_Object_Declaration
then
23933 Item_Id
:= Defining_Entity
(Decl
);
23935 -- Capture source variables only as internally generated
23936 -- temporaries cannot be named and participate in refinement.
23938 if Ekind
(Item_Id
) = E_Variable
23939 and then Comes_From_Source
(Item_Id
)
23941 Add_Item
(Item_Id
, Result
);
23944 elsif Nkind
(Decl
) = N_Package_Declaration
then
23945 Item_Id
:= Defining_Entity
(Decl
);
23947 -- Capture the visible abstract states and variables of a
23948 -- source package [instantiation].
23950 if Comes_From_Source
(Item_Id
) then
23951 Collect_Visible_States
(Item_Id
);
23959 end Collect_Body_States
;
23961 -----------------------------
23962 -- Report_Unrefined_States --
23963 -----------------------------
23965 procedure Report_Unrefined_States
(States
: Elist_Id
) is
23966 State_Elmt
: Elmt_Id
;
23969 if Present
(States
) then
23970 State_Elmt
:= First_Elmt
(States
);
23971 while Present
(State_Elmt
) loop
23973 ("abstract state & must be refined", Node
(State_Elmt
));
23975 Next_Elmt
(State_Elmt
);
23978 end Report_Unrefined_States
;
23980 --------------------------
23981 -- Report_Unused_States --
23982 --------------------------
23984 procedure Report_Unused_States
(States
: Elist_Id
) is
23985 Posted
: Boolean := False;
23986 State_Elmt
: Elmt_Id
;
23987 State_Id
: Entity_Id
;
23990 if Present
(States
) then
23991 State_Elmt
:= First_Elmt
(States
);
23992 while Present
(State_Elmt
) loop
23993 State_Id
:= Node
(State_Elmt
);
23995 -- Generate an error message of the form:
23997 -- body of package ... has unused hidden states
23998 -- abstract state ... defined at ...
23999 -- variable ... defined at ...
24004 ("body of package & has unused hidden states", Body_Id
);
24007 Error_Msg_Sloc
:= Sloc
(State_Id
);
24009 if Ekind
(State_Id
) = E_Abstract_State
then
24011 ("\abstract state & defined #", Body_Id
, State_Id
);
24014 ("\variable & defined #", Body_Id
, State_Id
);
24017 Next_Elmt
(State_Elmt
);
24020 end Report_Unused_States
;
24022 -- Local declarations
24024 Body_Decl
: constant Node_Id
:= Parent
(N
);
24025 Clauses
: constant Node_Id
:=
24026 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
24029 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24034 Body_Id
:= Defining_Entity
(Body_Decl
);
24035 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
24037 -- Replicate the abstract states declared by the package because the
24038 -- matching algorithm will consume states.
24040 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24042 -- Gather all abstract states and variables declared in the visible
24043 -- state space of the package body. These items must be utilized as
24044 -- constituents in a state refinement.
24046 Body_States
:= Collect_Body_States
(Spec_Id
);
24048 -- Multiple non-null state refinements appear as an aggregate
24050 if Nkind
(Clauses
) = N_Aggregate
then
24051 if Present
(Expressions
(Clauses
)) then
24053 ("state refinements must appear as component associations",
24056 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24057 Clause
:= First
(Component_Associations
(Clauses
));
24058 while Present
(Clause
) loop
24059 Analyze_Refinement_Clause
(Clause
);
24065 -- Various forms of a single state refinement. Note that these may
24066 -- include malformed refinements.
24069 Analyze_Refinement_Clause
(Clauses
);
24072 -- List all abstract states that were left unrefined
24074 Report_Unrefined_States
(Available_States
);
24076 -- Ensure that all abstract states and variables declared in the body
24077 -- state space of the related package are utilized as constituents.
24079 Report_Unused_States
(Body_States
);
24080 end Analyze_Refined_State_In_Decl_Part
;
24082 ------------------------------------
24083 -- Analyze_Test_Case_In_Decl_Part --
24084 ------------------------------------
24086 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
24088 -- Install formals and push subprogram spec onto scope stack so that we
24089 -- can see the formals from the pragma.
24092 Install_Formals
(S
);
24094 -- Preanalyze the boolean expressions, we treat these as spec
24095 -- expressions (i.e. similar to a default expression).
24097 if Pragma_Name
(N
) = Name_Test_Case
then
24098 Preanalyze_CTC_Args
24100 Get_Requires_From_CTC_Pragma
(N
),
24101 Get_Ensures_From_CTC_Pragma
(N
));
24104 -- Remove the subprogram from the scope stack now that the pre-analysis
24105 -- of the expressions in the contract case or test case is done.
24108 end Analyze_Test_Case_In_Decl_Part
;
24114 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24119 if Present
(List
) then
24120 Elmt
:= First_Elmt
(List
);
24121 while Present
(Elmt
) loop
24122 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24125 Id
:= Entity_Of
(Node
(Elmt
));
24128 if Id
= Item_Id
then
24139 -----------------------------
24140 -- Check_Applicable_Policy --
24141 -----------------------------
24143 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24147 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
24150 -- No effect if not valid assertion kind name
24152 if not Is_Valid_Assertion_Kind
(Ename
) then
24156 -- Loop through entries in check policy list
24158 PP
:= Opt
.Check_Policy_List
;
24159 while Present
(PP
) loop
24161 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24162 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24166 or else Pnm
= Name_Assertion
24167 or else (Pnm
= Name_Statement_Assertions
24168 and then Nam_In
(Ename
, Name_Assert
,
24169 Name_Assert_And_Cut
,
24171 Name_Loop_Invariant
,
24172 Name_Loop_Variant
))
24174 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24177 when Name_Off | Name_Ignore
=>
24178 Set_Is_Ignored
(N
, True);
24179 Set_Is_Checked
(N
, False);
24181 when Name_On | Name_Check
=>
24182 Set_Is_Checked
(N
, True);
24183 Set_Is_Ignored
(N
, False);
24185 when Name_Disable
=>
24186 Set_Is_Ignored
(N
, True);
24187 Set_Is_Checked
(N
, False);
24188 Set_Is_Disabled
(N
, True);
24190 -- That should be exhaustive, the null here is a defence
24191 -- against a malformed tree from previous errors.
24200 PP
:= Next_Pragma
(PP
);
24204 -- If there are no specific entries that matched, then we let the
24205 -- setting of assertions govern. Note that this provides the needed
24206 -- compatibility with the RM for the cases of assertion, invariant,
24207 -- precondition, predicate, and postcondition.
24209 if Assertions_Enabled
then
24210 Set_Is_Checked
(N
, True);
24211 Set_Is_Ignored
(N
, False);
24213 Set_Is_Checked
(N
, False);
24214 Set_Is_Ignored
(N
, True);
24216 end Check_Applicable_Policy
;
24218 -------------------------------
24219 -- Check_External_Properties --
24220 -------------------------------
24222 procedure Check_External_Properties
24230 -- All properties enabled
24232 if AR
and AW
and ER
and EW
then
24235 -- Async_Readers + Effective_Writes
24236 -- Async_Readers + Async_Writers + Effective_Writes
24238 elsif AR
and EW
and not ER
then
24241 -- Async_Writers + Effective_Reads
24242 -- Async_Readers + Async_Writers + Effective_Reads
24244 elsif AW
and ER
and not EW
then
24247 -- Async_Readers + Async_Writers
24249 elsif AR
and AW
and not ER
and not EW
then
24254 elsif AR
and not AW
and not ER
and not EW
then
24259 elsif AW
and not AR
and not ER
and not EW
then
24264 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24267 end Check_External_Properties
;
24273 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24277 -- Loop through entries in check policy list
24279 PP
:= Opt
.Check_Policy_List
;
24280 while Present
(PP
) loop
24282 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24283 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24287 or else (Pnm
= Name_Assertion
24288 and then Is_Valid_Assertion_Kind
(Nam
))
24289 or else (Pnm
= Name_Statement_Assertions
24290 and then Nam_In
(Nam
, Name_Assert
,
24291 Name_Assert_And_Cut
,
24293 Name_Loop_Invariant
,
24294 Name_Loop_Variant
))
24296 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24297 when Name_On | Name_Check
=>
24299 when Name_Off | Name_Ignore
=>
24300 return Name_Ignore
;
24301 when Name_Disable
=>
24302 return Name_Disable
;
24304 raise Program_Error
;
24308 PP
:= Next_Pragma
(PP
);
24313 -- If there are no specific entries that matched, then we let the
24314 -- setting of assertions govern. Note that this provides the needed
24315 -- compatibility with the RM for the cases of assertion, invariant,
24316 -- precondition, predicate, and postcondition.
24318 if Assertions_Enabled
then
24321 return Name_Ignore
;
24325 ---------------------------
24326 -- Check_Missing_Part_Of --
24327 ---------------------------
24329 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24330 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24331 -- Determine whether a package denoted by Pack_Id declares at least one
24334 -----------------------
24335 -- Has_Visible_State --
24336 -----------------------
24338 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24339 Item_Id
: Entity_Id
;
24342 -- Traverse the entity chain of the package trying to find at least
24343 -- one visible abstract state, variable or a package [instantiation]
24344 -- that declares a visible state.
24346 Item_Id
:= First_Entity
(Pack_Id
);
24347 while Present
(Item_Id
)
24348 and then not In_Private_Part
(Item_Id
)
24350 -- Do not consider internally generated items
24352 if not Comes_From_Source
(Item_Id
) then
24355 -- A visible state has been found
24357 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24360 -- Recursively peek into nested packages and instantiations
24362 elsif Ekind
(Item_Id
) = E_Package
24363 and then Has_Visible_State
(Item_Id
)
24368 Next_Entity
(Item_Id
);
24372 end Has_Visible_State
;
24376 Pack_Id
: Entity_Id
;
24377 Placement
: State_Space_Kind
;
24379 -- Start of processing for Check_Missing_Part_Of
24382 -- Do not consider abstract states, variables or package instantiations
24383 -- coming from an instance as those always inherit the Part_Of indicator
24384 -- of the instance itself.
24386 if In_Instance
then
24389 -- Do not consider internally generated entities as these can never
24390 -- have a Part_Of indicator.
24392 elsif not Comes_From_Source
(Item_Id
) then
24395 -- Perform these checks only when SPARK_Mode is enabled as they will
24396 -- interfere with standard Ada rules and produce false positives.
24398 elsif SPARK_Mode
/= On
then
24402 -- Find where the abstract state, variable or package instantiation
24403 -- lives with respect to the state space.
24405 Find_Placement_In_State_Space
24406 (Item_Id
=> Item_Id
,
24407 Placement
=> Placement
,
24408 Pack_Id
=> Pack_Id
);
24410 -- Items that appear in a non-package construct (subprogram, block, etc)
24411 -- do not require a Part_Of indicator because they can never act as a
24414 if Placement
= Not_In_Package
then
24417 -- An item declared in the body state space of a package always act as a
24418 -- constituent and does not need explicit Part_Of indicator.
24420 elsif Placement
= Body_State_Space
then
24423 -- In general an item declared in the visible state space of a package
24424 -- does not require a Part_Of indicator. The only exception is when the
24425 -- related package is a private child unit in which case Part_Of must
24426 -- denote a state in the parent unit or in one of its descendants.
24428 elsif Placement
= Visible_State_Space
then
24429 if Is_Child_Unit
(Pack_Id
)
24430 and then Is_Private_Descendant
(Pack_Id
)
24432 -- A package instantiation does not need a Part_Of indicator when
24433 -- the related generic template has no visible state.
24435 if Ekind
(Item_Id
) = E_Package
24436 and then Is_Generic_Instance
(Item_Id
)
24437 and then not Has_Visible_State
(Item_Id
)
24441 -- All other cases require Part_Of
24445 ("indicator Part_Of is required in this context "
24446 & "(SPARK RM 7.2.6(3))", Item_Id
);
24447 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24449 ("\& is declared in the visible part of private child "
24450 & "unit %", Item_Id
);
24454 -- When the item appears in the private state space of a packge, it must
24455 -- be a part of some state declared by the said package.
24457 else pragma Assert
(Placement
= Private_State_Space
);
24459 -- The related package does not declare a state, the item cannot act
24460 -- as a Part_Of constituent.
24462 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24465 -- A package instantiation does not need a Part_Of indicator when the
24466 -- related generic template has no visible state.
24468 elsif Ekind
(Pack_Id
) = E_Package
24469 and then Is_Generic_Instance
(Pack_Id
)
24470 and then not Has_Visible_State
(Pack_Id
)
24474 -- All other cases require Part_Of
24478 ("indicator Part_Of is required in this context "
24479 & "(SPARK RM 7.2.6(2))", Item_Id
);
24480 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24482 ("\& is declared in the private part of package %", Item_Id
);
24485 end Check_Missing_Part_Of
;
24487 ---------------------------------
24488 -- Check_SPARK_Aspect_For_ASIS --
24489 ---------------------------------
24491 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
24495 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
24496 Expr
:= Expression
(Corresponding_Aspect
(N
));
24497 if Nkind
(Expr
) /= N_Aggregate
then
24498 Preanalyze_And_Resolve
(Expr
);
24502 Comps
: constant List_Id
:= Component_Associations
(Expr
);
24503 Exprs
: constant List_Id
:= Expressions
(Expr
);
24508 E
:= First
(Exprs
);
24509 while Present
(E
) loop
24514 C
:= First
(Comps
);
24515 while Present
(C
) loop
24516 Analyze
(Expression
(C
));
24522 end Check_SPARK_Aspect_For_ASIS
;
24524 -------------------------------------
24525 -- Check_State_And_Constituent_Use --
24526 -------------------------------------
24528 procedure Check_State_And_Constituent_Use
24529 (States
: Elist_Id
;
24530 Constits
: Elist_Id
;
24533 function Find_Encapsulating_State
24534 (Constit_Id
: Entity_Id
) return Entity_Id
;
24535 -- Given the entity of a constituent, try to find a corresponding
24536 -- encapsulating state that appears in the same context. The routine
24537 -- returns Empty is no such state is found.
24539 ------------------------------
24540 -- Find_Encapsulating_State --
24541 ------------------------------
24543 function Find_Encapsulating_State
24544 (Constit_Id
: Entity_Id
) return Entity_Id
24546 State_Id
: Entity_Id
;
24549 -- Since a constituent may be part of a larger constituent set, climb
24550 -- the encapsulated state chain looking for a state that appears in
24551 -- the same context.
24553 State_Id
:= Encapsulating_State
(Constit_Id
);
24554 while Present
(State_Id
) loop
24555 if Contains
(States
, State_Id
) then
24559 State_Id
:= Encapsulating_State
(State_Id
);
24563 end Find_Encapsulating_State
;
24567 Constit_Elmt
: Elmt_Id
;
24568 Constit_Id
: Entity_Id
;
24569 State_Id
: Entity_Id
;
24571 -- Start of processing for Check_State_And_Constituent_Use
24574 -- Nothing to do if there are no states or constituents
24576 if No
(States
) or else No
(Constits
) then
24580 -- Inspect the list of constituents and try to determine whether its
24581 -- encapsulating state is in list States.
24583 Constit_Elmt
:= First_Elmt
(Constits
);
24584 while Present
(Constit_Elmt
) loop
24585 Constit_Id
:= Node
(Constit_Elmt
);
24587 -- Determine whether the constituent is part of an encapsulating
24588 -- state that appears in the same context and if this is the case,
24589 -- emit an error (SPARK RM 7.2.6(7)).
24591 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
24593 if Present
(State_Id
) then
24594 Error_Msg_Name_1
:= Chars
(Constit_Id
);
24596 ("cannot mention state & and its constituent % in the same "
24597 & "context", Context
, State_Id
);
24601 Next_Elmt
(Constit_Elmt
);
24603 end Check_State_And_Constituent_Use
;
24605 --------------------------
24606 -- Collect_Global_Items --
24607 --------------------------
24609 procedure Collect_Global_Items
24611 In_Items
: in out Elist_Id
;
24612 In_Out_Items
: in out Elist_Id
;
24613 Out_Items
: in out Elist_Id
;
24614 Proof_In_Items
: in out Elist_Id
;
24615 Has_In_State
: out Boolean;
24616 Has_In_Out_State
: out Boolean;
24617 Has_Out_State
: out Boolean;
24618 Has_Proof_In_State
: out Boolean;
24619 Has_Null_State
: out Boolean)
24621 procedure Process_Global_List
24623 Mode
: Name_Id
:= Name_Input
);
24624 -- Collect all items housed in a global list. Formal Mode denotes the
24625 -- current mode in effect.
24627 -------------------------
24628 -- Process_Global_List --
24629 -------------------------
24631 procedure Process_Global_List
24633 Mode
: Name_Id
:= Name_Input
)
24635 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24636 -- Add a single item to the appropriate list. Formal Mode denotes the
24637 -- current mode in effect.
24639 -------------------------
24640 -- Process_Global_Item --
24641 -------------------------
24643 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24644 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
24645 -- The above handles abstract views of variables and states built
24646 -- for limited with clauses.
24649 -- Signal that the global list contains at least one abstract
24650 -- state with a visible refinement. Note that the refinement may
24651 -- be null in which case there are no constituents.
24653 if Ekind
(Item_Id
) = E_Abstract_State
then
24654 if Has_Null_Refinement
(Item_Id
) then
24655 Has_Null_State
:= True;
24657 elsif Has_Non_Null_Refinement
(Item_Id
) then
24658 if Mode
= Name_Input
then
24659 Has_In_State
:= True;
24660 elsif Mode
= Name_In_Out
then
24661 Has_In_Out_State
:= True;
24662 elsif Mode
= Name_Output
then
24663 Has_Out_State
:= True;
24664 elsif Mode
= Name_Proof_In
then
24665 Has_Proof_In_State
:= True;
24670 -- Add the item to the proper list
24672 if Mode
= Name_Input
then
24673 Add_Item
(Item_Id
, In_Items
);
24674 elsif Mode
= Name_In_Out
then
24675 Add_Item
(Item_Id
, In_Out_Items
);
24676 elsif Mode
= Name_Output
then
24677 Add_Item
(Item_Id
, Out_Items
);
24678 elsif Mode
= Name_Proof_In
then
24679 Add_Item
(Item_Id
, Proof_In_Items
);
24681 end Process_Global_Item
;
24687 -- Start of processing for Process_Global_List
24690 if Nkind
(List
) = N_Null
then
24693 -- Single global item declaration
24695 elsif Nkind_In
(List
, N_Expanded_Name
,
24697 N_Selected_Component
)
24699 Process_Global_Item
(List
, Mode
);
24701 -- Single global list or moded global list declaration
24703 elsif Nkind
(List
) = N_Aggregate
then
24705 -- The declaration of a simple global list appear as a collection
24708 if Present
(Expressions
(List
)) then
24709 Item
:= First
(Expressions
(List
));
24710 while Present
(Item
) loop
24711 Process_Global_Item
(Item
, Mode
);
24716 -- The declaration of a moded global list appears as a collection
24717 -- of component associations where individual choices denote mode.
24719 elsif Present
(Component_Associations
(List
)) then
24720 Item
:= First
(Component_Associations
(List
));
24721 while Present
(Item
) loop
24722 Process_Global_List
24723 (List
=> Expression
(Item
),
24724 Mode
=> Chars
(First
(Choices
(Item
))));
24732 raise Program_Error
;
24735 -- To accomodate partial decoration of disabled SPARK features, this
24736 -- routine may be called with illegal input. If this is the case, do
24737 -- not raise Program_Error.
24742 end Process_Global_List
;
24746 Items
: constant Node_Id
:=
24747 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
)));
24749 -- Start of processing for Collect_Global_Items
24752 -- Assume that no states have been encountered
24754 Has_In_State
:= False;
24755 Has_In_Out_State
:= False;
24756 Has_Out_State
:= False;
24757 Has_Proof_In_State
:= False;
24758 Has_Null_State
:= False;
24760 Process_Global_List
(Items
);
24761 end Collect_Global_Items
;
24763 ---------------------------------------
24764 -- Collect_Subprogram_Inputs_Outputs --
24765 ---------------------------------------
24767 procedure Collect_Subprogram_Inputs_Outputs
24768 (Subp_Id
: Entity_Id
;
24769 Subp_Inputs
: in out Elist_Id
;
24770 Subp_Outputs
: in out Elist_Id
;
24771 Global_Seen
: out Boolean)
24773 procedure Collect_Global_List
24775 Mode
: Name_Id
:= Name_Input
);
24776 -- Collect all relevant items from a global list
24778 -------------------------
24779 -- Collect_Global_List --
24780 -------------------------
24782 procedure Collect_Global_List
24784 Mode
: Name_Id
:= Name_Input
)
24786 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24787 -- Add an item to the proper subprogram input or output collection
24789 -------------------------
24790 -- Collect_Global_Item --
24791 -------------------------
24793 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24795 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
24796 Add_Item
(Item
, Subp_Inputs
);
24799 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
24800 Add_Item
(Item
, Subp_Outputs
);
24802 end Collect_Global_Item
;
24809 -- Start of processing for Collect_Global_List
24812 if Nkind
(List
) = N_Null
then
24815 -- Single global item declaration
24817 elsif Nkind_In
(List
, N_Expanded_Name
,
24819 N_Selected_Component
)
24821 Collect_Global_Item
(List
, Mode
);
24823 -- Simple global list or moded global list declaration
24825 elsif Nkind
(List
) = N_Aggregate
then
24826 if Present
(Expressions
(List
)) then
24827 Item
:= First
(Expressions
(List
));
24828 while Present
(Item
) loop
24829 Collect_Global_Item
(Item
, Mode
);
24834 Assoc
:= First
(Component_Associations
(List
));
24835 while Present
(Assoc
) loop
24836 Collect_Global_List
24837 (List
=> Expression
(Assoc
),
24838 Mode
=> Chars
(First
(Choices
(Assoc
))));
24843 -- To accomodate partial decoration of disabled SPARK features, this
24844 -- routine may be called with illegal input. If this is the case, do
24845 -- not raise Program_Error.
24850 end Collect_Global_List
;
24854 Subp_Decl
: constant Node_Id
:= Parent
(Parent
(Subp_Id
));
24855 Formal
: Entity_Id
;
24858 Spec_Id
: Entity_Id
;
24860 -- Start of processing for Collect_Subprogram_Inputs_Outputs
24863 Global_Seen
:= False;
24865 -- Find the entity of the corresponding spec when processing a body
24867 if Nkind
(Subp_Decl
) = N_Subprogram_Body
24868 and then Present
(Corresponding_Spec
(Subp_Decl
))
24870 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
24872 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
24873 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
24875 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
24878 Spec_Id
:= Subp_Id
;
24881 -- Process all formal parameters
24883 Formal
:= First_Formal
(Spec_Id
);
24884 while Present
(Formal
) loop
24885 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
24886 Add_Item
(Formal
, Subp_Inputs
);
24889 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
24890 Add_Item
(Formal
, Subp_Outputs
);
24892 -- Out parameters can act as inputs when the related type is
24893 -- tagged, unconstrained array, unconstrained record or record
24894 -- with unconstrained components.
24896 if Ekind
(Formal
) = E_Out_Parameter
24897 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
24899 Add_Item
(Formal
, Subp_Inputs
);
24903 Next_Formal
(Formal
);
24906 -- When processing a subprogram body, look for pragma Refined_Global as
24907 -- it provides finer granularity of inputs and outputs.
24909 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
24910 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
24912 -- Subprogram declaration case, look for pragma Global
24915 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
24918 if Present
(Global
) then
24919 Global_Seen
:= True;
24920 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
24922 -- The pragma may not have been analyzed because of the arbitrary
24923 -- declaration order of aspects. Make sure that it is analyzed for
24924 -- the purposes of item extraction.
24926 if not Analyzed
(List
) then
24927 if Pragma_Name
(Global
) = Name_Refined_Global
then
24928 Analyze_Refined_Global_In_Decl_Part
(Global
);
24930 Analyze_Global_In_Decl_Part
(Global
);
24934 -- Nothing to be done for a null global list
24936 if Nkind
(List
) /= N_Null
then
24937 Collect_Global_List
(List
);
24940 end Collect_Subprogram_Inputs_Outputs
;
24942 ---------------------------------
24943 -- Delay_Config_Pragma_Analyze --
24944 ---------------------------------
24946 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
24948 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
24949 Name_Priority_Specific_Dispatching
);
24950 end Delay_Config_Pragma_Analyze
;
24952 -------------------------------------
24953 -- Find_Related_Subprogram_Or_Body --
24954 -------------------------------------
24956 function Find_Related_Subprogram_Or_Body
24958 Do_Checks
: Boolean := False) return Node_Id
24960 Context
: constant Node_Id
:= Parent
(Prag
);
24961 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
24964 Look_For_Body
: constant Boolean :=
24965 Nam_In
(Nam
, Name_Refined_Depends
,
24966 Name_Refined_Global
,
24967 Name_Refined_Post
);
24968 -- Refinement pragmas must be associated with a subprogram body [stub]
24971 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
24973 -- If the pragma is a byproduct of aspect expansion, return the related
24974 -- context of the original aspect.
24976 if Present
(Corresponding_Aspect
(Prag
)) then
24977 return Parent
(Corresponding_Aspect
(Prag
));
24980 -- Otherwise the pragma is a source construct, most likely part of a
24981 -- declarative list. Skip preceding declarations while looking for a
24982 -- proper subprogram declaration.
24984 pragma Assert
(Is_List_Member
(Prag
));
24986 Stmt
:= Prev
(Prag
);
24987 while Present
(Stmt
) loop
24989 -- Skip prior pragmas, but check for duplicates
24991 if Nkind
(Stmt
) = N_Pragma
then
24992 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
24993 Error_Msg_Name_1
:= Nam
;
24994 Error_Msg_Sloc
:= Sloc
(Stmt
);
24995 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
24998 -- Emit an error when a refinement pragma appears on an expression
24999 -- function without a completion.
25002 and then Look_For_Body
25003 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25004 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25005 and then not Has_Completion
(Defining_Entity
(Stmt
))
25007 Error_Msg_Name_1
:= Nam
;
25009 ("pragma % cannot apply to a stand alone expression function",
25014 -- The refinement pragma applies to a subprogram body stub
25016 elsif Look_For_Body
25017 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25021 -- Skip internally generated code
25023 elsif not Comes_From_Source
(Stmt
) then
25026 -- Return the current construct which is either a subprogram body,
25027 -- a subprogram declaration or is illegal.
25036 -- If we fall through, then the pragma was either the first declaration
25037 -- or it was preceded by other pragmas and no source constructs.
25039 -- The pragma is associated with a library-level subprogram
25041 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25042 return Unit
(Parent
(Context
));
25044 -- The pragma appears inside the declarative part of a subprogram body
25046 elsif Nkind
(Context
) = N_Subprogram_Body
then
25049 -- No candidate subprogram [body] found
25054 end Find_Related_Subprogram_Or_Body
;
25056 -------------------------
25057 -- Get_Base_Subprogram --
25058 -------------------------
25060 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25061 Result
: Entity_Id
;
25064 -- Follow subprogram renaming chain
25068 if Is_Subprogram
(Result
)
25070 Nkind
(Parent
(Declaration_Node
(Result
))) =
25071 N_Subprogram_Renaming_Declaration
25072 and then Present
(Alias
(Result
))
25074 Result
:= Alias
(Result
);
25078 end Get_Base_Subprogram
;
25080 -----------------------
25081 -- Get_SPARK_Mode_Type --
25082 -----------------------
25084 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25086 if N
= Name_On
then
25088 elsif N
= Name_Off
then
25091 -- Any other argument is illegal
25094 raise Program_Error
;
25096 end Get_SPARK_Mode_Type
;
25098 --------------------------------
25099 -- Get_SPARK_Mode_From_Pragma --
25100 --------------------------------
25102 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25107 pragma Assert
(Nkind
(N
) = N_Pragma
);
25108 Args
:= Pragma_Argument_Associations
(N
);
25110 -- Extract the mode from the argument list
25112 if Present
(Args
) then
25113 Mode
:= First
(Pragma_Argument_Associations
(N
));
25114 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25116 -- If SPARK_Mode pragma has no argument, default is ON
25121 end Get_SPARK_Mode_From_Pragma
;
25123 ---------------------------
25124 -- Has_Extra_Parentheses --
25125 ---------------------------
25127 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25131 -- The aggregate should not have an expression list because a clause
25132 -- is always interpreted as a component association. The only way an
25133 -- expression list can sneak in is by adding extra parentheses around
25134 -- the individual clauses:
25136 -- Depends (Output => Input) -- proper form
25137 -- Depends ((Output => Input)) -- extra parentheses
25139 -- Since the extra parentheses are not allowed by the syntax of the
25140 -- pragma, flag them now to avoid emitting misleading errors down the
25143 if Nkind
(Clause
) = N_Aggregate
25144 and then Present
(Expressions
(Clause
))
25146 Expr
:= First
(Expressions
(Clause
));
25147 while Present
(Expr
) loop
25149 -- A dependency clause surrounded by extra parentheses appears
25150 -- as an aggregate of component associations with an optional
25151 -- Paren_Count set.
25153 if Nkind
(Expr
) = N_Aggregate
25154 and then Present
(Component_Associations
(Expr
))
25157 ("dependency clause contains extra parentheses", Expr
);
25159 -- Otherwise the expression is a malformed construct
25162 SPARK_Msg_N
("malformed dependency clause", Expr
);
25172 end Has_Extra_Parentheses
;
25178 procedure Initialize
is
25189 Dummy
:= Dummy
+ 1;
25192 -----------------------------
25193 -- Is_Config_Static_String --
25194 -----------------------------
25196 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25198 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25199 -- This is an internal recursive function that is just like the outer
25200 -- function except that it adds the string to the name buffer rather
25201 -- than placing the string in the name buffer.
25203 ------------------------------
25204 -- Add_Config_Static_String --
25205 ------------------------------
25207 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25214 if Nkind
(N
) = N_Op_Concat
then
25215 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25216 N
:= Right_Opnd
(N
);
25222 if Nkind
(N
) /= N_String_Literal
then
25223 Error_Msg_N
("string literal expected for pragma argument", N
);
25227 for J
in 1 .. String_Length
(Strval
(N
)) loop
25228 C
:= Get_String_Char
(Strval
(N
), J
);
25230 if not In_Character_Range
(C
) then
25232 ("string literal contains invalid wide character",
25233 Sloc
(N
) + 1 + Source_Ptr
(J
));
25237 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25242 end Add_Config_Static_String
;
25244 -- Start of processing for Is_Config_Static_String
25249 return Add_Config_Static_String
(Arg
);
25250 end Is_Config_Static_String
;
25252 -------------------------------
25253 -- Is_Elaboration_SPARK_Mode --
25254 -------------------------------
25256 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
25259 (Nkind
(N
) = N_Pragma
25260 and then Pragma_Name
(N
) = Name_SPARK_Mode
25261 and then Is_List_Member
(N
));
25263 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25264 -- appears in the statement part of the body.
25267 Present
(Parent
(N
))
25268 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
25269 and then List_Containing
(N
) = Statements
(Parent
(N
))
25270 and then Present
(Parent
(Parent
(N
)))
25271 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
25272 end Is_Elaboration_SPARK_Mode
;
25274 -----------------------------------------
25275 -- Is_Non_Significant_Pragma_Reference --
25276 -----------------------------------------
25278 -- This function makes use of the following static table which indicates
25279 -- whether appearance of some name in a given pragma is to be considered
25280 -- as a reference for the purposes of warnings about unreferenced objects.
25282 -- -1 indicates that appearence in any argument is significant
25283 -- 0 indicates that appearance in any argument is not significant
25284 -- +n indicates that appearance as argument n is significant, but all
25285 -- other arguments are not significant
25286 -- 9n arguments from n on are significant, before n inisignificant
25288 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
25289 (Pragma_Abort_Defer
=> -1,
25290 Pragma_Abstract_State
=> -1,
25291 Pragma_Ada_83
=> -1,
25292 Pragma_Ada_95
=> -1,
25293 Pragma_Ada_05
=> -1,
25294 Pragma_Ada_2005
=> -1,
25295 Pragma_Ada_12
=> -1,
25296 Pragma_Ada_2012
=> -1,
25297 Pragma_All_Calls_Remote
=> -1,
25298 Pragma_Allow_Integer_Address
=> -1,
25299 Pragma_Annotate
=> 93,
25300 Pragma_Assert
=> -1,
25301 Pragma_Assert_And_Cut
=> -1,
25302 Pragma_Assertion_Policy
=> 0,
25303 Pragma_Assume
=> -1,
25304 Pragma_Assume_No_Invalid_Values
=> 0,
25305 Pragma_Async_Readers
=> 0,
25306 Pragma_Async_Writers
=> 0,
25307 Pragma_Asynchronous
=> 0,
25308 Pragma_Atomic
=> 0,
25309 Pragma_Atomic_Components
=> 0,
25310 Pragma_Attach_Handler
=> -1,
25311 Pragma_Attribute_Definition
=> 92,
25312 Pragma_Check
=> -1,
25313 Pragma_Check_Float_Overflow
=> 0,
25314 Pragma_Check_Name
=> 0,
25315 Pragma_Check_Policy
=> 0,
25316 Pragma_CIL_Constructor
=> 0,
25317 Pragma_CPP_Class
=> 0,
25318 Pragma_CPP_Constructor
=> 0,
25319 Pragma_CPP_Virtual
=> 0,
25320 Pragma_CPP_Vtable
=> 0,
25322 Pragma_C_Pass_By_Copy
=> 0,
25323 Pragma_Comment
=> -1,
25324 Pragma_Common_Object
=> 0,
25325 Pragma_Compile_Time_Error
=> -1,
25326 Pragma_Compile_Time_Warning
=> -1,
25327 Pragma_Compiler_Unit
=> -1,
25328 Pragma_Compiler_Unit_Warning
=> -1,
25329 Pragma_Complete_Representation
=> 0,
25330 Pragma_Complex_Representation
=> 0,
25331 Pragma_Component_Alignment
=> 0,
25332 Pragma_Contract_Cases
=> -1,
25333 Pragma_Controlled
=> 0,
25334 Pragma_Convention
=> 0,
25335 Pragma_Convention_Identifier
=> 0,
25336 Pragma_Debug
=> -1,
25337 Pragma_Debug_Policy
=> 0,
25338 Pragma_Detect_Blocking
=> 0,
25339 Pragma_Default_Initial_Condition
=> -1,
25340 Pragma_Default_Scalar_Storage_Order
=> 0,
25341 Pragma_Default_Storage_Pool
=> 0,
25342 Pragma_Depends
=> -1,
25343 Pragma_Disable_Atomic_Synchronization
=> 0,
25344 Pragma_Discard_Names
=> 0,
25345 Pragma_Dispatching_Domain
=> -1,
25346 Pragma_Effective_Reads
=> 0,
25347 Pragma_Effective_Writes
=> 0,
25348 Pragma_Elaborate
=> 0,
25349 Pragma_Elaborate_All
=> 0,
25350 Pragma_Elaborate_Body
=> 0,
25351 Pragma_Elaboration_Checks
=> 0,
25352 Pragma_Eliminate
=> 0,
25353 Pragma_Enable_Atomic_Synchronization
=> 0,
25354 Pragma_Export
=> -1,
25355 Pragma_Export_Function
=> -1,
25356 Pragma_Export_Object
=> -1,
25357 Pragma_Export_Procedure
=> -1,
25358 Pragma_Export_Value
=> -1,
25359 Pragma_Export_Valued_Procedure
=> -1,
25360 Pragma_Extend_System
=> -1,
25361 Pragma_Extensions_Allowed
=> 0,
25362 Pragma_Extensions_Visible
=> 0,
25363 Pragma_External
=> -1,
25364 Pragma_Favor_Top_Level
=> 0,
25365 Pragma_External_Name_Casing
=> 0,
25366 Pragma_Fast_Math
=> 0,
25367 Pragma_Finalize_Storage_Only
=> 0,
25369 Pragma_Global
=> -1,
25370 Pragma_Ident
=> -1,
25371 Pragma_Implementation_Defined
=> -1,
25372 Pragma_Implemented
=> -1,
25373 Pragma_Implicit_Packing
=> 0,
25374 Pragma_Import
=> 93,
25375 Pragma_Import_Function
=> 0,
25376 Pragma_Import_Object
=> 0,
25377 Pragma_Import_Procedure
=> 0,
25378 Pragma_Import_Valued_Procedure
=> 0,
25379 Pragma_Independent
=> 0,
25380 Pragma_Independent_Components
=> 0,
25381 Pragma_Initial_Condition
=> -1,
25382 Pragma_Initialize_Scalars
=> 0,
25383 Pragma_Initializes
=> -1,
25384 Pragma_Inline
=> 0,
25385 Pragma_Inline_Always
=> 0,
25386 Pragma_Inline_Generic
=> 0,
25387 Pragma_Inspection_Point
=> -1,
25388 Pragma_Interface
=> 92,
25389 Pragma_Interface_Name
=> 0,
25390 Pragma_Interrupt_Handler
=> -1,
25391 Pragma_Interrupt_Priority
=> -1,
25392 Pragma_Interrupt_State
=> -1,
25393 Pragma_Invariant
=> -1,
25394 Pragma_Java_Constructor
=> -1,
25395 Pragma_Java_Interface
=> -1,
25396 Pragma_Keep_Names
=> 0,
25397 Pragma_License
=> 0,
25398 Pragma_Link_With
=> -1,
25399 Pragma_Linker_Alias
=> -1,
25400 Pragma_Linker_Constructor
=> -1,
25401 Pragma_Linker_Destructor
=> -1,
25402 Pragma_Linker_Options
=> -1,
25403 Pragma_Linker_Section
=> 0,
25405 Pragma_Lock_Free
=> 0,
25406 Pragma_Locking_Policy
=> 0,
25407 Pragma_Loop_Invariant
=> -1,
25408 Pragma_Loop_Optimize
=> 0,
25409 Pragma_Loop_Variant
=> -1,
25410 Pragma_Machine_Attribute
=> -1,
25412 Pragma_Main_Storage
=> -1,
25413 Pragma_Memory_Size
=> 0,
25414 Pragma_No_Return
=> 0,
25415 Pragma_No_Body
=> 0,
25416 Pragma_No_Elaboration_Code_All
=> 0,
25417 Pragma_No_Inline
=> 0,
25418 Pragma_No_Run_Time
=> -1,
25419 Pragma_No_Strict_Aliasing
=> -1,
25420 Pragma_No_Tagged_Streams
=> 0,
25421 Pragma_Normalize_Scalars
=> 0,
25422 Pragma_Obsolescent
=> 0,
25423 Pragma_Optimize
=> 0,
25424 Pragma_Optimize_Alignment
=> 0,
25425 Pragma_Overflow_Mode
=> 0,
25426 Pragma_Overriding_Renamings
=> 0,
25427 Pragma_Ordered
=> 0,
25430 Pragma_Part_Of
=> 0,
25431 Pragma_Partition_Elaboration_Policy
=> 0,
25432 Pragma_Passive
=> 0,
25433 Pragma_Persistent_BSS
=> 0,
25434 Pragma_Polling
=> 0,
25435 Pragma_Prefix_Exception_Messages
=> 0,
25437 Pragma_Postcondition
=> -1,
25438 Pragma_Post_Class
=> -1,
25440 Pragma_Precondition
=> -1,
25441 Pragma_Predicate
=> -1,
25442 Pragma_Preelaborable_Initialization
=> -1,
25443 Pragma_Preelaborate
=> 0,
25444 Pragma_Pre_Class
=> -1,
25445 Pragma_Priority
=> -1,
25446 Pragma_Priority_Specific_Dispatching
=> 0,
25447 Pragma_Profile
=> 0,
25448 Pragma_Profile_Warnings
=> 0,
25449 Pragma_Propagate_Exceptions
=> 0,
25450 Pragma_Provide_Shift_Operators
=> 0,
25451 Pragma_Psect_Object
=> 0,
25453 Pragma_Pure_Function
=> 0,
25454 Pragma_Queuing_Policy
=> 0,
25455 Pragma_Rational
=> 0,
25456 Pragma_Ravenscar
=> 0,
25457 Pragma_Refined_Depends
=> -1,
25458 Pragma_Refined_Global
=> -1,
25459 Pragma_Refined_Post
=> -1,
25460 Pragma_Refined_State
=> -1,
25461 Pragma_Relative_Deadline
=> 0,
25462 Pragma_Remote_Access_Type
=> -1,
25463 Pragma_Remote_Call_Interface
=> -1,
25464 Pragma_Remote_Types
=> -1,
25465 Pragma_Restricted_Run_Time
=> 0,
25466 Pragma_Restriction_Warnings
=> 0,
25467 Pragma_Restrictions
=> 0,
25468 Pragma_Reviewable
=> -1,
25469 Pragma_Short_Circuit_And_Or
=> 0,
25470 Pragma_Share_Generic
=> 0,
25471 Pragma_Shared
=> 0,
25472 Pragma_Shared_Passive
=> 0,
25473 Pragma_Short_Descriptors
=> 0,
25474 Pragma_Simple_Storage_Pool_Type
=> 0,
25475 Pragma_Source_File_Name
=> 0,
25476 Pragma_Source_File_Name_Project
=> 0,
25477 Pragma_Source_Reference
=> 0,
25478 Pragma_SPARK_Mode
=> 0,
25479 Pragma_Storage_Size
=> -1,
25480 Pragma_Storage_Unit
=> 0,
25481 Pragma_Static_Elaboration_Desired
=> 0,
25482 Pragma_Stream_Convert
=> 0,
25483 Pragma_Style_Checks
=> 0,
25484 Pragma_Subtitle
=> 0,
25485 Pragma_Suppress
=> 0,
25486 Pragma_Suppress_Exception_Locations
=> 0,
25487 Pragma_Suppress_All
=> 0,
25488 Pragma_Suppress_Debug_Info
=> 0,
25489 Pragma_Suppress_Initialization
=> 0,
25490 Pragma_System_Name
=> 0,
25491 Pragma_Task_Dispatching_Policy
=> 0,
25492 Pragma_Task_Info
=> -1,
25493 Pragma_Task_Name
=> -1,
25494 Pragma_Task_Storage
=> -1,
25495 Pragma_Test_Case
=> -1,
25496 Pragma_Thread_Local_Storage
=> -1,
25497 Pragma_Time_Slice
=> -1,
25499 Pragma_Type_Invariant
=> -1,
25500 Pragma_Type_Invariant_Class
=> -1,
25501 Pragma_Unchecked_Union
=> 0,
25502 Pragma_Unimplemented_Unit
=> 0,
25503 Pragma_Universal_Aliasing
=> 0,
25504 Pragma_Universal_Data
=> 0,
25505 Pragma_Unmodified
=> 0,
25506 Pragma_Unreferenced
=> 0,
25507 Pragma_Unreferenced_Objects
=> 0,
25508 Pragma_Unreserve_All_Interrupts
=> 0,
25509 Pragma_Unsuppress
=> 0,
25510 Pragma_Unevaluated_Use_Of_Old
=> 0,
25511 Pragma_Use_VADS_Size
=> 0,
25512 Pragma_Validity_Checks
=> 0,
25513 Pragma_Volatile
=> 0,
25514 Pragma_Volatile_Components
=> 0,
25515 Pragma_Warning_As_Error
=> 0,
25516 Pragma_Warnings
=> 0,
25517 Pragma_Weak_External
=> 0,
25518 Pragma_Wide_Character_Encoding
=> 0,
25519 Unknown_Pragma
=> 0);
25521 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25527 function Arg_No
return Nat
;
25528 -- Returns an integer showing what argument we are in. A value of
25529 -- zero means we are not in any of the arguments.
25535 function Arg_No
return Nat
is
25540 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25554 -- Start of processing for Non_Significant_Pragma_Reference
25559 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25563 Id
:= Get_Pragma_Id
(Parent
(P
));
25564 C
:= Sig_Flags
(Id
);
25579 return AN
< (C
- 90);
25585 end Is_Non_Significant_Pragma_Reference
;
25587 ------------------------------
25588 -- Is_Pragma_String_Literal --
25589 ------------------------------
25591 -- This function returns true if the corresponding pragma argument is a
25592 -- static string expression. These are the only cases in which string
25593 -- literals can appear as pragma arguments. We also allow a string literal
25594 -- as the first argument to pragma Assert (although it will of course
25595 -- always generate a type error).
25597 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
25598 Pragn
: constant Node_Id
:= Parent
(Par
);
25599 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
25600 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
25606 N
:= First
(Assoc
);
25613 if Pname
= Name_Assert
then
25616 elsif Pname
= Name_Export
then
25619 elsif Pname
= Name_Ident
then
25622 elsif Pname
= Name_Import
then
25625 elsif Pname
= Name_Interface_Name
then
25628 elsif Pname
= Name_Linker_Alias
then
25631 elsif Pname
= Name_Linker_Section
then
25634 elsif Pname
= Name_Machine_Attribute
then
25637 elsif Pname
= Name_Source_File_Name
then
25640 elsif Pname
= Name_Source_Reference
then
25643 elsif Pname
= Name_Title
then
25646 elsif Pname
= Name_Subtitle
then
25652 end Is_Pragma_String_Literal
;
25654 ---------------------------
25655 -- Is_Private_SPARK_Mode --
25656 ---------------------------
25658 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
25661 (Nkind
(N
) = N_Pragma
25662 and then Pragma_Name
(N
) = Name_SPARK_Mode
25663 and then Is_List_Member
(N
));
25665 -- For pragma SPARK_Mode to be private, it has to appear in the private
25666 -- declarations of a package.
25669 Present
(Parent
(N
))
25670 and then Nkind
(Parent
(N
)) = N_Package_Specification
25671 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
25672 end Is_Private_SPARK_Mode
;
25674 -------------------------------------
25675 -- Is_Unconstrained_Or_Tagged_Item --
25676 -------------------------------------
25678 function Is_Unconstrained_Or_Tagged_Item
25679 (Item
: Entity_Id
) return Boolean
25681 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
25682 -- Determine whether record type Typ has at least one unconstrained
25685 ---------------------------------
25686 -- Has_Unconstrained_Component --
25687 ---------------------------------
25689 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
25693 Comp
:= First_Component
(Typ
);
25694 while Present
(Comp
) loop
25695 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
25699 Next_Component
(Comp
);
25703 end Has_Unconstrained_Component
;
25707 Typ
: constant Entity_Id
:= Etype
(Item
);
25709 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
25712 if Is_Tagged_Type
(Typ
) then
25715 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
25718 elsif Is_Record_Type
(Typ
) then
25719 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
25722 return Has_Unconstrained_Component
(Typ
);
25725 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
25731 end Is_Unconstrained_Or_Tagged_Item
;
25733 -----------------------------
25734 -- Is_Valid_Assertion_Kind --
25735 -----------------------------
25737 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
25744 Name_Static_Predicate |
25745 Name_Dynamic_Predicate |
25750 Name_Type_Invariant |
25751 Name_uType_Invariant |
25755 Name_Assert_And_Cut |
25757 Name_Contract_Cases |
25759 Name_Default_Initial_Condition |
25761 Name_Initial_Condition |
25764 Name_Loop_Invariant |
25765 Name_Loop_Variant |
25766 Name_Postcondition |
25767 Name_Precondition |
25769 Name_Refined_Post |
25770 Name_Statement_Assertions
=> return True;
25772 when others => return False;
25774 end Is_Valid_Assertion_Kind
;
25776 -----------------------------------------
25777 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
25778 -----------------------------------------
25780 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
25781 Aspects
: constant List_Id
:= New_List
;
25782 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
25783 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
25785 Original_Aspects
: List_Id
;
25786 -- To capture global references, a copy of the created aspects must be
25787 -- inserted in the original tree.
25790 Prag_Arg_Ass
: Node_Id
;
25791 Prag_Id
: Pragma_Id
;
25794 -- Check for any PPC pragmas that appear within Decl
25796 Prag
:= Next
(Decl
);
25797 while Nkind
(Prag
) = N_Pragma
loop
25798 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
25801 when Pragma_Postcondition | Pragma_Precondition
=>
25802 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
25804 -- Make an aspect from any PPC pragma
25806 Append_To
(Aspects
,
25807 Make_Aspect_Specification
(Loc
,
25809 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
25811 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
25813 -- Generate the analysis information in the pragma expression
25814 -- and then set the pragma node analyzed to avoid any further
25817 Analyze
(Expression
(Prag_Arg_Ass
));
25818 Set_Analyzed
(Prag
, True);
25820 when others => null;
25826 -- Set all new aspects into the generic declaration node
25828 if Is_Non_Empty_List
(Aspects
) then
25830 -- Create the list of aspects to be inserted in the original tree
25832 Original_Aspects
:= Copy_Separate_List
(Aspects
);
25834 -- Check if Decl already has aspects
25836 -- Attach the new lists of aspects to both the generic copy and the
25839 if Has_Aspects
(Decl
) then
25840 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
25841 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
25844 Set_Parent
(Aspects
, Decl
);
25845 Set_Aspect_Specifications
(Decl
, Aspects
);
25846 Set_Parent
(Original_Aspects
, Or_Decl
);
25847 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
25850 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
25852 -------------------------
25853 -- Preanalyze_CTC_Args --
25854 -------------------------
25856 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
25858 -- Preanalyze the boolean expressions, we treat these as spec
25859 -- expressions (i.e. similar to a default expression).
25861 if Present
(Arg_Req
) then
25862 Preanalyze_Assert_Expression
25863 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
25865 -- In ASIS mode, for a pragma generated from a source aspect, also
25866 -- analyze the original aspect expression.
25868 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
25869 Preanalyze_Assert_Expression
25870 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
25874 if Present
(Arg_Ens
) then
25875 Preanalyze_Assert_Expression
25876 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
25878 -- In ASIS mode, for a pragma generated from a source aspect, also
25879 -- analyze the original aspect expression.
25881 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
25882 Preanalyze_Assert_Expression
25883 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
25886 end Preanalyze_CTC_Args
;
25888 --------------------------------------
25889 -- Process_Compilation_Unit_Pragmas --
25890 --------------------------------------
25892 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
25894 -- A special check for pragma Suppress_All, a very strange DEC pragma,
25895 -- strange because it comes at the end of the unit. Rational has the
25896 -- same name for a pragma, but treats it as a program unit pragma, In
25897 -- GNAT we just decide to allow it anywhere at all. If it appeared then
25898 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
25899 -- node, and we insert a pragma Suppress (All_Checks) at the start of
25900 -- the context clause to ensure the correct processing.
25902 if Has_Pragma_Suppress_All
(N
) then
25903 Prepend_To
(Context_Items
(N
),
25904 Make_Pragma
(Sloc
(N
),
25905 Chars
=> Name_Suppress
,
25906 Pragma_Argument_Associations
=> New_List
(
25907 Make_Pragma_Argument_Association
(Sloc
(N
),
25908 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
25911 -- Nothing else to do at the current time
25913 end Process_Compilation_Unit_Pragmas
;
25915 ------------------------------------
25916 -- Record_Possible_Body_Reference --
25917 ------------------------------------
25919 procedure Record_Possible_Body_Reference
25920 (State_Id
: Entity_Id
;
25924 Spec_Id
: Entity_Id
;
25927 -- Ensure that we are dealing with a reference to a state
25929 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
25931 -- Climb the tree starting from the reference looking for a package body
25932 -- whose spec declares the referenced state. This criteria automatically
25933 -- excludes references in package specs which are legal. Note that it is
25934 -- not wise to emit an error now as the package body may lack pragma
25935 -- Refined_State or the referenced state may not be mentioned in the
25936 -- refinement. This approach avoids the generation of misleading errors.
25939 while Present
(Context
) loop
25940 if Nkind
(Context
) = N_Package_Body
then
25941 Spec_Id
:= Corresponding_Spec
(Context
);
25943 if Present
(Abstract_States
(Spec_Id
))
25944 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
25946 if No
(Body_References
(State_Id
)) then
25947 Set_Body_References
(State_Id
, New_Elmt_List
);
25950 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
25955 Context
:= Parent
(Context
);
25957 end Record_Possible_Body_Reference
;
25959 ------------------------------
25960 -- Relocate_Pragmas_To_Body --
25961 ------------------------------
25963 procedure Relocate_Pragmas_To_Body
25964 (Subp_Body
: Node_Id
;
25965 Target_Body
: Node_Id
:= Empty
)
25967 procedure Relocate_Pragma
(Prag
: Node_Id
);
25968 -- Remove a single pragma from its current list and add it to the
25969 -- declarations of the proper body (either Subp_Body or Target_Body).
25971 ---------------------
25972 -- Relocate_Pragma --
25973 ---------------------
25975 procedure Relocate_Pragma
(Prag
: Node_Id
) is
25980 -- When subprogram stubs or expression functions are involves, the
25981 -- destination declaration list belongs to the proper body.
25983 if Present
(Target_Body
) then
25984 Target
:= Target_Body
;
25986 Target
:= Subp_Body
;
25989 Decls
:= Declarations
(Target
);
25993 Set_Declarations
(Target
, Decls
);
25996 -- Unhook the pragma from its current list
25999 Prepend
(Prag
, Decls
);
26000 end Relocate_Pragma
;
26004 Body_Id
: constant Entity_Id
:=
26005 Defining_Unit_Name
(Specification
(Subp_Body
));
26006 Next_Stmt
: Node_Id
;
26009 -- Start of processing for Relocate_Pragmas_To_Body
26012 -- Do not process a body that comes from a separate unit as no construct
26013 -- can possibly follow it.
26015 if not Is_List_Member
(Subp_Body
) then
26018 -- Do not relocate pragmas that follow a stub if the stub does not have
26021 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26022 and then No
(Target_Body
)
26026 -- Do not process internally generated routine _Postconditions
26028 elsif Ekind
(Body_Id
) = E_Procedure
26029 and then Chars
(Body_Id
) = Name_uPostconditions
26034 -- Look at what is following the body. We are interested in certain kind
26035 -- of pragmas (either from source or byproducts of expansion) that can
26036 -- apply to a body [stub].
26038 Stmt
:= Next
(Subp_Body
);
26039 while Present
(Stmt
) loop
26041 -- Preserve the following statement for iteration purposes due to a
26042 -- possible relocation of a pragma.
26044 Next_Stmt
:= Next
(Stmt
);
26046 -- Move a candidate pragma following the body to the declarations of
26049 if Nkind
(Stmt
) = N_Pragma
26050 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26052 Relocate_Pragma
(Stmt
);
26054 -- Skip internally generated code
26056 elsif not Comes_From_Source
(Stmt
) then
26059 -- No candidate pragmas are available for relocation
26067 end Relocate_Pragmas_To_Body
;
26069 -------------------
26070 -- Resolve_State --
26071 -------------------
26073 procedure Resolve_State
(N
: Node_Id
) is
26078 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26079 Func
:= Entity
(N
);
26081 -- Handle overloading of state names by functions. Traverse the
26082 -- homonym chain looking for an abstract state.
26084 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26085 State
:= Homonym
(Func
);
26086 while Present
(State
) loop
26088 -- Resolve the overloading by setting the proper entity of the
26089 -- reference to that of the state.
26091 if Ekind
(State
) = E_Abstract_State
then
26092 Set_Etype
(N
, Standard_Void_Type
);
26093 Set_Entity
(N
, State
);
26094 Set_Associated_Node
(N
, State
);
26098 State
:= Homonym
(State
);
26101 -- A function can never act as a state. If the homonym chain does
26102 -- not contain a corresponding state, then something went wrong in
26103 -- the overloading mechanism.
26105 raise Program_Error
;
26110 ----------------------------
26111 -- Rewrite_Assertion_Kind --
26112 ----------------------------
26114 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26118 if Nkind
(N
) = N_Attribute_Reference
26119 and then Attribute_Name
(N
) = Name_Class
26120 and then Nkind
(Prefix
(N
)) = N_Identifier
26122 case Chars
(Prefix
(N
)) is
26127 when Name_Type_Invariant
=>
26128 Nam
:= Name_uType_Invariant
;
26129 when Name_Invariant
=>
26130 Nam
:= Name_uInvariant
;
26135 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26137 end Rewrite_Assertion_Kind
;
26145 Dummy
:= Dummy
+ 1;
26148 --------------------------------
26149 -- Set_Encoded_Interface_Name --
26150 --------------------------------
26152 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26153 Str
: constant String_Id
:= Strval
(S
);
26154 Len
: constant Int
:= String_Length
(Str
);
26159 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26162 -- Stores encoded value of character code CC. The encoding we use an
26163 -- underscore followed by four lower case hex digits.
26169 procedure Encode
is
26171 Store_String_Char
(Get_Char_Code
('_'));
26173 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26175 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26177 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26179 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26182 -- Start of processing for Set_Encoded_Interface_Name
26185 -- If first character is asterisk, this is a link name, and we leave it
26186 -- completely unmodified. We also ignore null strings (the latter case
26187 -- happens only in error cases) and no encoding should occur for Java or
26188 -- AAMP interface names.
26191 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26192 or else VM_Target
/= No_VM
26193 or else AAMP_On_Target
26195 Set_Interface_Name
(E
, S
);
26200 CC
:= Get_String_Char
(Str
, J
);
26202 exit when not In_Character_Range
(CC
);
26204 C
:= Get_Character
(CC
);
26206 exit when C
/= '_' and then C
/= '$'
26207 and then C
not in '0' .. '9'
26208 and then C
not in 'a' .. 'z'
26209 and then C
not in 'A' .. 'Z';
26212 Set_Interface_Name
(E
, S
);
26220 -- Here we need to encode. The encoding we use as follows:
26221 -- three underscores + four hex digits (lower case)
26225 for J
in 1 .. String_Length
(Str
) loop
26226 CC
:= Get_String_Char
(Str
, J
);
26228 if not In_Character_Range
(CC
) then
26231 C
:= Get_Character
(CC
);
26233 if C
= '_' or else C
= '$'
26234 or else C
in '0' .. '9'
26235 or else C
in 'a' .. 'z'
26236 or else C
in 'A' .. 'Z'
26238 Store_String_Char
(CC
);
26245 Set_Interface_Name
(E
,
26246 Make_String_Literal
(Sloc
(S
),
26247 Strval
=> End_String
));
26249 end Set_Encoded_Interface_Name
;
26251 -------------------
26252 -- Set_Unit_Name --
26253 -------------------
26255 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26260 if Nkind
(N
) = N_Identifier
26261 and then Nkind
(With_Item
) = N_Identifier
26263 Set_Entity
(N
, Entity
(With_Item
));
26265 elsif Nkind
(N
) = N_Selected_Component
then
26266 Change_Selected_Component_To_Expanded_Name
(N
);
26267 Set_Entity
(N
, Entity
(With_Item
));
26268 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26270 Pref
:= Prefix
(N
);
26271 Scop
:= Scope
(Entity
(N
));
26272 while Nkind
(Pref
) = N_Selected_Component
loop
26273 Change_Selected_Component_To_Expanded_Name
(Pref
);
26274 Set_Entity
(Selector_Name
(Pref
), Scop
);
26275 Set_Entity
(Pref
, Scop
);
26276 Pref
:= Prefix
(Pref
);
26277 Scop
:= Scope
(Scop
);
26280 Set_Entity
(Pref
, Scop
);