1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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_VFpt
; use Sem_VFpt
;
72 with Sem_Warn
; use Sem_Warn
;
73 with Stand
; use Stand
;
74 with Sinfo
; use Sinfo
;
75 with Sinfo
.CN
; use Sinfo
.CN
;
76 with Sinput
; use Sinput
;
77 with Stringt
; use Stringt
;
78 with Stylesw
; use Stylesw
;
80 with Targparm
; use Targparm
;
81 with Tbuild
; use Tbuild
;
83 with Uintp
; use Uintp
;
84 with Uname
; use Uname
;
85 with Urealp
; use Urealp
;
86 with Validsw
; use Validsw
;
87 with Warnsw
; use Warnsw
;
89 package body Sem_Prag
is
91 ----------------------------------------------
92 -- Common Handling of Import-Export Pragmas --
93 ----------------------------------------------
95 -- In the following section, a number of Import_xxx and Export_xxx pragmas
96 -- are defined by GNAT. These are compatible with the DEC pragmas of the
97 -- same name, and all have the following common form and processing:
100 -- [Internal =>] LOCAL_NAME
101 -- [, [External =>] EXTERNAL_SYMBOL]
102 -- [, other optional parameters ]);
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
109 -- EXTERNAL_SYMBOL ::=
111 -- | static_string_EXPRESSION
113 -- The internal LOCAL_NAME designates the entity that is imported or
114 -- exported, and must refer to an entity in the current declarative
115 -- part (as required by the rules for LOCAL_NAME).
117 -- The external linker name is designated by the External parameter if
118 -- given, or the Internal parameter if not (if there is no External
119 -- parameter, the External parameter is a copy of the Internal name).
121 -- If the External parameter is given as a string, then this string is
122 -- treated as an external name (exactly as though it had been given as an
123 -- External_Name parameter for a normal Import pragma).
125 -- If the External parameter is given as an identifier (or there is no
126 -- External parameter, so that the Internal identifier is used), then
127 -- the external name is the characters of the identifier, translated
128 -- to all upper case letters for OpenVMS versions of GNAT, and to all
129 -- lower case letters for all other versions
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals
is new Table
.Table
(
158 Table_Component_Type
=> Node_Id
,
159 Table_Index_Type
=> Int
,
160 Table_Low_Bound
=> 0,
161 Table_Initial
=> 100,
162 Table_Increment
=> 100,
163 Table_Name
=> "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
);
170 -- Subsidiary routine to the analysis of pragmas Depends, Global and
171 -- Refined_State. Append an entity to a list. If the list is empty, create
174 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
175 -- This routine is used for possible casing adjustment of an explicit
176 -- external name supplied as a string literal (the node N), according to
177 -- the casing requirement of Opt.External_Name_Casing. If this is set to
178 -- As_Is, then the string literal is returned unchanged, but if it is set
179 -- to Uppercase or Lowercase, then a new string literal with appropriate
180 -- casing is constructed.
182 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
183 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
184 -- whether a particular item appears in a mixed list of nodes and entities.
185 -- It is assumed that all nodes in the list have entities.
187 procedure Check_Dependence_List_Syntax
(List
: Node_Id
);
188 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
189 -- Verify the syntax of dependence relation List.
191 procedure Check_Global_List_Syntax
(List
: Node_Id
);
192 -- Subsidiary to the analysis of pragmas Global and Refined_Global. Verify
193 -- the syntax of global list List.
195 procedure Check_Item_Syntax
(Item
: Node_Id
);
196 -- Subsidiary to the analysis of pragmas Depends, Global, Initializes,
197 -- Part_Of, Refined_Depends, Refined_Depends and Refined_State. Verify the
198 -- syntax of a SPARK annotation item.
200 function Check_Kind
(Nam
: Name_Id
) return Name_Id
;
201 -- This function is used in connection with pragmas Assert, Check,
202 -- and assertion aspects and pragmas, to determine if Check pragmas
203 -- (or corresponding assertion aspects or pragmas) are currently active
204 -- as determined by the presence of -gnata on the command line (which
205 -- sets the default), and the appearance of pragmas Check_Policy and
206 -- Assertion_Policy as configuration pragmas either in a configuration
207 -- pragma file, or at the start of the current unit, or locally given
208 -- Check_Policy and Assertion_Policy pragmas that are currently active.
210 -- The value returned is one of the names Check, Ignore, Disable (On
211 -- returns Check, and Off returns Ignore).
213 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
214 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
215 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
216 -- _Post, _Invariant, or _Type_Invariant, which are special names used
217 -- in identifiers to represent these attribute references.
219 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
);
220 -- In ASIS mode we need to analyze the original expression in the aspect
221 -- specification. For Initializes, Global, and related SPARK aspects, the
222 -- expression has a sui-generis syntax which may be a list, an expression,
225 procedure Check_State_And_Constituent_Use
229 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
230 -- Global and Initializes. Determine whether a state from list States and a
231 -- corresponding constituent from list Constits (if any) appear in the same
232 -- context denoted by Context. If this is the case, emit an error.
234 procedure Collect_Global_Items
236 In_Items
: in out Elist_Id
;
237 In_Out_Items
: in out Elist_Id
;
238 Out_Items
: in out Elist_Id
;
239 Proof_In_Items
: in out Elist_Id
;
240 Has_In_State
: out Boolean;
241 Has_In_Out_State
: out Boolean;
242 Has_Out_State
: out Boolean;
243 Has_Proof_In_State
: out Boolean;
244 Has_Null_State
: out Boolean);
245 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
246 -- Prag denotes pragma [Refined_]Global. Gather all input, in out, output
247 -- and Proof_In items of Prag in lists In_Items, In_Out_Items, Out_Items
248 -- and Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
249 -- and Has_Proof_In_State are set when there is at least one abstract state
250 -- with visible refinement available in the corresponding mode. Flag
251 -- Has_Null_State is set when at least state has a null refinement.
253 procedure Collect_Subprogram_Inputs_Outputs
254 (Subp_Id
: Entity_Id
;
255 Subp_Inputs
: in out Elist_Id
;
256 Subp_Outputs
: in out Elist_Id
;
257 Global_Seen
: out Boolean);
258 -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends
259 -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id
260 -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram
261 -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen
262 -- is set when the related subprogram has pragma [Refined_]Global.
264 function Find_Related_Subprogram_Or_Body
266 Do_Checks
: Boolean := False) return Node_Id
;
267 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
268 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
269 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
270 -- Do_Checks is set, the routine reports duplicate pragmas and detects
271 -- improper use of refinement pragmas in stand alone expression functions.
272 -- The returned value depends on the related pragma as follows:
273 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
274 -- N_Subprogram_Declaration node or if the pragma applies to a stand
275 -- alone body, the N_Subprogram_Body node or Empty if illegal.
276 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
277 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
280 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
281 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
282 -- original one, following the renaming chain) is returned. Otherwise the
283 -- entity is returned unchanged. Should be in Einfo???
285 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
286 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
287 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
290 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
291 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
292 -- Determine whether dependency clause Clause is surrounded by extra
293 -- parentheses. If this is the case, issue an error message.
295 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
296 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
297 -- pragma Depends. Determine whether the type of dependency item Item is
298 -- tagged, unconstrained array, unconstrained record or a record with at
299 -- least one unconstrained component.
301 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
);
302 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
303 -- of a Test_Case pragma if present (possibly Empty). We treat these as
304 -- spec expressions (i.e. similar to a default expression).
306 procedure Record_Possible_Body_Reference
307 (State_Id
: Entity_Id
;
309 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
310 -- Global. Given an abstract state denoted by State_Id and a reference Ref
311 -- to it, determine whether the reference appears in a package body that
312 -- will eventually refine the state. If this is the case, record the
313 -- reference for future checks (see Analyze_Refined_State_In_Decls).
315 procedure Resolve_State
(N
: Node_Id
);
316 -- Handle the overloading of state names by functions. When N denotes a
317 -- function, this routine finds the corresponding state and sets the entity
318 -- of N to that of the state.
320 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
321 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
322 -- then it is rewritten as an identifier with the corresponding special
323 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
324 -- Check, Check_Policy.
326 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
327 -- Place semantic information on the argument of an Elaborate/Elaborate_All
328 -- pragma. Entity name for unit and its parents is taken from item in
329 -- previous with_clause that mentions the unit.
332 -- This is a dummy function called by the processing for pragma Reviewable.
333 -- It is there for assisting front end debugging. By placing a Reviewable
334 -- pragma in the source program, a breakpoint on rv catches this place in
335 -- the source, allowing convenient stepping to the point of interest.
341 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
344 To_List
:= New_Elmt_List
;
347 Append_Elmt
(Item
, To_List
);
350 -------------------------------
351 -- Adjust_External_Name_Case --
352 -------------------------------
354 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
358 -- Adjust case of literal if required
360 if Opt
.External_Name_Exp_Casing
= As_Is
then
364 -- Copy existing string
370 for J
in 1 .. String_Length
(Strval
(N
)) loop
371 CC
:= Get_String_Char
(Strval
(N
), J
);
373 if Opt
.External_Name_Exp_Casing
= Uppercase
374 and then CC
>= Get_Char_Code
('a')
375 and then CC
<= Get_Char_Code
('z')
377 Store_String_Char
(CC
- 32);
379 elsif Opt
.External_Name_Exp_Casing
= Lowercase
380 and then CC
>= Get_Char_Code
('A')
381 and then CC
<= Get_Char_Code
('Z')
383 Store_String_Char
(CC
+ 32);
386 Store_String_Char
(CC
);
391 Make_String_Literal
(Sloc
(N
),
392 Strval
=> End_String
);
394 end Adjust_External_Name_Case
;
396 -----------------------------------------
397 -- Analyze_Contract_Cases_In_Decl_Part --
398 -----------------------------------------
400 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
401 Others_Seen
: Boolean := False;
403 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
404 -- Verify the legality of a single contract case
406 ---------------------------
407 -- Analyze_Contract_Case --
408 ---------------------------
410 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
411 Case_Guard
: Node_Id
;
413 Extra_Guard
: Node_Id
;
416 if Nkind
(CCase
) = N_Component_Association
then
417 Case_Guard
:= First
(Choices
(CCase
));
418 Conseq
:= Expression
(CCase
);
420 -- Each contract case must have exactly one case guard
422 Extra_Guard
:= Next
(Case_Guard
);
424 if Present
(Extra_Guard
) then
426 ("contract case must have exactly one case guard",
430 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
432 if Nkind
(Case_Guard
) = N_Others_Choice
then
435 ("only one others choice allowed in contract cases",
441 elsif Others_Seen
then
443 ("others must be the last choice in contract cases", N
);
446 -- Preanalyze the case guard and consequence
448 if Nkind
(Case_Guard
) /= N_Others_Choice
then
449 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
452 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
454 -- The contract case is malformed
457 Error_Msg_N
("wrong syntax in contract case", CCase
);
459 end Analyze_Contract_Case
;
468 Restore_Scope
: Boolean := False;
469 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
471 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
476 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
477 Subp_Id
:= Defining_Entity
(Subp_Decl
);
478 All_Cases
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
480 -- Single and multiple contract cases must appear in aggregate form. If
481 -- this is not the case, then either the parser of the analysis of the
482 -- pragma failed to produce an aggregate.
484 pragma Assert
(Nkind
(All_Cases
) = N_Aggregate
);
486 if No
(Component_Associations
(All_Cases
)) then
487 Error_Msg_N
("wrong syntax for constract cases", N
);
489 -- Individual contract cases appear as component associations
492 -- Ensure that the formal parameters are visible when analyzing all
493 -- clauses. This falls out of the general rule of aspects pertaining
494 -- to subprogram declarations. Skip the installation for subprogram
495 -- bodies because the formals are already visible.
497 if not In_Open_Scopes
(Subp_Id
) then
498 Restore_Scope
:= True;
499 Push_Scope
(Subp_Id
);
500 Install_Formals
(Subp_Id
);
503 CCase
:= First
(Component_Associations
(All_Cases
));
504 while Present
(CCase
) loop
505 Analyze_Contract_Case
(CCase
);
509 if Restore_Scope
then
513 end Analyze_Contract_Cases_In_Decl_Part
;
515 ----------------------------------
516 -- Analyze_Depends_In_Decl_Part --
517 ----------------------------------
519 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
520 Loc
: constant Source_Ptr
:= Sloc
(N
);
522 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
523 -- A list containing the entities of all the inputs processed so far.
524 -- The list is populated with unique entities because the same input
525 -- may appear in multiple input lists.
527 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
528 -- A list containing the entities of all the outputs processed so far.
529 -- The list is populated with unique entities because output items are
530 -- unique in a dependence relation.
532 Constits_Seen
: Elist_Id
:= No_Elist
;
533 -- A list containing the entities of all constituents processed so far.
534 -- It aids in detecting illegal usage of a state and a corresponding
535 -- constituent in pragma [Refinde_]Depends.
537 Global_Seen
: Boolean := False;
538 -- A flag set when pragma Global has been processed
540 Null_Output_Seen
: Boolean := False;
541 -- A flag used to track the legality of a null output
543 Result_Seen
: Boolean := False;
544 -- A flag set when Subp_Id'Result is processed
547 -- The entity of the subprogram subject to pragma [Refined_]Depends
549 States_Seen
: Elist_Id
:= No_Elist
;
550 -- A list containing the entities of all states processed so far. It
551 -- helps in detecting illegal usage of a state and a corresponding
552 -- constituent in pragma [Refined_]Depends.
555 -- The entity of the subprogram [body or stub] subject to pragma
556 -- [Refined_]Depends.
558 Subp_Inputs
: Elist_Id
:= No_Elist
;
559 Subp_Outputs
: Elist_Id
:= No_Elist
;
560 -- Two lists containing the full set of inputs and output of the related
561 -- subprograms. Note that these lists contain both nodes and entities.
563 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
564 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
565 -- to the name buffer. The individual kinds are as follows:
566 -- E_Abstract_State - "state"
567 -- E_In_Parameter - "parameter"
568 -- E_In_Out_Parameter - "parameter"
569 -- E_Out_Parameter - "parameter"
570 -- E_Variable - "global"
572 procedure Analyze_Dependency_Clause
575 -- Verify the legality of a single dependency clause. Flag Is_Last
576 -- denotes whether Clause is the last clause in the relation.
578 procedure Check_Function_Return
;
579 -- Verify that Funtion'Result appears as one of the outputs
580 -- (SPARK RM 6.1.5(10)).
587 -- Ensure that an item fulfils its designated input and/or output role
588 -- as specified by pragma Global (if any) or the enclosing context. If
589 -- this is not the case, emit an error. Item and Item_Id denote the
590 -- attributes of an item. Flag Is_Input should be set when item comes
591 -- from an input list. Flag Self_Ref should be set when the item is an
592 -- output and the dependency clause has operator "+".
594 procedure Check_Usage
595 (Subp_Items
: Elist_Id
;
596 Used_Items
: Elist_Id
;
598 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
599 -- error if this is not the case.
601 procedure Normalize_Clause
(Clause
: Node_Id
);
602 -- Remove a self-dependency "+" from the input list of a clause. Split
603 -- a clause with multiple outputs into multiple clauses with a single
606 -----------------------------
607 -- Add_Item_To_Name_Buffer --
608 -----------------------------
610 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
612 if Ekind
(Item_Id
) = E_Abstract_State
then
613 Add_Str_To_Name_Buffer
("state");
615 elsif Is_Formal
(Item_Id
) then
616 Add_Str_To_Name_Buffer
("parameter");
618 elsif Ekind
(Item_Id
) = E_Variable
then
619 Add_Str_To_Name_Buffer
("global");
621 -- The routine should not be called with non-SPARK items
626 end Add_Item_To_Name_Buffer
;
628 -------------------------------
629 -- Analyze_Dependency_Clause --
630 -------------------------------
632 procedure Analyze_Dependency_Clause
636 procedure Analyze_Input_List
(Inputs
: Node_Id
);
637 -- Verify the legality of a single input list
639 procedure Analyze_Input_Output
644 Seen
: in out Elist_Id
;
645 Null_Seen
: in out Boolean;
646 Non_Null_Seen
: in out Boolean);
647 -- Verify the legality of a single input or output item. Flag
648 -- Is_Input should be set whenever Item is an input, False when it
649 -- denotes an output. Flag Self_Ref should be set when the item is an
650 -- output and the dependency clause has a "+". Flag Top_Level should
651 -- be set whenever Item appears immediately within an input or output
652 -- list. Seen is a collection of all abstract states, variables and
653 -- formals processed so far. Flag Null_Seen denotes whether a null
654 -- input or output has been encountered. Flag Non_Null_Seen denotes
655 -- whether a non-null input or output has been encountered.
657 ------------------------
658 -- Analyze_Input_List --
659 ------------------------
661 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
662 Inputs_Seen
: Elist_Id
:= No_Elist
;
663 -- A list containing the entities of all inputs that appear in the
664 -- current input list.
666 Non_Null_Input_Seen
: Boolean := False;
667 Null_Input_Seen
: Boolean := False;
668 -- Flags used to check the legality of an input list
673 -- Multiple inputs appear as an aggregate
675 if Nkind
(Inputs
) = N_Aggregate
then
676 if Present
(Component_Associations
(Inputs
)) then
678 ("nested dependency relations not allowed", Inputs
);
680 elsif Present
(Expressions
(Inputs
)) then
681 Input
:= First
(Expressions
(Inputs
));
682 while Present
(Input
) loop
689 Null_Seen
=> Null_Input_Seen
,
690 Non_Null_Seen
=> Non_Null_Input_Seen
);
696 Error_Msg_N
("malformed input dependency list", Inputs
);
699 -- Process a solitary input
708 Null_Seen
=> Null_Input_Seen
,
709 Non_Null_Seen
=> Non_Null_Input_Seen
);
712 -- Detect an illegal dependency clause of the form
716 if Null_Output_Seen
and then Null_Input_Seen
then
718 ("null dependency clause cannot have a null input list",
721 end Analyze_Input_List
;
723 --------------------------
724 -- Analyze_Input_Output --
725 --------------------------
727 procedure Analyze_Input_Output
732 Seen
: in out Elist_Id
;
733 Null_Seen
: in out Boolean;
734 Non_Null_Seen
: in out Boolean)
736 Is_Output
: constant Boolean := not Is_Input
;
741 -- Multiple input or output items appear as an aggregate
743 if Nkind
(Item
) = N_Aggregate
then
744 if not Top_Level
then
745 Error_Msg_N
("nested grouping of items not allowed", Item
);
747 elsif Present
(Component_Associations
(Item
)) then
749 ("nested dependency relations not allowed", Item
);
751 -- Recursively analyze the grouped items
753 elsif Present
(Expressions
(Item
)) then
754 Grouped
:= First
(Expressions
(Item
));
755 while Present
(Grouped
) loop
758 Is_Input
=> Is_Input
,
759 Self_Ref
=> Self_Ref
,
762 Null_Seen
=> Null_Seen
,
763 Non_Null_Seen
=> Non_Null_Seen
);
769 Error_Msg_N
("malformed dependency list", Item
);
772 -- Process Function'Result in the context of a dependency clause
774 elsif Is_Attribute_Result
(Item
) then
775 Non_Null_Seen
:= True;
777 -- It is sufficent to analyze the prefix of 'Result in order to
778 -- establish legality of the attribute.
780 Analyze
(Prefix
(Item
));
782 -- The prefix of 'Result must denote the function for which
783 -- pragma Depends applies (SPARK RM 6.1.5(11)).
785 if not Is_Entity_Name
(Prefix
(Item
))
786 or else Ekind
(Spec_Id
) /= E_Function
787 or else Entity
(Prefix
(Item
)) /= Spec_Id
789 Error_Msg_Name_1
:= Name_Result
;
791 ("prefix of attribute % must denote the enclosing "
794 -- Function'Result is allowed to appear on the output side of a
795 -- dependency clause (SPARK RM 6.1.5(6)).
798 Error_Msg_N
("function result cannot act as input", Item
);
802 ("cannot mix null and non-null dependency items", Item
);
808 -- Detect multiple uses of null in a single dependency list or
809 -- throughout the whole relation. Verify the placement of a null
810 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
812 elsif Nkind
(Item
) = N_Null
then
815 ("multiple null dependency relations not allowed", Item
);
817 elsif Non_Null_Seen
then
819 ("cannot mix null and non-null dependency items", Item
);
827 ("null output list must be the last clause in a "
828 & "dependency relation", Item
);
830 -- Catch a useless dependence of the form:
835 ("useless dependence, null depends on itself", Item
);
843 Non_Null_Seen
:= True;
846 Error_Msg_N
("cannot mix null and non-null items", Item
);
850 Resolve_State
(Item
);
852 -- Find the entity of the item. If this is a renaming, climb
853 -- the renaming chain to reach the root object. Renamings of
854 -- non-entire objects do not yield an entity (Empty).
856 Item_Id
:= Entity_Of
(Item
);
858 if Present
(Item_Id
) then
859 if Ekind_In
(Item_Id
, E_Abstract_State
,
865 -- Ensure that the item fulfils its role as input and/or
866 -- output as specified by pragma Global or the enclosing
869 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
871 -- Detect multiple uses of the same state, variable or
872 -- formal parameter. If this is not the case, add the
873 -- item to the list of processed relations.
875 if Contains
(Seen
, Item_Id
) then
877 ("duplicate use of item &", Item
, Item_Id
);
879 Add_Item
(Item_Id
, Seen
);
882 -- Detect illegal use of an input related to a null
883 -- output. Such input items cannot appear in other
884 -- input lists (SPARK RM 6.1.5(13)).
887 and then Null_Output_Seen
888 and then Contains
(All_Inputs_Seen
, Item_Id
)
891 ("input of a null output list cannot appear in "
892 & "multiple input lists", Item
);
895 -- Add an input or a self-referential output to the list
896 -- of all processed inputs.
898 if Is_Input
or else Self_Ref
then
899 Add_Item
(Item_Id
, All_Inputs_Seen
);
902 -- State related checks (SPARK RM 6.1.5(3))
904 if Ekind
(Item_Id
) = E_Abstract_State
then
905 if Has_Visible_Refinement
(Item_Id
) then
907 ("cannot mention state & in global refinement",
910 ("\use its constituents instead", Item
);
913 -- If the reference to the abstract state appears in
914 -- an enclosing package body that will eventually
915 -- refine the state, record the reference for future
919 Record_Possible_Body_Reference
920 (State_Id
=> Item_Id
,
925 -- When the item renames an entire object, replace the
926 -- item with a reference to the object.
928 if Present
(Renamed_Object
(Entity
(Item
))) then
930 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
934 -- Add the entity of the current item to the list of
937 if Ekind
(Item_Id
) = E_Abstract_State
then
938 Add_Item
(Item_Id
, States_Seen
);
941 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
942 and then Present
(Encapsulating_State
(Item_Id
))
944 Add_Item
(Item_Id
, Constits_Seen
);
947 -- All other input/output items are illegal
948 -- (SPARK RM 6.1.5(1)).
952 ("item must denote parameter, variable, or state",
956 -- All other input/output items are illegal
957 -- (SPARK RM 6.1.5(1))
961 ("item must denote parameter, variable, or state",
965 end Analyze_Input_Output
;
973 Non_Null_Output_Seen
: Boolean := False;
974 -- Flag used to check the legality of an output list
976 -- Start of processing for Analyze_Dependency_Clause
979 Inputs
:= Expression
(Clause
);
982 -- An input list with a self-dependency appears as operator "+" where
983 -- the actuals inputs are the right operand.
985 if Nkind
(Inputs
) = N_Op_Plus
then
986 Inputs
:= Right_Opnd
(Inputs
);
990 -- Process the output_list of a dependency_clause
992 Output
:= First
(Choices
(Clause
));
993 while Present
(Output
) loop
997 Self_Ref
=> Self_Ref
,
999 Seen
=> All_Outputs_Seen
,
1000 Null_Seen
=> Null_Output_Seen
,
1001 Non_Null_Seen
=> Non_Null_Output_Seen
);
1006 -- Process the input_list of a dependency_clause
1008 Analyze_Input_List
(Inputs
);
1009 end Analyze_Dependency_Clause
;
1011 ---------------------------
1012 -- Check_Function_Return --
1013 ---------------------------
1015 procedure Check_Function_Return
is
1017 if Ekind
(Spec_Id
) = E_Function
and then not Result_Seen
then
1019 ("result of & must appear in exactly one output list",
1022 end Check_Function_Return
;
1028 procedure Check_Role
1030 Item_Id
: Entity_Id
;
1035 (Item_Is_Input
: out Boolean;
1036 Item_Is_Output
: out Boolean);
1037 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1038 -- Item_Is_Output are set depending on the role.
1040 procedure Role_Error
1041 (Item_Is_Input
: Boolean;
1042 Item_Is_Output
: Boolean);
1043 -- Emit an error message concerning the incorrect use of Item in
1044 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1045 -- denote whether the item is an input and/or an output.
1052 (Item_Is_Input
: out Boolean;
1053 Item_Is_Output
: out Boolean)
1056 Item_Is_Input
:= False;
1057 Item_Is_Output
:= False;
1059 -- Abstract state cases
1061 if Ekind
(Item_Id
) = E_Abstract_State
then
1063 -- When pragma Global is present, the mode of the state may be
1064 -- further constrained by setting a more restrictive mode.
1067 if Appears_In
(Subp_Inputs
, Item_Id
) then
1068 Item_Is_Input
:= True;
1071 if Appears_In
(Subp_Outputs
, Item_Id
) then
1072 Item_Is_Output
:= True;
1075 -- Otherwise the state has a default IN OUT mode
1078 Item_Is_Input
:= True;
1079 Item_Is_Output
:= True;
1084 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1085 Item_Is_Input
:= True;
1087 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1088 Item_Is_Input
:= True;
1089 Item_Is_Output
:= True;
1091 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1092 if Scope
(Item_Id
) = Spec_Id
then
1094 -- An OUT parameter of the related subprogram has mode IN
1095 -- if its type is unconstrained or tagged because array
1096 -- bounds, discriminants or tags can be read.
1098 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1099 Item_Is_Input
:= True;
1102 Item_Is_Output
:= True;
1104 -- An OUT parameter of an enclosing subprogram behaves as a
1105 -- read-write variable in which case the mode is IN OUT.
1108 Item_Is_Input
:= True;
1109 Item_Is_Output
:= True;
1114 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1116 -- When pragma Global is present, the mode of the variable may
1117 -- be further constrained by setting a more restrictive mode.
1121 -- A variable has mode IN when its type is unconstrained or
1122 -- tagged because array bounds, discriminants or tags can be
1125 if Appears_In
(Subp_Inputs
, Item_Id
)
1126 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1128 Item_Is_Input
:= True;
1131 if Appears_In
(Subp_Outputs
, Item_Id
) then
1132 Item_Is_Output
:= True;
1135 -- Otherwise the variable has a default IN OUT mode
1138 Item_Is_Input
:= True;
1139 Item_Is_Output
:= True;
1148 procedure Role_Error
1149 (Item_Is_Input
: Boolean;
1150 Item_Is_Output
: Boolean)
1152 Error_Msg
: Name_Id
;
1157 -- When the item is not part of the input and the output set of
1158 -- the related subprogram, then it appears as extra in pragma
1159 -- [Refined_]Depends.
1161 if not Item_Is_Input
and then not Item_Is_Output
then
1162 Add_Item_To_Name_Buffer
(Item_Id
);
1163 Add_Str_To_Name_Buffer
1164 (" & cannot appear in dependence relation");
1166 Error_Msg
:= Name_Find
;
1167 Error_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1169 Error_Msg_Name_1
:= Chars
(Subp_Id
);
1171 ("\& is not part of the input or output set of subprogram %",
1174 -- The mode of the item and its role in pragma [Refined_]Depends
1175 -- are in conflict. Construct a detailed message explaining the
1176 -- illegality (SPARK RM 6.1.5(5-6)).
1179 if Item_Is_Input
then
1180 Add_Str_To_Name_Buffer
("read-only");
1182 Add_Str_To_Name_Buffer
("write-only");
1185 Add_Char_To_Name_Buffer
(' ');
1186 Add_Item_To_Name_Buffer
(Item_Id
);
1187 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1189 if Item_Is_Input
then
1190 Add_Str_To_Name_Buffer
("output");
1192 Add_Str_To_Name_Buffer
("input");
1195 Add_Str_To_Name_Buffer
(" in dependence relation");
1196 Error_Msg
:= Name_Find
;
1197 Error_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1203 Item_Is_Input
: Boolean;
1204 Item_Is_Output
: Boolean;
1206 -- Start of processing for Check_Role
1209 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1214 if not Item_Is_Input
then
1215 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1218 -- Self-referential item
1221 if not Item_Is_Input
or else not Item_Is_Output
then
1222 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1227 elsif not Item_Is_Output
then
1228 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1236 procedure Check_Usage
1237 (Subp_Items
: Elist_Id
;
1238 Used_Items
: Elist_Id
;
1241 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
1242 -- Emit an error concerning the erroneous usage of an item
1248 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
1249 Error_Msg
: Name_Id
;
1256 -- Unconstrained and tagged items are not part of the explicit
1257 -- input set of the related subprogram, they do not have to be
1258 -- present in a dependence relation and should not be flagged
1259 -- (SPARK RM 6.1.5(8)).
1261 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1264 Add_Item_To_Name_Buffer
(Item_Id
);
1265 Add_Str_To_Name_Buffer
1266 (" & must appear in at least one input dependence list");
1268 Error_Msg
:= Name_Find
;
1269 Error_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1272 -- Output case (SPARK RM 6.1.5(10))
1277 Add_Item_To_Name_Buffer
(Item_Id
);
1278 Add_Str_To_Name_Buffer
1279 (" & must appear in exactly one output dependence list");
1281 Error_Msg
:= Name_Find
;
1282 Error_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1290 Item_Id
: Entity_Id
;
1292 -- Start of processing for Check_Usage
1295 if No
(Subp_Items
) then
1299 -- Each input or output of the subprogram must appear in a dependency
1302 Elmt
:= First_Elmt
(Subp_Items
);
1303 while Present
(Elmt
) loop
1304 Item
:= Node
(Elmt
);
1306 if Nkind
(Item
) = N_Defining_Identifier
then
1309 Item_Id
:= Entity_Of
(Item
);
1312 -- The item does not appear in a dependency
1314 if Present
(Item_Id
)
1315 and then not Contains
(Used_Items
, Item_Id
)
1317 if Is_Formal
(Item_Id
) then
1318 Usage_Error
(Item
, Item_Id
);
1320 -- States and global variables are not used properly only when
1321 -- the subprogram is subject to pragma Global.
1323 elsif Global_Seen
then
1324 Usage_Error
(Item
, Item_Id
);
1332 ----------------------
1333 -- Normalize_Clause --
1334 ----------------------
1336 procedure Normalize_Clause
(Clause
: Node_Id
) is
1337 procedure Create_Or_Modify_Clause
1343 Multiple
: Boolean);
1344 -- Create a brand new clause to represent the self-reference or
1345 -- modify the input and/or output lists of an existing clause. Output
1346 -- denotes a self-referencial output. Outputs is the output list of a
1347 -- clause. Inputs is the input list of a clause. After denotes the
1348 -- clause after which the new clause is to be inserted. Flag In_Place
1349 -- should be set when normalizing the last output of an output list.
1350 -- Flag Multiple should be set when Output comes from a list with
1353 procedure Split_Multiple_Outputs
;
1354 -- If Clause contains more than one output, split the clause into
1355 -- multiple clauses with a single output. All new clauses are added
1358 -----------------------------
1359 -- Create_Or_Modify_Clause --
1360 -----------------------------
1362 procedure Create_Or_Modify_Clause
1370 procedure Propagate_Output
1373 -- Handle the various cases of output propagation to the input
1374 -- list. Output denotes a self-referencial output item. Inputs is
1375 -- the input list of a clause.
1377 ----------------------
1378 -- Propagate_Output --
1379 ----------------------
1381 procedure Propagate_Output
1385 function In_Input_List
1387 Inputs
: List_Id
) return Boolean;
1388 -- Determine whether a particulat item appears in the input
1389 -- list of a clause.
1395 function In_Input_List
1397 Inputs
: List_Id
) return Boolean
1402 Elmt
:= First
(Inputs
);
1403 while Present
(Elmt
) loop
1404 if Entity_Of
(Elmt
) = Item
then
1416 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1419 -- Start of processing for Propagate_Output
1422 -- The clause is of the form:
1424 -- (Output =>+ null)
1426 -- Remove the null input and replace it with a copy of the
1429 -- (Output => Output)
1431 if Nkind
(Inputs
) = N_Null
then
1432 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1434 -- The clause is of the form:
1436 -- (Output =>+ (Input1, ..., InputN))
1438 -- Determine whether the output is not already mentioned in the
1439 -- input list and if not, add it to the list of inputs:
1441 -- (Output => (Output, Input1, ..., InputN))
1443 elsif Nkind
(Inputs
) = N_Aggregate
then
1444 Grouped
:= Expressions
(Inputs
);
1446 if not In_Input_List
1450 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1453 -- The clause is of the form:
1455 -- (Output =>+ Input)
1457 -- If the input does not mention the output, group the two
1460 -- (Output => (Output, Input))
1462 elsif Entity_Of
(Inputs
) /= Output_Id
then
1464 Make_Aggregate
(Loc
,
1465 Expressions
=> New_List
(
1466 New_Copy_Tree
(Output
),
1467 New_Copy_Tree
(Inputs
))));
1469 end Propagate_Output
;
1473 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1474 New_Clause
: Node_Id
;
1476 -- Start of processing for Create_Or_Modify_Clause
1479 -- A null output depending on itself does not require any
1482 if Nkind
(Output
) = N_Null
then
1485 -- A function result cannot depend on itself because it cannot
1486 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1488 elsif Is_Attribute_Result
(Output
) then
1489 Error_Msg_N
("function result cannot depend on itself", Output
);
1493 -- When performing the transformation in place, simply add the
1494 -- output to the list of inputs (if not already there). This case
1495 -- arises when dealing with the last output of an output list -
1496 -- we perform the normalization in place to avoid generating a
1500 Propagate_Output
(Output
, Inputs
);
1502 -- A list with multiple outputs is slowly trimmed until only
1503 -- one element remains. When this happens, replace the
1504 -- aggregate with the element itself.
1508 Rewrite
(Outputs
, Output
);
1514 -- Unchain the output from its output list as it will appear in
1515 -- a new clause. Note that we cannot simply rewrite the output
1516 -- as null because this will violate the semantics of pragma
1521 -- Generate a new clause of the form:
1522 -- (Output => Inputs)
1525 Make_Component_Association
(Loc
,
1526 Choices
=> New_List
(Output
),
1527 Expression
=> New_Copy_Tree
(Inputs
));
1529 -- The new clause contains replicated content that has already
1530 -- been analyzed. There is not need to reanalyze it or
1531 -- renormalize it again.
1533 Set_Analyzed
(New_Clause
);
1536 (Output
=> First
(Choices
(New_Clause
)),
1537 Inputs
=> Expression
(New_Clause
));
1539 Insert_After
(After
, New_Clause
);
1541 end Create_Or_Modify_Clause
;
1543 ----------------------------
1544 -- Split_Multiple_Outputs --
1545 ----------------------------
1547 procedure Split_Multiple_Outputs
is
1548 Inputs
: constant Node_Id
:= Expression
(Clause
);
1549 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1550 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1551 Last_Output
: Node_Id
;
1552 Next_Output
: Node_Id
;
1556 -- Start of processing for Split_Multiple_Outputs
1559 -- Multiple outputs appear as an aggregate. Nothing to do when
1560 -- the clause has exactly one output.
1562 if Nkind
(Outputs
) = N_Aggregate
then
1563 Last_Output
:= Last
(Expressions
(Outputs
));
1565 -- Create a clause for each output. Note that each time a new
1566 -- clause is created, the original output list slowly shrinks
1567 -- until there is one item left.
1569 Output
:= First
(Expressions
(Outputs
));
1570 while Present
(Output
) loop
1571 Next_Output
:= Next
(Output
);
1573 -- Unhook the output from the original output list as it
1574 -- will be relocated to a new clause.
1578 -- Special processing for the last output. At this point
1579 -- the original aggregate has been stripped down to one
1580 -- element. Replace the aggregate by the element itself.
1582 if Output
= Last_Output
then
1583 Rewrite
(Outputs
, Output
);
1586 -- Generate a clause of the form:
1587 -- (Output => Inputs)
1590 Make_Component_Association
(Loc
,
1591 Choices
=> New_List
(Output
),
1592 Expression
=> New_Copy_Tree
(Inputs
));
1594 -- The new clause contains replicated content that has
1595 -- already been analyzed. There is not need to reanalyze
1598 Set_Analyzed
(Split
);
1599 Insert_After
(Clause
, Split
);
1602 Output
:= Next_Output
;
1605 end Split_Multiple_Outputs
;
1609 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1611 Last_Output
: Node_Id
;
1612 Next_Output
: Node_Id
;
1615 -- Start of processing for Normalize_Clause
1618 -- A self-dependency appears as operator "+". Remove the "+" from the
1619 -- tree by moving the real inputs to their proper place.
1621 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1622 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1623 Inputs
:= Expression
(Clause
);
1625 -- Multiple outputs appear as an aggregate
1627 if Nkind
(Outputs
) = N_Aggregate
then
1628 Last_Output
:= Last
(Expressions
(Outputs
));
1630 Output
:= First
(Expressions
(Outputs
));
1631 while Present
(Output
) loop
1633 -- Normalization may remove an output from its list,
1634 -- preserve the subsequent output now.
1636 Next_Output
:= Next
(Output
);
1638 Create_Or_Modify_Clause
1643 In_Place
=> Output
= Last_Output
,
1646 Output
:= Next_Output
;
1652 Create_Or_Modify_Clause
1662 -- Split a clause with multiple outputs into multiple clauses with a
1665 Split_Multiple_Outputs
;
1666 end Normalize_Clause
;
1670 Deps
: constant Node_Id
:=
1672 (First
(Pragma_Argument_Associations
(N
)));
1675 Last_Clause
: Node_Id
;
1676 Subp_Decl
: Node_Id
;
1678 Restore_Scope
: Boolean := False;
1679 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1681 -- Start of processing for Analyze_Depends_In_Decl_Part
1686 -- Verify the syntax of pragma Depends when SPARK checks are suppressed.
1687 -- Semantic analysis and normalization are disabled in this mode.
1689 if SPARK_Mode
= Off
then
1690 Check_Dependence_List_Syntax
(Deps
);
1694 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
1695 Subp_Id
:= Defining_Entity
(Subp_Decl
);
1697 -- The logic in this routine is used to analyze both pragma Depends and
1698 -- pragma Refined_Depends since they have the same syntax and base
1699 -- semantics. Find the entity of the corresponding spec when analyzing
1702 if Nkind
(Subp_Decl
) = N_Subprogram_Body
1703 and then not Acts_As_Spec
(Subp_Decl
)
1705 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
1707 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
then
1708 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
1714 -- Empty dependency list
1716 if Nkind
(Deps
) = N_Null
then
1718 -- Gather all states, variables and formal parameters that the
1719 -- subprogram may depend on. These items are obtained from the
1720 -- parameter profile or pragma [Refined_]Global (if available).
1722 Collect_Subprogram_Inputs_Outputs
1723 (Subp_Id
=> Subp_Id
,
1724 Subp_Inputs
=> Subp_Inputs
,
1725 Subp_Outputs
=> Subp_Outputs
,
1726 Global_Seen
=> Global_Seen
);
1728 -- Verify that every input or output of the subprogram appear in a
1731 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1732 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1733 Check_Function_Return
;
1735 -- Dependency clauses appear as component associations of an aggregate
1737 elsif Nkind
(Deps
) = N_Aggregate
then
1739 -- Do not attempt to perform analysis of a syntactically illegal
1740 -- clause as this will lead to misleading errors.
1742 if Has_Extra_Parentheses
(Deps
) then
1746 if Present
(Component_Associations
(Deps
)) then
1747 Last_Clause
:= Last
(Component_Associations
(Deps
));
1749 -- Gather all states, variables and formal parameters that the
1750 -- subprogram may depend on. These items are obtained from the
1751 -- parameter profile or pragma [Refined_]Global (if available).
1753 Collect_Subprogram_Inputs_Outputs
1754 (Subp_Id
=> Subp_Id
,
1755 Subp_Inputs
=> Subp_Inputs
,
1756 Subp_Outputs
=> Subp_Outputs
,
1757 Global_Seen
=> Global_Seen
);
1759 -- Ensure that the formal parameters are visible when analyzing
1760 -- all clauses. This falls out of the general rule of aspects
1761 -- pertaining to subprogram declarations. Skip the installation
1762 -- for subprogram bodies because the formals are already visible.
1764 if not In_Open_Scopes
(Spec_Id
) then
1765 Restore_Scope
:= True;
1766 Push_Scope
(Spec_Id
);
1767 Install_Formals
(Spec_Id
);
1770 Clause
:= First
(Component_Associations
(Deps
));
1771 while Present
(Clause
) loop
1772 Errors
:= Serious_Errors_Detected
;
1774 -- Normalization may create extra clauses that contain
1775 -- replicated input and output names. There is no need to
1778 if not Analyzed
(Clause
) then
1779 Set_Analyzed
(Clause
);
1781 Analyze_Dependency_Clause
1783 Is_Last
=> Clause
= Last_Clause
);
1786 -- Do not normalize an erroneous clause because the inputs
1787 -- and/or outputs may denote illegal items. Normalization is
1788 -- disabled in ASIS mode as it alters the tree by introducing
1789 -- new nodes similar to expansion.
1791 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1792 Normalize_Clause
(Clause
);
1798 if Restore_Scope
then
1802 -- Verify that every input or output of the subprogram appear in a
1805 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1806 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1807 Check_Function_Return
;
1809 -- The dependency list is malformed
1812 Error_Msg_N
("malformed dependency relation", Deps
);
1816 -- The top level dependency relation is malformed
1819 Error_Msg_N
("malformed dependency relation", Deps
);
1823 -- Ensure that a state and a corresponding constituent do not appear
1824 -- together in pragma [Refined_]Depends.
1826 Check_State_And_Constituent_Use
1827 (States
=> States_Seen
,
1828 Constits
=> Constits_Seen
,
1830 end Analyze_Depends_In_Decl_Part
;
1832 --------------------------------------------
1833 -- Analyze_External_Property_In_Decl_Part --
1834 --------------------------------------------
1836 procedure Analyze_External_Property_In_Decl_Part
1838 Expr_Val
: out Boolean)
1840 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1841 Obj
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
1842 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Next
(Arg1
));
1845 Error_Msg_Name_1
:= Pragma_Name
(N
);
1847 -- The Async / Effective pragmas must apply to a volatile object other
1848 -- than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1850 if Is_SPARK_Volatile_Object
(Obj
) then
1851 if Is_Entity_Name
(Obj
)
1852 and then Present
(Entity
(Obj
))
1853 and then Is_Formal
(Entity
(Obj
))
1855 Error_Msg_N
("external property % cannot apply to parameter", N
);
1859 ("external property % must apply to a volatile object", N
);
1862 -- Ensure that the expression (if present) is static Boolean. A missing
1863 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1867 if Present
(Expr
) then
1868 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
1870 if Is_Static_Expression
(Expr
) then
1871 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1873 Error_Msg_Name_1
:= Pragma_Name
(N
);
1874 Error_Msg_N
("expression of % must be static", Expr
);
1877 end Analyze_External_Property_In_Decl_Part
;
1879 ---------------------------------
1880 -- Analyze_Global_In_Decl_Part --
1881 ---------------------------------
1883 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1884 Constits_Seen
: Elist_Id
:= No_Elist
;
1885 -- A list containing the entities of all constituents processed so far.
1886 -- It aids in detecting illegal usage of a state and a corresponding
1887 -- constituent in pragma [Refinde_]Global.
1889 Seen
: Elist_Id
:= No_Elist
;
1890 -- A list containing the entities of all the items processed so far. It
1891 -- plays a role in detecting distinct entities.
1893 Spec_Id
: Entity_Id
;
1894 -- The entity of the subprogram subject to pragma [Refined_]Global
1896 States_Seen
: Elist_Id
:= No_Elist
;
1897 -- A list containing the entities of all states processed so far. It
1898 -- helps in detecting illegal usage of a state and a corresponding
1899 -- constituent in pragma [Refined_]Global.
1901 Subp_Id
: Entity_Id
;
1902 -- The entity of the subprogram [body or stub] subject to pragma
1903 -- [Refined_]Global.
1905 In_Out_Seen
: Boolean := False;
1906 Input_Seen
: Boolean := False;
1907 Output_Seen
: Boolean := False;
1908 Proof_Seen
: Boolean := False;
1909 -- Flags used to verify the consistency of modes
1911 procedure Analyze_Global_List
1913 Global_Mode
: Name_Id
:= Name_Input
);
1914 -- Verify the legality of a single global list declaration. Global_Mode
1915 -- denotes the current mode in effect.
1917 -------------------------
1918 -- Analyze_Global_List --
1919 -------------------------
1921 procedure Analyze_Global_List
1923 Global_Mode
: Name_Id
:= Name_Input
)
1925 procedure Analyze_Global_Item
1927 Global_Mode
: Name_Id
);
1928 -- Verify the legality of a single global item declaration.
1929 -- Global_Mode denotes the current mode in effect.
1931 procedure Check_Duplicate_Mode
1933 Status
: in out Boolean);
1934 -- Flag Status denotes whether a particular mode has been seen while
1935 -- processing a global list. This routine verifies that Mode is not a
1936 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1938 procedure Check_Mode_Restriction_In_Enclosing_Context
1940 Item_Id
: Entity_Id
);
1941 -- Verify that an item of mode In_Out or Output does not appear as an
1942 -- input in the Global aspect of an enclosing subprogram. If this is
1943 -- the case, emit an error. Item and Item_Id are respectively the
1944 -- item and its entity.
1946 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1947 -- Mode denotes either In_Out or Output. Depending on the kind of the
1948 -- related subprogram, emit an error if those two modes apply to a
1949 -- function (SPARK RM 6.1.4(10)).
1951 -------------------------
1952 -- Analyze_Global_Item --
1953 -------------------------
1955 procedure Analyze_Global_Item
1957 Global_Mode
: Name_Id
)
1959 Item_Id
: Entity_Id
;
1962 -- Detect one of the following cases
1964 -- with Global => (null, Name)
1965 -- with Global => (Name_1, null, Name_2)
1966 -- with Global => (Name, null)
1968 if Nkind
(Item
) = N_Null
then
1969 Error_Msg_N
("cannot mix null and non-null global items", Item
);
1974 Resolve_State
(Item
);
1976 -- Find the entity of the item. If this is a renaming, climb the
1977 -- renaming chain to reach the root object. Renamings of non-
1978 -- entire objects do not yield an entity (Empty).
1980 Item_Id
:= Entity_Of
(Item
);
1982 if Present
(Item_Id
) then
1984 -- A global item may denote a formal parameter of an enclosing
1985 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1986 -- provide a better error diagnostic.
1988 if Is_Formal
(Item_Id
) then
1989 if Scope
(Item_Id
) = Spec_Id
then
1991 ("global item cannot reference parameter of subprogram",
1996 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1997 -- Do this check first to provide a better error diagnostic.
1999 elsif Ekind
(Item_Id
) = E_Constant
then
2000 Error_Msg_N
("global item cannot denote a constant", Item
);
2002 -- The only legal references are those to abstract states and
2003 -- variables (SPARK RM 6.1.4(4)).
2005 elsif not Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
2007 ("global item must denote variable or state", Item
);
2011 -- State related checks
2013 if Ekind
(Item_Id
) = E_Abstract_State
then
2015 -- An abstract state with visible refinement cannot appear
2016 -- in pragma [Refined_]Global as its place must be taken by
2017 -- some of its constituents (SPARK RM 6.1.4(8)).
2019 if Has_Visible_Refinement
(Item_Id
) then
2021 ("cannot mention state & in global refinement",
2023 Error_Msg_N
("\use its constituents instead", Item
);
2026 -- If the reference to the abstract state appears in an
2027 -- enclosing package body that will eventually refine the
2028 -- state, record the reference for future checks.
2031 Record_Possible_Body_Reference
2032 (State_Id
=> Item_Id
,
2036 -- Variable related checks. These are only relevant when
2037 -- SPARK_Mode is on as they are not standard Ada legality
2040 elsif SPARK_Mode
= On
2041 and then Is_SPARK_Volatile_Object
(Item_Id
)
2043 -- A volatile object cannot appear as a global item of a
2044 -- function (SPARK RM 7.1.3(9)).
2046 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2048 ("volatile object & cannot act as global item of a "
2049 & "function", Item
, Item_Id
);
2052 -- A volatile object with property Effective_Reads set to
2053 -- True must have mode Output or In_Out.
2055 elsif Effective_Reads_Enabled
(Item_Id
)
2056 and then Global_Mode
= Name_Input
2059 ("volatile object & with property Effective_Reads must "
2060 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
2066 -- When the item renames an entire object, replace the item
2067 -- with a reference to the object.
2069 if Present
(Renamed_Object
(Entity
(Item
))) then
2070 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2074 -- Some form of illegal construct masquerading as a name
2075 -- (SPARK RM 6.1.4(4)).
2078 Error_Msg_N
("global item must denote variable or state", Item
);
2082 -- Verify that an output does not appear as an input in an
2083 -- enclosing subprogram.
2085 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2086 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2089 -- The same entity might be referenced through various way.
2090 -- Check the entity of the item rather than the item itself
2091 -- (SPARK RM 6.1.4(11)).
2093 if Contains
(Seen
, Item_Id
) then
2094 Error_Msg_N
("duplicate global item", Item
);
2096 -- Add the entity of the current item to the list of processed
2100 Add_Item
(Item_Id
, Seen
);
2102 if Ekind
(Item_Id
) = E_Abstract_State
then
2103 Add_Item
(Item_Id
, States_Seen
);
2106 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
2107 and then Present
(Encapsulating_State
(Item_Id
))
2109 Add_Item
(Item_Id
, Constits_Seen
);
2112 end Analyze_Global_Item
;
2114 --------------------------
2115 -- Check_Duplicate_Mode --
2116 --------------------------
2118 procedure Check_Duplicate_Mode
2120 Status
: in out Boolean)
2124 Error_Msg_N
("duplicate global mode", Mode
);
2128 end Check_Duplicate_Mode
;
2130 -------------------------------------------------
2131 -- Check_Mode_Restriction_In_Enclosing_Context --
2132 -------------------------------------------------
2134 procedure Check_Mode_Restriction_In_Enclosing_Context
2136 Item_Id
: Entity_Id
)
2138 Context
: Entity_Id
;
2140 Inputs
: Elist_Id
:= No_Elist
;
2141 Outputs
: Elist_Id
:= No_Elist
;
2144 -- Traverse the scope stack looking for enclosing subprograms
2145 -- subject to pragma [Refined_]Global.
2147 Context
:= Scope
(Subp_Id
);
2148 while Present
(Context
) and then Context
/= Standard_Standard
loop
2149 if Is_Subprogram
(Context
)
2151 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2153 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2155 Collect_Subprogram_Inputs_Outputs
2156 (Subp_Id
=> Context
,
2157 Subp_Inputs
=> Inputs
,
2158 Subp_Outputs
=> Outputs
,
2159 Global_Seen
=> Dummy
);
2161 -- The item is classified as In_Out or Output but appears as
2162 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2164 if Appears_In
(Inputs
, Item_Id
)
2165 and then not Appears_In
(Outputs
, Item_Id
)
2168 ("global item & cannot have mode In_Out or Output",
2171 ("\item already appears as input of subprogram &",
2174 -- Stop the traversal once an error has been detected
2180 Context
:= Scope
(Context
);
2182 end Check_Mode_Restriction_In_Enclosing_Context
;
2184 ----------------------------------------
2185 -- Check_Mode_Restriction_In_Function --
2186 ----------------------------------------
2188 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2190 if Ekind
(Spec_Id
) = E_Function
then
2192 ("global mode & is not applicable to functions", Mode
);
2194 end Check_Mode_Restriction_In_Function
;
2202 -- Start of processing for Analyze_Global_List
2205 if Nkind
(List
) = N_Null
then
2206 Set_Analyzed
(List
);
2208 -- Single global item declaration
2210 elsif Nkind_In
(List
, N_Expanded_Name
,
2212 N_Selected_Component
)
2214 Analyze_Global_Item
(List
, Global_Mode
);
2216 -- Simple global list or moded global list declaration
2218 elsif Nkind
(List
) = N_Aggregate
then
2219 Set_Analyzed
(List
);
2221 -- The declaration of a simple global list appear as a collection
2224 if Present
(Expressions
(List
)) then
2225 if Present
(Component_Associations
(List
)) then
2227 ("cannot mix moded and non-moded global lists", List
);
2230 Item
:= First
(Expressions
(List
));
2231 while Present
(Item
) loop
2232 Analyze_Global_Item
(Item
, Global_Mode
);
2237 -- The declaration of a moded global list appears as a collection
2238 -- of component associations where individual choices denote
2241 elsif Present
(Component_Associations
(List
)) then
2242 if Present
(Expressions
(List
)) then
2244 ("cannot mix moded and non-moded global lists", List
);
2247 Assoc
:= First
(Component_Associations
(List
));
2248 while Present
(Assoc
) loop
2249 Mode
:= First
(Choices
(Assoc
));
2251 if Nkind
(Mode
) = N_Identifier
then
2252 if Chars
(Mode
) = Name_In_Out
then
2253 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2254 Check_Mode_Restriction_In_Function
(Mode
);
2256 elsif Chars
(Mode
) = Name_Input
then
2257 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2259 elsif Chars
(Mode
) = Name_Output
then
2260 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2261 Check_Mode_Restriction_In_Function
(Mode
);
2263 elsif Chars
(Mode
) = Name_Proof_In
then
2264 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2267 Error_Msg_N
("invalid mode selector", Mode
);
2271 Error_Msg_N
("invalid mode selector", Mode
);
2274 -- Items in a moded list appear as a collection of
2275 -- expressions. Reuse the existing machinery to analyze
2279 (List
=> Expression
(Assoc
),
2280 Global_Mode
=> Chars
(Mode
));
2288 raise Program_Error
;
2291 -- Any other attempt to declare a global item is erroneous
2294 Error_Msg_N
("malformed global list", List
);
2296 end Analyze_Global_List
;
2300 Items
: constant Node_Id
:=
2301 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2302 Subp_Decl
: Node_Id
;
2304 Restore_Scope
: Boolean := False;
2305 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2307 -- Start of processing for Analyze_Global_In_Decl_List
2311 Check_SPARK_Aspect_For_ASIS
(N
);
2313 -- Verify the syntax of pragma Global when SPARK checks are suppressed.
2314 -- Semantic analysis is disabled in this mode.
2316 if SPARK_Mode
= Off
then
2317 Check_Global_List_Syntax
(Items
);
2321 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
2322 Subp_Id
:= Defining_Entity
(Subp_Decl
);
2324 -- The logic in this routine is used to analyze both pragma Global and
2325 -- pragma Refined_Global since they have the same syntax and base
2326 -- semantics. Find the entity of the corresponding spec when analyzing
2329 if Nkind
(Subp_Decl
) = N_Subprogram_Body
2330 and then not Acts_As_Spec
(Subp_Decl
)
2332 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
2334 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
then
2335 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
2341 -- There is nothing to be done for a null global list
2343 if Nkind
(Items
) = N_Null
then
2344 Set_Analyzed
(Items
);
2346 -- Analyze the various forms of global lists and items. Note that some
2347 -- of these may be malformed in which case the analysis emits error
2351 -- Ensure that the formal parameters are visible when processing an
2352 -- item. This falls out of the general rule of aspects pertaining to
2353 -- subprogram declarations.
2355 if not In_Open_Scopes
(Spec_Id
) then
2356 Restore_Scope
:= True;
2357 Push_Scope
(Spec_Id
);
2358 Install_Formals
(Spec_Id
);
2361 Analyze_Global_List
(Items
);
2363 if Restore_Scope
then
2368 -- Ensure that a state and a corresponding constituent do not appear
2369 -- together in pragma [Refined_]Global.
2371 Check_State_And_Constituent_Use
2372 (States
=> States_Seen
,
2373 Constits
=> Constits_Seen
,
2375 end Analyze_Global_In_Decl_Part
;
2377 --------------------------------------------
2378 -- Analyze_Initial_Condition_In_Decl_Part --
2379 --------------------------------------------
2381 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2382 Expr
: constant Node_Id
:=
2383 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2388 -- The expression is preanalyzed because it has not been moved to its
2389 -- final place yet. A direct analysis may generate side effects and this
2390 -- is not desired at this point.
2392 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
2393 end Analyze_Initial_Condition_In_Decl_Part
;
2395 --------------------------------------
2396 -- Analyze_Initializes_In_Decl_Part --
2397 --------------------------------------
2399 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2400 Pack_Spec
: constant Node_Id
:= Parent
(N
);
2401 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Parent
(Pack_Spec
));
2403 Constits_Seen
: Elist_Id
:= No_Elist
;
2404 -- A list containing the entities of all constituents processed so far.
2405 -- It aids in detecting illegal usage of a state and a corresponding
2406 -- constituent in pragma Initializes.
2408 Items_Seen
: Elist_Id
:= No_Elist
;
2409 -- A list of all initialization items processed so far. This list is
2410 -- used to detect duplicate items.
2412 Non_Null_Seen
: Boolean := False;
2413 Null_Seen
: Boolean := False;
2414 -- Flags used to check the legality of a null initialization list
2416 States_And_Vars
: Elist_Id
:= No_Elist
;
2417 -- A list of all abstract states and variables declared in the visible
2418 -- declarations of the related package. This list is used to detect the
2419 -- legality of initialization items.
2421 States_Seen
: Elist_Id
:= No_Elist
;
2422 -- A list containing the entities of all states processed so far. It
2423 -- helps in detecting illegal usage of a state and a corresponding
2424 -- constituent in pragma Initializes.
2426 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2427 -- Verify the legality of a single initialization item
2429 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2430 -- Verify the legality of a single initialization item followed by a
2431 -- list of input items.
2433 procedure Check_Initialization_List_Syntax
(List
: Node_Id
);
2434 -- Verify the syntax of initialization list List
2436 procedure Collect_States_And_Variables
;
2437 -- Inspect the visible declarations of the related package and gather
2438 -- the entities of all abstract states and variables in States_And_Vars.
2440 ---------------------------------
2441 -- Analyze_Initialization_Item --
2442 ---------------------------------
2444 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2445 Item_Id
: Entity_Id
;
2448 -- Null initialization list
2450 if Nkind
(Item
) = N_Null
then
2452 Error_Msg_N
("multiple null initializations not allowed", Item
);
2454 elsif Non_Null_Seen
then
2456 ("cannot mix null and non-null initialization items", Item
);
2461 -- Initialization item
2464 Non_Null_Seen
:= True;
2468 ("cannot mix null and non-null initialization items", Item
);
2472 Resolve_State
(Item
);
2474 if Is_Entity_Name
(Item
) then
2475 Item_Id
:= Entity_Of
(Item
);
2477 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
2479 -- The state or variable must be declared in the visible
2480 -- declarations of the package (SPARK RM 7.1.5(7)).
2482 if not Contains
(States_And_Vars
, Item_Id
) then
2483 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2485 ("initialization item & must appear in the visible "
2486 & "declarations of package %", Item
, Item_Id
);
2488 -- Detect a duplicate use of the same initialization item
2489 -- (SPARK RM 7.1.5(5)).
2491 elsif Contains
(Items_Seen
, Item_Id
) then
2492 Error_Msg_N
("duplicate initialization item", Item
);
2494 -- The item is legal, add it to the list of processed states
2498 Add_Item
(Item_Id
, Items_Seen
);
2500 if Ekind
(Item_Id
) = E_Abstract_State
then
2501 Add_Item
(Item_Id
, States_Seen
);
2504 if Present
(Encapsulating_State
(Item_Id
)) then
2505 Add_Item
(Item_Id
, Constits_Seen
);
2509 -- The item references something that is not a state or a
2510 -- variable (SPARK RM 7.1.5(3)).
2514 ("initialization item must denote variable or state",
2518 -- Some form of illegal construct masquerading as a name
2519 -- (SPARK RM 7.1.5(3)).
2523 ("initialization item must denote variable or state", Item
);
2526 end Analyze_Initialization_Item
;
2528 ---------------------------------------------
2529 -- Analyze_Initialization_Item_With_Inputs --
2530 ---------------------------------------------
2532 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2533 Inputs_Seen
: Elist_Id
:= No_Elist
;
2534 -- A list of all inputs processed so far. This list is used to detect
2535 -- duplicate uses of an input.
2537 Non_Null_Seen
: Boolean := False;
2538 Null_Seen
: Boolean := False;
2539 -- Flags used to check the legality of an input list
2541 procedure Analyze_Input_Item
(Input
: Node_Id
);
2542 -- Verify the legality of a single input item
2544 ------------------------
2545 -- Analyze_Input_Item --
2546 ------------------------
2548 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2549 Input_Id
: Entity_Id
;
2554 if Nkind
(Input
) = N_Null
then
2557 ("multiple null initializations not allowed", Item
);
2559 elsif Non_Null_Seen
then
2561 ("cannot mix null and non-null initialization item", Item
);
2569 Non_Null_Seen
:= True;
2573 ("cannot mix null and non-null initialization item", Item
);
2577 Resolve_State
(Input
);
2579 if Is_Entity_Name
(Input
) then
2580 Input_Id
:= Entity_Of
(Input
);
2582 if Ekind_In
(Input_Id
, E_Abstract_State
, E_Variable
) then
2584 -- The input cannot denote states or variables declared
2585 -- within the related package.
2587 if Within_Scope
(Input_Id
, Current_Scope
) then
2588 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2590 ("input item & cannot denote a visible variable or "
2591 & "state of package % (SPARK RM 7.1.5(4))",
2594 -- Detect a duplicate use of the same input item
2595 -- (SPARK RM 7.1.5(5)).
2597 elsif Contains
(Inputs_Seen
, Input_Id
) then
2598 Error_Msg_N
("duplicate input item", Input
);
2600 -- Input is legal, add it to the list of processed inputs
2603 Add_Item
(Input_Id
, Inputs_Seen
);
2605 if Ekind
(Input_Id
) = E_Abstract_State
then
2606 Add_Item
(Input_Id
, States_Seen
);
2609 if Present
(Encapsulating_State
(Input_Id
)) then
2610 Add_Item
(Input_Id
, Constits_Seen
);
2614 -- The input references something that is not a state or a
2619 ("input item must denote variable or state", Input
);
2622 -- Some form of illegal construct masquerading as a name
2626 ("input item must denote variable or state", Input
);
2629 end Analyze_Input_Item
;
2633 Inputs
: constant Node_Id
:= Expression
(Item
);
2637 Name_Seen
: Boolean := False;
2638 -- A flag used to detect multiple item names
2640 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2643 -- Inspect the name of an item with inputs
2645 Elmt
:= First
(Choices
(Item
));
2646 while Present
(Elmt
) loop
2648 Error_Msg_N
("only one item allowed in initialization", Elmt
);
2651 Analyze_Initialization_Item
(Elmt
);
2657 -- Multiple input items appear as an aggregate
2659 if Nkind
(Inputs
) = N_Aggregate
then
2660 if Present
(Expressions
(Inputs
)) then
2661 Input
:= First
(Expressions
(Inputs
));
2662 while Present
(Input
) loop
2663 Analyze_Input_Item
(Input
);
2668 if Present
(Component_Associations
(Inputs
)) then
2670 ("inputs must appear in named association form", Inputs
);
2673 -- Single input item
2676 Analyze_Input_Item
(Inputs
);
2678 end Analyze_Initialization_Item_With_Inputs
;
2680 --------------------------------------
2681 -- Check_Initialization_List_Syntax --
2682 --------------------------------------
2684 procedure Check_Initialization_List_Syntax
(List
: Node_Id
) is
2689 -- Null initialization list
2691 if Nkind
(List
) = N_Null
then
2694 elsif Nkind
(List
) = N_Aggregate
then
2696 -- Simple initialization items
2698 if Present
(Expressions
(List
)) then
2699 Init
:= First
(Expressions
(List
));
2700 while Present
(Init
) loop
2701 Check_Item_Syntax
(Init
);
2706 -- Initialization items with a input lists
2708 if Present
(Component_Associations
(List
)) then
2709 Init
:= First
(Component_Associations
(List
));
2710 while Present
(Init
) loop
2711 Check_Item_Syntax
(First
(Choices
(Init
)));
2713 if Nkind
(Expression
(Init
)) = N_Aggregate
2714 and then Present
(Expressions
(Expression
(Init
)))
2716 Input
:= First
(Expressions
(Expression
(Init
)));
2717 while Present
(Input
) loop
2718 Check_Item_Syntax
(Input
);
2723 Error_Msg_N
("malformed initialization item", Init
);
2731 Error_Msg_N
("malformed initialization list", List
);
2733 end Check_Initialization_List_Syntax
;
2735 ----------------------------------
2736 -- Collect_States_And_Variables --
2737 ----------------------------------
2739 procedure Collect_States_And_Variables
is
2743 -- Collect the abstract states defined in the package (if any)
2745 if Present
(Abstract_States
(Pack_Id
)) then
2746 States_And_Vars
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2749 -- Collect all variables the appear in the visible declarations of
2750 -- the related package.
2752 if Present
(Visible_Declarations
(Pack_Spec
)) then
2753 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2754 while Present
(Decl
) loop
2755 if Nkind
(Decl
) = N_Object_Declaration
2756 and then Ekind
(Defining_Entity
(Decl
)) = E_Variable
2757 and then Comes_From_Source
(Decl
)
2759 Add_Item
(Defining_Entity
(Decl
), States_And_Vars
);
2765 end Collect_States_And_Variables
;
2769 Inits
: constant Node_Id
:=
2770 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2773 -- Start of processing for Analyze_Initializes_In_Decl_Part
2778 Check_SPARK_Aspect_For_ASIS
(N
);
2780 -- Nothing to do when the initialization list is empty
2782 if Nkind
(Inits
) = N_Null
then
2785 -- Verify the syntax of pragma Initializes when SPARK checks are
2786 -- suppressed. Semantic analysis is disabled in this mode.
2788 elsif SPARK_Mode
= Off
then
2789 Check_Initialization_List_Syntax
(Inits
);
2793 -- Single and multiple initialization clauses appear as an aggregate. If
2794 -- this is not the case, then either the parser or the analysis of the
2795 -- pragma failed to produce an aggregate.
2797 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2799 -- Initialize the various lists used during analysis
2801 Collect_States_And_Variables
;
2803 if Present
(Expressions
(Inits
)) then
2804 Init
:= First
(Expressions
(Inits
));
2805 while Present
(Init
) loop
2806 Analyze_Initialization_Item
(Init
);
2811 if Present
(Component_Associations
(Inits
)) then
2812 Init
:= First
(Component_Associations
(Inits
));
2813 while Present
(Init
) loop
2814 Analyze_Initialization_Item_With_Inputs
(Init
);
2819 -- Ensure that a state and a corresponding constituent do not appear
2820 -- together in pragma Initializes.
2822 Check_State_And_Constituent_Use
2823 (States
=> States_Seen
,
2824 Constits
=> Constits_Seen
,
2826 end Analyze_Initializes_In_Decl_Part
;
2828 --------------------
2829 -- Analyze_Pragma --
2830 --------------------
2832 --------------------
2833 -- Analyze_Pragma --
2834 --------------------
2836 procedure Analyze_Pragma
(N
: Node_Id
) is
2837 Loc
: constant Source_Ptr
:= Sloc
(N
);
2838 Prag_Id
: Pragma_Id
;
2841 -- Name of the source pragma, or name of the corresponding aspect for
2842 -- pragmas which originate in a source aspect. In the latter case, the
2843 -- name may be different from the pragma name.
2845 Pragma_Exit
: exception;
2846 -- This exception is used to exit pragma processing completely. It
2847 -- is used when an error is detected, and no further processing is
2848 -- required. It is also used if an earlier error has left the tree in
2849 -- a state where the pragma should not be processed.
2852 -- Number of pragma argument associations
2858 -- First four pragma arguments (pragma argument association nodes, or
2859 -- Empty if the corresponding argument does not exist).
2861 type Name_List
is array (Natural range <>) of Name_Id
;
2862 type Args_List
is array (Natural range <>) of Node_Id
;
2863 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2865 procedure Ada_2005_Pragma
;
2866 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2867 -- Ada 95 mode, these are implementation defined pragmas, so should be
2868 -- caught by the No_Implementation_Pragmas restriction.
2870 procedure Ada_2012_Pragma
;
2871 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2872 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2873 -- should be caught by the No_Implementation_Pragmas restriction.
2875 procedure Analyze_Part_Of
2876 (Item_Id
: Entity_Id
;
2879 Legal
: out Boolean);
2880 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2881 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2882 -- an abstract state, variable or package instantiation. State is the
2883 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2884 -- set when the indicator is legal.
2886 procedure Analyze_Refined_Pragma
2887 (Spec_Id
: out Entity_Id
;
2888 Body_Id
: out Entity_Id
;
2889 Legal
: out Boolean);
2890 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2891 -- Refined_Global and Refined_Post. Check the placement and related
2892 -- context of the pragma. Spec_Id is the entity of the related
2893 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2894 -- Legal is set when the pragma is properly placed.
2896 procedure Check_Ada_83_Warning
;
2897 -- Issues a warning message for the current pragma if operating in Ada
2898 -- 83 mode (used for language pragmas that are not a standard part of
2899 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2902 procedure Check_Arg_Count
(Required
: Nat
);
2903 -- Check argument count for pragma is equal to given parameter. If not,
2904 -- then issue an error message and raise Pragma_Exit.
2906 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2907 -- Arg which can either be a pragma argument association, in which case
2908 -- the check is applied to the expression of the association or an
2909 -- expression directly.
2911 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
2912 -- Check that an argument has the right form for an EXTERNAL_NAME
2913 -- parameter of an extended import/export pragma. The rule is that the
2914 -- name must be an identifier or string literal (in Ada 83 mode) or a
2915 -- static string expression (in Ada 95 mode).
2917 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
2918 -- Check the specified argument Arg to make sure that it is an
2919 -- identifier. If not give error and raise Pragma_Exit.
2921 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
2922 -- Check the specified argument Arg to make sure that it is an integer
2923 -- literal. If not give error and raise Pragma_Exit.
2925 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
2926 -- Check the specified argument Arg to make sure that it has the proper
2927 -- syntactic form for a local name and meets the semantic requirements
2928 -- for a local name. The local name is analyzed as part of the
2929 -- processing for this call. In addition, the local name is required
2930 -- to represent an entity at the library level.
2932 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
2933 -- Check the specified argument Arg to make sure that it has the proper
2934 -- syntactic form for a local name and meets the semantic requirements
2935 -- for a local name. The local name is analyzed as part of the
2936 -- processing for this call.
2938 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
2939 -- Check the specified argument Arg to make sure that it is a valid
2940 -- locking policy name. If not give error and raise Pragma_Exit.
2942 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
2943 -- Check the specified argument Arg to make sure that it is a valid
2944 -- elaboration policy name. If not give error and raise Pragma_Exit.
2946 procedure Check_Arg_Is_One_Of
2949 procedure Check_Arg_Is_One_Of
2951 N1
, N2
, N3
: Name_Id
);
2952 procedure Check_Arg_Is_One_Of
2954 N1
, N2
, N3
, N4
: Name_Id
);
2955 procedure Check_Arg_Is_One_Of
2957 N1
, N2
, N3
, N4
, N5
: Name_Id
);
2958 -- Check the specified argument Arg to make sure that it is an
2959 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2960 -- present). If not then give error and raise Pragma_Exit.
2962 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
2963 -- Check the specified argument Arg to make sure that it is a valid
2964 -- queuing policy name. If not give error and raise Pragma_Exit.
2966 procedure Check_Arg_Is_Static_Expression
2968 Typ
: Entity_Id
:= Empty
);
2969 -- Check the specified argument Arg to make sure that it is a static
2970 -- expression of the given type (i.e. it will be analyzed and resolved
2971 -- using this type, which can be any valid argument to Resolve, e.g.
2972 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2973 -- Typ is left Empty, then any static expression is allowed.
2975 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
2976 -- Check the specified argument Arg to make sure that it is a valid task
2977 -- dispatching policy name. If not give error and raise Pragma_Exit.
2979 procedure Check_Arg_Order
(Names
: Name_List
);
2980 -- Checks for an instance of two arguments with identifiers for the
2981 -- current pragma which are not in the sequence indicated by Names,
2982 -- and if so, generates a fatal message about bad order of arguments.
2984 procedure Check_At_Least_N_Arguments
(N
: Nat
);
2985 -- Check there are at least N arguments present
2987 procedure Check_At_Most_N_Arguments
(N
: Nat
);
2988 -- Check there are no more than N arguments present
2990 procedure Check_Component
2993 In_Variant_Part
: Boolean := False);
2994 -- Examine an Unchecked_Union component for correct use of per-object
2995 -- constrained subtypes, and for restrictions on finalizable components.
2996 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2997 -- should be set when Comp comes from a record variant.
2999 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
);
3000 -- Subsidiary routine to the analysis of pragmas Abstract_State,
3001 -- Initial_Condition and Initializes. Determine whether pragma First
3002 -- appears before pragma Second. If this is not the case, emit an error.
3004 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3005 -- Check if a rep item of the same name as the current pragma is already
3006 -- chained as a rep pragma to the given entity. If so give a message
3007 -- about the duplicate, and then raise Pragma_Exit so does not return.
3008 -- Note that if E is a type, then this routine avoids flagging a pragma
3009 -- which applies to a parent type from which E is derived.
3011 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3012 -- Nam is an N_String_Literal node containing the external name set by
3013 -- an Import or Export pragma (or extended Import or Export pragma).
3014 -- This procedure checks for possible duplications if this is the export
3015 -- case, and if found, issues an appropriate error message.
3017 procedure Check_Expr_Is_Static_Expression
3019 Typ
: Entity_Id
:= Empty
);
3020 -- Check the specified expression Expr to make sure that it is a static
3021 -- expression of the given type (i.e. it will be analyzed and resolved
3022 -- using this type, which can be any valid argument to Resolve, e.g.
3023 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3024 -- Typ is left Empty, then any static expression is allowed.
3026 procedure Check_First_Subtype
(Arg
: Node_Id
);
3027 -- Checks that Arg, whose expression is an entity name, references a
3030 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3031 -- Checks that the given argument has an identifier, and if so, requires
3032 -- it to match the given identifier name. If there is no identifier, or
3033 -- a non-matching identifier, then an error message is given and
3034 -- Pragma_Exit is raised.
3036 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3037 -- Checks that the given argument has an identifier, and if so, requires
3038 -- it to match one of the given identifier names. If there is no
3039 -- identifier, or a non-matching identifier, then an error message is
3040 -- given and Pragma_Exit is raised.
3042 procedure Check_In_Main_Program
;
3043 -- Common checks for pragmas that appear within a main program
3044 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3046 procedure Check_Interrupt_Or_Attach_Handler
;
3047 -- Common processing for first argument of pragma Interrupt_Handler or
3048 -- pragma Attach_Handler.
3050 procedure Check_Loop_Pragma_Placement
;
3051 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3052 -- appear immediately within a construct restricted to loops, and that
3053 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3055 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3056 -- Check that pragma appears in a declarative part, or in a package
3057 -- specification, i.e. that it does not occur in a statement sequence
3060 procedure Check_No_Identifier
(Arg
: Node_Id
);
3061 -- Checks that the given argument does not have an identifier. If
3062 -- an identifier is present, then an error message is issued, and
3063 -- Pragma_Exit is raised.
3065 procedure Check_No_Identifiers
;
3066 -- Checks that none of the arguments to the pragma has an identifier.
3067 -- If any argument has an identifier, then an error message is issued,
3068 -- and Pragma_Exit is raised.
3070 procedure Check_No_Link_Name
;
3071 -- Checks that no link name is specified
3073 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3074 -- Checks if the given argument has an identifier, and if so, requires
3075 -- it to match the given identifier name. If there is a non-matching
3076 -- identifier, then an error message is given and Pragma_Exit is raised.
3078 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3079 -- Checks if the given argument has an identifier, and if so, requires
3080 -- it to match the given identifier name. If there is a non-matching
3081 -- identifier, then an error message is given and Pragma_Exit is raised.
3082 -- In this version of the procedure, the identifier name is given as
3083 -- a string with lower case letters.
3085 procedure Check_Pre_Post
;
3086 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
3087 -- pragmas. These are processed by transformation to equivalent
3088 -- Precondition and Postcondition pragmas, but Pre and Post need an
3089 -- additional check that they are not used in a subprogram body when
3090 -- there is a separate spec present.
3092 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
3093 -- Called to process a precondition or postcondition pragma. There are
3096 -- The pragma appears after a subprogram spec
3098 -- If the corresponding check is not enabled, the pragma is analyzed
3099 -- but otherwise ignored and control returns with In_Body set False.
3101 -- If the check is enabled, then the first step is to analyze the
3102 -- pragma, but this is skipped if the subprogram spec appears within
3103 -- a package specification (because this is the case where we delay
3104 -- analysis till the end of the spec). Then (whether or not it was
3105 -- analyzed), the pragma is chained to the subprogram in question
3106 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
3107 -- to the caller with In_Body set False.
3109 -- The pragma appears at the start of subprogram body declarations
3111 -- In this case an immediate return to the caller is made with
3112 -- In_Body set True, and the pragma is NOT analyzed.
3114 -- In all other cases, an error message for bad placement is given
3116 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3117 -- Constr is a constraint from an N_Subtype_Indication node from a
3118 -- component constraint in an Unchecked_Union type. This routine checks
3119 -- that the constraint is static as required by the restrictions for
3122 procedure Check_Test_Case
;
3123 -- Called to process a test-case pragma. It starts with checking pragma
3124 -- arguments, and the rest of the treatment is similar to the one for
3125 -- pre- and postcondition in Check_Precondition_Postcondition, except
3126 -- the placement rules for the test-case pragma are stricter. These
3127 -- pragmas may only occur after a subprogram spec declared directly
3128 -- in a package spec unit. In this case, the pragma is chained to the
3129 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
3130 -- and analysis of the pragma is delayed till the end of the spec. In
3131 -- all other cases, an error message for bad placement is given.
3133 procedure Check_Valid_Configuration_Pragma
;
3134 -- Legality checks for placement of a configuration pragma
3136 procedure Check_Valid_Library_Unit_Pragma
;
3137 -- Legality checks for library unit pragmas. A special case arises for
3138 -- pragmas in generic instances that come from copies of the original
3139 -- library unit pragmas in the generic templates. In the case of other
3140 -- than library level instantiations these can appear in contexts which
3141 -- would normally be invalid (they only apply to the original template
3142 -- and to library level instantiations), and they are simply ignored,
3143 -- which is implemented by rewriting them as null statements.
3145 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3146 -- Check an Unchecked_Union variant for lack of nested variants and
3147 -- presence of at least one component. UU_Typ is the related Unchecked_
3150 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3151 -- Subsidiary routine to the processing of pragmas Abstract_State,
3152 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3153 -- Refined_Global and Refined_State. Transform argument Arg into an
3154 -- aggregate if not one already. N_Null is never transformed.
3156 procedure Error_Pragma
(Msg
: String);
3157 pragma No_Return
(Error_Pragma
);
3158 -- Outputs error message for current pragma. The message contains a %
3159 -- that will be replaced with the pragma name, and the flag is placed
3160 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3161 -- calls Fix_Error (see spec of that procedure for details).
3163 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3164 pragma No_Return
(Error_Pragma_Arg
);
3165 -- Outputs error message for current pragma. The message may contain
3166 -- a % that will be replaced with the pragma name. The parameter Arg
3167 -- may either be a pragma argument association, in which case the flag
3168 -- is placed on the expression of this association, or an expression,
3169 -- in which case the flag is placed directly on the expression. The
3170 -- message is placed using Error_Msg_N, so the message may also contain
3171 -- an & insertion character which will reference the given Arg value.
3172 -- After placing the message, Pragma_Exit is raised. Note: this routine
3173 -- calls Fix_Error (see spec of that procedure for details).
3175 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3176 pragma No_Return
(Error_Pragma_Arg
);
3177 -- Similar to above form of Error_Pragma_Arg except that two messages
3178 -- are provided, the second is a continuation comment starting with \.
3180 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3181 pragma No_Return
(Error_Pragma_Arg_Ident
);
3182 -- Outputs error message for current pragma. The message may contain a %
3183 -- that will be replaced with the pragma name. The parameter Arg must be
3184 -- a pragma argument association with a non-empty identifier (i.e. its
3185 -- Chars field must be set), and the error message is placed on the
3186 -- identifier. The message is placed using Error_Msg_N so the message
3187 -- may also contain an & insertion character which will reference
3188 -- the identifier. After placing the message, Pragma_Exit is raised.
3189 -- Note: this routine calls Fix_Error (see spec of that procedure for
3192 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3193 pragma No_Return
(Error_Pragma_Ref
);
3194 -- Outputs error message for current pragma. The message may contain
3195 -- a % that will be replaced with the pragma name. The parameter Ref
3196 -- must be an entity whose name can be referenced by & and sloc by #.
3197 -- After placing the message, Pragma_Exit is raised. Note: this routine
3198 -- calls Fix_Error (see spec of that procedure for details).
3200 function Find_Lib_Unit_Name
return Entity_Id
;
3201 -- Used for a library unit pragma to find the entity to which the
3202 -- library unit pragma applies, returns the entity found.
3204 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3205 -- If the pragma is a compilation unit pragma, the id must denote the
3206 -- compilation unit in the same compilation, and the pragma must appear
3207 -- in the list of preceding or trailing pragmas. If it is a program
3208 -- unit pragma that is not a compilation unit pragma, then the
3209 -- identifier must be visible.
3211 function Find_Unique_Parameterless_Procedure
3213 Arg
: Node_Id
) return Entity_Id
;
3214 -- Used for a procedure pragma to find the unique parameterless
3215 -- procedure identified by Name, returns it if it exists, otherwise
3216 -- errors out and uses Arg as the pragma argument for the message.
3218 procedure Fix_Error
(Msg
: in out String);
3219 -- This is called prior to issuing an error message. Msg is a string
3220 -- that typically contains the substring "pragma". If the pragma comes
3221 -- from an aspect, each such "pragma" substring is replaced with the
3222 -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
3223 -- aspect (which may be different from the pragma name). If the current
3224 -- pragma results from rewriting another pragma, then Error_Msg_Name_1
3225 -- is set to the original pragma name.
3227 procedure Gather_Associations
3229 Args
: out Args_List
);
3230 -- This procedure is used to gather the arguments for a pragma that
3231 -- permits arbitrary ordering of parameters using the normal rules
3232 -- for named and positional parameters. The Names argument is a list
3233 -- of Name_Id values that corresponds to the allowed pragma argument
3234 -- association identifiers in order. The result returned in Args is
3235 -- a list of corresponding expressions that are the pragma arguments.
3236 -- Note that this is a list of expressions, not of pragma argument
3237 -- associations (Gather_Associations has completely checked all the
3238 -- optional identifiers when it returns). An entry in Args is Empty
3239 -- on return if the corresponding argument is not present.
3241 procedure GNAT_Pragma
;
3242 -- Called for all GNAT defined pragmas to check the relevant restriction
3243 -- (No_Implementation_Pragmas).
3245 function Is_Before_First_Decl
3246 (Pragma_Node
: Node_Id
;
3247 Decls
: List_Id
) return Boolean;
3248 -- Return True if Pragma_Node is before the first declarative item in
3249 -- Decls where Decls is the list of declarative items.
3251 function Is_Configuration_Pragma
return Boolean;
3252 -- Determines if the placement of the current pragma is appropriate
3253 -- for a configuration pragma.
3255 function Is_In_Context_Clause
return Boolean;
3256 -- Returns True if pragma appears within the context clause of a unit,
3257 -- and False for any other placement (does not generate any messages).
3259 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3260 -- Analyzes the argument, and determines if it is a static string
3261 -- expression, returns True if so, False if non-static or not String.
3263 procedure Pragma_Misplaced
;
3264 pragma No_Return
(Pragma_Misplaced
);
3265 -- Issue fatal error message for misplaced pragma
3267 procedure Process_Atomic_Shared_Volatile
;
3268 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3269 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3270 -- in effect to pragma Atomic.
3272 procedure Process_Compile_Time_Warning_Or_Error
;
3273 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3275 procedure Process_Convention
3276 (C
: out Convention_Id
;
3277 Ent
: out Entity_Id
);
3278 -- Common processing for Convention, Interface, Import and Export.
3279 -- Checks first two arguments of pragma, and sets the appropriate
3280 -- convention value in the specified entity or entities. On return
3281 -- C is the convention, Ent is the referenced entity.
3283 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3284 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3285 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3287 procedure Process_Extended_Import_Export_Exception_Pragma
3288 (Arg_Internal
: Node_Id
;
3289 Arg_External
: Node_Id
;
3291 Arg_Code
: Node_Id
);
3292 -- Common processing for the pragmas Import/Export_Exception. The three
3293 -- arguments correspond to the three named parameters of the pragma. An
3294 -- argument is empty if the corresponding parameter is not present in
3297 procedure Process_Extended_Import_Export_Object_Pragma
3298 (Arg_Internal
: Node_Id
;
3299 Arg_External
: Node_Id
;
3300 Arg_Size
: Node_Id
);
3301 -- Common processing for the pragmas Import/Export_Object. The three
3302 -- arguments correspond to the three named parameters of the pragmas. An
3303 -- argument is empty if the corresponding parameter is not present in
3306 procedure Process_Extended_Import_Export_Internal_Arg
3307 (Arg_Internal
: Node_Id
:= Empty
);
3308 -- Common processing for all extended Import and Export pragmas. The
3309 -- argument is the pragma parameter for the Internal argument. If
3310 -- Arg_Internal is empty or inappropriate, an error message is posted.
3311 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3312 -- set to identify the referenced entity.
3314 procedure Process_Extended_Import_Export_Subprogram_Pragma
3315 (Arg_Internal
: Node_Id
;
3316 Arg_External
: Node_Id
;
3317 Arg_Parameter_Types
: Node_Id
;
3318 Arg_Result_Type
: Node_Id
:= Empty
;
3319 Arg_Mechanism
: Node_Id
;
3320 Arg_Result_Mechanism
: Node_Id
:= Empty
;
3321 Arg_First_Optional_Parameter
: Node_Id
:= Empty
);
3322 -- Common processing for all extended Import and Export pragmas applying
3323 -- to subprograms. The caller omits any arguments that do not apply to
3324 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3325 -- only in the Import_Function and Export_Function cases). The argument
3326 -- names correspond to the allowed pragma association identifiers.
3328 procedure Process_Generic_List
;
3329 -- Common processing for Share_Generic and Inline_Generic
3331 procedure Process_Import_Or_Interface
;
3332 -- Common processing for Import of Interface
3334 procedure Process_Import_Predefined_Type
;
3335 -- Processing for completing a type with pragma Import. This is used
3336 -- to declare types that match predefined C types, especially for cases
3337 -- without corresponding Ada predefined type.
3339 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3340 -- Inline status of a subprogram, indicated as follows:
3341 -- Suppressed: inlining is suppressed for the subprogram
3342 -- Disabled: no inlining is requested for the subprogram
3343 -- Enabled: inlining is requested/required for the subprogram
3345 procedure Process_Inline
(Status
: Inline_Status
);
3346 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3347 -- indicates the inline status specified by the pragma.
3349 procedure Process_Interface_Name
3350 (Subprogram_Def
: Entity_Id
;
3352 Link_Arg
: Node_Id
);
3353 -- Given the last two arguments of pragma Import, pragma Export, or
3354 -- pragma Interface_Name, performs validity checks and sets the
3355 -- Interface_Name field of the given subprogram entity to the
3356 -- appropriate external or link name, depending on the arguments given.
3357 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3358 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3359 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3360 -- nor Link_Arg is present, the interface name is set to the default
3361 -- from the subprogram name.
3363 procedure Process_Interrupt_Or_Attach_Handler
;
3364 -- Common processing for Interrupt and Attach_Handler pragmas
3366 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3367 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3368 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3369 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3370 -- is not set in the Restrictions case.
3372 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3373 -- Common processing for Suppress and Unsuppress. The boolean parameter
3374 -- Suppress_Case is True for the Suppress case, and False for the
3377 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3378 -- This procedure sets the Is_Exported flag for the given entity,
3379 -- checking that the entity was not previously imported. Arg is
3380 -- the argument that specified the entity. A check is also made
3381 -- for exporting inappropriate entities.
3383 procedure Set_Extended_Import_Export_External_Name
3384 (Internal_Ent
: Entity_Id
;
3385 Arg_External
: Node_Id
);
3386 -- Common processing for all extended import export pragmas. The first
3387 -- argument, Internal_Ent, is the internal entity, which has already
3388 -- been checked for validity by the caller. Arg_External is from the
3389 -- Import or Export pragma, and may be null if no External parameter
3390 -- was present. If Arg_External is present and is a non-null string
3391 -- (a null string is treated as the default), then the Interface_Name
3392 -- field of Internal_Ent is set appropriately.
3394 procedure Set_Imported
(E
: Entity_Id
);
3395 -- This procedure sets the Is_Imported flag for the given entity,
3396 -- checking that it is not previously exported or imported.
3398 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3399 -- Mech is a parameter passing mechanism (see Import_Function syntax
3400 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3401 -- has the right form, and if not issues an error message. If the
3402 -- argument has the right form then the Mechanism field of Ent is
3403 -- set appropriately.
3405 procedure Set_Rational_Profile
;
3406 -- Activate the set of configuration pragmas and permissions that make
3407 -- up the Rational profile.
3409 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3410 -- Activate the set of configuration pragmas and restrictions that make
3411 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3412 -- is used for error messages on any constructs that violate the
3415 ---------------------
3416 -- Ada_2005_Pragma --
3417 ---------------------
3419 procedure Ada_2005_Pragma
is
3421 if Ada_Version
<= Ada_95
then
3422 Check_Restriction
(No_Implementation_Pragmas
, N
);
3424 end Ada_2005_Pragma
;
3426 ---------------------
3427 -- Ada_2012_Pragma --
3428 ---------------------
3430 procedure Ada_2012_Pragma
is
3432 if Ada_Version
<= Ada_2005
then
3433 Check_Restriction
(No_Implementation_Pragmas
, N
);
3435 end Ada_2012_Pragma
;
3437 ---------------------
3438 -- Analyze_Part_Of --
3439 ---------------------
3441 procedure Analyze_Part_Of
3442 (Item_Id
: Entity_Id
;
3445 Legal
: out Boolean)
3447 Pack_Id
: Entity_Id
;
3448 Placement
: State_Space_Kind
;
3449 State_Id
: Entity_Id
;
3452 -- Assume that the pragma/option is illegal
3456 -- Verify the syntax of the encapsulating state when SPARK check are
3457 -- suppressed. Semantic analysis is disabled in this mode.
3459 if SPARK_Mode
= Off
then
3460 Check_Item_Syntax
(State
);
3465 Resolve_State
(State
);
3467 if Is_Entity_Name
(State
)
3468 and then Ekind
(Entity
(State
)) = E_Abstract_State
3470 State_Id
:= Entity
(State
);
3474 ("indicator Part_Of must denote an abstract state", State
);
3478 -- Determine where the state, variable or the package instantiation
3479 -- lives with respect to the enclosing packages or package bodies (if
3480 -- any). This placement dictates the legality of the encapsulating
3483 Find_Placement_In_State_Space
3484 (Item_Id
=> Item_Id
,
3485 Placement
=> Placement
,
3486 Pack_Id
=> Pack_Id
);
3488 -- The item appears in a non-package construct with a declarative
3489 -- part (subprogram, block, etc). As such, the item is not allowed
3490 -- to be a part of an encapsulating state because the item is not
3493 if Placement
= Not_In_Package
then
3495 ("indicator Part_Of cannot appear in this context "
3496 & "(SPARK RM 7.2.6(5))", Indic
);
3497 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3499 ("\& is not part of the hidden state of package %",
3502 -- The item appears in the visible state space of some package. In
3503 -- general this scenario does not warrant Part_Of except when the
3504 -- package is a private child unit and the encapsulating state is
3505 -- declared in a parent unit or a public descendant of that parent
3508 elsif Placement
= Visible_State_Space
then
3509 if Is_Child_Unit
(Pack_Id
)
3510 and then Is_Private_Descendant
(Pack_Id
)
3512 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3514 ("indicator Part_Of must denote an abstract state of "
3515 & "parent unit or descendant (SPARK RM 7.2.6(3))", Indic
);
3517 -- If the unit is a public child of a private unit it cannot
3518 -- refine the state of a private parent, only that of a
3519 -- public ancestor or descendant thereof.
3521 elsif not Private_Present
3522 (Parent
(Unit_Declaration_Node
(Pack_Id
)))
3523 and then Is_Private_Descendant
(Scope
(State_Id
))
3526 ("indicator Part_Of must denote the abstract state of "
3527 & "a public ancestor", State
);
3530 -- Indicator Part_Of is not needed when the related package is not
3531 -- a private child unit or a public descendant thereof.
3535 ("indicator Part_Of cannot appear in this context (SPARK "
3536 & "RM 7.2.6(5))", Indic
);
3537 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3539 ("\& is declared in the visible part of package %",
3543 -- When the item appears in the private state space of a package, the
3544 -- encapsulating state must be declared in the same package.
3546 elsif Placement
= Private_State_Space
then
3547 if Scope
(State_Id
) /= Pack_Id
then
3549 ("indicator Part_Of must designate an abstract state of "
3550 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3551 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3553 ("\& is declared in the private part of package %",
3557 -- Items declared in the body state space of a package do not need
3558 -- Part_Of indicators as the refinement has already been seen.
3562 ("indicator Part_Of cannot appear in this context "
3563 & "(SPARK RM 7.2.6(5))", Indic
);
3565 if Scope
(State_Id
) = Pack_Id
then
3566 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3568 ("\& is declared in the body of package %", Indic
, Item_Id
);
3573 end Analyze_Part_Of
;
3575 ----------------------------
3576 -- Analyze_Refined_Pragma --
3577 ----------------------------
3579 procedure Analyze_Refined_Pragma
3580 (Spec_Id
: out Entity_Id
;
3581 Body_Id
: out Entity_Id
;
3582 Legal
: out Boolean)
3584 Body_Decl
: Node_Id
;
3585 Spec_Decl
: Node_Id
;
3588 -- Assume that the pragma is illegal
3595 Check_Arg_Count
(1);
3596 Check_No_Identifiers
;
3598 if Nam_In
(Pname
, Name_Refined_Depends
,
3599 Name_Refined_Global
,
3602 Ensure_Aggregate_Form
(Arg1
);
3605 -- Verify the placement of the pragma and check for duplicates. The
3606 -- pragma must apply to a subprogram body [stub].
3608 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3610 -- Extract the entities of the spec and body
3612 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3613 Body_Id
:= Defining_Entity
(Body_Decl
);
3614 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3616 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3617 Body_Id
:= Defining_Entity
(Body_Decl
);
3618 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3625 -- The pragma must apply to the second declaration of a subprogram.
3626 -- In other words, the body [stub] cannot acts as a spec.
3628 if No
(Spec_Id
) then
3629 Error_Pragma
("pragma % cannot apply to a stand alone body");
3632 -- Catch the case where the subprogram body is a subunit and acts as
3633 -- the third declaration of the subprogram.
3635 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3636 Error_Pragma
("pragma % cannot apply to a subunit");
3640 -- The pragma can only apply to the body [stub] of a subprogram
3641 -- declared in the visible part of a package. Retrieve the context of
3642 -- the subprogram declaration.
3644 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3646 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3648 ("pragma % must apply to the body of a subprogram declared in a "
3649 & "package specification");
3653 -- If we get here, then the pragma is legal
3656 end Analyze_Refined_Pragma
;
3658 --------------------------
3659 -- Check_Ada_83_Warning --
3660 --------------------------
3662 procedure Check_Ada_83_Warning
is
3664 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3665 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3667 end Check_Ada_83_Warning
;
3669 ---------------------
3670 -- Check_Arg_Count --
3671 ---------------------
3673 procedure Check_Arg_Count
(Required
: Nat
) is
3675 if Arg_Count
/= Required
then
3676 Error_Pragma
("wrong number of arguments for pragma%");
3678 end Check_Arg_Count
;
3680 --------------------------------
3681 -- Check_Arg_Is_External_Name --
3682 --------------------------------
3684 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3685 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3688 if Nkind
(Argx
) = N_Identifier
then
3692 Analyze_And_Resolve
(Argx
, Standard_String
);
3694 if Is_OK_Static_Expression
(Argx
) then
3697 elsif Etype
(Argx
) = Any_Type
then
3700 -- An interesting special case, if we have a string literal and
3701 -- we are in Ada 83 mode, then we allow it even though it will
3702 -- not be flagged as static. This allows expected Ada 83 mode
3703 -- use of external names which are string literals, even though
3704 -- technically these are not static in Ada 83.
3706 elsif Ada_Version
= Ada_83
3707 and then Nkind
(Argx
) = N_String_Literal
3711 -- Static expression that raises Constraint_Error. This has
3712 -- already been flagged, so just exit from pragma processing.
3714 elsif Is_Static_Expression
(Argx
) then
3717 -- Here we have a real error (non-static expression)
3720 Error_Msg_Name_1
:= Pname
;
3724 "argument for pragma% must be a identifier or "
3725 & "static string expression!";
3728 Flag_Non_Static_Expr
(Msg
, Argx
);
3733 end Check_Arg_Is_External_Name
;
3735 -----------------------------
3736 -- Check_Arg_Is_Identifier --
3737 -----------------------------
3739 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3740 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3742 if Nkind
(Argx
) /= N_Identifier
then
3744 ("argument for pragma% must be identifier", Argx
);
3746 end Check_Arg_Is_Identifier
;
3748 ----------------------------------
3749 -- Check_Arg_Is_Integer_Literal --
3750 ----------------------------------
3752 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3753 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3755 if Nkind
(Argx
) /= N_Integer_Literal
then
3757 ("argument for pragma% must be integer literal", Argx
);
3759 end Check_Arg_Is_Integer_Literal
;
3761 -------------------------------------------
3762 -- Check_Arg_Is_Library_Level_Local_Name --
3763 -------------------------------------------
3767 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3768 -- | library_unit_NAME
3770 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3772 Check_Arg_Is_Local_Name
(Arg
);
3774 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3775 and then Comes_From_Source
(N
)
3778 ("argument for pragma% must be library level entity", Arg
);
3780 end Check_Arg_Is_Library_Level_Local_Name
;
3782 -----------------------------
3783 -- Check_Arg_Is_Local_Name --
3784 -----------------------------
3788 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3789 -- | library_unit_NAME
3791 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3792 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3797 if Nkind
(Argx
) not in N_Direct_Name
3798 and then (Nkind
(Argx
) /= N_Attribute_Reference
3799 or else Present
(Expressions
(Argx
))
3800 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3801 and then (not Is_Entity_Name
(Argx
)
3802 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3804 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3807 -- No further check required if not an entity name
3809 if not Is_Entity_Name
(Argx
) then
3815 Ent
: constant Entity_Id
:= Entity
(Argx
);
3816 Scop
: constant Entity_Id
:= Scope
(Ent
);
3819 -- Case of a pragma applied to a compilation unit: pragma must
3820 -- occur immediately after the program unit in the compilation.
3822 if Is_Compilation_Unit
(Ent
) then
3824 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3827 -- Case of pragma placed immediately after spec
3829 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3832 -- Case of pragma placed immediately after body
3834 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3835 and then Present
(Corresponding_Body
(Decl
))
3839 (Parent
(Unit_Declaration_Node
3840 (Corresponding_Body
(Decl
))));
3842 -- All other cases are illegal
3849 -- Special restricted placement rule from 10.2.1(11.8/2)
3851 elsif Is_Generic_Formal
(Ent
)
3852 and then Prag_Id
= Pragma_Preelaborable_Initialization
3854 OK
:= List_Containing
(N
) =
3855 Generic_Formal_Declarations
3856 (Unit_Declaration_Node
(Scop
));
3858 -- If this is an aspect applied to a subprogram body, the
3859 -- pragma is inserted in its declarative part.
3861 elsif From_Aspect_Specification
(N
)
3863 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3864 and then Ent
= Current_Scope
3868 -- If the aspect is a predicate (possibly others ???) and the
3869 -- context is a record type, this is a discriminant expression
3870 -- within a type declaration, that freezes the predicated
3873 elsif From_Aspect_Specification
(N
)
3874 and then Prag_Id
= Pragma_Predicate
3875 and then Ekind
(Current_Scope
) = E_Record_Type
3876 and then Scop
= Scope
(Current_Scope
)
3880 -- Default case, just check that the pragma occurs in the scope
3881 -- of the entity denoted by the name.
3884 OK
:= Current_Scope
= Scop
;
3889 ("pragma% argument must be in same declarative part", Arg
);
3893 end Check_Arg_Is_Local_Name
;
3895 ---------------------------------
3896 -- Check_Arg_Is_Locking_Policy --
3897 ---------------------------------
3899 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3900 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3903 Check_Arg_Is_Identifier
(Argx
);
3905 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3906 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3908 end Check_Arg_Is_Locking_Policy
;
3910 -----------------------------------------------
3911 -- Check_Arg_Is_Partition_Elaboration_Policy --
3912 -----------------------------------------------
3914 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3915 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3918 Check_Arg_Is_Identifier
(Argx
);
3920 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3922 ("& is not a valid partition elaboration policy name", Argx
);
3924 end Check_Arg_Is_Partition_Elaboration_Policy
;
3926 -------------------------
3927 -- Check_Arg_Is_One_Of --
3928 -------------------------
3930 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3931 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3934 Check_Arg_Is_Identifier
(Argx
);
3936 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3937 Error_Msg_Name_2
:= N1
;
3938 Error_Msg_Name_3
:= N2
;
3939 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3941 end Check_Arg_Is_One_Of
;
3943 procedure Check_Arg_Is_One_Of
3945 N1
, N2
, N3
: Name_Id
)
3947 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3950 Check_Arg_Is_Identifier
(Argx
);
3952 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3953 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3955 end Check_Arg_Is_One_Of
;
3957 procedure Check_Arg_Is_One_Of
3959 N1
, N2
, N3
, N4
: Name_Id
)
3961 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3964 Check_Arg_Is_Identifier
(Argx
);
3966 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3967 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3969 end Check_Arg_Is_One_Of
;
3971 procedure Check_Arg_Is_One_Of
3973 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3975 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3978 Check_Arg_Is_Identifier
(Argx
);
3980 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3981 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3983 end Check_Arg_Is_One_Of
;
3985 ---------------------------------
3986 -- Check_Arg_Is_Queuing_Policy --
3987 ---------------------------------
3989 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3990 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3993 Check_Arg_Is_Identifier
(Argx
);
3995 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3996 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3998 end Check_Arg_Is_Queuing_Policy
;
4000 ------------------------------------
4001 -- Check_Arg_Is_Static_Expression --
4002 ------------------------------------
4004 procedure Check_Arg_Is_Static_Expression
4006 Typ
: Entity_Id
:= Empty
)
4009 Check_Expr_Is_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
4010 end Check_Arg_Is_Static_Expression
;
4012 ------------------------------------------
4013 -- Check_Arg_Is_Task_Dispatching_Policy --
4014 ------------------------------------------
4016 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4017 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4020 Check_Arg_Is_Identifier
(Argx
);
4022 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4024 ("& is not a valid task dispatching policy name", Argx
);
4026 end Check_Arg_Is_Task_Dispatching_Policy
;
4028 ---------------------
4029 -- Check_Arg_Order --
4030 ---------------------
4032 procedure Check_Arg_Order
(Names
: Name_List
) is
4035 Highest_So_Far
: Natural := 0;
4036 -- Highest index in Names seen do far
4040 for J
in 1 .. Arg_Count
loop
4041 if Chars
(Arg
) /= No_Name
then
4042 for K
in Names
'Range loop
4043 if Chars
(Arg
) = Names
(K
) then
4044 if K
< Highest_So_Far
then
4045 Error_Msg_Name_1
:= Pname
;
4047 ("parameters out of order for pragma%", Arg
);
4048 Error_Msg_Name_1
:= Names
(K
);
4049 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4050 Error_Msg_N
("\% must appear before %", Arg
);
4054 Highest_So_Far
:= K
;
4062 end Check_Arg_Order
;
4064 --------------------------------
4065 -- Check_At_Least_N_Arguments --
4066 --------------------------------
4068 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4070 if Arg_Count
< N
then
4071 Error_Pragma
("too few arguments for pragma%");
4073 end Check_At_Least_N_Arguments
;
4075 -------------------------------
4076 -- Check_At_Most_N_Arguments --
4077 -------------------------------
4079 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4082 if Arg_Count
> N
then
4084 for J
in 1 .. N
loop
4086 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4089 end Check_At_Most_N_Arguments
;
4091 ---------------------
4092 -- Check_Component --
4093 ---------------------
4095 procedure Check_Component
4098 In_Variant_Part
: Boolean := False)
4100 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4101 Sindic
: constant Node_Id
:=
4102 Subtype_Indication
(Component_Definition
(Comp
));
4103 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4106 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4107 -- object constraint, then the component type shall be an Unchecked_
4110 if Nkind
(Sindic
) = N_Subtype_Indication
4111 and then Has_Per_Object_Constraint
(Comp_Id
)
4112 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4115 ("component subtype subject to per-object constraint "
4116 & "must be an Unchecked_Union", Comp
);
4118 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4119 -- the body of a generic unit, or within the body of any of its
4120 -- descendant library units, no part of the type of a component
4121 -- declared in a variant_part of the unchecked union type shall be of
4122 -- a formal private type or formal private extension declared within
4123 -- the formal part of the generic unit.
4125 elsif Ada_Version
>= Ada_2012
4126 and then In_Generic_Body
(UU_Typ
)
4127 and then In_Variant_Part
4128 and then Is_Private_Type
(Typ
)
4129 and then Is_Generic_Type
(Typ
)
4132 ("component of unchecked union cannot be of generic type", Comp
);
4134 elsif Needs_Finalization
(Typ
) then
4136 ("component of unchecked union cannot be controlled", Comp
);
4138 elsif Has_Task
(Typ
) then
4140 ("component of unchecked union cannot have tasks", Comp
);
4142 end Check_Component
;
4144 -----------------------------
4145 -- Check_Declaration_Order --
4146 -----------------------------
4148 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4149 procedure Check_Aspect_Specification_Order
;
4150 -- Inspect the aspect specifications of the context to determine the
4153 --------------------------------------
4154 -- Check_Aspect_Specification_Order --
4155 --------------------------------------
4157 procedure Check_Aspect_Specification_Order
is
4158 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4159 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4163 -- Both aspects must be part of the same aspect specification list
4166 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4168 -- Try to reach Second starting from First in a left to right
4169 -- traversal of the aspect specifications.
4171 Asp
:= Next
(Asp_First
);
4172 while Present
(Asp
) loop
4174 -- The order is ok, First is followed by Second
4176 if Asp
= Asp_Second
then
4183 -- If we get here, then the aspects are out of order
4185 Error_Msg_N
("aspect % cannot come after aspect %", First
);
4186 end Check_Aspect_Specification_Order
;
4192 -- Start of processing for Check_Declaration_Order
4195 -- Cannot check the order if one of the pragmas is missing
4197 if No
(First
) or else No
(Second
) then
4201 -- Set up the error names in case the order is incorrect
4203 Error_Msg_Name_1
:= Pragma_Name
(First
);
4204 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4206 if From_Aspect_Specification
(First
) then
4208 -- Both pragmas are actually aspects, check their declaration
4209 -- order in the associated aspect specification list. Otherwise
4210 -- First is an aspect and Second a source pragma.
4212 if From_Aspect_Specification
(Second
) then
4213 Check_Aspect_Specification_Order
;
4216 -- Abstract_States is a source pragma
4219 if From_Aspect_Specification
(Second
) then
4220 Error_Msg_N
("pragma % cannot come after aspect %", First
);
4222 -- Both pragmas are source constructs. Try to reach First from
4223 -- Second by traversing the declarations backwards.
4226 Stmt
:= Prev
(Second
);
4227 while Present
(Stmt
) loop
4229 -- The order is ok, First is followed by Second
4231 if Stmt
= First
then
4238 -- If we get here, then the pragmas are out of order
4240 Error_Msg_N
("pragma % cannot come after pragma %", First
);
4243 end Check_Declaration_Order
;
4245 ----------------------------
4246 -- Check_Duplicate_Pragma --
4247 ----------------------------
4249 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4250 Id
: Entity_Id
:= E
;
4254 -- Nothing to do if this pragma comes from an aspect specification,
4255 -- since we could not be duplicating a pragma, and we dealt with the
4256 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4258 if From_Aspect_Specification
(N
) then
4262 -- Otherwise current pragma may duplicate previous pragma or a
4263 -- previously given aspect specification or attribute definition
4264 -- clause for the same pragma.
4266 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4270 -- If the entity is a type, then we have to make sure that the
4271 -- ostensible duplicate is not for a parent type from which this
4275 if Nkind
(P
) = N_Pragma
then
4277 Args
: constant List_Id
:=
4278 Pragma_Argument_Associations
(P
);
4281 and then Is_Entity_Name
(Expression
(First
(Args
)))
4282 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4283 and then Entity
(Expression
(First
(Args
))) /= E
4289 elsif Nkind
(P
) = N_Aspect_Specification
4290 and then Is_Type
(Entity
(P
))
4291 and then Entity
(P
) /= E
4297 -- Here we have a definite duplicate
4299 Error_Msg_Name_1
:= Pragma_Name
(N
);
4300 Error_Msg_Sloc
:= Sloc
(P
);
4302 -- For a single protected or a single task object, the error is
4303 -- issued on the original entity.
4305 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4306 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4309 if Nkind
(P
) = N_Aspect_Specification
4310 or else From_Aspect_Specification
(P
)
4312 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4314 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4319 end Check_Duplicate_Pragma
;
4321 ----------------------------------
4322 -- Check_Duplicated_Export_Name --
4323 ----------------------------------
4325 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4326 String_Val
: constant String_Id
:= Strval
(Nam
);
4329 -- We are only interested in the export case, and in the case of
4330 -- generics, it is the instance, not the template, that is the
4331 -- problem (the template will generate a warning in any case).
4333 if not Inside_A_Generic
4334 and then (Prag_Id
= Pragma_Export
4336 Prag_Id
= Pragma_Export_Procedure
4338 Prag_Id
= Pragma_Export_Valued_Procedure
4340 Prag_Id
= Pragma_Export_Function
)
4342 for J
in Externals
.First
.. Externals
.Last
loop
4343 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4344 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4345 Error_Msg_N
("external name duplicates name given#", Nam
);
4350 Externals
.Append
(Nam
);
4352 end Check_Duplicated_Export_Name
;
4354 -------------------------------------
4355 -- Check_Expr_Is_Static_Expression --
4356 -------------------------------------
4358 procedure Check_Expr_Is_Static_Expression
4360 Typ
: Entity_Id
:= Empty
)
4363 if Present
(Typ
) then
4364 Analyze_And_Resolve
(Expr
, Typ
);
4366 Analyze_And_Resolve
(Expr
);
4369 if Is_OK_Static_Expression
(Expr
) then
4372 elsif Etype
(Expr
) = Any_Type
then
4375 -- An interesting special case, if we have a string literal and we
4376 -- are in Ada 83 mode, then we allow it even though it will not be
4377 -- flagged as static. This allows the use of Ada 95 pragmas like
4378 -- Import in Ada 83 mode. They will of course be flagged with
4379 -- warnings as usual, but will not cause errors.
4381 elsif Ada_Version
= Ada_83
4382 and then Nkind
(Expr
) = N_String_Literal
4386 -- Static expression that raises Constraint_Error. This has already
4387 -- been flagged, so just exit from pragma processing.
4389 elsif Is_Static_Expression
(Expr
) then
4392 -- Finally, we have a real error
4395 Error_Msg_Name_1
:= Pname
;
4399 "argument for pragma% must be a static expression!";
4402 Flag_Non_Static_Expr
(Msg
, Expr
);
4407 end Check_Expr_Is_Static_Expression
;
4409 -------------------------
4410 -- Check_First_Subtype --
4411 -------------------------
4413 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4414 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4415 Ent
: constant Entity_Id
:= Entity
(Argx
);
4418 if Is_First_Subtype
(Ent
) then
4421 elsif Is_Type
(Ent
) then
4423 ("pragma% cannot apply to subtype", Argx
);
4425 elsif Is_Object
(Ent
) then
4427 ("pragma% cannot apply to object, requires a type", Argx
);
4431 ("pragma% cannot apply to&, requires a type", Argx
);
4433 end Check_First_Subtype
;
4435 ----------------------
4436 -- Check_Identifier --
4437 ----------------------
4439 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4442 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4444 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4445 Error_Msg_Name_1
:= Pname
;
4446 Error_Msg_Name_2
:= Id
;
4447 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4451 end Check_Identifier
;
4453 --------------------------------
4454 -- Check_Identifier_Is_One_Of --
4455 --------------------------------
4457 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4460 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4462 if Chars
(Arg
) = No_Name
then
4463 Error_Msg_Name_1
:= Pname
;
4464 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4467 elsif Chars
(Arg
) /= N1
4468 and then Chars
(Arg
) /= N2
4470 Error_Msg_Name_1
:= Pname
;
4471 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4475 end Check_Identifier_Is_One_Of
;
4477 ---------------------------
4478 -- Check_In_Main_Program --
4479 ---------------------------
4481 procedure Check_In_Main_Program
is
4482 P
: constant Node_Id
:= Parent
(N
);
4485 -- Must be at in subprogram body
4487 if Nkind
(P
) /= N_Subprogram_Body
then
4488 Error_Pragma
("% pragma allowed only in subprogram");
4490 -- Otherwise warn if obviously not main program
4492 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4493 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4495 Error_Msg_Name_1
:= Pname
;
4497 ("??pragma% is only effective in main program", N
);
4499 end Check_In_Main_Program
;
4501 ---------------------------------------
4502 -- Check_Interrupt_Or_Attach_Handler --
4503 ---------------------------------------
4505 procedure Check_Interrupt_Or_Attach_Handler
is
4506 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4507 Handler_Proc
, Proc_Scope
: Entity_Id
;
4512 if Prag_Id
= Pragma_Interrupt_Handler
then
4513 Check_Restriction
(No_Dynamic_Attachment
, N
);
4516 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4517 Proc_Scope
:= Scope
(Handler_Proc
);
4519 -- On AAMP only, a pragma Interrupt_Handler is supported for
4520 -- nonprotected parameterless procedures.
4522 if not AAMP_On_Target
4523 or else Prag_Id
= Pragma_Attach_Handler
4525 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4527 ("argument of pragma% must be protected procedure", Arg1
);
4530 -- For pragma case (as opposed to access case), check placement.
4531 -- We don't need to do that for aspects, because we have the
4532 -- check that they are apply an appropriate procedure.
4534 if not From_Aspect_Specification
(N
)
4535 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4537 Error_Pragma
("pragma% must be in protected definition");
4541 if not Is_Library_Level_Entity
(Proc_Scope
)
4542 or else (AAMP_On_Target
4543 and then not Is_Library_Level_Entity
(Handler_Proc
))
4546 ("argument for pragma% must be library level entity", Arg1
);
4549 -- AI05-0033: A pragma cannot appear within a generic body, because
4550 -- instance can be in a nested scope. The check that protected type
4551 -- is itself a library-level declaration is done elsewhere.
4553 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4554 -- handle code prior to AI-0033. Analysis tools typically are not
4555 -- interested in this pragma in any case, so no need to worry too
4556 -- much about its placement.
4558 if Inside_A_Generic
then
4559 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4560 and then In_Package_Body
(Scope
(Current_Scope
))
4561 and then not Relaxed_RM_Semantics
4563 Error_Pragma
("pragma% cannot be used inside a generic");
4566 end Check_Interrupt_Or_Attach_Handler
;
4568 ---------------------------------
4569 -- Check_Loop_Pragma_Placement --
4570 ---------------------------------
4572 procedure Check_Loop_Pragma_Placement
is
4573 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4574 -- Verify whether the current pragma is properly grouped with other
4575 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4576 -- related loop where the pragma appears.
4578 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4579 -- Determine whether an arbitrary statement Stmt denotes pragma
4580 -- Loop_Invariant or Loop_Variant.
4582 procedure Placement_Error
(Constr
: Node_Id
);
4583 pragma No_Return
(Placement_Error
);
4584 -- Node Constr denotes the last loop restricted construct before we
4585 -- encountered an illegal relation between enclosing constructs. Emit
4586 -- an error depending on what Constr was.
4588 --------------------------------
4589 -- Check_Loop_Pragma_Grouping --
4590 --------------------------------
4592 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4593 Stop_Search
: exception;
4594 -- This exception is used to terminate the recursive descent of
4595 -- routine Check_Grouping.
4597 procedure Check_Grouping
(L
: List_Id
);
4598 -- Find the first group of pragmas in list L and if successful,
4599 -- ensure that the current pragma is part of that group. The
4600 -- routine raises Stop_Search once such a check is performed to
4601 -- halt the recursive descent.
4603 procedure Grouping_Error
(Prag
: Node_Id
);
4604 pragma No_Return
(Grouping_Error
);
4605 -- Emit an error concerning the current pragma indicating that it
4606 -- should be placed after pragma Prag.
4608 --------------------
4609 -- Check_Grouping --
4610 --------------------
4612 procedure Check_Grouping
(L
: List_Id
) is
4618 -- Inspect the list of declarations or statements looking for
4619 -- the first grouping of pragmas:
4622 -- pragma Loop_Invariant ...;
4623 -- pragma Loop_Variant ...;
4625 -- pragma Loop_Variant ...; -- current pragma
4627 -- If the current pragma is not in the grouping, then it must
4628 -- either appear in a different declarative or statement list
4629 -- or the construct at (1) is separating the pragma from the
4633 while Present
(Stmt
) loop
4635 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4636 -- inside a loop or a block housed inside a loop. Inspect
4637 -- the declarations and statements of the block as they may
4638 -- contain the first grouping.
4640 if Nkind
(Stmt
) = N_Block_Statement
then
4641 HSS
:= Handled_Statement_Sequence
(Stmt
);
4643 Check_Grouping
(Declarations
(Stmt
));
4645 if Present
(HSS
) then
4646 Check_Grouping
(Statements
(HSS
));
4649 -- First pragma of the first topmost grouping has been found
4651 elsif Is_Loop_Pragma
(Stmt
) then
4653 -- The group and the current pragma are not in the same
4654 -- declarative or statement list.
4656 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4657 Grouping_Error
(Stmt
);
4659 -- Try to reach the current pragma from the first pragma
4660 -- of the grouping while skipping other members:
4662 -- pragma Loop_Invariant ...; -- first pragma
4663 -- pragma Loop_Variant ...; -- member
4665 -- pragma Loop_Variant ...; -- current pragma
4668 while Present
(Stmt
) loop
4670 -- The current pragma is either the first pragma
4671 -- of the group or is a member of the group. Stop
4672 -- the search as the placement is legal.
4677 -- Skip group members, but keep track of the last
4678 -- pragma in the group.
4680 elsif Is_Loop_Pragma
(Stmt
) then
4683 -- A non-pragma is separating the group from the
4684 -- current pragma, the placement is erroneous.
4687 Grouping_Error
(Prag
);
4693 -- If the traversal did not reach the current pragma,
4694 -- then the list must be malformed.
4696 raise Program_Error
;
4704 --------------------
4705 -- Grouping_Error --
4706 --------------------
4708 procedure Grouping_Error
(Prag
: Node_Id
) is
4710 Error_Msg_Sloc
:= Sloc
(Prag
);
4711 Error_Pragma
("pragma% must appear next to pragma#");
4714 -- Start of processing for Check_Loop_Pragma_Grouping
4717 -- Inspect the statements of the loop or nested blocks housed
4718 -- within to determine whether the current pragma is part of the
4719 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4721 Check_Grouping
(Statements
(Loop_Stmt
));
4724 when Stop_Search
=> null;
4725 end Check_Loop_Pragma_Grouping
;
4727 --------------------
4728 -- Is_Loop_Pragma --
4729 --------------------
4731 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4733 -- Inspect the original node as Loop_Invariant and Loop_Variant
4734 -- pragmas are rewritten to null when assertions are disabled.
4736 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4738 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4739 Name_Loop_Invariant
,
4746 ---------------------
4747 -- Placement_Error --
4748 ---------------------
4750 procedure Placement_Error
(Constr
: Node_Id
) is
4751 LA
: constant String := " with Loop_Entry";
4754 if Prag_Id
= Pragma_Assert
then
4755 Error_Msg_String
(1 .. LA
'Length) := LA
;
4756 Error_Msg_Strlen
:= LA
'Length;
4758 Error_Msg_Strlen
:= 0;
4761 if Nkind
(Constr
) = N_Pragma
then
4763 ("pragma %~ must appear immediately within the statements "
4767 ("block containing pragma %~ must appear immediately within "
4768 & "the statements of a loop", Constr
);
4770 end Placement_Error
;
4772 -- Local declarations
4777 -- Start of processing for Check_Loop_Pragma_Placement
4780 -- Check that pragma appears immediately within a loop statement,
4781 -- ignoring intervening block statements.
4785 while Present
(Stmt
) loop
4787 -- The pragma or previous block must appear immediately within the
4788 -- current block's declarative or statement part.
4790 if Nkind
(Stmt
) = N_Block_Statement
then
4791 if (No
(Declarations
(Stmt
))
4792 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4794 List_Containing
(Prev
) /=
4795 Statements
(Handled_Statement_Sequence
(Stmt
))
4797 Placement_Error
(Prev
);
4800 -- Keep inspecting the parents because we are now within a
4801 -- chain of nested blocks.
4805 Stmt
:= Parent
(Stmt
);
4808 -- The pragma or previous block must appear immediately within the
4809 -- statements of the loop.
4811 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4812 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4813 Placement_Error
(Prev
);
4816 -- Stop the traversal because we reached the innermost loop
4817 -- regardless of whether we encountered an error or not.
4821 -- Ignore a handled statement sequence. Note that this node may
4822 -- be related to a subprogram body in which case we will emit an
4823 -- error on the next iteration of the search.
4825 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4826 Stmt
:= Parent
(Stmt
);
4828 -- Any other statement breaks the chain from the pragma to the
4832 Placement_Error
(Prev
);
4837 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4838 -- grouped together with other such pragmas.
4840 if Is_Loop_Pragma
(N
) then
4842 -- The previous check should have located the related loop
4844 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4845 Check_Loop_Pragma_Grouping
(Stmt
);
4847 end Check_Loop_Pragma_Placement
;
4849 -------------------------------------------
4850 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4851 -------------------------------------------
4853 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4862 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4865 elsif Nkind_In
(P
, N_Package_Specification
,
4870 -- Note: the following tests seem a little peculiar, because
4871 -- they test for bodies, but if we were in the statement part
4872 -- of the body, we would already have hit the handled statement
4873 -- sequence, so the only way we get here is by being in the
4874 -- declarative part of the body.
4876 elsif Nkind_In
(P
, N_Subprogram_Body
,
4887 Error_Pragma
("pragma% is not in declarative part or package spec");
4888 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4890 -------------------------
4891 -- Check_No_Identifier --
4892 -------------------------
4894 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4896 if Nkind
(Arg
) = N_Pragma_Argument_Association
4897 and then Chars
(Arg
) /= No_Name
4899 Error_Pragma_Arg_Ident
4900 ("pragma% does not permit identifier& here", Arg
);
4902 end Check_No_Identifier
;
4904 --------------------------
4905 -- Check_No_Identifiers --
4906 --------------------------
4908 procedure Check_No_Identifiers
is
4912 for J
in 1 .. Arg_Count
loop
4913 Check_No_Identifier
(Arg_Node
);
4916 end Check_No_Identifiers
;
4918 ------------------------
4919 -- Check_No_Link_Name --
4920 ------------------------
4922 procedure Check_No_Link_Name
is
4924 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4928 if Present
(Arg4
) then
4930 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4932 end Check_No_Link_Name
;
4934 -------------------------------
4935 -- Check_Optional_Identifier --
4936 -------------------------------
4938 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4941 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4942 and then Chars
(Arg
) /= No_Name
4944 if Chars
(Arg
) /= Id
then
4945 Error_Msg_Name_1
:= Pname
;
4946 Error_Msg_Name_2
:= Id
;
4947 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4951 end Check_Optional_Identifier
;
4953 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4955 Name_Buffer
(1 .. Id
'Length) := Id
;
4956 Name_Len
:= Id
'Length;
4957 Check_Optional_Identifier
(Arg
, Name_Find
);
4958 end Check_Optional_Identifier
;
4960 --------------------
4961 -- Check_Pre_Post --
4962 --------------------
4964 procedure Check_Pre_Post
is
4969 if not Is_List_Member
(N
) then
4973 -- If we are within an inlined body, the legality of the pragma
4974 -- has been checked already.
4976 if In_Inlined_Body
then
4980 -- Search prior declarations
4983 while Present
(Prev
(P
)) loop
4986 -- If the previous node is a generic subprogram, do not go to to
4987 -- the original node, which is the unanalyzed tree: we need to
4988 -- attach the pre/postconditions to the analyzed version at this
4989 -- point. They get propagated to the original tree when analyzing
4990 -- the corresponding body.
4992 if Nkind
(P
) not in N_Generic_Declaration
then
4993 PO
:= Original_Node
(P
);
4998 -- Skip past prior pragma
5000 if Nkind
(PO
) = N_Pragma
then
5003 -- Skip stuff not coming from source
5005 elsif not Comes_From_Source
(PO
) then
5007 -- The condition may apply to a subprogram instantiation
5009 if Nkind
(PO
) = N_Subprogram_Declaration
5010 and then Present
(Generic_Parent
(Specification
(PO
)))
5014 elsif Nkind
(PO
) = N_Subprogram_Declaration
5015 and then In_Instance
5019 -- For all other cases of non source code, do nothing
5025 -- Only remaining possibility is subprogram declaration
5032 -- If we fall through loop, pragma is at start of list, so see if it
5033 -- is at the start of declarations of a subprogram body.
5037 if Nkind
(PO
) = N_Subprogram_Body
5038 and then List_Containing
(N
) = Declarations
(PO
)
5040 -- This is only allowed if there is no separate specification
5042 if Present
(Corresponding_Spec
(PO
)) then
5044 ("pragma% must apply to subprogram specification");
5051 --------------------------------------
5052 -- Check_Precondition_Postcondition --
5053 --------------------------------------
5055 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
5059 procedure Chain_PPC
(PO
: Node_Id
);
5060 -- If PO is an entry or a [generic] subprogram declaration node, then
5061 -- the precondition/postcondition applies to this subprogram and the
5062 -- processing for the pragma is completed. Otherwise the pragma is
5069 procedure Chain_PPC
(PO
: Node_Id
) is
5073 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5074 if not From_Aspect_Specification
(N
) then
5076 ("pragma% cannot be applied to abstract subprogram");
5078 elsif Class_Present
(N
) then
5083 ("aspect % requires ''Class for abstract subprogram");
5086 -- AI05-0230: The same restriction applies to null procedures. For
5087 -- compatibility with earlier uses of the Ada pragma, apply this
5088 -- rule only to aspect specifications.
5090 -- The above discrepency needs documentation. Robert is dubious
5091 -- about whether it is a good idea ???
5093 elsif Nkind
(PO
) = N_Subprogram_Declaration
5094 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
5095 and then Null_Present
(Specification
(PO
))
5096 and then From_Aspect_Specification
(N
)
5097 and then not Class_Present
(N
)
5100 ("aspect % requires ''Class for null procedure");
5102 -- Pre/postconditions are legal on a subprogram body if it is not
5103 -- a completion of a declaration. They are also legal on a stub
5104 -- with no previous declarations (this is checked when processing
5105 -- the corresponding aspects).
5107 elsif Nkind
(PO
) = N_Subprogram_Body
5108 and then Acts_As_Spec
(PO
)
5112 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
5115 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5116 N_Expression_Function
,
5117 N_Generic_Subprogram_Declaration
,
5118 N_Entry_Declaration
)
5123 -- Here if we have [generic] subprogram or entry declaration
5125 if Nkind
(PO
) = N_Entry_Declaration
then
5126 S
:= Defining_Entity
(PO
);
5128 S
:= Defining_Unit_Name
(Specification
(PO
));
5130 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5131 S
:= Defining_Identifier
(S
);
5135 -- Note: we do not analyze the pragma at this point. Instead we
5136 -- delay this analysis until the end of the declarative part in
5137 -- which the pragma appears. This implements the required delay
5138 -- in this analysis, allowing forward references. The analysis
5139 -- happens at the end of Analyze_Declarations.
5141 -- Chain spec PPC pragma to list for subprogram
5143 Add_Contract_Item
(N
, S
);
5145 -- Return indicating spec case
5151 -- Start of processing for Check_Precondition_Postcondition
5154 if not Is_List_Member
(N
) then
5158 -- Preanalyze message argument if present. Visibility in this
5159 -- argument is established at the point of pragma occurrence.
5161 if Arg_Count
= 2 then
5162 Check_Optional_Identifier
(Arg2
, Name_Message
);
5163 Preanalyze_Spec_Expression
5164 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5167 -- For a pragma PPC in the extended main source unit, record enabled
5170 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5171 Set_SCO_Pragma_Enabled
(Loc
);
5174 -- If we are within an inlined body, the legality of the pragma
5175 -- has been checked already.
5177 if In_Inlined_Body
then
5182 -- Search prior declarations
5185 while Present
(Prev
(P
)) loop
5188 -- If the previous node is a generic subprogram, do not go to to
5189 -- the original node, which is the unanalyzed tree: we need to
5190 -- attach the pre/postconditions to the analyzed version at this
5191 -- point. They get propagated to the original tree when analyzing
5192 -- the corresponding body.
5194 if Nkind
(P
) not in N_Generic_Declaration
then
5195 PO
:= Original_Node
(P
);
5200 -- Skip past prior pragma
5202 if Nkind
(PO
) = N_Pragma
then
5205 -- Skip stuff not coming from source
5207 elsif not Comes_From_Source
(PO
) then
5209 -- The condition may apply to a subprogram instantiation
5211 if Nkind
(PO
) = N_Subprogram_Declaration
5212 and then Present
(Generic_Parent
(Specification
(PO
)))
5217 elsif Nkind
(PO
) = N_Subprogram_Declaration
5218 and then In_Instance
5223 -- For all other cases of non source code, do nothing
5229 -- Only remaining possibility is subprogram declaration
5237 -- If we fall through loop, pragma is at start of list, so see if it
5238 -- is at the start of declarations of a subprogram body.
5242 if Nkind
(PO
) = N_Subprogram_Body
5243 and then List_Containing
(N
) = Declarations
(PO
)
5245 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5247 -- Analyze pragma expression for correctness and for ASIS use
5249 Preanalyze_Assert_Expression
5250 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5252 -- In ASIS mode, for a pragma generated from a source aspect,
5253 -- also analyze the original aspect expression.
5255 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5256 Preanalyze_Assert_Expression
5257 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5261 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5262 -- The copy is needed because the pragma is expanded into other
5263 -- constructs which are not acceptable in the N_Contract node.
5265 if Acts_As_Spec
(PO
)
5266 and then GNATprove_Mode
5269 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5272 -- Preanalyze the pragma
5274 Preanalyze_Assert_Expression
5276 (First
(Pragma_Argument_Associations
(Prag
))),
5279 -- Preanalyze the corresponding aspect (if any)
5281 if Present
(Corresponding_Aspect
(Prag
)) then
5282 Preanalyze_Assert_Expression
5283 (Expression
(Corresponding_Aspect
(Prag
)),
5287 -- Chain the copy on the contract of the body
5290 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5297 -- See if it is in the pragmas after a library level subprogram
5299 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5301 -- In GNATprove mode, analyze pragma expression for correctness,
5302 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5303 -- no later point at which the aspect will be analyzed.
5305 if GNATprove_Mode
or ASIS_Mode
then
5306 Analyze_Pre_Post_Condition_In_Decl_Part
5307 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5310 Chain_PPC
(Unit
(Parent
(PO
)));
5314 -- If we fall through, pragma was misplaced
5317 end Check_Precondition_Postcondition
;
5319 -----------------------------
5320 -- Check_Static_Constraint --
5321 -----------------------------
5323 -- Note: for convenience in writing this procedure, in addition to
5324 -- the officially (i.e. by spec) allowed argument which is always a
5325 -- constraint, it also allows ranges and discriminant associations.
5326 -- Above is not clear ???
5328 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5330 procedure Require_Static
(E
: Node_Id
);
5331 -- Require given expression to be static expression
5333 --------------------
5334 -- Require_Static --
5335 --------------------
5337 procedure Require_Static
(E
: Node_Id
) is
5339 if not Is_OK_Static_Expression
(E
) then
5340 Flag_Non_Static_Expr
5341 ("non-static constraint not allowed in Unchecked_Union!", E
);
5346 -- Start of processing for Check_Static_Constraint
5349 case Nkind
(Constr
) is
5350 when N_Discriminant_Association
=>
5351 Require_Static
(Expression
(Constr
));
5354 Require_Static
(Low_Bound
(Constr
));
5355 Require_Static
(High_Bound
(Constr
));
5357 when N_Attribute_Reference
=>
5358 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5359 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5361 when N_Range_Constraint
=>
5362 Check_Static_Constraint
(Range_Expression
(Constr
));
5364 when N_Index_Or_Discriminant_Constraint
=>
5368 IDC
:= First
(Constraints
(Constr
));
5369 while Present
(IDC
) loop
5370 Check_Static_Constraint
(IDC
);
5378 end Check_Static_Constraint
;
5380 ---------------------
5381 -- Check_Test_Case --
5382 ---------------------
5384 procedure Check_Test_Case
is
5388 procedure Chain_CTC
(PO
: Node_Id
);
5389 -- If PO is a [generic] subprogram declaration node, then the
5390 -- test-case applies to this subprogram and the processing for
5391 -- the pragma is completed. Otherwise the pragma is misplaced.
5397 procedure Chain_CTC
(PO
: Node_Id
) is
5401 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5403 ("pragma% cannot be applied to abstract subprogram");
5405 elsif Nkind
(PO
) = N_Entry_Declaration
then
5406 Error_Pragma
("pragma% cannot be applied to entry");
5408 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5409 N_Generic_Subprogram_Declaration
)
5414 -- Here if we have [generic] subprogram declaration
5416 S
:= Defining_Unit_Name
(Specification
(PO
));
5418 -- Note: we do not analyze the pragma at this point. Instead we
5419 -- delay this analysis until the end of the declarative part in
5420 -- which the pragma appears. This implements the required delay
5421 -- in this analysis, allowing forward references. The analysis
5422 -- happens at the end of Analyze_Declarations.
5424 -- There should not be another test-case with the same name
5425 -- associated to this subprogram.
5428 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5432 CTC
:= Contract_Test_Cases
(Contract
(S
));
5433 while Present
(CTC
) loop
5435 -- Omit pragma Contract_Cases because it does not introduce
5436 -- a unique case name and it does not follow the syntax of
5439 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5443 (Name
, Get_Name_From_CTC_Pragma
(CTC
))
5445 Error_Msg_Sloc
:= Sloc
(CTC
);
5446 Error_Pragma
("name for pragma% is already used#");
5449 CTC
:= Next_Pragma
(CTC
);
5453 -- Chain spec CTC pragma to list for subprogram
5455 Add_Contract_Item
(N
, S
);
5458 -- Start of processing for Check_Test_Case
5461 -- First check pragma arguments
5463 Check_At_Least_N_Arguments
(2);
5464 Check_At_Most_N_Arguments
(4);
5466 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5468 Check_Optional_Identifier
(Arg1
, Name_Name
);
5469 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
5471 -- In ASIS mode, for a pragma generated from a source aspect, also
5472 -- analyze the original aspect expression.
5474 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5475 Check_Expr_Is_Static_Expression
5476 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5479 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5480 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5482 if Arg_Count
= 4 then
5483 Check_Identifier
(Arg3
, Name_Requires
);
5484 Check_Identifier
(Arg4
, Name_Ensures
);
5486 elsif Arg_Count
= 3 then
5487 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5490 -- Check pragma placement
5492 if not Is_List_Member
(N
) then
5496 -- Test-case should only appear in package spec unit
5498 if Get_Source_Unit
(N
) = No_Unit
5499 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Get_Source_Unit
(N
))),
5500 N_Package_Declaration
,
5501 N_Generic_Package_Declaration
)
5506 -- Search prior declarations
5509 while Present
(Prev
(P
)) loop
5512 -- If the previous node is a generic subprogram, do not go to to
5513 -- the original node, which is the unanalyzed tree: we need to
5514 -- attach the test-case to the analyzed version at this point.
5515 -- They get propagated to the original tree when analyzing the
5516 -- corresponding body.
5518 if Nkind
(P
) not in N_Generic_Declaration
then
5519 PO
:= Original_Node
(P
);
5524 -- Skip past prior pragma
5526 if Nkind
(PO
) = N_Pragma
then
5529 -- Skip stuff not coming from source
5531 elsif not Comes_From_Source
(PO
) then
5534 -- Only remaining possibility is subprogram declaration. First
5535 -- check that it is declared directly in a package declaration.
5536 -- This may be either the package declaration for the current unit
5537 -- being defined or a local package declaration.
5539 elsif not Present
(Parent
(Parent
(PO
)))
5540 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5541 or else not Nkind_In
(Parent
(Parent
(PO
)),
5542 N_Package_Declaration
,
5543 N_Generic_Package_Declaration
)
5553 -- If we fall through, pragma was misplaced
5556 end Check_Test_Case
;
5558 --------------------------------------
5559 -- Check_Valid_Configuration_Pragma --
5560 --------------------------------------
5562 -- A configuration pragma must appear in the context clause of a
5563 -- compilation unit, and only other pragmas may precede it. Note that
5564 -- the test also allows use in a configuration pragma file.
5566 procedure Check_Valid_Configuration_Pragma
is
5568 if not Is_Configuration_Pragma
then
5569 Error_Pragma
("incorrect placement for configuration pragma%");
5571 end Check_Valid_Configuration_Pragma
;
5573 -------------------------------------
5574 -- Check_Valid_Library_Unit_Pragma --
5575 -------------------------------------
5577 procedure Check_Valid_Library_Unit_Pragma
is
5579 Parent_Node
: Node_Id
;
5580 Unit_Name
: Entity_Id
;
5581 Unit_Kind
: Node_Kind
;
5582 Unit_Node
: Node_Id
;
5583 Sindex
: Source_File_Index
;
5586 if not Is_List_Member
(N
) then
5590 Plist
:= List_Containing
(N
);
5591 Parent_Node
:= Parent
(Plist
);
5593 if Parent_Node
= Empty
then
5596 -- Case of pragma appearing after a compilation unit. In this case
5597 -- it must have an argument with the corresponding name and must
5598 -- be part of the following pragmas of its parent.
5600 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5601 if Plist
/= Pragmas_After
(Parent_Node
) then
5604 elsif Arg_Count
= 0 then
5606 ("argument required if outside compilation unit");
5609 Check_No_Identifiers
;
5610 Check_Arg_Count
(1);
5611 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5612 Unit_Kind
:= Nkind
(Unit_Node
);
5614 Analyze
(Get_Pragma_Arg
(Arg1
));
5616 if Unit_Kind
= N_Generic_Subprogram_Declaration
5617 or else Unit_Kind
= N_Subprogram_Declaration
5619 Unit_Name
:= Defining_Entity
(Unit_Node
);
5621 elsif Unit_Kind
in N_Generic_Instantiation
then
5622 Unit_Name
:= Defining_Entity
(Unit_Node
);
5625 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5628 if Chars
(Unit_Name
) /=
5629 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5632 ("pragma% argument is not current unit name", Arg1
);
5635 if Ekind
(Unit_Name
) = E_Package
5636 and then Present
(Renamed_Entity
(Unit_Name
))
5638 Error_Pragma
("pragma% not allowed for renamed package");
5642 -- Pragma appears other than after a compilation unit
5645 -- Here we check for the generic instantiation case and also
5646 -- for the case of processing a generic formal package. We
5647 -- detect these cases by noting that the Sloc on the node
5648 -- does not belong to the current compilation unit.
5650 Sindex
:= Source_Index
(Current_Sem_Unit
);
5652 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5653 Rewrite
(N
, Make_Null_Statement
(Loc
));
5656 -- If before first declaration, the pragma applies to the
5657 -- enclosing unit, and the name if present must be this name.
5659 elsif Is_Before_First_Decl
(N
, Plist
) then
5660 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5661 Unit_Kind
:= Nkind
(Unit_Node
);
5663 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5666 elsif Unit_Kind
= N_Subprogram_Body
5667 and then not Acts_As_Spec
(Unit_Node
)
5671 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5674 elsif Nkind
(Parent_Node
) = N_Package_Specification
5675 and then Plist
= Private_Declarations
(Parent_Node
)
5679 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5680 or else Nkind
(Parent_Node
) =
5681 N_Generic_Subprogram_Declaration
)
5682 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5686 elsif Arg_Count
> 0 then
5687 Analyze
(Get_Pragma_Arg
(Arg1
));
5689 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5691 ("name in pragma% must be enclosing unit", Arg1
);
5694 -- It is legal to have no argument in this context
5700 -- Error if not before first declaration. This is because a
5701 -- library unit pragma argument must be the name of a library
5702 -- unit (RM 10.1.5(7)), but the only names permitted in this
5703 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5704 -- generic subprogram declarations or generic instantiations.
5708 ("pragma% misplaced, must be before first declaration");
5712 end Check_Valid_Library_Unit_Pragma
;
5718 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5719 Clist
: constant Node_Id
:= Component_List
(Variant
);
5723 Comp
:= First
(Component_Items
(Clist
));
5724 while Present
(Comp
) loop
5725 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5730 ---------------------------
5731 -- Ensure_Aggregate_Form --
5732 ---------------------------
5734 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5735 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5736 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5737 Nam
: constant Name_Id
:= Chars
(Arg
);
5738 Comps
: List_Id
:= No_List
;
5739 Exprs
: List_Id
:= No_List
;
5742 -- The argument is already in aggregate form, but the presence of a
5743 -- name causes this to be interpreted as a named association which in
5744 -- turn must be converted into an aggregate.
5746 -- pragma Global (In_Out => (A, B, C))
5750 -- pragma Global ((In_Out => (A, B, C)))
5752 -- aggregate aggregate
5754 if Nkind
(Expr
) = N_Aggregate
then
5755 if Nam
= No_Name
then
5759 -- Do not transform a null argument into an aggregate as N_Null has
5760 -- special meaning in formal verification pragmas.
5762 elsif Nkind
(Expr
) = N_Null
then
5766 -- Positional argument is transformed into an aggregate with an
5767 -- Expressions list.
5769 if Nam
= No_Name
then
5770 Exprs
:= New_List
(Relocate_Node
(Expr
));
5772 -- An associative argument is transformed into an aggregate with
5773 -- Component_Associations.
5777 Make_Component_Association
(Loc
,
5778 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5779 Expression
=> Relocate_Node
(Expr
)));
5783 -- Remove the pragma argument name as this information has been
5784 -- captured in the aggregate.
5786 Set_Chars
(Arg
, No_Name
);
5788 Set_Expression
(Arg
,
5789 Make_Aggregate
(Loc
,
5790 Component_Associations
=> Comps
,
5791 Expressions
=> Exprs
));
5792 end Ensure_Aggregate_Form
;
5798 procedure Error_Pragma
(Msg
: String) is
5799 MsgF
: String := Msg
;
5801 Error_Msg_Name_1
:= Pname
;
5803 Error_Msg_N
(MsgF
, N
);
5807 ----------------------
5808 -- Error_Pragma_Arg --
5809 ----------------------
5811 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5812 MsgF
: String := Msg
;
5814 Error_Msg_Name_1
:= Pname
;
5816 Error_Msg_N
(MsgF
, Get_Pragma_Arg
(Arg
));
5818 end Error_Pragma_Arg
;
5820 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5821 MsgF
: String := Msg1
;
5823 Error_Msg_Name_1
:= Pname
;
5825 Error_Msg_N
(MsgF
, Get_Pragma_Arg
(Arg
));
5826 Error_Pragma_Arg
(Msg2
, Arg
);
5827 end Error_Pragma_Arg
;
5829 ----------------------------
5830 -- Error_Pragma_Arg_Ident --
5831 ----------------------------
5833 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5834 MsgF
: String := Msg
;
5836 Error_Msg_Name_1
:= Pname
;
5838 Error_Msg_N
(MsgF
, Arg
);
5840 end Error_Pragma_Arg_Ident
;
5842 ----------------------
5843 -- Error_Pragma_Ref --
5844 ----------------------
5846 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5847 MsgF
: String := Msg
;
5849 Error_Msg_Name_1
:= Pname
;
5851 Error_Msg_Sloc
:= Sloc
(Ref
);
5852 Error_Msg_NE
(MsgF
, N
, Ref
);
5854 end Error_Pragma_Ref
;
5856 ------------------------
5857 -- Find_Lib_Unit_Name --
5858 ------------------------
5860 function Find_Lib_Unit_Name
return Entity_Id
is
5862 -- Return inner compilation unit entity, for case of nested
5863 -- categorization pragmas. This happens in generic unit.
5865 if Nkind
(Parent
(N
)) = N_Package_Specification
5866 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5868 return Defining_Entity
(Parent
(N
));
5870 return Current_Scope
;
5872 end Find_Lib_Unit_Name
;
5874 ----------------------------
5875 -- Find_Program_Unit_Name --
5876 ----------------------------
5878 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5879 Unit_Name
: Entity_Id
;
5880 Unit_Kind
: Node_Kind
;
5881 P
: constant Node_Id
:= Parent
(N
);
5884 if Nkind
(P
) = N_Compilation_Unit
then
5885 Unit_Kind
:= Nkind
(Unit
(P
));
5887 if Unit_Kind
= N_Subprogram_Declaration
5888 or else Unit_Kind
= N_Package_Declaration
5889 or else Unit_Kind
in N_Generic_Declaration
5891 Unit_Name
:= Defining_Entity
(Unit
(P
));
5893 if Chars
(Id
) = Chars
(Unit_Name
) then
5894 Set_Entity
(Id
, Unit_Name
);
5895 Set_Etype
(Id
, Etype
(Unit_Name
));
5897 Set_Etype
(Id
, Any_Type
);
5899 ("cannot find program unit referenced by pragma%");
5903 Set_Etype
(Id
, Any_Type
);
5904 Error_Pragma
("pragma% inapplicable to this unit");
5910 end Find_Program_Unit_Name
;
5912 -----------------------------------------
5913 -- Find_Unique_Parameterless_Procedure --
5914 -----------------------------------------
5916 function Find_Unique_Parameterless_Procedure
5918 Arg
: Node_Id
) return Entity_Id
5920 Proc
: Entity_Id
:= Empty
;
5923 -- The body of this procedure needs some comments ???
5925 if not Is_Entity_Name
(Name
) then
5927 ("argument of pragma% must be entity name", Arg
);
5929 elsif not Is_Overloaded
(Name
) then
5930 Proc
:= Entity
(Name
);
5932 if Ekind
(Proc
) /= E_Procedure
5933 or else Present
(First_Formal
(Proc
))
5936 ("argument of pragma% must be parameterless procedure", Arg
);
5941 Found
: Boolean := False;
5943 Index
: Interp_Index
;
5946 Get_First_Interp
(Name
, Index
, It
);
5947 while Present
(It
.Nam
) loop
5950 if Ekind
(Proc
) = E_Procedure
5951 and then No
(First_Formal
(Proc
))
5955 Set_Entity
(Name
, Proc
);
5956 Set_Is_Overloaded
(Name
, False);
5959 ("ambiguous handler name for pragma% ", Arg
);
5963 Get_Next_Interp
(Index
, It
);
5968 ("argument of pragma% must be parameterless procedure",
5971 Proc
:= Entity
(Name
);
5977 end Find_Unique_Parameterless_Procedure
;
5983 procedure Fix_Error
(Msg
: in out String) is
5985 -- If we have a rewriting of another pragma, go to that pragma
5987 if Is_Rewrite_Substitution
(N
)
5988 and then Nkind
(Original_Node
(N
)) = N_Pragma
5990 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5993 -- Case where pragma comes from an aspect specification
5995 if From_Aspect_Specification
(N
) then
5997 -- Change appearence of "pragma" in message to "aspect"
5999 for J
in Msg
'First .. Msg
'Last - 5 loop
6000 if Msg
(J
.. J
+ 5) = "pragma" then
6001 Msg
(J
.. J
+ 5) := "aspect";
6005 -- Get name from corresponding aspect
6007 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
6011 -------------------------
6012 -- Gather_Associations --
6013 -------------------------
6015 procedure Gather_Associations
6017 Args
: out Args_List
)
6022 -- Initialize all parameters to Empty
6024 for J
in Args
'Range loop
6028 -- That's all we have to do if there are no argument associations
6030 if No
(Pragma_Argument_Associations
(N
)) then
6034 -- Otherwise first deal with any positional parameters present
6036 Arg
:= First
(Pragma_Argument_Associations
(N
));
6037 for Index
in Args
'Range loop
6038 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6039 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6043 -- Positional parameters all processed, if any left, then we
6044 -- have too many positional parameters.
6046 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6048 ("too many positional associations for pragma%", Arg
);
6051 -- Process named parameters if any are present
6053 while Present
(Arg
) loop
6054 if Chars
(Arg
) = No_Name
then
6056 ("positional association cannot follow named association",
6060 for Index
in Names
'Range loop
6061 if Names
(Index
) = Chars
(Arg
) then
6062 if Present
(Args
(Index
)) then
6064 ("duplicate argument association for pragma%", Arg
);
6066 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6071 if Index
= Names
'Last then
6072 Error_Msg_Name_1
:= Pname
;
6073 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6075 -- Check for possible misspelling
6077 for Index1
in Names
'Range loop
6078 if Is_Bad_Spelling_Of
6079 (Chars
(Arg
), Names
(Index1
))
6081 Error_Msg_Name_1
:= Names
(Index1
);
6082 Error_Msg_N
-- CODEFIX
6083 ("\possible misspelling of%", Arg
);
6095 end Gather_Associations
;
6101 procedure GNAT_Pragma
is
6103 -- We need to check the No_Implementation_Pragmas restriction for
6104 -- the case of a pragma from source. Note that the case of aspects
6105 -- generating corresponding pragmas marks these pragmas as not being
6106 -- from source, so this test also catches that case.
6108 if Comes_From_Source
(N
) then
6109 Check_Restriction
(No_Implementation_Pragmas
, N
);
6113 --------------------------
6114 -- Is_Before_First_Decl --
6115 --------------------------
6117 function Is_Before_First_Decl
6118 (Pragma_Node
: Node_Id
;
6119 Decls
: List_Id
) return Boolean
6121 Item
: Node_Id
:= First
(Decls
);
6124 -- Only other pragmas can come before this pragma
6127 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6130 elsif Item
= Pragma_Node
then
6136 end Is_Before_First_Decl
;
6138 -----------------------------
6139 -- Is_Configuration_Pragma --
6140 -----------------------------
6142 -- A configuration pragma must appear in the context clause of a
6143 -- compilation unit, and only other pragmas may precede it. Note that
6144 -- the test below also permits use in a configuration pragma file.
6146 function Is_Configuration_Pragma
return Boolean is
6147 Lis
: constant List_Id
:= List_Containing
(N
);
6148 Par
: constant Node_Id
:= Parent
(N
);
6152 -- If no parent, then we are in the configuration pragma file,
6153 -- so the placement is definitely appropriate.
6158 -- Otherwise we must be in the context clause of a compilation unit
6159 -- and the only thing allowed before us in the context list is more
6160 -- configuration pragmas.
6162 elsif Nkind
(Par
) = N_Compilation_Unit
6163 and then Context_Items
(Par
) = Lis
6170 elsif Nkind
(Prg
) /= N_Pragma
then
6180 end Is_Configuration_Pragma
;
6182 --------------------------
6183 -- Is_In_Context_Clause --
6184 --------------------------
6186 function Is_In_Context_Clause
return Boolean is
6188 Parent_Node
: Node_Id
;
6191 if not Is_List_Member
(N
) then
6195 Plist
:= List_Containing
(N
);
6196 Parent_Node
:= Parent
(Plist
);
6198 if Parent_Node
= Empty
6199 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6200 or else Context_Items
(Parent_Node
) /= Plist
6207 end Is_In_Context_Clause
;
6209 ---------------------------------
6210 -- Is_Static_String_Expression --
6211 ---------------------------------
6213 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6214 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6217 Analyze_And_Resolve
(Argx
);
6218 return Is_OK_Static_Expression
(Argx
)
6219 and then Nkind
(Argx
) = N_String_Literal
;
6220 end Is_Static_String_Expression
;
6222 ----------------------
6223 -- Pragma_Misplaced --
6224 ----------------------
6226 procedure Pragma_Misplaced
is
6228 Error_Pragma
("incorrect placement of pragma%");
6229 end Pragma_Misplaced
;
6231 ------------------------------------
6232 -- Process_Atomic_Shared_Volatile --
6233 ------------------------------------
6235 procedure Process_Atomic_Shared_Volatile
is
6242 procedure Set_Atomic
(E
: Entity_Id
);
6243 -- Set given type as atomic, and if no explicit alignment was given,
6244 -- set alignment to unknown, since back end knows what the alignment
6245 -- requirements are for atomic arrays. Note: this step is necessary
6246 -- for derived types.
6252 procedure Set_Atomic
(E
: Entity_Id
) is
6256 if not Has_Alignment_Clause
(E
) then
6257 Set_Alignment
(E
, Uint_0
);
6261 -- Start of processing for Process_Atomic_Shared_Volatile
6264 Check_Ada_83_Warning
;
6265 Check_No_Identifiers
;
6266 Check_Arg_Count
(1);
6267 Check_Arg_Is_Local_Name
(Arg1
);
6268 E_Id
:= Get_Pragma_Arg
(Arg1
);
6270 if Etype
(E_Id
) = Any_Type
then
6275 D
:= Declaration_Node
(E
);
6278 -- Check duplicate before we chain ourselves
6280 Check_Duplicate_Pragma
(E
);
6282 -- Now check appropriateness of the entity
6285 if Rep_Item_Too_Early
(E
, N
)
6287 Rep_Item_Too_Late
(E
, N
)
6291 Check_First_Subtype
(Arg1
);
6294 if Prag_Id
/= Pragma_Volatile
then
6296 Set_Atomic
(Underlying_Type
(E
));
6297 Set_Atomic
(Base_Type
(E
));
6300 -- Attribute belongs on the base type. If the view of the type is
6301 -- currently private, it also belongs on the underlying type.
6303 Set_Is_Volatile
(Base_Type
(E
));
6304 Set_Is_Volatile
(Underlying_Type
(E
));
6306 Set_Treat_As_Volatile
(E
);
6307 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6309 elsif K
= N_Object_Declaration
6310 or else (K
= N_Component_Declaration
6311 and then Original_Record_Component
(E
) = E
)
6313 if Rep_Item_Too_Late
(E
, N
) then
6317 if Prag_Id
/= Pragma_Volatile
then
6320 -- If the object declaration has an explicit initialization, a
6321 -- temporary may have to be created to hold the expression, to
6322 -- ensure that access to the object remain atomic.
6324 if Nkind
(Parent
(E
)) = N_Object_Declaration
6325 and then Present
(Expression
(Parent
(E
)))
6327 Set_Has_Delayed_Freeze
(E
);
6330 -- An interesting improvement here. If an object of composite
6331 -- type X is declared atomic, and the type X isn't, that's a
6332 -- pity, since it may not have appropriate alignment etc. We
6333 -- can rescue this in the special case where the object and
6334 -- type are in the same unit by just setting the type as
6335 -- atomic, so that the back end will process it as atomic.
6337 -- Note: we used to do this for elementary types as well,
6338 -- but that turns out to be a bad idea and can have unwanted
6339 -- effects, most notably if the type is elementary, the object
6340 -- a simple component within a record, and both are in a spec:
6341 -- every object of this type in the entire program will be
6342 -- treated as atomic, thus incurring a potentially costly
6343 -- synchronization operation for every access.
6345 -- Of course it would be best if the back end could just adjust
6346 -- the alignment etc for the specific object, but that's not
6347 -- something we are capable of doing at this point.
6349 Utyp
:= Underlying_Type
(Etype
(E
));
6352 and then Is_Composite_Type
(Utyp
)
6353 and then Sloc
(E
) > No_Location
6354 and then Sloc
(Utyp
) > No_Location
6356 Get_Source_File_Index
(Sloc
(E
)) =
6357 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6359 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6363 Set_Is_Volatile
(E
);
6364 Set_Treat_As_Volatile
(E
);
6368 ("inappropriate entity for pragma%", Arg1
);
6370 end Process_Atomic_Shared_Volatile
;
6372 -------------------------------------------
6373 -- Process_Compile_Time_Warning_Or_Error --
6374 -------------------------------------------
6376 procedure Process_Compile_Time_Warning_Or_Error
is
6377 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6380 Check_Arg_Count
(2);
6381 Check_No_Identifiers
;
6382 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
6383 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6385 if Compile_Time_Known_Value
(Arg1x
) then
6386 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6388 Str
: constant String_Id
:=
6389 Strval
(Get_Pragma_Arg
(Arg2
));
6390 Len
: constant Int
:= String_Length
(Str
);
6395 Cent
: constant Entity_Id
:=
6396 Cunit_Entity
(Current_Sem_Unit
);
6398 Force
: constant Boolean :=
6399 Prag_Id
= Pragma_Compile_Time_Warning
6401 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6402 and then (Ekind
(Cent
) /= E_Package
6403 or else not In_Private_Part
(Cent
));
6404 -- Set True if this is the warning case, and we are in the
6405 -- visible part of a package spec, or in a subprogram spec,
6406 -- in which case we want to force the client to see the
6407 -- warning, even though it is not in the main unit.
6410 -- Loop through segments of message separated by line feeds.
6411 -- We output these segments as separate messages with
6412 -- continuation marks for all but the first.
6417 Error_Msg_Strlen
:= 0;
6419 -- Loop to copy characters from argument to error message
6423 exit when Ptr
> Len
;
6424 CC
:= Get_String_Char
(Str
, Ptr
);
6427 -- Ignore wide chars ??? else store character
6429 if In_Character_Range
(CC
) then
6430 C
:= Get_Character
(CC
);
6431 exit when C
= ASCII
.LF
;
6432 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6433 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6437 -- Here with one line ready to go
6439 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6441 -- If this is a warning in a spec, then we want clients
6442 -- to see the warning, so mark the message with the
6443 -- special sequence !! to force the warning. In the case
6444 -- of a package spec, we do not force this if we are in
6445 -- the private part of the spec.
6448 if Cont
= False then
6449 Error_Msg_N
("<~!!", Arg1
);
6452 Error_Msg_N
("\<~!!", Arg1
);
6455 -- Error, rather than warning, or in a body, so we do not
6456 -- need to force visibility for client (error will be
6457 -- output in any case, and this is the situation in which
6458 -- we do not want a client to get a warning, since the
6459 -- warning is in the body or the spec private part).
6462 if Cont
= False then
6463 Error_Msg_N
("<~", Arg1
);
6466 Error_Msg_N
("\<~", Arg1
);
6470 exit when Ptr
> Len
;
6475 end Process_Compile_Time_Warning_Or_Error
;
6477 ------------------------
6478 -- Process_Convention --
6479 ------------------------
6481 procedure Process_Convention
6482 (C
: out Convention_Id
;
6483 Ent
: out Entity_Id
)
6489 Comp_Unit
: Unit_Number_Type
;
6491 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6492 -- Called if we have more than one Export/Import/Convention pragma.
6493 -- This is generally illegal, but we have a special case of allowing
6494 -- Import and Interface to coexist if they specify the convention in
6495 -- a consistent manner. We are allowed to do this, since Interface is
6496 -- an implementation defined pragma, and we choose to do it since we
6497 -- know Rational allows this combination. S is the entity id of the
6498 -- subprogram in question. This procedure also sets the special flag
6499 -- Import_Interface_Present in both pragmas in the case where we do
6500 -- have matching Import and Interface pragmas.
6502 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6503 -- Set convention in entity E, and also flag that the entity has a
6504 -- convention pragma. If entity is for a private or incomplete type,
6505 -- also set convention and flag on underlying type. This procedure
6506 -- also deals with the special case of C_Pass_By_Copy convention,
6507 -- and error checks for inappropriate convention specification.
6509 -------------------------------
6510 -- Diagnose_Multiple_Pragmas --
6511 -------------------------------
6513 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6514 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6518 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6519 -- Decl is a pragma node. This function returns True if this
6520 -- pragma has a first argument that is an identifier with a
6521 -- Chars field corresponding to the Convention_Id C.
6523 function Same_Name
(Decl
: Node_Id
) return Boolean;
6524 -- Decl is a pragma node. This function returns True if this
6525 -- pragma has a second argument that is an identifier with a
6526 -- Chars field that matches the Chars of the current subprogram.
6528 ---------------------
6529 -- Same_Convention --
6530 ---------------------
6532 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6533 Arg1
: constant Node_Id
:=
6534 First
(Pragma_Argument_Associations
(Decl
));
6537 if Present
(Arg1
) then
6539 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6541 if Nkind
(Arg
) = N_Identifier
6542 and then Is_Convention_Name
(Chars
(Arg
))
6543 and then Get_Convention_Id
(Chars
(Arg
)) = C
6551 end Same_Convention
;
6557 function Same_Name
(Decl
: Node_Id
) return Boolean is
6558 Arg1
: constant Node_Id
:=
6559 First
(Pragma_Argument_Associations
(Decl
));
6567 Arg2
:= Next
(Arg1
);
6574 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6576 if Nkind
(Arg
) = N_Identifier
6577 and then Chars
(Arg
) = Chars
(S
)
6586 -- Start of processing for Diagnose_Multiple_Pragmas
6591 -- Definitely give message if we have Convention/Export here
6593 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6596 -- If we have an Import or Export, scan back from pragma to
6597 -- find any previous pragma applying to the same procedure.
6598 -- The scan will be terminated by the start of the list, or
6599 -- hitting the subprogram declaration. This won't allow one
6600 -- pragma to appear in the public part and one in the private
6601 -- part, but that seems very unlikely in practice.
6605 while Present
(Decl
) and then Decl
/= Pdec
loop
6607 -- Look for pragma with same name as us
6609 if Nkind
(Decl
) = N_Pragma
6610 and then Same_Name
(Decl
)
6612 -- Give error if same as our pragma or Export/Convention
6614 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6620 -- Case of Import/Interface or the other way round
6622 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6625 -- Here we know that we have Import and Interface. It
6626 -- doesn't matter which way round they are. See if
6627 -- they specify the same convention. If so, all OK,
6628 -- and set special flags to stop other messages
6630 if Same_Convention
(Decl
) then
6631 Set_Import_Interface_Present
(N
);
6632 Set_Import_Interface_Present
(Decl
);
6635 -- If different conventions, special message
6638 Error_Msg_Sloc
:= Sloc
(Decl
);
6640 ("convention differs from that given#", Arg1
);
6650 -- Give message if needed if we fall through those tests
6651 -- except on Relaxed_RM_Semantics where we let go: either this
6652 -- is a case accepted/ignored by other Ada compilers (e.g.
6653 -- a mix of Convention and Import), or another error will be
6654 -- generated later (e.g. using both Import and Export).
6656 if Err
and not Relaxed_RM_Semantics
then
6658 ("at most one Convention/Export/Import pragma is allowed",
6661 end Diagnose_Multiple_Pragmas
;
6663 --------------------------------
6664 -- Set_Convention_From_Pragma --
6665 --------------------------------
6667 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6669 -- Ghost convention is allowed only for functions
6671 if Ekind
(E
) /= E_Function
and then C
= Convention_Ghost
then
6673 ("& may not have Ghost convention", E
);
6675 ("\only functions are permitted to have Ghost convention",
6680 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6681 -- for an overridden dispatching operation. Technically this is
6682 -- an amendment and should only be done in Ada 2005 mode. However,
6683 -- this is clearly a mistake, since the problem that is addressed
6684 -- by this AI is that there is a clear gap in the RM.
6686 if Is_Dispatching_Operation
(E
)
6687 and then Present
(Overridden_Operation
(E
))
6688 and then C
/= Convention
(Overridden_Operation
(E
))
6690 -- An attempt to override a function with a ghost function
6691 -- appears as a mismatch in conventions.
6693 if C
= Convention_Ghost
then
6694 Error_Msg_N
("ghost function & cannot be overriding", E
);
6697 ("cannot change convention for overridden dispatching "
6698 & "operation", Arg1
);
6702 -- Special checks for Convention_Stdcall
6704 if C
= Convention_Stdcall
then
6706 -- A dispatching call is not allowed. A dispatching subprogram
6707 -- cannot be used to interface to the Win32 API, so in fact
6708 -- this check does not impose any effective restriction.
6710 if Is_Dispatching_Operation
(E
) then
6711 Error_Msg_Sloc
:= Sloc
(E
);
6713 -- Note: make this unconditional so that if there is more
6714 -- than one call to which the pragma applies, we get a
6715 -- message for each call. Also don't use Error_Pragma,
6716 -- so that we get multiple messages.
6719 ("dispatching subprogram# cannot use Stdcall convention!",
6722 -- Subprogram is allowed, but not a generic subprogram
6724 elsif not Is_Subprogram
(E
)
6725 and then not Is_Generic_Subprogram
(E
)
6729 and then Ekind
(E
) /= E_Variable
6731 -- An access to subprogram is also allowed
6735 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6737 -- Allow internal call to set convention of subprogram type
6739 and then not (Ekind
(E
) = E_Subprogram_Type
)
6742 ("second argument of pragma% must be subprogram (type)",
6747 -- Set the convention
6749 Set_Convention
(E
, C
);
6750 Set_Has_Convention_Pragma
(E
);
6752 -- For the case of a record base type, also set the convention of
6753 -- any anonymous access types declared in the record which do not
6754 -- currently have a specified convention.
6756 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6761 Comp
:= First_Component
(E
);
6762 while Present
(Comp
) loop
6763 if Present
(Etype
(Comp
))
6764 and then Ekind_In
(Etype
(Comp
),
6765 E_Anonymous_Access_Type
,
6766 E_Anonymous_Access_Subprogram_Type
)
6767 and then not Has_Convention_Pragma
(Comp
)
6769 Set_Convention
(Comp
, C
);
6772 Next_Component
(Comp
);
6777 -- Deal with incomplete/private type case, where underlying type
6778 -- is available, so set convention of that underlying type.
6780 if Is_Incomplete_Or_Private_Type
(E
)
6781 and then Present
(Underlying_Type
(E
))
6783 Set_Convention
(Underlying_Type
(E
), C
);
6784 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6787 -- A class-wide type should inherit the convention of the specific
6788 -- root type (although this isn't specified clearly by the RM).
6790 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6791 Set_Convention
(Class_Wide_Type
(E
), C
);
6794 -- If the entity is a record type, then check for special case of
6795 -- C_Pass_By_Copy, which is treated the same as C except that the
6796 -- special record flag is set. This convention is only permitted
6797 -- on record types (see AI95-00131).
6799 if Cname
= Name_C_Pass_By_Copy
then
6800 if Is_Record_Type
(E
) then
6801 Set_C_Pass_By_Copy
(Base_Type
(E
));
6802 elsif Is_Incomplete_Or_Private_Type
(E
)
6803 and then Is_Record_Type
(Underlying_Type
(E
))
6805 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6808 ("C_Pass_By_Copy convention allowed only for record type",
6813 -- If the entity is a derived boolean type, check for the special
6814 -- case of convention C, C++, or Fortran, where we consider any
6815 -- nonzero value to represent true.
6817 if Is_Discrete_Type
(E
)
6818 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6824 C
= Convention_Fortran
)
6826 Set_Nonzero_Is_True
(Base_Type
(E
));
6828 end Set_Convention_From_Pragma
;
6830 -- Start of processing for Process_Convention
6833 Check_At_Least_N_Arguments
(2);
6834 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6835 Check_Arg_Is_Identifier
(Arg1
);
6836 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6838 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6839 -- tested again below to set the critical flag).
6841 if Cname
= Name_C_Pass_By_Copy
then
6844 -- Otherwise we must have something in the standard convention list
6846 elsif Is_Convention_Name
(Cname
) then
6847 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6849 -- In DEC VMS, it seems that there is an undocumented feature that
6850 -- any unrecognized convention is treated as the default, which for
6851 -- us is convention C. It does not seem so terrible to do this
6852 -- unconditionally, silently in the VMS case, and with a warning
6853 -- in the non-VMS case.
6856 if Warn_On_Export_Import
and not OpenVMS_On_Target
then
6858 ("??unrecognized convention name, C assumed",
6859 Get_Pragma_Arg
(Arg1
));
6865 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6866 Check_Arg_Is_Local_Name
(Arg2
);
6868 Id
:= Get_Pragma_Arg
(Arg2
);
6871 if not Is_Entity_Name
(Id
) then
6872 Error_Pragma_Arg
("entity name required", Arg2
);
6877 -- Set entity to return
6881 -- Ada_Pass_By_Copy special checking
6883 if C
= Convention_Ada_Pass_By_Copy
then
6884 if not Is_First_Subtype
(E
) then
6886 ("convention `Ada_Pass_By_Copy` only allowed for types",
6890 if Is_By_Reference_Type
(E
) then
6892 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6897 -- Ada_Pass_By_Reference special checking
6899 if C
= Convention_Ada_Pass_By_Reference
then
6900 if not Is_First_Subtype
(E
) then
6902 ("convention `Ada_Pass_By_Reference` only allowed for types",
6906 if Is_By_Copy_Type
(E
) then
6908 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6913 -- Ghost special checking
6915 if Is_Ghost_Subprogram
(E
)
6916 and then Present
(Overridden_Operation
(E
))
6918 Error_Msg_N
("ghost function & cannot be overriding", E
);
6921 -- Go to renamed subprogram if present, since convention applies to
6922 -- the actual renamed entity, not to the renaming entity. If the
6923 -- subprogram is inherited, go to parent subprogram.
6925 if Is_Subprogram
(E
)
6926 and then Present
(Alias
(E
))
6928 if Nkind
(Parent
(Declaration_Node
(E
))) =
6929 N_Subprogram_Renaming_Declaration
6931 if Scope
(E
) /= Scope
(Alias
(E
)) then
6933 ("cannot apply pragma% to non-local entity&#", E
);
6938 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6939 N_Private_Extension_Declaration
)
6940 and then Scope
(E
) = Scope
(Alias
(E
))
6944 -- Return the parent subprogram the entity was inherited from
6950 -- Check that we are not applying this to a specless body
6951 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
6954 if Is_Subprogram
(E
)
6955 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6956 and then not Relaxed_RM_Semantics
6959 ("pragma% requires separate spec and must come before body");
6962 -- Check that we are not applying this to a named constant
6964 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6965 Error_Msg_Name_1
:= Pname
;
6967 ("cannot apply pragma% to named constant!",
6968 Get_Pragma_Arg
(Arg2
));
6970 ("\supply appropriate type for&!", Arg2
);
6973 if Ekind
(E
) = E_Enumeration_Literal
then
6974 Error_Pragma
("enumeration literal not allowed for pragma%");
6977 -- Check for rep item appearing too early or too late
6979 if Etype
(E
) = Any_Type
6980 or else Rep_Item_Too_Early
(E
, N
)
6984 elsif Present
(Underlying_Type
(E
)) then
6985 E
:= Underlying_Type
(E
);
6988 if Rep_Item_Too_Late
(E
, N
) then
6992 if Has_Convention_Pragma
(E
) then
6993 Diagnose_Multiple_Pragmas
(E
);
6995 elsif Convention
(E
) = Convention_Protected
6996 or else Ekind
(Scope
(E
)) = E_Protected_Type
6999 ("a protected operation cannot be given a different convention",
7003 -- For Intrinsic, a subprogram is required
7005 if C
= Convention_Intrinsic
7006 and then not Is_Subprogram
(E
)
7007 and then not Is_Generic_Subprogram
(E
)
7010 ("second argument of pragma% must be a subprogram", Arg2
);
7013 -- Deal with non-subprogram cases
7015 if not Is_Subprogram
(E
)
7016 and then not Is_Generic_Subprogram
(E
)
7018 Set_Convention_From_Pragma
(E
);
7021 Check_First_Subtype
(Arg2
);
7022 Set_Convention_From_Pragma
(Base_Type
(E
));
7024 -- For access subprograms, we must set the convention on the
7025 -- internally generated directly designated type as well.
7027 if Ekind
(E
) = E_Access_Subprogram_Type
then
7028 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7032 -- For the subprogram case, set proper convention for all homonyms
7033 -- in same scope and the same declarative part, i.e. the same
7034 -- compilation unit.
7037 Comp_Unit
:= Get_Source_Unit
(E
);
7038 Set_Convention_From_Pragma
(E
);
7040 -- Treat a pragma Import as an implicit body, and pragma import
7041 -- as implicit reference (for navigation in GPS).
7043 if Prag_Id
= Pragma_Import
then
7044 Generate_Reference
(E
, Id
, 'b');
7046 -- For exported entities we restrict the generation of references
7047 -- to entities exported to foreign languages since entities
7048 -- exported to Ada do not provide further information to GPS and
7049 -- add undesired references to the output of the gnatxref tool.
7051 elsif Prag_Id
= Pragma_Export
7052 and then Convention
(E
) /= Convention_Ada
7054 Generate_Reference
(E
, Id
, 'i');
7057 -- If the pragma comes from from an aspect, it only applies to the
7058 -- given entity, not its homonyms.
7060 if From_Aspect_Specification
(N
) then
7064 -- Otherwise Loop through the homonyms of the pragma argument's
7065 -- entity, an apply convention to those in the current scope.
7071 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7073 -- Ignore entry for which convention is already set
7075 if Has_Convention_Pragma
(E1
) then
7079 -- Do not set the pragma on inherited operations or on formal
7082 if Comes_From_Source
(E1
)
7083 and then Comp_Unit
= Get_Source_Unit
(E1
)
7084 and then not Is_Formal_Subprogram
(E1
)
7085 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7086 N_Full_Type_Declaration
7088 if Present
(Alias
(E1
))
7089 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7092 ("cannot apply pragma% to non-local entity& declared#",
7096 Set_Convention_From_Pragma
(E1
);
7098 if Prag_Id
= Pragma_Import
then
7099 Generate_Reference
(E1
, Id
, 'b');
7107 end Process_Convention
;
7109 ----------------------------------------
7110 -- Process_Disable_Enable_Atomic_Sync --
7111 ----------------------------------------
7113 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7115 Check_No_Identifiers
;
7116 Check_At_Most_N_Arguments
(1);
7118 -- Modeled internally as
7119 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7123 Pragma_Identifier
=>
7124 Make_Identifier
(Loc
, Nam
),
7125 Pragma_Argument_Associations
=> New_List
(
7126 Make_Pragma_Argument_Association
(Loc
,
7128 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7130 if Present
(Arg1
) then
7131 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7135 end Process_Disable_Enable_Atomic_Sync
;
7137 -----------------------------------------------------
7138 -- Process_Extended_Import_Export_Exception_Pragma --
7139 -----------------------------------------------------
7141 procedure Process_Extended_Import_Export_Exception_Pragma
7142 (Arg_Internal
: Node_Id
;
7143 Arg_External
: Node_Id
;
7151 if not OpenVMS_On_Target
then
7153 ("??pragma% ignored (applies only to Open'V'M'S)");
7156 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7157 Def_Id
:= Entity
(Arg_Internal
);
7159 if Ekind
(Def_Id
) /= E_Exception
then
7161 ("pragma% must refer to declared exception", Arg_Internal
);
7164 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7166 if Present
(Arg_Form
) then
7167 Check_Arg_Is_One_Of
(Arg_Form
, Name_Ada
, Name_VMS
);
7170 if Present
(Arg_Form
)
7171 and then Chars
(Arg_Form
) = Name_Ada
7175 Set_Is_VMS_Exception
(Def_Id
);
7176 Set_Exception_Code
(Def_Id
, No_Uint
);
7179 if Present
(Arg_Code
) then
7180 if not Is_VMS_Exception
(Def_Id
) then
7182 ("Code option for pragma% not allowed for Ada case",
7186 Check_Arg_Is_Static_Expression
(Arg_Code
, Any_Integer
);
7187 Code_Val
:= Expr_Value
(Arg_Code
);
7189 if not UI_Is_In_Int_Range
(Code_Val
) then
7191 ("Code option for pragma% must be in 32-bit range",
7195 Set_Exception_Code
(Def_Id
, Code_Val
);
7198 end Process_Extended_Import_Export_Exception_Pragma
;
7200 -------------------------------------------------
7201 -- Process_Extended_Import_Export_Internal_Arg --
7202 -------------------------------------------------
7204 procedure Process_Extended_Import_Export_Internal_Arg
7205 (Arg_Internal
: Node_Id
:= Empty
)
7208 if No
(Arg_Internal
) then
7209 Error_Pragma
("Internal parameter required for pragma%");
7212 if Nkind
(Arg_Internal
) = N_Identifier
then
7215 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7216 and then (Prag_Id
= Pragma_Import_Function
7218 Prag_Id
= Pragma_Export_Function
)
7224 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7227 Check_Arg_Is_Local_Name
(Arg_Internal
);
7228 end Process_Extended_Import_Export_Internal_Arg
;
7230 --------------------------------------------------
7231 -- Process_Extended_Import_Export_Object_Pragma --
7232 --------------------------------------------------
7234 procedure Process_Extended_Import_Export_Object_Pragma
7235 (Arg_Internal
: Node_Id
;
7236 Arg_External
: Node_Id
;
7242 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7243 Def_Id
:= Entity
(Arg_Internal
);
7245 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7247 ("pragma% must designate an object", Arg_Internal
);
7250 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7252 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7255 ("previous Common/Psect_Object applies, pragma % not permitted",
7259 if Rep_Item_Too_Late
(Def_Id
, N
) then
7263 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7265 if Present
(Arg_Size
) then
7266 Check_Arg_Is_External_Name
(Arg_Size
);
7269 -- Export_Object case
7271 if Prag_Id
= Pragma_Export_Object
then
7272 if not Is_Library_Level_Entity
(Def_Id
) then
7274 ("argument for pragma% must be library level entity",
7278 if Ekind
(Current_Scope
) = E_Generic_Package
then
7279 Error_Pragma
("pragma& cannot appear in a generic unit");
7282 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7284 ("exported object must have compile time known size",
7288 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7289 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7291 Set_Exported
(Def_Id
, Arg_Internal
);
7294 -- Import_Object case
7297 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7299 ("cannot use pragma% for task/protected object",
7303 if Ekind
(Def_Id
) = E_Constant
then
7305 ("cannot import a constant", Arg_Internal
);
7308 if Warn_On_Export_Import
7309 and then Has_Discriminants
(Etype
(Def_Id
))
7312 ("imported value must be initialized??", Arg_Internal
);
7315 if Warn_On_Export_Import
7316 and then Is_Access_Type
(Etype
(Def_Id
))
7319 ("cannot import object of an access type??", Arg_Internal
);
7322 if Warn_On_Export_Import
7323 and then Is_Imported
(Def_Id
)
7325 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7327 -- Check for explicit initialization present. Note that an
7328 -- initialization generated by the code generator, e.g. for an
7329 -- access type, does not count here.
7331 elsif Present
(Expression
(Parent
(Def_Id
)))
7334 (Original_Node
(Expression
(Parent
(Def_Id
))))
7336 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7338 ("imported entities cannot be initialized (RM B.1(24))",
7339 "\no initialization allowed for & declared#", Arg1
);
7341 Set_Imported
(Def_Id
);
7342 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7345 end Process_Extended_Import_Export_Object_Pragma
;
7347 ------------------------------------------------------
7348 -- Process_Extended_Import_Export_Subprogram_Pragma --
7349 ------------------------------------------------------
7351 procedure Process_Extended_Import_Export_Subprogram_Pragma
7352 (Arg_Internal
: Node_Id
;
7353 Arg_External
: Node_Id
;
7354 Arg_Parameter_Types
: Node_Id
;
7355 Arg_Result_Type
: Node_Id
:= Empty
;
7356 Arg_Mechanism
: Node_Id
;
7357 Arg_Result_Mechanism
: Node_Id
:= Empty
;
7358 Arg_First_Optional_Parameter
: Node_Id
:= Empty
)
7364 Ambiguous
: Boolean;
7368 function Same_Base_Type
7370 Formal
: Entity_Id
) return Boolean;
7371 -- Determines if Ptype references the type of Formal. Note that only
7372 -- the base types need to match according to the spec. Ptype here is
7373 -- the argument from the pragma, which is either a type name, or an
7374 -- access attribute.
7376 --------------------
7377 -- Same_Base_Type --
7378 --------------------
7380 function Same_Base_Type
7382 Formal
: Entity_Id
) return Boolean
7384 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7388 -- Case where pragma argument is typ'Access
7390 if Nkind
(Ptype
) = N_Attribute_Reference
7391 and then Attribute_Name
(Ptype
) = Name_Access
7393 Pref
:= Prefix
(Ptype
);
7396 if not Is_Entity_Name
(Pref
)
7397 or else Entity
(Pref
) = Any_Type
7402 -- We have a match if the corresponding argument is of an
7403 -- anonymous access type, and its designated type matches the
7404 -- type of the prefix of the access attribute
7406 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7407 and then Base_Type
(Entity
(Pref
)) =
7408 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7410 -- Case where pragma argument is a type name
7415 if not Is_Entity_Name
(Ptype
)
7416 or else Entity
(Ptype
) = Any_Type
7421 -- We have a match if the corresponding argument is of the type
7422 -- given in the pragma (comparing base types)
7424 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7428 -- Start of processing for
7429 -- Process_Extended_Import_Export_Subprogram_Pragma
7432 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7436 -- Loop through homonyms (overloadings) of the entity
7438 Hom_Id
:= Entity
(Arg_Internal
);
7439 while Present
(Hom_Id
) loop
7440 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7442 -- We need a subprogram in the current scope
7444 if not Is_Subprogram
(Def_Id
)
7445 or else Scope
(Def_Id
) /= Current_Scope
7452 -- Pragma cannot apply to subprogram body
7454 if Is_Subprogram
(Def_Id
)
7455 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7459 ("pragma% requires separate spec"
7460 & " and must come before body");
7463 -- Test result type if given, note that the result type
7464 -- parameter can only be present for the function cases.
7466 if Present
(Arg_Result_Type
)
7467 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7471 elsif Etype
(Def_Id
) /= Standard_Void_Type
7473 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7477 -- Test parameter types if given. Note that this parameter
7478 -- has not been analyzed (and must not be, since it is
7479 -- semantic nonsense), so we get it as the parser left it.
7481 elsif Present
(Arg_Parameter_Types
) then
7482 Check_Matching_Types
: declare
7487 Formal
:= First_Formal
(Def_Id
);
7489 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7490 if Present
(Formal
) then
7494 -- A list of one type, e.g. (List) is parsed as
7495 -- a parenthesized expression.
7497 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7498 and then Paren_Count
(Arg_Parameter_Types
) = 1
7501 or else Present
(Next_Formal
(Formal
))
7506 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7509 -- A list of more than one type is parsed as a aggregate
7511 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7512 and then Paren_Count
(Arg_Parameter_Types
) = 0
7514 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7515 while Present
(Ptype
) or else Present
(Formal
) loop
7518 or else not Same_Base_Type
(Ptype
, Formal
)
7523 Next_Formal
(Formal
);
7528 -- Anything else is of the wrong form
7532 ("wrong form for Parameter_Types parameter",
7533 Arg_Parameter_Types
);
7535 end Check_Matching_Types
;
7538 -- Match is now False if the entry we found did not match
7539 -- either a supplied Parameter_Types or Result_Types argument
7545 -- Ambiguous case, the flag Ambiguous shows if we already
7546 -- detected this and output the initial messages.
7549 if not Ambiguous
then
7551 Error_Msg_Name_1
:= Pname
;
7553 ("pragma% does not uniquely identify subprogram!",
7555 Error_Msg_Sloc
:= Sloc
(Ent
);
7556 Error_Msg_N
("matching subprogram #!", N
);
7560 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7561 Error_Msg_N
("matching subprogram #!", N
);
7566 Hom_Id
:= Homonym
(Hom_Id
);
7569 -- See if we found an entry
7572 if not Ambiguous
then
7573 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7575 ("pragma% cannot be given for generic subprogram");
7578 ("pragma% does not identify local subprogram");
7585 -- Import pragmas must be for imported entities
7587 if Prag_Id
= Pragma_Import_Function
7589 Prag_Id
= Pragma_Import_Procedure
7591 Prag_Id
= Pragma_Import_Valued_Procedure
7593 if not Is_Imported
(Ent
) then
7595 ("pragma Import or Interface must precede pragma%");
7598 -- Here we have the Export case which can set the entity as exported
7600 -- But does not do so if the specified external name is null, since
7601 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7602 -- compatible) to request no external name.
7604 elsif Nkind
(Arg_External
) = N_String_Literal
7605 and then String_Length
(Strval
(Arg_External
)) = 0
7609 -- In all other cases, set entity as exported
7612 Set_Exported
(Ent
, Arg_Internal
);
7615 -- Special processing for Valued_Procedure cases
7617 if Prag_Id
= Pragma_Import_Valued_Procedure
7619 Prag_Id
= Pragma_Export_Valued_Procedure
7621 Formal
:= First_Formal
(Ent
);
7624 Error_Pragma
("at least one parameter required for pragma%");
7626 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7627 Error_Pragma
("first parameter must have mode out for pragma%");
7630 Set_Is_Valued_Procedure
(Ent
);
7634 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7636 -- Process Result_Mechanism argument if present. We have already
7637 -- checked that this is only allowed for the function case.
7639 if Present
(Arg_Result_Mechanism
) then
7640 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7643 -- Process Mechanism parameter if present. Note that this parameter
7644 -- is not analyzed, and must not be analyzed since it is semantic
7645 -- nonsense, so we get it in exactly as the parser left it.
7647 if Present
(Arg_Mechanism
) then
7655 -- A single mechanism association without a formal parameter
7656 -- name is parsed as a parenthesized expression. All other
7657 -- cases are parsed as aggregates, so we rewrite the single
7658 -- parameter case as an aggregate for consistency.
7660 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7661 and then Paren_Count
(Arg_Mechanism
) = 1
7663 Rewrite
(Arg_Mechanism
,
7664 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7665 Expressions
=> New_List
(
7666 Relocate_Node
(Arg_Mechanism
))));
7669 -- Case of only mechanism name given, applies to all formals
7671 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7672 Formal
:= First_Formal
(Ent
);
7673 while Present
(Formal
) loop
7674 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7675 Next_Formal
(Formal
);
7678 -- Case of list of mechanism associations given
7681 if Null_Record_Present
(Arg_Mechanism
) then
7683 ("inappropriate form for Mechanism parameter",
7687 -- Deal with positional ones first
7689 Formal
:= First_Formal
(Ent
);
7691 if Present
(Expressions
(Arg_Mechanism
)) then
7692 Mname
:= First
(Expressions
(Arg_Mechanism
));
7693 while Present
(Mname
) loop
7696 ("too many mechanism associations", Mname
);
7699 Set_Mechanism_Value
(Formal
, Mname
);
7700 Next_Formal
(Formal
);
7705 -- Deal with named entries
7707 if Present
(Component_Associations
(Arg_Mechanism
)) then
7708 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7709 while Present
(Massoc
) loop
7710 Choice
:= First
(Choices
(Massoc
));
7712 if Nkind
(Choice
) /= N_Identifier
7713 or else Present
(Next
(Choice
))
7716 ("incorrect form for mechanism association",
7720 Formal
:= First_Formal
(Ent
);
7724 ("parameter name & not present", Choice
);
7727 if Chars
(Choice
) = Chars
(Formal
) then
7729 (Formal
, Expression
(Massoc
));
7731 -- Set entity on identifier (needed by ASIS)
7733 Set_Entity
(Choice
, Formal
);
7738 Next_Formal
(Formal
);
7748 -- Process First_Optional_Parameter argument if present. We have
7749 -- already checked that this is only allowed for the Import case.
7751 if Present
(Arg_First_Optional_Parameter
) then
7752 if Nkind
(Arg_First_Optional_Parameter
) /= N_Identifier
then
7754 ("first optional parameter must be formal parameter name",
7755 Arg_First_Optional_Parameter
);
7758 Formal
:= First_Formal
(Ent
);
7762 ("specified formal parameter& not found",
7763 Arg_First_Optional_Parameter
);
7766 exit when Chars
(Formal
) =
7767 Chars
(Arg_First_Optional_Parameter
);
7769 Next_Formal
(Formal
);
7772 Set_First_Optional_Parameter
(Ent
, Formal
);
7774 -- Check specified and all remaining formals have right form
7776 while Present
(Formal
) loop
7777 if Ekind
(Formal
) /= E_In_Parameter
then
7779 ("optional formal& is not of mode in!",
7780 Arg_First_Optional_Parameter
, Formal
);
7783 Dval
:= Default_Value
(Formal
);
7787 ("optional formal& does not have default value!",
7788 Arg_First_Optional_Parameter
, Formal
);
7790 elsif Compile_Time_Known_Value_Or_Aggr
(Dval
) then
7795 ("default value for optional formal& is non-static!",
7796 Arg_First_Optional_Parameter
, Formal
);
7800 Set_Is_Optional_Parameter
(Formal
);
7801 Next_Formal
(Formal
);
7804 end Process_Extended_Import_Export_Subprogram_Pragma
;
7806 --------------------------
7807 -- Process_Generic_List --
7808 --------------------------
7810 procedure Process_Generic_List
is
7815 Check_No_Identifiers
;
7816 Check_At_Least_N_Arguments
(1);
7818 -- Check all arguments are names of generic units or instances
7821 while Present
(Arg
) loop
7822 Exp
:= Get_Pragma_Arg
(Arg
);
7825 if not Is_Entity_Name
(Exp
)
7827 (not Is_Generic_Instance
(Entity
(Exp
))
7829 not Is_Generic_Unit
(Entity
(Exp
)))
7832 ("pragma% argument must be name of generic unit/instance",
7838 end Process_Generic_List
;
7840 ------------------------------------
7841 -- Process_Import_Predefined_Type --
7842 ------------------------------------
7844 procedure Process_Import_Predefined_Type
is
7845 Loc
: constant Source_Ptr
:= Sloc
(N
);
7847 Ftyp
: Node_Id
:= Empty
;
7853 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7856 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7857 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7861 Ftyp
:= Node
(Elmt
);
7863 if Present
(Ftyp
) then
7865 -- Don't build a derived type declaration, because predefined C
7866 -- types have no declaration anywhere, so cannot really be named.
7867 -- Instead build a full type declaration, starting with an
7868 -- appropriate type definition is built
7870 if Is_Floating_Point_Type
(Ftyp
) then
7871 Def
:= Make_Floating_Point_Definition
(Loc
,
7872 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7873 Make_Real_Range_Specification
(Loc
,
7874 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7875 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7877 -- Should never have a predefined type we cannot handle
7880 raise Program_Error
;
7883 -- Build and insert a Full_Type_Declaration, which will be
7884 -- analyzed as soon as this list entry has been analyzed.
7886 Decl
:= Make_Full_Type_Declaration
(Loc
,
7887 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7888 Type_Definition
=> Def
);
7890 Insert_After
(N
, Decl
);
7891 Mark_Rewrite_Insertion
(Decl
);
7894 Error_Pragma_Arg
("no matching type found for pragma%",
7897 end Process_Import_Predefined_Type
;
7899 ---------------------------------
7900 -- Process_Import_Or_Interface --
7901 ---------------------------------
7903 procedure Process_Import_Or_Interface
is
7909 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7910 -- pragma Import (Entity, "external name");
7912 if Relaxed_RM_Semantics
7913 and then Arg_Count
= 2
7914 and then Prag_Id
= Pragma_Import
7915 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7918 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7921 if not Is_Entity_Name
(Def_Id
) then
7922 Error_Pragma_Arg
("entity name required", Arg1
);
7925 Def_Id
:= Entity
(Def_Id
);
7926 Kill_Size_Check_Code
(Def_Id
);
7927 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7930 Process_Convention
(C
, Def_Id
);
7931 Kill_Size_Check_Code
(Def_Id
);
7932 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7935 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7937 -- We do not permit Import to apply to a renaming declaration
7939 if Present
(Renamed_Object
(Def_Id
)) then
7941 ("pragma% not allowed for object renaming", Arg2
);
7943 -- User initialization is not allowed for imported object, but
7944 -- the object declaration may contain a default initialization,
7945 -- that will be discarded. Note that an explicit initialization
7946 -- only counts if it comes from source, otherwise it is simply
7947 -- the code generator making an implicit initialization explicit.
7949 elsif Present
(Expression
(Parent
(Def_Id
)))
7950 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
7952 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7954 ("no initialization allowed for declaration of& #",
7955 "\imported entities cannot be initialized (RM B.1(24))",
7959 Set_Imported
(Def_Id
);
7960 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7962 -- Note that we do not set Is_Public here. That's because we
7963 -- only want to set it if there is no address clause, and we
7964 -- don't know that yet, so we delay that processing till
7967 -- pragma Import completes deferred constants
7969 if Ekind
(Def_Id
) = E_Constant
then
7970 Set_Has_Completion
(Def_Id
);
7973 -- It is not possible to import a constant of an unconstrained
7974 -- array type (e.g. string) because there is no simple way to
7975 -- write a meaningful subtype for it.
7977 if Is_Array_Type
(Etype
(Def_Id
))
7978 and then not Is_Constrained
(Etype
(Def_Id
))
7981 ("imported constant& must have a constrained subtype",
7986 elsif Is_Subprogram
(Def_Id
)
7987 or else Is_Generic_Subprogram
(Def_Id
)
7989 -- If the name is overloaded, pragma applies to all of the denoted
7990 -- entities in the same declarative part, unless the pragma comes
7991 -- from an aspect specification.
7994 while Present
(Hom_Id
) loop
7996 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7998 -- Ignore inherited subprograms because the pragma will apply
7999 -- to the parent operation, which is the one called.
8001 if Is_Overloadable
(Def_Id
)
8002 and then Present
(Alias
(Def_Id
))
8006 -- If it is not a subprogram, it must be in an outer scope and
8007 -- pragma does not apply.
8009 elsif not Is_Subprogram
(Def_Id
)
8010 and then not Is_Generic_Subprogram
(Def_Id
)
8014 -- The pragma does not apply to primitives of interfaces
8016 elsif Is_Dispatching_Operation
(Def_Id
)
8017 and then Present
(Find_Dispatching_Type
(Def_Id
))
8018 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8022 -- Verify that the homonym is in the same declarative part (not
8023 -- just the same scope). If the pragma comes from an aspect
8024 -- specification we know that it is part of the declaration.
8026 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8027 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8028 and then not From_Aspect_Specification
(N
)
8033 Set_Imported
(Def_Id
);
8035 -- Reject an Import applied to an abstract subprogram
8037 if Is_Subprogram
(Def_Id
)
8038 and then Is_Abstract_Subprogram
(Def_Id
)
8040 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8042 ("cannot import abstract subprogram& declared#",
8046 -- Special processing for Convention_Intrinsic
8048 if C
= Convention_Intrinsic
then
8050 -- Link_Name argument not allowed for intrinsic
8054 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8056 -- If no external name is present, then check that this
8057 -- is a valid intrinsic subprogram. If an external name
8058 -- is present, then this is handled by the back end.
8061 Check_Intrinsic_Subprogram
8062 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8066 -- Verify that the subprogram does not have a completion
8067 -- through a renaming declaration. For other completions the
8068 -- pragma appears as a too late representation.
8071 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8075 and then Nkind
(Decl
) = N_Subprogram_Declaration
8076 and then Present
(Corresponding_Body
(Decl
))
8077 and then Nkind
(Unit_Declaration_Node
8078 (Corresponding_Body
(Decl
))) =
8079 N_Subprogram_Renaming_Declaration
8081 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8083 ("cannot import&, renaming already provided for "
8084 & "declaration #", N
, Def_Id
);
8088 Set_Has_Completion
(Def_Id
);
8089 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8092 if Is_Compilation_Unit
(Hom_Id
) then
8094 -- Its possible homonyms are not affected by the pragma.
8095 -- Such homonyms might be present in the context of other
8096 -- units being compiled.
8100 elsif From_Aspect_Specification
(N
) then
8104 Hom_Id
:= Homonym
(Hom_Id
);
8108 -- When the convention is Java or CIL, we also allow Import to
8109 -- be given for packages, generic packages, exceptions, record
8110 -- components, and access to subprograms.
8112 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
8114 (Is_Package_Or_Generic_Package
(Def_Id
)
8115 or else Ekind
(Def_Id
) = E_Exception
8116 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
8117 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
8119 Set_Imported
(Def_Id
);
8120 Set_Is_Public
(Def_Id
);
8121 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8123 -- Import a CPP class
8125 elsif C
= Convention_CPP
8126 and then (Is_Record_Type
(Def_Id
)
8127 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8129 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8130 if Present
(Full_View
(Def_Id
)) then
8131 Def_Id
:= Full_View
(Def_Id
);
8135 ("cannot import 'C'P'P type before full declaration seen",
8136 Get_Pragma_Arg
(Arg2
));
8138 -- Although we have reported the error we decorate it as
8139 -- CPP_Class to avoid reporting spurious errors
8141 Set_Is_CPP_Class
(Def_Id
);
8146 -- Types treated as CPP classes must be declared limited (note:
8147 -- this used to be a warning but there is no real benefit to it
8148 -- since we did effectively intend to treat the type as limited
8151 if not Is_Limited_Type
(Def_Id
) then
8153 ("imported 'C'P'P type must be limited",
8154 Get_Pragma_Arg
(Arg2
));
8157 if Etype
(Def_Id
) /= Def_Id
8158 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8160 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8163 Set_Is_CPP_Class
(Def_Id
);
8165 -- Imported CPP types must not have discriminants (because C++
8166 -- classes do not have discriminants).
8168 if Has_Discriminants
(Def_Id
) then
8170 ("imported 'C'P'P type cannot have discriminants",
8171 First
(Discriminant_Specifications
8172 (Declaration_Node
(Def_Id
))));
8175 -- Check that components of imported CPP types do not have default
8176 -- expressions. For private types this check is performed when the
8177 -- full view is analyzed (see Process_Full_View).
8179 if not Is_Private_Type
(Def_Id
) then
8180 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8183 -- Import a CPP exception
8185 elsif C
= Convention_CPP
8186 and then Ekind
(Def_Id
) = E_Exception
8190 ("'External_'Name arguments is required for 'Cpp exception",
8193 -- As only a string is allowed, Check_Arg_Is_External_Name
8195 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
8198 if Present
(Arg4
) then
8200 ("Link_Name argument not allowed for imported Cpp exception",
8204 -- Do not call Set_Interface_Name as the name of the exception
8205 -- shouldn't be modified (and in particular it shouldn't be
8206 -- the External_Name). For exceptions, the External_Name is the
8207 -- name of the RTTI structure.
8209 -- ??? Emit an error if pragma Import/Export_Exception is present
8211 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8213 Check_Arg_Count
(3);
8214 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
8216 Process_Import_Predefined_Type
;
8220 ("second argument of pragma% must be object, subprogram "
8221 & "or incomplete type",
8225 -- If this pragma applies to a compilation unit, then the unit, which
8226 -- is a subprogram, does not require (or allow) a body. We also do
8227 -- not need to elaborate imported procedures.
8229 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8231 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8233 Set_Body_Required
(Cunit
, False);
8236 end Process_Import_Or_Interface
;
8238 --------------------
8239 -- Process_Inline --
8240 --------------------
8242 procedure Process_Inline
(Status
: Inline_Status
) is
8249 Effective
: Boolean := False;
8250 -- Set True if inline has some effect, i.e. if there is at least one
8251 -- subprogram set as inlined as a result of the use of the pragma.
8253 procedure Make_Inline
(Subp
: Entity_Id
);
8254 -- Subp is the defining unit name of the subprogram declaration. Set
8255 -- the flag, as well as the flag in the corresponding body, if there
8258 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8259 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8260 -- Has_Pragma_Inline_Always for the Inline_Always case.
8262 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8263 -- Returns True if it can be determined at this stage that inlining
8264 -- is not possible, for example if the body is available and contains
8265 -- exception handlers, we prevent inlining, since otherwise we can
8266 -- get undefined symbols at link time. This function also emits a
8267 -- warning if front-end inlining is enabled and the pragma appears
8270 -- ??? is business with link symbols still valid, or does it relate
8271 -- to front end ZCX which is being phased out ???
8273 ---------------------------
8274 -- Inlining_Not_Possible --
8275 ---------------------------
8277 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8278 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8282 if Nkind
(Decl
) = N_Subprogram_Body
then
8283 Stats
:= Handled_Statement_Sequence
(Decl
);
8284 return Present
(Exception_Handlers
(Stats
))
8285 or else Present
(At_End_Proc
(Stats
));
8287 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8288 and then Present
(Corresponding_Body
(Decl
))
8290 if Front_End_Inlining
8291 and then Analyzed
(Corresponding_Body
(Decl
))
8293 Error_Msg_N
("pragma appears too late, ignored??", N
);
8296 -- If the subprogram is a renaming as body, the body is just a
8297 -- call to the renamed subprogram, and inlining is trivially
8301 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8302 N_Subprogram_Renaming_Declaration
8308 Handled_Statement_Sequence
8309 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8312 Present
(Exception_Handlers
(Stats
))
8313 or else Present
(At_End_Proc
(Stats
));
8317 -- If body is not available, assume the best, the check is
8318 -- performed again when compiling enclosing package bodies.
8322 end Inlining_Not_Possible
;
8328 procedure Make_Inline
(Subp
: Entity_Id
) is
8329 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8330 Inner_Subp
: Entity_Id
:= Subp
;
8333 -- Ignore if bad type, avoid cascaded error
8335 if Etype
(Subp
) = Any_Type
then
8339 -- Ignore if all inlining is suppressed
8341 elsif Suppress_All_Inlining
then
8345 -- If inlining is not possible, for now do not treat as an error
8347 elsif Status
/= Suppressed
8348 and then Inlining_Not_Possible
(Subp
)
8353 -- Here we have a candidate for inlining, but we must exclude
8354 -- derived operations. Otherwise we would end up trying to inline
8355 -- a phantom declaration, and the result would be to drag in a
8356 -- body which has no direct inlining associated with it. That
8357 -- would not only be inefficient but would also result in the
8358 -- backend doing cross-unit inlining in cases where it was
8359 -- definitely inappropriate to do so.
8361 -- However, a simple Comes_From_Source test is insufficient, since
8362 -- we do want to allow inlining of generic instances which also do
8363 -- not come from source. We also need to recognize specs generated
8364 -- by the front-end for bodies that carry the pragma. Finally,
8365 -- predefined operators do not come from source but are not
8366 -- inlineable either.
8368 elsif Is_Generic_Instance
(Subp
)
8369 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8373 elsif not Comes_From_Source
(Subp
)
8374 and then Scope
(Subp
) /= Standard_Standard
8380 -- The referenced entity must either be the enclosing entity, or
8381 -- an entity declared within the current open scope.
8383 if Present
(Scope
(Subp
))
8384 and then Scope
(Subp
) /= Current_Scope
8385 and then Subp
/= Current_Scope
8388 ("argument of% must be entity in current scope", Assoc
);
8392 -- Processing for procedure, operator or function. If subprogram
8393 -- is aliased (as for an instance) indicate that the renamed
8394 -- entity (if declared in the same unit) is inlined.
8396 if Is_Subprogram
(Subp
) then
8397 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8399 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8400 Set_Inline_Flags
(Inner_Subp
);
8402 Decl
:= Parent
(Parent
(Inner_Subp
));
8404 if Nkind
(Decl
) = N_Subprogram_Declaration
8405 and then Present
(Corresponding_Body
(Decl
))
8407 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8409 elsif Is_Generic_Instance
(Subp
) then
8411 -- Indicate that the body needs to be created for
8412 -- inlining subsequent calls. The instantiation node
8413 -- follows the declaration of the wrapper package
8416 if Scope
(Subp
) /= Standard_Standard
8418 Need_Subprogram_Instance_Body
8419 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8425 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8426 -- appear in a formal part to apply to a formal subprogram.
8427 -- Do not apply check within an instance or a formal package
8428 -- the test will have been applied to the original generic.
8430 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8431 and then List_Containing
(Decl
) = List_Containing
(N
)
8432 and then not In_Instance
8435 ("Inline cannot apply to a formal subprogram", N
);
8437 -- If Subp is a renaming, it is the renamed entity that
8438 -- will appear in any call, and be inlined. However, for
8439 -- ASIS uses it is convenient to indicate that the renaming
8440 -- itself is an inlined subprogram, so that some gnatcheck
8441 -- rules can be applied in the absence of expansion.
8443 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8444 Set_Inline_Flags
(Subp
);
8450 -- For a generic subprogram set flag as well, for use at the point
8451 -- of instantiation, to determine whether the body should be
8454 elsif Is_Generic_Subprogram
(Subp
) then
8455 Set_Inline_Flags
(Subp
);
8458 -- Literals are by definition inlined
8460 elsif Kind
= E_Enumeration_Literal
then
8463 -- Anything else is an error
8467 ("expect subprogram name for pragma%", Assoc
);
8471 ----------------------
8472 -- Set_Inline_Flags --
8473 ----------------------
8475 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8477 -- First set the Has_Pragma_XXX flags and issue the appropriate
8478 -- errors and warnings for suspicious combinations.
8480 if Prag_Id
= Pragma_No_Inline
then
8481 if Has_Pragma_Inline_Always
(Subp
) then
8483 ("Inline_Always and No_Inline are mutually exclusive", N
);
8484 elsif Has_Pragma_Inline
(Subp
) then
8486 ("Inline and No_Inline both specified for& ??",
8487 N
, Entity
(Subp_Id
));
8490 Set_Has_Pragma_No_Inline
(Subp
);
8492 if Prag_Id
= Pragma_Inline_Always
then
8493 if Has_Pragma_No_Inline
(Subp
) then
8495 ("Inline_Always and No_Inline are mutually exclusive",
8499 Set_Has_Pragma_Inline_Always
(Subp
);
8501 if Has_Pragma_No_Inline
(Subp
) then
8503 ("Inline and No_Inline both specified for& ??",
8504 N
, Entity
(Subp_Id
));
8508 if not Has_Pragma_Inline
(Subp
) then
8509 Set_Has_Pragma_Inline
(Subp
);
8514 -- Then adjust the Is_Inlined flag. It can never be set if the
8515 -- subprogram is subject to pragma No_Inline.
8519 Set_Is_Inlined
(Subp
, False);
8523 if not Has_Pragma_No_Inline
(Subp
) then
8524 Set_Is_Inlined
(Subp
, True);
8527 end Set_Inline_Flags
;
8529 -- Start of processing for Process_Inline
8532 Check_No_Identifiers
;
8533 Check_At_Least_N_Arguments
(1);
8535 if Status
= Enabled
then
8536 Inline_Processing_Required
:= True;
8540 while Present
(Assoc
) loop
8541 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8545 if Is_Entity_Name
(Subp_Id
) then
8546 Subp
:= Entity
(Subp_Id
);
8548 if Subp
= Any_Id
then
8550 -- If previous error, avoid cascaded errors
8552 Check_Error_Detected
;
8559 -- For the pragma case, climb homonym chain. This is
8560 -- what implements allowing the pragma in the renaming
8561 -- case, with the result applying to the ancestors, and
8562 -- also allows Inline to apply to all previous homonyms.
8564 if not From_Aspect_Specification
(N
) then
8565 while Present
(Homonym
(Subp
))
8566 and then Scope
(Homonym
(Subp
)) = Current_Scope
8568 Make_Inline
(Homonym
(Subp
));
8569 Subp
:= Homonym
(Subp
);
8577 ("inappropriate argument for pragma%", Assoc
);
8580 and then Warn_On_Redundant_Constructs
8581 and then not (Status
= Suppressed
or else Suppress_All_Inlining
)
8583 if Inlining_Not_Possible
(Subp
) then
8585 ("pragma Inline for& is ignored?r?",
8586 N
, Entity
(Subp_Id
));
8589 ("pragma Inline for& is redundant?r?",
8590 N
, Entity
(Subp_Id
));
8598 ----------------------------
8599 -- Process_Interface_Name --
8600 ----------------------------
8602 procedure Process_Interface_Name
8603 (Subprogram_Def
: Entity_Id
;
8609 String_Val
: String_Id
;
8611 procedure Check_Form_Of_Interface_Name
8613 Ext_Name_Case
: Boolean);
8614 -- SN is a string literal node for an interface name. This routine
8615 -- performs some minimal checks that the name is reasonable. In
8616 -- particular that no spaces or other obviously incorrect characters
8617 -- appear. This is only a warning, since any characters are allowed.
8618 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8620 ----------------------------------
8621 -- Check_Form_Of_Interface_Name --
8622 ----------------------------------
8624 procedure Check_Form_Of_Interface_Name
8626 Ext_Name_Case
: Boolean)
8628 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8629 SL
: constant Nat
:= String_Length
(S
);
8634 Error_Msg_N
("interface name cannot be null string", SN
);
8637 for J
in 1 .. SL
loop
8638 C
:= Get_String_Char
(S
, J
);
8640 -- Look for dubious character and issue unconditional warning.
8641 -- Definitely dubious if not in character range.
8643 if not In_Character_Range
(C
)
8645 -- For all cases except CLI target,
8646 -- commas, spaces and slashes are dubious (in CLI, we use
8647 -- commas and backslashes in external names to specify
8648 -- assembly version and public key, while slashes and spaces
8649 -- can be used in names to mark nested classes and
8652 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8653 and then (Get_Character
(C
) = ','
8655 Get_Character
(C
) = '\'))
8656 or else (VM_Target
/= CLI_Target
8657 and then (Get_Character
(C
) = ' '
8659 Get_Character
(C
) = '/'))
8662 ("??interface name contains illegal character",
8663 Sloc
(SN
) + Source_Ptr
(J
));
8666 end Check_Form_Of_Interface_Name
;
8668 -- Start of processing for Process_Interface_Name
8671 if No
(Link_Arg
) then
8672 if No
(Ext_Arg
) then
8673 if VM_Target
= CLI_Target
8674 and then Ekind
(Subprogram_Def
) = E_Package
8675 and then Nkind
(Parent
(Subprogram_Def
)) =
8676 N_Package_Specification
8677 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8682 (Generic_Parent
(Parent
(Subprogram_Def
))));
8687 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8689 Link_Nam
:= Expression
(Ext_Arg
);
8692 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8693 Ext_Nam
:= Expression
(Ext_Arg
);
8698 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8699 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8700 Ext_Nam
:= Expression
(Ext_Arg
);
8701 Link_Nam
:= Expression
(Link_Arg
);
8704 -- Check expressions for external name and link name are static
8706 if Present
(Ext_Nam
) then
8707 Check_Arg_Is_Static_Expression
(Ext_Nam
, Standard_String
);
8708 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8710 -- Verify that external name is not the name of a local entity,
8711 -- which would hide the imported one and could lead to run-time
8712 -- surprises. The problem can only arise for entities declared in
8713 -- a package body (otherwise the external name is fully qualified
8714 -- and will not conflict).
8722 if Prag_Id
= Pragma_Import
then
8723 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8725 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
8727 if Nam
/= Chars
(Subprogram_Def
)
8728 and then Present
(E
)
8729 and then not Is_Overloadable
(E
)
8730 and then Is_Immediately_Visible
(E
)
8731 and then not Is_Imported
(E
)
8732 and then Ekind
(Scope
(E
)) = E_Package
8735 while Present
(Par
) loop
8736 if Nkind
(Par
) = N_Package_Body
then
8737 Error_Msg_Sloc
:= Sloc
(E
);
8739 ("imported entity is hidden by & declared#",
8744 Par
:= Parent
(Par
);
8751 if Present
(Link_Nam
) then
8752 Check_Arg_Is_Static_Expression
(Link_Nam
, Standard_String
);
8753 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8756 -- If there is no link name, just set the external name
8758 if No
(Link_Nam
) then
8759 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8761 -- For the Link_Name case, the given literal is preceded by an
8762 -- asterisk, which indicates to GCC that the given name should be
8763 -- taken literally, and in particular that no prepending of
8764 -- underlines should occur, even in systems where this is the
8770 if VM_Target
= No_VM
then
8771 Store_String_Char
(Get_Char_Code
('*'));
8774 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8775 Store_String_Chars
(String_Val
);
8777 Make_String_Literal
(Sloc
(Link_Nam
),
8778 Strval
=> End_String
);
8781 -- Set the interface name. If the entity is a generic instance, use
8782 -- its alias, which is the callable entity.
8784 if Is_Generic_Instance
(Subprogram_Def
) then
8785 Set_Encoded_Interface_Name
8786 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8788 Set_Encoded_Interface_Name
8789 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8792 -- We allow duplicated export names in CIL/Java, as they are always
8793 -- enclosed in a namespace that differentiates them, and overloaded
8794 -- entities are supported by the VM.
8796 if Convention
(Subprogram_Def
) /= Convention_CIL
8798 Convention
(Subprogram_Def
) /= Convention_Java
8800 Check_Duplicated_Export_Name
(Link_Nam
);
8802 end Process_Interface_Name
;
8804 -----------------------------------------
8805 -- Process_Interrupt_Or_Attach_Handler --
8806 -----------------------------------------
8808 procedure Process_Interrupt_Or_Attach_Handler
is
8809 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8810 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8811 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8814 Set_Is_Interrupt_Handler
(Handler_Proc
);
8816 -- If the pragma is not associated with a handler procedure within a
8817 -- protected type, then it must be for a nonprotected procedure for
8818 -- the AAMP target, in which case we don't associate a representation
8819 -- item with the procedure's scope.
8821 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8822 if Prag_Id
= Pragma_Interrupt_Handler
8824 Prag_Id
= Pragma_Attach_Handler
8826 Record_Rep_Item
(Proc_Scope
, N
);
8829 end Process_Interrupt_Or_Attach_Handler
;
8831 --------------------------------------------------
8832 -- Process_Restrictions_Or_Restriction_Warnings --
8833 --------------------------------------------------
8835 -- Note: some of the simple identifier cases were handled in par-prag,
8836 -- but it is harmless (and more straightforward) to simply handle all
8837 -- cases here, even if it means we repeat a bit of work in some cases.
8839 procedure Process_Restrictions_Or_Restriction_Warnings
8843 R_Id
: Restriction_Id
;
8849 -- Ignore all Restrictions pragmas in CodePeer mode
8851 if CodePeer_Mode
then
8855 Check_Ada_83_Warning
;
8856 Check_At_Least_N_Arguments
(1);
8857 Check_Valid_Configuration_Pragma
;
8860 while Present
(Arg
) loop
8862 Expr
:= Get_Pragma_Arg
(Arg
);
8864 -- Case of no restriction identifier present
8866 if Id
= No_Name
then
8867 if Nkind
(Expr
) /= N_Identifier
then
8869 ("invalid form for restriction", Arg
);
8874 (Process_Restriction_Synonyms
(Expr
));
8876 if R_Id
not in All_Boolean_Restrictions
then
8877 Error_Msg_Name_1
:= Pname
;
8879 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8881 -- Check for possible misspelling
8883 for J
in Restriction_Id
loop
8885 Rnm
: constant String := Restriction_Id
'Image (J
);
8888 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8889 Name_Len
:= Rnm
'Length;
8890 Set_Casing
(All_Lower_Case
);
8892 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8894 (Identifier_Casing
(Current_Source_File
));
8895 Error_Msg_String
(1 .. Rnm
'Length) :=
8896 Name_Buffer
(1 .. Name_Len
);
8897 Error_Msg_Strlen
:= Rnm
'Length;
8898 Error_Msg_N
-- CODEFIX
8899 ("\possible misspelling of ""~""",
8900 Get_Pragma_Arg
(Arg
));
8909 if Implementation_Restriction
(R_Id
) then
8910 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8913 -- Special processing for No_Elaboration_Code restriction
8915 if R_Id
= No_Elaboration_Code
then
8917 -- Restriction is only recognized within a configuration
8918 -- pragma file, or within a unit of the main extended
8919 -- program. Note: the test for Main_Unit is needed to
8920 -- properly include the case of configuration pragma files.
8922 if not (Current_Sem_Unit
= Main_Unit
8923 or else In_Extended_Main_Source_Unit
(N
))
8927 -- Don't allow in a subunit unless already specified in
8930 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8931 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8932 and then not Restriction_Active
(No_Elaboration_Code
)
8935 ("invalid specification of ""No_Elaboration_Code""",
8938 ("\restriction cannot be specified in a subunit", N
);
8940 ("\unless also specified in body or spec", N
);
8943 -- If we have a No_Elaboration_Code pragma that we
8944 -- accept, then it needs to be added to the configuration
8945 -- restrcition set so that we get proper application to
8946 -- other units in the main extended source as required.
8949 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8953 -- If this is a warning, then set the warning unless we already
8954 -- have a real restriction active (we never want a warning to
8955 -- override a real restriction).
8958 if not Restriction_Active
(R_Id
) then
8959 Set_Restriction
(R_Id
, N
);
8960 Restriction_Warnings
(R_Id
) := True;
8963 -- If real restriction case, then set it and make sure that the
8964 -- restriction warning flag is off, since a real restriction
8965 -- always overrides a warning.
8968 Set_Restriction
(R_Id
, N
);
8969 Restriction_Warnings
(R_Id
) := False;
8972 -- Check for obsolescent restrictions in Ada 2005 mode
8975 and then Ada_Version
>= Ada_2005
8976 and then (R_Id
= No_Asynchronous_Control
8978 R_Id
= No_Unchecked_Deallocation
8980 R_Id
= No_Unchecked_Conversion
)
8982 Check_Restriction
(No_Obsolescent_Features
, N
);
8985 -- A very special case that must be processed here: pragma
8986 -- Restrictions (No_Exceptions) turns off all run-time
8987 -- checking. This is a bit dubious in terms of the formal
8988 -- language definition, but it is what is intended by RM
8989 -- H.4(12). Restriction_Warnings never affects generated code
8990 -- so this is done only in the real restriction case.
8992 -- Atomic_Synchronization is not a real check, so it is not
8993 -- affected by this processing).
8995 if R_Id
= No_Exceptions
and then not Warn
then
8996 for J
in Scope_Suppress
.Suppress
'Range loop
8997 if J
/= Atomic_Synchronization
then
8998 Scope_Suppress
.Suppress
(J
) := True;
9003 -- Case of No_Dependence => unit-name. Note that the parser
9004 -- already made the necessary entry in the No_Dependence table.
9006 elsif Id
= Name_No_Dependence
then
9007 if not OK_No_Dependence_Unit_Name
(Expr
) then
9011 -- Case of No_Specification_Of_Aspect => Identifier.
9013 elsif Id
= Name_No_Specification_Of_Aspect
then
9018 if Nkind
(Expr
) /= N_Identifier
then
9021 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
9024 if A_Id
= No_Aspect
then
9025 Error_Pragma_Arg
("invalid restriction name", Arg
);
9027 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
9031 elsif Id
= Name_No_Use_Of_Attribute
then
9032 if Nkind
(Expr
) /= N_Identifier
9033 or else not Is_Attribute_Name
(Chars
(Expr
))
9035 Error_Msg_N
("unknown attribute name?", Expr
);
9038 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9041 elsif Id
= Name_No_Use_Of_Pragma
then
9042 if Nkind
(Expr
) /= N_Identifier
9043 or else not Is_Pragma_Name
(Chars
(Expr
))
9045 Error_Msg_N
("unknown pragma name?", Expr
);
9048 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9051 -- All other cases of restriction identifier present
9054 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9055 Analyze_And_Resolve
(Expr
, Any_Integer
);
9057 if R_Id
not in All_Parameter_Restrictions
then
9059 ("invalid restriction parameter identifier", Arg
);
9061 elsif not Is_OK_Static_Expression
(Expr
) then
9062 Flag_Non_Static_Expr
9063 ("value must be static expression!", Expr
);
9066 elsif not Is_Integer_Type
(Etype
(Expr
))
9067 or else Expr_Value
(Expr
) < 0
9070 ("value must be non-negative integer", Arg
);
9073 -- Restriction pragma is active
9075 Val
:= Expr_Value
(Expr
);
9077 if not UI_Is_In_Int_Range
(Val
) then
9079 ("pragma ignored, value too large??", Arg
);
9082 -- Warning case. If the real restriction is active, then we
9083 -- ignore the request, since warning never overrides a real
9084 -- restriction. Otherwise we set the proper warning. Note that
9085 -- this circuit sets the warning again if it is already set,
9086 -- which is what we want, since the constant may have changed.
9089 if not Restriction_Active
(R_Id
) then
9091 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9092 Restriction_Warnings
(R_Id
) := True;
9095 -- Real restriction case, set restriction and make sure warning
9096 -- flag is off since real restriction always overrides warning.
9099 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9100 Restriction_Warnings
(R_Id
) := False;
9106 end Process_Restrictions_Or_Restriction_Warnings
;
9108 ---------------------------------
9109 -- Process_Suppress_Unsuppress --
9110 ---------------------------------
9112 -- Note: this procedure makes entries in the check suppress data
9113 -- structures managed by Sem. See spec of package Sem for full
9114 -- details on how we handle recording of check suppression.
9116 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9121 In_Package_Spec
: constant Boolean :=
9122 Is_Package_Or_Generic_Package
(Current_Scope
)
9123 and then not In_Package_Body
(Current_Scope
);
9125 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9126 -- Used to suppress a single check on the given entity
9128 --------------------------------
9129 -- Suppress_Unsuppress_Echeck --
9130 --------------------------------
9132 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9134 -- Check for error of trying to set atomic synchronization for
9135 -- a non-atomic variable.
9137 if C
= Atomic_Synchronization
9138 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9141 ("pragma & requires atomic type or variable",
9142 Pragma_Identifier
(Original_Node
(N
)));
9145 Set_Checks_May_Be_Suppressed
(E
);
9147 if In_Package_Spec
then
9148 Push_Global_Suppress_Stack_Entry
9151 Suppress
=> Suppress_Case
);
9153 Push_Local_Suppress_Stack_Entry
9156 Suppress
=> Suppress_Case
);
9159 -- If this is a first subtype, and the base type is distinct,
9160 -- then also set the suppress flags on the base type.
9162 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9163 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9165 end Suppress_Unsuppress_Echeck
;
9167 -- Start of processing for Process_Suppress_Unsuppress
9170 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9171 -- on user code: we want to generate checks for analysis purposes, as
9172 -- set respectively by -gnatC and -gnatd.F
9174 if (CodePeer_Mode
or GNATprove_Mode
)
9175 and then Comes_From_Source
(N
)
9180 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9181 -- declarative part or a package spec (RM 11.5(5)).
9183 if not Is_Configuration_Pragma
then
9184 Check_Is_In_Decl_Part_Or_Package_Spec
;
9187 Check_At_Least_N_Arguments
(1);
9188 Check_At_Most_N_Arguments
(2);
9189 Check_No_Identifier
(Arg1
);
9190 Check_Arg_Is_Identifier
(Arg1
);
9192 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9194 if C
= No_Check_Id
then
9196 ("argument of pragma% is not valid check name", Arg1
);
9199 if Arg_Count
= 1 then
9201 -- Make an entry in the local scope suppress table. This is the
9202 -- table that directly shows the current value of the scope
9203 -- suppress check for any check id value.
9205 if C
= All_Checks
then
9207 -- For All_Checks, we set all specific predefined checks with
9208 -- the exception of Elaboration_Check, which is handled
9209 -- specially because of not wanting All_Checks to have the
9210 -- effect of deactivating static elaboration order processing.
9211 -- Atomic_Synchronization is also not affected, since this is
9212 -- not a real check.
9214 for J
in Scope_Suppress
.Suppress
'Range loop
9215 if J
/= Elaboration_Check
9217 J
/= Atomic_Synchronization
9219 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9223 -- If not All_Checks, and predefined check, then set appropriate
9224 -- scope entry. Note that we will set Elaboration_Check if this
9225 -- is explicitly specified. Atomic_Synchronization is allowed
9226 -- only if internally generated and entity is atomic.
9228 elsif C
in Predefined_Check_Id
9229 and then (not Comes_From_Source
(N
)
9230 or else C
/= Atomic_Synchronization
)
9232 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9235 -- Also make an entry in the Local_Entity_Suppress table
9237 Push_Local_Suppress_Stack_Entry
9240 Suppress
=> Suppress_Case
);
9242 -- Case of two arguments present, where the check is suppressed for
9243 -- a specified entity (given as the second argument of the pragma)
9246 -- This is obsolescent in Ada 2005 mode
9248 if Ada_Version
>= Ada_2005
then
9249 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9252 Check_Optional_Identifier
(Arg2
, Name_On
);
9253 E_Id
:= Get_Pragma_Arg
(Arg2
);
9256 if not Is_Entity_Name
(E_Id
) then
9258 ("second argument of pragma% must be entity name", Arg2
);
9267 -- Enforce RM 11.5(7) which requires that for a pragma that
9268 -- appears within a package spec, the named entity must be
9269 -- within the package spec. We allow the package name itself
9270 -- to be mentioned since that makes sense, although it is not
9271 -- strictly allowed by 11.5(7).
9274 and then E
/= Current_Scope
9275 and then Scope
(E
) /= Current_Scope
9278 ("entity in pragma% is not in package spec (RM 11.5(7))",
9282 -- Loop through homonyms. As noted below, in the case of a package
9283 -- spec, only homonyms within the package spec are considered.
9286 Suppress_Unsuppress_Echeck
(E
, C
);
9288 if Is_Generic_Instance
(E
)
9289 and then Is_Subprogram
(E
)
9290 and then Present
(Alias
(E
))
9292 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9295 -- Move to next homonym if not aspect spec case
9297 exit when From_Aspect_Specification
(N
);
9301 -- If we are within a package specification, the pragma only
9302 -- applies to homonyms in the same scope.
9304 exit when In_Package_Spec
9305 and then Scope
(E
) /= Current_Scope
;
9308 end Process_Suppress_Unsuppress
;
9314 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9316 if Is_Imported
(E
) then
9318 ("cannot export entity& that was previously imported", Arg
);
9320 elsif Present
(Address_Clause
(E
))
9321 and then not Relaxed_RM_Semantics
9324 ("cannot export entity& that has an address clause", Arg
);
9327 Set_Is_Exported
(E
);
9329 -- Generate a reference for entity explicitly, because the
9330 -- identifier may be overloaded and name resolution will not
9333 Generate_Reference
(E
, Arg
);
9335 -- Deal with exporting non-library level entity
9337 if not Is_Library_Level_Entity
(E
) then
9339 -- Not allowed at all for subprograms
9341 if Is_Subprogram
(E
) then
9342 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9344 -- Otherwise set public and statically allocated
9348 Set_Is_Statically_Allocated
(E
);
9350 -- Warn if the corresponding W flag is set and the pragma comes
9351 -- from source. The latter may not be true e.g. on VMS where we
9352 -- expand export pragmas for exception codes associated with
9353 -- imported or exported exceptions. We do not want to generate
9354 -- a warning for something that the user did not write.
9356 if Warn_On_Export_Import
9357 and then Comes_From_Source
(Arg
)
9360 ("?x?& has been made static as a result of Export",
9363 ("\?x?this usage is non-standard and non-portable",
9369 if Warn_On_Export_Import
and then Is_Type
(E
) then
9370 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9373 if Warn_On_Export_Import
and Inside_A_Generic
then
9375 ("all instances of& will have the same external name?x?",
9380 ----------------------------------------------
9381 -- Set_Extended_Import_Export_External_Name --
9382 ----------------------------------------------
9384 procedure Set_Extended_Import_Export_External_Name
9385 (Internal_Ent
: Entity_Id
;
9386 Arg_External
: Node_Id
)
9388 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9392 if No
(Arg_External
) then
9396 Check_Arg_Is_External_Name
(Arg_External
);
9398 if Nkind
(Arg_External
) = N_String_Literal
then
9399 if String_Length
(Strval
(Arg_External
)) = 0 then
9402 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9405 elsif Nkind
(Arg_External
) = N_Identifier
then
9406 New_Name
:= Get_Default_External_Name
(Arg_External
);
9408 -- Check_Arg_Is_External_Name should let through only identifiers and
9409 -- string literals or static string expressions (which are folded to
9410 -- string literals).
9413 raise Program_Error
;
9416 -- If we already have an external name set (by a prior normal Import
9417 -- or Export pragma), then the external names must match
9419 if Present
(Interface_Name
(Internal_Ent
)) then
9421 -- Ignore mismatching names in CodePeer mode, to support some
9422 -- old compilers which would export the same procedure under
9423 -- different names, e.g:
9425 -- pragma Export_Procedure (P, "a");
9426 -- pragma Export_Procedure (P, "b");
9428 if CodePeer_Mode
then
9432 Check_Matching_Internal_Names
: declare
9433 S1
: constant String_Id
:= Strval
(Old_Name
);
9434 S2
: constant String_Id
:= Strval
(New_Name
);
9437 pragma No_Return
(Mismatch
);
9438 -- Called if names do not match
9444 procedure Mismatch
is
9446 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9448 ("external name does not match that given #",
9452 -- Start of processing for Check_Matching_Internal_Names
9455 if String_Length
(S1
) /= String_Length
(S2
) then
9459 for J
in 1 .. String_Length
(S1
) loop
9460 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9465 end Check_Matching_Internal_Names
;
9467 -- Otherwise set the given name
9470 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9471 Check_Duplicated_Export_Name
(New_Name
);
9473 end Set_Extended_Import_Export_External_Name
;
9479 procedure Set_Imported
(E
: Entity_Id
) is
9481 -- Error message if already imported or exported
9483 if Is_Exported
(E
) or else Is_Imported
(E
) then
9485 -- Error if being set Exported twice
9487 if Is_Exported
(E
) then
9488 Error_Msg_NE
("entity& was previously exported", N
, E
);
9490 -- Ignore error in CodePeer mode where we treat all imported
9491 -- subprograms as unknown.
9493 elsif CodePeer_Mode
then
9496 -- OK if Import/Interface case
9498 elsif Import_Interface_Present
(N
) then
9501 -- Error if being set Imported twice
9504 Error_Msg_NE
("entity& was previously imported", N
, E
);
9507 Error_Msg_Name_1
:= Pname
;
9509 ("\(pragma% applies to all previous entities)", N
);
9511 Error_Msg_Sloc
:= Sloc
(E
);
9512 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9514 -- Here if not previously imported or exported, OK to import
9517 Set_Is_Imported
(E
);
9519 -- For subprogram, set Import_Pragma field
9521 if Is_Subprogram
(E
) then
9522 Set_Import_Pragma
(E
, N
);
9525 -- If the entity is an object that is not at the library level,
9526 -- then it is statically allocated. We do not worry about objects
9527 -- with address clauses in this context since they are not really
9528 -- imported in the linker sense.
9531 and then not Is_Library_Level_Entity
(E
)
9532 and then No
(Address_Clause
(E
))
9534 Set_Is_Statically_Allocated
(E
);
9541 -------------------------
9542 -- Set_Mechanism_Value --
9543 -------------------------
9545 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9546 -- analyzed, since it is semantic nonsense), so we get it in the exact
9547 -- form created by the parser.
9549 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9552 Mech_Name_Id
: Name_Id
;
9554 procedure Bad_Class
;
9555 pragma No_Return
(Bad_Class
);
9556 -- Signal bad descriptor class name
9558 procedure Bad_Mechanism
;
9559 pragma No_Return
(Bad_Mechanism
);
9560 -- Signal bad mechanism name
9566 procedure Bad_Class
is
9568 Error_Pragma_Arg
("unrecognized descriptor class name", Class
);
9571 -------------------------
9572 -- Bad_Mechanism_Value --
9573 -------------------------
9575 procedure Bad_Mechanism
is
9577 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9580 -- Start of processing for Set_Mechanism_Value
9583 if Mechanism
(Ent
) /= Default_Mechanism
then
9585 ("mechanism for & has already been set", Mech_Name
, Ent
);
9588 -- MECHANISM_NAME ::= value | reference | descriptor |
9591 if Nkind
(Mech_Name
) = N_Identifier
then
9592 if Chars
(Mech_Name
) = Name_Value
then
9593 Set_Mechanism
(Ent
, By_Copy
);
9596 elsif Chars
(Mech_Name
) = Name_Reference
then
9597 Set_Mechanism
(Ent
, By_Reference
);
9600 elsif Chars
(Mech_Name
) = Name_Descriptor
then
9601 Check_VMS
(Mech_Name
);
9603 -- Descriptor => Short_Descriptor if pragma was given
9605 if Short_Descriptors
then
9606 Set_Mechanism
(Ent
, By_Short_Descriptor
);
9608 Set_Mechanism
(Ent
, By_Descriptor
);
9613 elsif Chars
(Mech_Name
) = Name_Short_Descriptor
then
9614 Check_VMS
(Mech_Name
);
9615 Set_Mechanism
(Ent
, By_Short_Descriptor
);
9618 elsif Chars
(Mech_Name
) = Name_Copy
then
9620 ("bad mechanism name, Value assumed", Mech_Name
);
9626 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
9627 -- short_descriptor (CLASS_NAME)
9628 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9630 -- Note: this form is parsed as an indexed component
9632 elsif Nkind
(Mech_Name
) = N_Indexed_Component
then
9633 Class
:= First
(Expressions
(Mech_Name
));
9635 if Nkind
(Prefix
(Mech_Name
)) /= N_Identifier
9637 not Nam_In
(Chars
(Prefix
(Mech_Name
)), Name_Descriptor
,
9638 Name_Short_Descriptor
)
9639 or else Present
(Next
(Class
))
9643 Mech_Name_Id
:= Chars
(Prefix
(Mech_Name
));
9645 -- Change Descriptor => Short_Descriptor if pragma was given
9647 if Mech_Name_Id
= Name_Descriptor
9648 and then Short_Descriptors
9650 Mech_Name_Id
:= Name_Short_Descriptor
;
9654 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
9655 -- short_descriptor (Class => CLASS_NAME)
9656 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9658 -- Note: this form is parsed as a function call
9660 elsif Nkind
(Mech_Name
) = N_Function_Call
then
9661 Param
:= First
(Parameter_Associations
(Mech_Name
));
9663 if Nkind
(Name
(Mech_Name
)) /= N_Identifier
9665 not Nam_In
(Chars
(Name
(Mech_Name
)), Name_Descriptor
,
9666 Name_Short_Descriptor
)
9667 or else Present
(Next
(Param
))
9668 or else No
(Selector_Name
(Param
))
9669 or else Chars
(Selector_Name
(Param
)) /= Name_Class
9673 Class
:= Explicit_Actual_Parameter
(Param
);
9674 Mech_Name_Id
:= Chars
(Name
(Mech_Name
));
9681 -- Fall through here with Class set to descriptor class name
9683 Check_VMS
(Mech_Name
);
9685 if Nkind
(Class
) /= N_Identifier
then
9688 elsif Mech_Name_Id
= Name_Descriptor
9689 and then Chars
(Class
) = Name_UBS
9691 Set_Mechanism
(Ent
, By_Descriptor_UBS
);
9693 elsif Mech_Name_Id
= Name_Descriptor
9694 and then Chars
(Class
) = Name_UBSB
9696 Set_Mechanism
(Ent
, By_Descriptor_UBSB
);
9698 elsif Mech_Name_Id
= Name_Descriptor
9699 and then Chars
(Class
) = Name_UBA
9701 Set_Mechanism
(Ent
, By_Descriptor_UBA
);
9703 elsif Mech_Name_Id
= Name_Descriptor
9704 and then Chars
(Class
) = Name_S
9706 Set_Mechanism
(Ent
, By_Descriptor_S
);
9708 elsif Mech_Name_Id
= Name_Descriptor
9709 and then Chars
(Class
) = Name_SB
9711 Set_Mechanism
(Ent
, By_Descriptor_SB
);
9713 elsif Mech_Name_Id
= Name_Descriptor
9714 and then Chars
(Class
) = Name_A
9716 Set_Mechanism
(Ent
, By_Descriptor_A
);
9718 elsif Mech_Name_Id
= Name_Descriptor
9719 and then Chars
(Class
) = Name_NCA
9721 Set_Mechanism
(Ent
, By_Descriptor_NCA
);
9723 elsif Mech_Name_Id
= Name_Short_Descriptor
9724 and then Chars
(Class
) = Name_UBS
9726 Set_Mechanism
(Ent
, By_Short_Descriptor_UBS
);
9728 elsif Mech_Name_Id
= Name_Short_Descriptor
9729 and then Chars
(Class
) = Name_UBSB
9731 Set_Mechanism
(Ent
, By_Short_Descriptor_UBSB
);
9733 elsif Mech_Name_Id
= Name_Short_Descriptor
9734 and then Chars
(Class
) = Name_UBA
9736 Set_Mechanism
(Ent
, By_Short_Descriptor_UBA
);
9738 elsif Mech_Name_Id
= Name_Short_Descriptor
9739 and then Chars
(Class
) = Name_S
9741 Set_Mechanism
(Ent
, By_Short_Descriptor_S
);
9743 elsif Mech_Name_Id
= Name_Short_Descriptor
9744 and then Chars
(Class
) = Name_SB
9746 Set_Mechanism
(Ent
, By_Short_Descriptor_SB
);
9748 elsif Mech_Name_Id
= Name_Short_Descriptor
9749 and then Chars
(Class
) = Name_A
9751 Set_Mechanism
(Ent
, By_Short_Descriptor_A
);
9753 elsif Mech_Name_Id
= Name_Short_Descriptor
9754 and then Chars
(Class
) = Name_NCA
9756 Set_Mechanism
(Ent
, By_Short_Descriptor_NCA
);
9761 end Set_Mechanism_Value
;
9763 --------------------------
9764 -- Set_Rational_Profile --
9765 --------------------------
9767 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9768 -- and extension to the semantics of renaming declarations.
9770 procedure Set_Rational_Profile
is
9772 Implicit_Packing
:= True;
9773 Overriding_Renamings
:= True;
9774 Use_VADS_Size
:= True;
9775 end Set_Rational_Profile
;
9777 ---------------------------
9778 -- Set_Ravenscar_Profile --
9779 ---------------------------
9781 -- The tasks to be done here are
9783 -- Set required policies
9785 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9786 -- pragma Locking_Policy (Ceiling_Locking)
9788 -- Set Detect_Blocking mode
9790 -- Set required restrictions (see System.Rident for detailed list)
9792 -- Set the No_Dependence rules
9793 -- No_Dependence => Ada.Asynchronous_Task_Control
9794 -- No_Dependence => Ada.Calendar
9795 -- No_Dependence => Ada.Execution_Time.Group_Budget
9796 -- No_Dependence => Ada.Execution_Time.Timers
9797 -- No_Dependence => Ada.Task_Attributes
9798 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9800 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9801 Prefix_Entity
: Entity_Id
;
9802 Selector_Entity
: Entity_Id
;
9803 Prefix_Node
: Node_Id
;
9807 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9809 if Task_Dispatching_Policy
/= ' '
9810 and then Task_Dispatching_Policy
/= 'F'
9812 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9813 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9815 -- Set the FIFO_Within_Priorities policy, but always preserve
9816 -- System_Location since we like the error message with the run time
9820 Task_Dispatching_Policy
:= 'F';
9822 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9823 Task_Dispatching_Policy_Sloc
:= Loc
;
9827 -- pragma Locking_Policy (Ceiling_Locking)
9829 if Locking_Policy
/= ' '
9830 and then Locking_Policy
/= 'C'
9832 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9833 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9835 -- Set the Ceiling_Locking policy, but preserve System_Location since
9836 -- we like the error message with the run time name.
9839 Locking_Policy
:= 'C';
9841 if Locking_Policy_Sloc
/= System_Location
then
9842 Locking_Policy_Sloc
:= Loc
;
9846 -- pragma Detect_Blocking
9848 Detect_Blocking
:= True;
9850 -- Set the corresponding restrictions
9852 Set_Profile_Restrictions
9853 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9855 -- Set the No_Dependence restrictions
9857 -- The following No_Dependence restrictions:
9858 -- No_Dependence => Ada.Asynchronous_Task_Control
9859 -- No_Dependence => Ada.Calendar
9860 -- No_Dependence => Ada.Task_Attributes
9861 -- are already set by previous call to Set_Profile_Restrictions.
9863 -- Set the following restrictions which were added to Ada 2005:
9864 -- No_Dependence => Ada.Execution_Time.Group_Budget
9865 -- No_Dependence => Ada.Execution_Time.Timers
9867 if Ada_Version
>= Ada_2005
then
9868 Name_Buffer
(1 .. 3) := "ada";
9871 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9873 Name_Buffer
(1 .. 14) := "execution_time";
9876 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9879 Make_Selected_Component
9881 Prefix
=> Prefix_Entity
,
9882 Selector_Name
=> Selector_Entity
);
9884 Name_Buffer
(1 .. 13) := "group_budgets";
9887 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9890 Make_Selected_Component
9892 Prefix
=> Prefix_Node
,
9893 Selector_Name
=> Selector_Entity
);
9895 Set_Restriction_No_Dependence
9897 Warn
=> Treat_Restrictions_As_Warnings
,
9898 Profile
=> Ravenscar
);
9900 Name_Buffer
(1 .. 6) := "timers";
9903 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9906 Make_Selected_Component
9908 Prefix
=> Prefix_Node
,
9909 Selector_Name
=> Selector_Entity
);
9911 Set_Restriction_No_Dependence
9913 Warn
=> Treat_Restrictions_As_Warnings
,
9914 Profile
=> Ravenscar
);
9917 -- Set the following restrictions which was added to Ada 2012 (see
9919 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9921 if Ada_Version
>= Ada_2012
then
9922 Name_Buffer
(1 .. 6) := "system";
9925 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9927 Name_Buffer
(1 .. 15) := "multiprocessors";
9930 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9933 Make_Selected_Component
9935 Prefix
=> Prefix_Entity
,
9936 Selector_Name
=> Selector_Entity
);
9938 Name_Buffer
(1 .. 19) := "dispatching_domains";
9941 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9944 Make_Selected_Component
9946 Prefix
=> Prefix_Node
,
9947 Selector_Name
=> Selector_Entity
);
9949 Set_Restriction_No_Dependence
9951 Warn
=> Treat_Restrictions_As_Warnings
,
9952 Profile
=> Ravenscar
);
9954 end Set_Ravenscar_Profile
;
9956 -- Start of processing for Analyze_Pragma
9959 -- The following code is a defense against recursion. Not clear that
9960 -- this can happen legitimately, but perhaps some error situations
9961 -- can cause it, and we did see this recursion during testing.
9963 if Analyzed
(N
) then
9966 Set_Analyzed
(N
, True);
9969 -- Deal with unrecognized pragma
9971 Pname
:= Pragma_Name
(N
);
9973 if not Is_Pragma_Name
(Pname
) then
9974 if Warn_On_Unrecognized_Pragma
then
9975 Error_Msg_Name_1
:= Pname
;
9976 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9978 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9979 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9980 Error_Msg_Name_1
:= PN
;
9981 Error_Msg_N
-- CODEFIX
9982 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9991 -- Here to start processing for recognized pragma
9993 Prag_Id
:= Get_Pragma_Id
(Pname
);
9994 Pname
:= Original_Aspect_Name
(N
);
9996 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9997 -- is already set, indicating that we have already checked the policy
9998 -- at the right point. This happens for example in the case of a pragma
9999 -- that is derived from an Aspect.
10001 if Is_Ignored
(N
) or else Is_Checked
(N
) then
10004 -- For a pragma that is a rewriting of another pragma, copy the
10005 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10007 elsif Is_Rewrite_Substitution
(N
)
10008 and then Nkind
(Original_Node
(N
)) = N_Pragma
10009 and then Original_Node
(N
) /= N
10011 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
10012 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
10014 -- Otherwise query the applicable policy at this point
10017 Check_Applicable_Policy
(N
);
10019 -- If pragma is disabled, rewrite as NULL and skip analysis
10021 if Is_Disabled
(N
) then
10022 Rewrite
(N
, Make_Null_Statement
(Loc
));
10028 -- Preset arguments
10036 if Present
(Pragma_Argument_Associations
(N
)) then
10037 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
10038 Arg1
:= First
(Pragma_Argument_Associations
(N
));
10040 if Present
(Arg1
) then
10041 Arg2
:= Next
(Arg1
);
10043 if Present
(Arg2
) then
10044 Arg3
:= Next
(Arg2
);
10046 if Present
(Arg3
) then
10047 Arg4
:= Next
(Arg3
);
10053 Check_Restriction_No_Use_Of_Pragma
(N
);
10055 -- An enumeration type defines the pragmas that are supported by the
10056 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10057 -- into the corresponding enumeration value for the following case.
10065 -- pragma Abort_Defer;
10067 when Pragma_Abort_Defer
=>
10069 Check_Arg_Count
(0);
10071 -- The only required semantic processing is to check the
10072 -- placement. This pragma must appear at the start of the
10073 -- statement sequence of a handled sequence of statements.
10075 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
10076 or else N
/= First
(Statements
(Parent
(N
)))
10081 --------------------
10082 -- Abstract_State --
10083 --------------------
10085 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10087 -- ABSTRACT_STATE_LIST ::=
10089 -- | STATE_NAME_WITH_OPTIONS
10090 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
10092 -- STATE_NAME_WITH_OPTIONS ::=
10094 -- | (STATE_NAME with OPTION_LIST)
10096 -- OPTION_LIST ::= OPTION {, OPTION}
10100 -- | NAME_VALUE_OPTION
10102 -- SIMPLE_OPTION ::= identifier
10104 -- NAME_VALUE_OPTION ::=
10105 -- Part_Of => ABSTRACT_STATE
10106 -- | External [=> EXTERNAL_PROPERTY_LIST]
10108 -- EXTERNAL_PROPERTY_LIST ::=
10109 -- EXTERNAL_PROPERTY
10110 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
10112 -- EXTERNAL_PROPERTY ::=
10113 -- Async_Readers [=> boolean_EXPRESSION]
10114 -- | Async_Writers [=> boolean_EXPRESSION]
10115 -- | Effective_Reads [=> boolean_EXPRESSION]
10116 -- | Effective_Writes [=> boolean_EXPRESSION]
10117 -- others => boolean_EXPRESSION
10119 -- STATE_NAME ::= defining_identifier
10121 -- ABSTRACT_STATE ::= name
10123 when Pragma_Abstract_State
=> Abstract_State
: declare
10125 -- Flags used to verify the consistency of states
10127 Non_Null_Seen
: Boolean := False;
10128 Null_Seen
: Boolean := False;
10130 Pack_Id
: Entity_Id
;
10131 -- Entity of related package when pragma Abstract_State appears
10133 procedure Analyze_Abstract_State
(State
: Node_Id
);
10134 -- Verify the legality of a single state declaration. Create and
10135 -- decorate a state abstraction entity and introduce it into the
10136 -- visibility chain.
10138 procedure Check_State_Declaration_Syntax
(State
: Node_Id
);
10139 -- Verify the syntex of state declaration State
10141 ----------------------------
10142 -- Analyze_Abstract_State --
10143 ----------------------------
10145 procedure Analyze_Abstract_State
(State
: Node_Id
) is
10147 -- Flags used to verify the consistency of options
10149 AR_Seen
: Boolean := False;
10150 AW_Seen
: Boolean := False;
10151 ER_Seen
: Boolean := False;
10152 EW_Seen
: Boolean := False;
10153 External_Seen
: Boolean := False;
10154 Others_Seen
: Boolean := False;
10155 Part_Of_Seen
: Boolean := False;
10157 -- Flags used to store the static value of all external states'
10160 AR_Val
: Boolean := False;
10161 AW_Val
: Boolean := False;
10162 ER_Val
: Boolean := False;
10163 EW_Val
: Boolean := False;
10165 State_Id
: Entity_Id
:= Empty
;
10166 -- The entity to be generated for the current state declaration
10168 procedure Analyze_External_Option
(Opt
: Node_Id
);
10169 -- Verify the legality of option External
10171 procedure Analyze_External_Property
10173 Expr
: Node_Id
:= Empty
);
10174 -- Verify the legailty of a single external property. Prop
10175 -- denotes the external property. Expr is the expression used
10176 -- to set the property.
10178 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
10179 -- Verify the legality of option Part_Of
10181 procedure Check_Duplicate_Option
10183 Status
: in out Boolean);
10184 -- Flag Status denotes whether a particular option has been
10185 -- seen while processing a state. This routine verifies that
10186 -- Opt is not a duplicate option and sets the flag Status
10187 -- (SPARK RM 7.1.4(1)).
10189 procedure Check_Duplicate_Property
10191 Status
: in out Boolean);
10192 -- Flag Status denotes whether a particular property has been
10193 -- seen while processing option External. This routine verifies
10194 -- that Prop is not a duplicate property and sets flag Status.
10195 -- Opt is not a duplicate property and sets the flag Status.
10196 -- (SPARK RM 7.1.4(2))
10198 procedure Create_Abstract_State
10202 Is_Null
: Boolean);
10203 -- Generate an abstract state entity with name Nam and enter it
10204 -- into visibility. Decl is the "declaration" of the state as
10205 -- it appears in pragma Abstract_State. Loc is the location of
10206 -- the related state "declaration". Flag Is_Null should be set
10207 -- when the associated Abstract_State pragma defines a null
10210 -----------------------------
10211 -- Analyze_External_Option --
10212 -----------------------------
10214 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10215 Errors
: constant Nat
:= Serious_Errors_Detected
;
10217 Props
: Node_Id
:= Empty
;
10220 Check_Duplicate_Option
(Opt
, External_Seen
);
10222 if Nkind
(Opt
) = N_Component_Association
then
10223 Props
:= Expression
(Opt
);
10226 -- External state with properties
10228 if Present
(Props
) then
10230 -- Multiple properties appear as an aggregate
10232 if Nkind
(Props
) = N_Aggregate
then
10234 -- Simple property form
10236 Prop
:= First
(Expressions
(Props
));
10237 while Present
(Prop
) loop
10238 Analyze_External_Property
(Prop
);
10242 -- Property with expression form
10244 Prop
:= First
(Component_Associations
(Props
));
10245 while Present
(Prop
) loop
10246 Analyze_External_Property
10247 (Prop
=> First
(Choices
(Prop
)),
10248 Expr
=> Expression
(Prop
));
10256 Analyze_External_Property
(Props
);
10259 -- An external state defined without any properties defaults
10260 -- all properties to True.
10269 -- Once all external properties have been processed, verify
10270 -- their mutual interaction. Do not perform the check when
10271 -- at least one of the properties is illegal as this will
10272 -- produce a bogus error.
10274 if Errors
= Serious_Errors_Detected
then
10275 Check_External_Properties
10276 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10278 end Analyze_External_Option
;
10280 -------------------------------
10281 -- Analyze_External_Property --
10282 -------------------------------
10284 procedure Analyze_External_Property
10286 Expr
: Node_Id
:= Empty
)
10288 Expr_Val
: Boolean;
10291 -- Check the placement of "others" (if available)
10293 if Nkind
(Prop
) = N_Others_Choice
then
10294 if Others_Seen
then
10296 ("only one others choice allowed in option External",
10299 Others_Seen
:= True;
10302 elsif Others_Seen
then
10304 ("others must be the last property in option External",
10307 -- The only remaining legal options are the four predefined
10308 -- external properties.
10310 elsif Nkind
(Prop
) = N_Identifier
10311 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10312 Name_Async_Writers
,
10313 Name_Effective_Reads
,
10314 Name_Effective_Writes
)
10318 -- Otherwise the construct is not a valid property
10321 Error_Msg_N
("invalid external state property", Prop
);
10325 -- Ensure that the expression of the external state property
10326 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10328 if Present
(Expr
) then
10329 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10331 if Is_Static_Expression
(Expr
) then
10332 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10335 ("expression of external state property must be "
10339 -- The lack of expression defaults the property to True
10345 -- Named properties
10347 if Nkind
(Prop
) = N_Identifier
then
10348 if Chars
(Prop
) = Name_Async_Readers
then
10349 Check_Duplicate_Property
(Prop
, AR_Seen
);
10350 AR_Val
:= Expr_Val
;
10352 elsif Chars
(Prop
) = Name_Async_Writers
then
10353 Check_Duplicate_Property
(Prop
, AW_Seen
);
10354 AW_Val
:= Expr_Val
;
10356 elsif Chars
(Prop
) = Name_Effective_Reads
then
10357 Check_Duplicate_Property
(Prop
, ER_Seen
);
10358 ER_Val
:= Expr_Val
;
10361 Check_Duplicate_Property
(Prop
, EW_Seen
);
10362 EW_Val
:= Expr_Val
;
10365 -- The handling of property "others" must take into account
10366 -- all other named properties that have been encountered so
10367 -- far. Only those that have not been seen are affected by
10371 if not AR_Seen
then
10372 AR_Val
:= Expr_Val
;
10375 if not AW_Seen
then
10376 AW_Val
:= Expr_Val
;
10379 if not ER_Seen
then
10380 ER_Val
:= Expr_Val
;
10383 if not EW_Seen
then
10384 EW_Val
:= Expr_Val
;
10387 end Analyze_External_Property
;
10389 ----------------------------
10390 -- Analyze_Part_Of_Option --
10391 ----------------------------
10393 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10394 Encaps
: constant Node_Id
:= Expression
(Opt
);
10395 Encaps_Id
: Entity_Id
;
10399 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10402 (Item_Id
=> State_Id
,
10404 Indic
=> First
(Choices
(Opt
)),
10407 -- The Part_Of indicator turns an abstract state into a
10408 -- constituent of the encapsulating state.
10411 Encaps_Id
:= Entity
(Encaps
);
10413 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10414 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10416 end Analyze_Part_Of_Option
;
10418 ----------------------------
10419 -- Check_Duplicate_Option --
10420 ----------------------------
10422 procedure Check_Duplicate_Option
10424 Status
: in out Boolean)
10428 Error_Msg_N
("duplicate state option", Opt
);
10432 end Check_Duplicate_Option
;
10434 ------------------------------
10435 -- Check_Duplicate_Property --
10436 ------------------------------
10438 procedure Check_Duplicate_Property
10440 Status
: in out Boolean)
10444 Error_Msg_N
("duplicate external property", Prop
);
10448 end Check_Duplicate_Property
;
10450 ---------------------------
10451 -- Create_Abstract_State --
10452 ---------------------------
10454 procedure Create_Abstract_State
10461 -- The generated state abstraction reuses the same chars
10462 -- from the original state declaration. Decorate the entity.
10464 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10466 -- Null states never come from source
10468 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10469 Set_Parent
(State_Id
, State
);
10470 Set_Ekind
(State_Id
, E_Abstract_State
);
10471 Set_Etype
(State_Id
, Standard_Void_Type
);
10472 Set_Encapsulating_State
(State_Id
, Empty
);
10473 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10474 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10476 -- Establish a link between the state declaration and the
10477 -- abstract state entity. Note that a null state remains as
10478 -- N_Null and does not carry any linkages.
10480 if not Is_Null
then
10481 if Present
(Decl
) then
10482 Set_Entity
(Decl
, State_Id
);
10483 Set_Etype
(Decl
, Standard_Void_Type
);
10486 -- Every non-null state must be defined, nameable and
10489 Push_Scope
(Pack_Id
);
10490 Generate_Definition
(State_Id
);
10491 Enter_Name
(State_Id
);
10494 end Create_Abstract_State
;
10501 -- Start of processing for Analyze_Abstract_State
10504 -- A package with a null abstract state is not allowed to
10505 -- declare additional states.
10509 ("package & has null abstract state", State
, Pack_Id
);
10511 -- Null states appear as internally generated entities
10513 elsif Nkind
(State
) = N_Null
then
10514 Create_Abstract_State
10515 (Nam
=> New_Internal_Name
('S'),
10517 Loc
=> Sloc
(State
),
10521 -- Catch a case where a null state appears in a list of
10522 -- non-null states.
10524 if Non_Null_Seen
then
10526 ("package & has non-null abstract state",
10530 -- Simple state declaration
10532 elsif Nkind
(State
) = N_Identifier
then
10533 Create_Abstract_State
10534 (Nam
=> Chars
(State
),
10536 Loc
=> Sloc
(State
),
10538 Non_Null_Seen
:= True;
10540 -- State declaration with various options. This construct
10541 -- appears as an extension aggregate in the tree.
10543 elsif Nkind
(State
) = N_Extension_Aggregate
then
10544 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10545 Create_Abstract_State
10546 (Nam
=> Chars
(Ancestor_Part
(State
)),
10547 Decl
=> Ancestor_Part
(State
),
10548 Loc
=> Sloc
(Ancestor_Part
(State
)),
10550 Non_Null_Seen
:= True;
10553 ("state name must be an identifier",
10554 Ancestor_Part
(State
));
10557 -- Catch an attempt to introduce a simple option which is
10558 -- currently not allowed. An exception to this is External
10559 -- defined without any properties.
10561 Opt
:= First
(Expressions
(State
));
10562 while Present
(Opt
) loop
10563 if Nkind
(Opt
) = N_Identifier
10564 and then Chars
(Opt
) = Name_External
10566 Analyze_External_Option
(Opt
);
10568 -- When an erroneous option Part_Of is without a parent
10569 -- state, it appears in the list of expression of the
10570 -- aggregate rather than the component associations
10571 -- (SPARK RM 7.1.4(9)).
10573 elsif Chars
(Opt
) = Name_Part_Of
then
10575 ("indicator Part_Of must denote an abstract state",
10580 ("simple option not allowed in state declaration",
10587 -- Options External and Part_Of appear as component
10590 Opt
:= First
(Component_Associations
(State
));
10591 while Present
(Opt
) loop
10592 Opt_Nam
:= First
(Choices
(Opt
));
10594 if Nkind
(Opt_Nam
) = N_Identifier
then
10595 if Chars
(Opt_Nam
) = Name_External
then
10596 Analyze_External_Option
(Opt
);
10598 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10599 Analyze_Part_Of_Option
(Opt
);
10602 Error_Msg_N
("invalid state option", Opt
);
10605 Error_Msg_N
("invalid state option", Opt
);
10611 -- Any other attempt to declare a state is erroneous
10614 Error_Msg_N
("malformed abstract state declaration", State
);
10617 -- Guard against a junk state. In such cases no entity is
10618 -- generated and the subsequent checks cannot be applied.
10620 if Present
(State_Id
) then
10622 -- Verify whether the state does not introduce an illegal
10623 -- hidden state within a package subject to a null abstract
10626 Check_No_Hidden_State
(State_Id
);
10628 -- Check whether the lack of option Part_Of agrees with the
10629 -- placement of the abstract state with respect to the state
10632 if not Part_Of_Seen
then
10633 Check_Missing_Part_Of
(State_Id
);
10636 -- Associate the state with its related package
10638 if No
(Abstract_States
(Pack_Id
)) then
10639 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10642 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10644 end Analyze_Abstract_State
;
10646 ------------------------------------
10647 -- Check_State_Declaration_Syntax --
10648 ------------------------------------
10650 procedure Check_State_Declaration_Syntax
(State
: Node_Id
) is
10654 -- Null abstract state
10656 if Nkind
(State
) = N_Null
then
10661 elsif Nkind
(State
) = N_Identifier
then
10664 -- State with various options
10666 elsif Nkind
(State
) = N_Extension_Aggregate
then
10667 if Nkind
(Ancestor_Part
(State
)) /= N_Identifier
then
10669 ("state name must be an identifier",
10670 Ancestor_Part
(State
));
10675 elsif Nkind
(State
) = N_Aggregate
10676 and then Present
(Expressions
(State
))
10678 Decl
:= First
(Expressions
(State
));
10679 while Present
(Decl
) loop
10680 Check_State_Declaration_Syntax
(Decl
);
10685 Error_Msg_N
("malformed abstract state", State
);
10687 end Check_State_Declaration_Syntax
;
10691 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10694 -- Start of processing for Abstract_State
10698 Check_Arg_Count
(1);
10699 Ensure_Aggregate_Form
(Arg1
);
10701 -- Ensure the proper placement of the pragma. Abstract states must
10702 -- be associated with a package declaration.
10704 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10705 N_Package_Declaration
)
10711 State
:= Expression
(Arg1
);
10713 -- Verify the syntax of pragma Abstract_State when SPARK checks
10714 -- are suppressed. Semantic analysis is disabled in this mode.
10716 if SPARK_Mode
= Off
then
10717 Check_State_Declaration_Syntax
(State
);
10721 Pack_Id
:= Defining_Entity
(Context
);
10723 -- Multiple non-null abstract states appear as an aggregate
10725 if Nkind
(State
) = N_Aggregate
then
10726 State
:= First
(Expressions
(State
));
10727 while Present
(State
) loop
10728 Analyze_Abstract_State
(State
);
10732 -- Various forms of a single abstract state. Note that these may
10733 -- include malformed state declarations.
10736 Analyze_Abstract_State
(State
);
10739 -- Save the pragma for retrieval by other tools
10741 Add_Contract_Item
(N
, Pack_Id
);
10743 -- Verify the declaration order of pragmas Abstract_State and
10746 Check_Declaration_Order
10748 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10749 end Abstract_State
;
10757 -- Note: this pragma also has some specific processing in Par.Prag
10758 -- because we want to set the Ada version mode during parsing.
10760 when Pragma_Ada_83
=>
10762 Check_Arg_Count
(0);
10764 -- We really should check unconditionally for proper configuration
10765 -- pragma placement, since we really don't want mixed Ada modes
10766 -- within a single unit, and the GNAT reference manual has always
10767 -- said this was a configuration pragma, but we did not check and
10768 -- are hesitant to add the check now.
10770 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10771 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10772 -- or Ada 2012 mode.
10774 if Ada_Version
>= Ada_2005
then
10775 Check_Valid_Configuration_Pragma
;
10778 -- Now set Ada 83 mode
10780 Ada_Version
:= Ada_83
;
10781 Ada_Version_Explicit
:= Ada_83
;
10782 Ada_Version_Pragma
:= N
;
10790 -- Note: this pragma also has some specific processing in Par.Prag
10791 -- because we want to set the Ada 83 version mode during parsing.
10793 when Pragma_Ada_95
=>
10795 Check_Arg_Count
(0);
10797 -- We really should check unconditionally for proper configuration
10798 -- pragma placement, since we really don't want mixed Ada modes
10799 -- within a single unit, and the GNAT reference manual has always
10800 -- said this was a configuration pragma, but we did not check and
10801 -- are hesitant to add the check now.
10803 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10804 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10806 if Ada_Version
>= Ada_2005
then
10807 Check_Valid_Configuration_Pragma
;
10810 -- Now set Ada 95 mode
10812 Ada_Version
:= Ada_95
;
10813 Ada_Version_Explicit
:= Ada_95
;
10814 Ada_Version_Pragma
:= N
;
10816 ---------------------
10817 -- Ada_05/Ada_2005 --
10818 ---------------------
10821 -- pragma Ada_05 (LOCAL_NAME);
10823 -- pragma Ada_2005;
10824 -- pragma Ada_2005 (LOCAL_NAME):
10826 -- Note: these pragmas also have some specific processing in Par.Prag
10827 -- because we want to set the Ada 2005 version mode during parsing.
10829 -- The one argument form is used for managing the transition from
10830 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10831 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10832 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10833 -- mode, a preference rule is established which does not choose
10834 -- such an entity unless it is unambiguously specified. This avoids
10835 -- extra subprograms marked this way from generating ambiguities in
10836 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10837 -- intended for exclusive use in the GNAT run-time library.
10839 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10845 if Arg_Count
= 1 then
10846 Check_Arg_Is_Local_Name
(Arg1
);
10847 E_Id
:= Get_Pragma_Arg
(Arg1
);
10849 if Etype
(E_Id
) = Any_Type
then
10853 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10854 Record_Rep_Item
(Entity
(E_Id
), N
);
10857 Check_Arg_Count
(0);
10859 -- For Ada_2005 we unconditionally enforce the documented
10860 -- configuration pragma placement, since we do not want to
10861 -- tolerate mixed modes in a unit involving Ada 2005. That
10862 -- would cause real difficulties for those cases where there
10863 -- are incompatibilities between Ada 95 and Ada 2005.
10865 Check_Valid_Configuration_Pragma
;
10867 -- Now set appropriate Ada mode
10869 Ada_Version
:= Ada_2005
;
10870 Ada_Version_Explicit
:= Ada_2005
;
10871 Ada_Version_Pragma
:= N
;
10875 ---------------------
10876 -- Ada_12/Ada_2012 --
10877 ---------------------
10880 -- pragma Ada_12 (LOCAL_NAME);
10882 -- pragma Ada_2012;
10883 -- pragma Ada_2012 (LOCAL_NAME):
10885 -- Note: these pragmas also have some specific processing in Par.Prag
10886 -- because we want to set the Ada 2012 version mode during parsing.
10888 -- The one argument form is used for managing the transition from Ada
10889 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10890 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10891 -- mode will generate a warning. In addition, in any pre-Ada_2012
10892 -- mode, a preference rule is established which does not choose
10893 -- such an entity unless it is unambiguously specified. This avoids
10894 -- extra subprograms marked this way from generating ambiguities in
10895 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10896 -- intended for exclusive use in the GNAT run-time library.
10898 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10904 if Arg_Count
= 1 then
10905 Check_Arg_Is_Local_Name
(Arg1
);
10906 E_Id
:= Get_Pragma_Arg
(Arg1
);
10908 if Etype
(E_Id
) = Any_Type
then
10912 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10913 Record_Rep_Item
(Entity
(E_Id
), N
);
10916 Check_Arg_Count
(0);
10918 -- For Ada_2012 we unconditionally enforce the documented
10919 -- configuration pragma placement, since we do not want to
10920 -- tolerate mixed modes in a unit involving Ada 2012. That
10921 -- would cause real difficulties for those cases where there
10922 -- are incompatibilities between Ada 95 and Ada 2012. We could
10923 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10925 Check_Valid_Configuration_Pragma
;
10927 -- Now set appropriate Ada mode
10929 Ada_Version
:= Ada_2012
;
10930 Ada_Version_Explicit
:= Ada_2012
;
10931 Ada_Version_Pragma
:= N
;
10935 ----------------------
10936 -- All_Calls_Remote --
10937 ----------------------
10939 -- pragma All_Calls_Remote [(library_package_NAME)];
10941 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10942 Lib_Entity
: Entity_Id
;
10945 Check_Ada_83_Warning
;
10946 Check_Valid_Library_Unit_Pragma
;
10948 if Nkind
(N
) = N_Null_Statement
then
10952 Lib_Entity
:= Find_Lib_Unit_Name
;
10954 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10956 if Present
(Lib_Entity
)
10957 and then not Debug_Flag_U
10959 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10960 Error_Pragma
("pragma% only apply to rci unit");
10962 -- Set flag for entity of the library unit
10965 Set_Has_All_Calls_Remote
(Lib_Entity
);
10969 end All_Calls_Remote
;
10971 ---------------------------
10972 -- Allow_Integer_Address --
10973 ---------------------------
10975 -- pragma Allow_Integer_Address;
10977 when Pragma_Allow_Integer_Address
=>
10979 Check_Valid_Configuration_Pragma
;
10980 Check_Arg_Count
(0);
10982 -- If Address is a private type, then set the flag to allow
10983 -- integer address values. If Address is not private (e.g. on
10984 -- VMS, where it is an integer type), then this pragma has no
10985 -- purpose, so it is simply ignored.
10987 if Is_Private_Type
(RTE
(RE_Address
)) then
10988 Opt
.Allow_Integer_Address
:= True;
10995 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
10996 -- ARG ::= NAME | EXPRESSION
10998 -- The first two arguments are by convention intended to refer to an
10999 -- external tool and a tool-specific function. These arguments are
11002 when Pragma_Annotate
=> Annotate
: declare
11008 Check_At_Least_N_Arguments
(1);
11009 Check_Arg_Is_Identifier
(Arg1
);
11010 Check_No_Identifiers
;
11013 -- Second parameter is optional, it is never analyzed
11018 -- Here if we have a second parameter
11021 -- Second parameter must be identifier
11023 Check_Arg_Is_Identifier
(Arg2
);
11025 -- Process remaining parameters if any
11027 Arg
:= Next
(Arg2
);
11028 while Present
(Arg
) loop
11029 Exp
:= Get_Pragma_Arg
(Arg
);
11032 if Is_Entity_Name
(Exp
) then
11035 -- For string literals, we assume Standard_String as the
11036 -- type, unless the string contains wide or wide_wide
11039 elsif Nkind
(Exp
) = N_String_Literal
then
11040 if Has_Wide_Wide_Character
(Exp
) then
11041 Resolve
(Exp
, Standard_Wide_Wide_String
);
11042 elsif Has_Wide_Character
(Exp
) then
11043 Resolve
(Exp
, Standard_Wide_String
);
11045 Resolve
(Exp
, Standard_String
);
11048 elsif Is_Overloaded
(Exp
) then
11050 ("ambiguous argument for pragma%", Exp
);
11061 -------------------------------------------------
11062 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11063 -------------------------------------------------
11066 -- ( [Check => ] Boolean_EXPRESSION
11067 -- [, [Message =>] Static_String_EXPRESSION]);
11069 -- pragma Assert_And_Cut
11070 -- ( [Check => ] Boolean_EXPRESSION
11071 -- [, [Message =>] Static_String_EXPRESSION]);
11074 -- ( [Check => ] Boolean_EXPRESSION
11075 -- [, [Message =>] Static_String_EXPRESSION]);
11077 -- pragma Loop_Invariant
11078 -- ( [Check => ] Boolean_EXPRESSION
11079 -- [, [Message =>] Static_String_EXPRESSION]);
11081 when Pragma_Assert |
11082 Pragma_Assert_And_Cut |
11084 Pragma_Loop_Invariant
=>
11089 Has_Loop_Entry
: Boolean;
11092 function Contains_Loop_Entry
return Boolean;
11093 -- Tests if Expr contains a Loop_Entry attribute reference
11095 -------------------------
11096 -- Contains_Loop_Entry --
11097 -------------------------
11099 function Contains_Loop_Entry
return Boolean is
11100 function Process
(N
: Node_Id
) return Traverse_Result
;
11101 -- Process function for traversal to look for Loop_Entry
11107 function Process
(N
: Node_Id
) return Traverse_Result
is
11109 if Nkind
(N
) = N_Attribute_Reference
11110 and then Attribute_Name
(N
) = Name_Loop_Entry
11112 Has_Loop_Entry
:= True;
11119 procedure Traverse
is new Traverse_Proc
(Process
);
11121 -- Start of processing for Contains_Loop_Entry
11124 Has_Loop_Entry
:= False;
11126 return Has_Loop_Entry
;
11127 end Contains_Loop_Entry
;
11129 -- Start of processing for Assert
11132 -- Assert is an Ada 2005 RM-defined pragma
11134 if Prag_Id
= Pragma_Assert
then
11137 -- The remaining ones are GNAT pragmas
11143 Check_At_Least_N_Arguments
(1);
11144 Check_At_Most_N_Arguments
(2);
11145 Check_Arg_Order
((Name_Check
, Name_Message
));
11146 Check_Optional_Identifier
(Arg1
, Name_Check
);
11147 Expr
:= Get_Pragma_Arg
(Arg1
);
11149 -- Special processing for Loop_Invariant or for other cases if
11150 -- a Loop_Entry attribute is present.
11152 if Prag_Id
= Pragma_Loop_Invariant
11153 or else Contains_Loop_Entry
11155 -- Check restricted placement, must be within a loop
11157 Check_Loop_Pragma_Placement
;
11159 -- Do preanalyze to deal with embedded Loop_Entry attribute
11161 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
11164 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11165 -- a corresponding Check pragma:
11167 -- pragma Check (name, condition [, msg]);
11169 -- Where name is the identifier matching the pragma name. So
11170 -- rewrite pragma in this manner, transfer the message argument
11171 -- if present, and analyze the result
11173 -- Note: When dealing with a semantically analyzed tree, the
11174 -- information that a Check node N corresponds to a source Assert,
11175 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11176 -- pragma kind of Original_Node(N).
11179 Make_Pragma_Argument_Association
(Loc
,
11180 Expression
=> Make_Identifier
(Loc
, Pname
)),
11181 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11182 Expression
=> Expr
));
11184 if Arg_Count
> 1 then
11185 Check_Optional_Identifier
(Arg2
, Name_Message
);
11186 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
11189 -- Rewrite as Check pragma
11193 Chars
=> Name_Check
,
11194 Pragma_Argument_Associations
=> Newa
));
11198 ----------------------
11199 -- Assertion_Policy --
11200 ----------------------
11202 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11204 -- The following form is Ada 2012 only, but we allow it in all modes
11206 -- Pragma Assertion_Policy (
11207 -- ASSERTION_KIND => POLICY_IDENTIFIER
11208 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11210 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11212 -- RM_ASSERTION_KIND ::= Assert |
11213 -- Static_Predicate |
11214 -- Dynamic_Predicate |
11219 -- Type_Invariant |
11220 -- Type_Invariant'Class
11222 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11224 -- Contract_Cases |
11226 -- Initial_Condition |
11227 -- Loop_Invariant |
11233 -- Statement_Assertions
11235 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11236 -- ID_ASSERTION_KIND list contains implementation-defined additions
11237 -- recognized by GNAT. The effect is to control the behavior of
11238 -- identically named aspects and pragmas, depending on the specified
11239 -- policy identifier:
11241 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11243 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11244 -- implementation defined addition that results in totally ignoring
11245 -- the corresponding assertion. If Disable is specified, then the
11246 -- argument of the assertion is not even analyzed. This is useful
11247 -- when the aspect/pragma argument references entities in a with'ed
11248 -- package that is replaced by a dummy package in the final build.
11250 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11251 -- and Type_Invariant'Class were recognized by the parser and
11252 -- transformed into references to the special internal identifiers
11253 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11254 -- processing is required here.
11256 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11265 -- This can always appear as a configuration pragma
11267 if Is_Configuration_Pragma
then
11270 -- It can also appear in a declarative part or package spec in Ada
11271 -- 2012 mode. We allow this in other modes, but in that case we
11272 -- consider that we have an Ada 2012 pragma on our hands.
11275 Check_Is_In_Decl_Part_Or_Package_Spec
;
11279 -- One argument case with no identifier (first form above)
11282 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11283 or else Chars
(Arg1
) = No_Name
)
11285 Check_Arg_Is_One_Of
11286 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11288 -- Treat one argument Assertion_Policy as equivalent to:
11290 -- pragma Check_Policy (Assertion, policy)
11292 -- So rewrite pragma in that manner and link on to the chain
11293 -- of Check_Policy pragmas, marking the pragma as analyzed.
11295 Policy
:= Get_Pragma_Arg
(Arg1
);
11299 Chars
=> Name_Check_Policy
,
11300 Pragma_Argument_Associations
=> New_List
(
11301 Make_Pragma_Argument_Association
(Loc
,
11302 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11304 Make_Pragma_Argument_Association
(Loc
,
11306 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11309 -- Here if we have two or more arguments
11312 Check_At_Least_N_Arguments
(1);
11315 -- Loop through arguments
11318 while Present
(Arg
) loop
11319 LocP
:= Sloc
(Arg
);
11321 -- Kind must be specified
11323 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11324 or else Chars
(Arg
) = No_Name
11327 ("missing assertion kind for pragma%", Arg
);
11330 -- Check Kind and Policy have allowed forms
11332 Kind
:= Chars
(Arg
);
11334 if not Is_Valid_Assertion_Kind
(Kind
) then
11336 ("invalid assertion kind for pragma%", Arg
);
11339 Check_Arg_Is_One_Of
11340 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11342 -- We rewrite the Assertion_Policy pragma as a series of
11343 -- Check_Policy pragmas:
11345 -- Check_Policy (Kind, Policy);
11349 Chars
=> Name_Check_Policy
,
11350 Pragma_Argument_Associations
=> New_List
(
11351 Make_Pragma_Argument_Association
(LocP
,
11352 Expression
=> Make_Identifier
(LocP
, Kind
)),
11353 Make_Pragma_Argument_Association
(LocP
,
11354 Expression
=> Get_Pragma_Arg
(Arg
)))));
11359 -- Rewrite the Assertion_Policy pragma as null since we have
11360 -- now inserted all the equivalent Check pragmas.
11362 Rewrite
(N
, Make_Null_Statement
(Loc
));
11365 end Assertion_Policy
;
11367 ------------------------------
11368 -- Assume_No_Invalid_Values --
11369 ------------------------------
11371 -- pragma Assume_No_Invalid_Values (On | Off);
11373 when Pragma_Assume_No_Invalid_Values
=>
11375 Check_Valid_Configuration_Pragma
;
11376 Check_Arg_Count
(1);
11377 Check_No_Identifiers
;
11378 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11380 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11381 Assume_No_Invalid_Values
:= True;
11383 Assume_No_Invalid_Values
:= False;
11386 --------------------------
11387 -- Attribute_Definition --
11388 --------------------------
11390 -- pragma Attribute_Definition
11391 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11392 -- [Entity =>] LOCAL_NAME,
11393 -- [Expression =>] EXPRESSION | NAME);
11395 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11396 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11401 Check_Arg_Count
(3);
11402 Check_Optional_Identifier
(Arg1
, "attribute");
11403 Check_Optional_Identifier
(Arg2
, "entity");
11404 Check_Optional_Identifier
(Arg3
, "expression");
11406 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11407 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11411 Check_Arg_Is_Local_Name
(Arg2
);
11413 -- If the attribute is not recognized, then issue a warning (not
11414 -- an error), and ignore the pragma.
11416 Aname
:= Chars
(Attribute_Designator
);
11418 if not Is_Attribute_Name
(Aname
) then
11419 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11423 -- Otherwise, rewrite the pragma as an attribute definition clause
11426 Make_Attribute_Definition_Clause
(Loc
,
11427 Name
=> Get_Pragma_Arg
(Arg2
),
11429 Expression
=> Get_Pragma_Arg
(Arg3
)));
11431 end Attribute_Definition
;
11437 -- pragma AST_Entry (entry_IDENTIFIER);
11439 when Pragma_AST_Entry
=> AST_Entry
: declare
11445 Check_Arg_Count
(1);
11446 Check_No_Identifiers
;
11447 Check_Arg_Is_Local_Name
(Arg1
);
11448 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
11450 -- Note: the implementation of the AST_Entry pragma could handle
11451 -- the entry family case fine, but for now we are consistent with
11452 -- the DEC rules, and do not allow the pragma, which of course
11453 -- has the effect of also forbidding the attribute.
11455 if Ekind
(Ent
) /= E_Entry
then
11457 ("pragma% argument must be simple entry name", Arg1
);
11459 elsif Is_AST_Entry
(Ent
) then
11461 ("duplicate % pragma for entry", Arg1
);
11463 elsif Has_Homonym
(Ent
) then
11465 ("pragma% argument cannot specify overloaded entry", Arg1
);
11469 FF
: constant Entity_Id
:= First_Formal
(Ent
);
11472 if Present
(FF
) then
11473 if Present
(Next_Formal
(FF
)) then
11475 ("entry for pragma% can have only one argument",
11478 elsif Parameter_Mode
(FF
) /= E_In_Parameter
then
11480 ("entry parameter for pragma% must have mode IN",
11486 Set_Is_AST_Entry
(Ent
);
11490 ------------------------------------------------------------------
11491 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11492 ------------------------------------------------------------------
11494 -- pragma Asynch_Readers ( identifier [, boolean_EXPRESSION] );
11495 -- pragma Asynch_Writers ( identifier [, boolean_EXPRESSION] );
11496 -- pragma Effective_Reads ( identifier [, boolean_EXPRESSION] );
11497 -- pragma Effective_Writes ( identifier [, boolean_EXPRESSION] );
11499 when Pragma_Async_Readers |
11500 Pragma_Async_Writers |
11501 Pragma_Effective_Reads |
11502 Pragma_Effective_Writes
=>
11503 Async_Effective
: declare
11505 Obj_Id
: Entity_Id
;
11509 Check_No_Identifiers
;
11510 Check_At_Least_N_Arguments
(1);
11511 Check_At_Most_N_Arguments
(2);
11512 Check_Arg_Is_Local_Name
(Arg1
);
11514 Arg1
:= Get_Pragma_Arg
(Arg1
);
11516 -- Perform minimal verification to ensure that the argument is at
11517 -- least a variable. Subsequent finer grained checks will be done
11518 -- at the end of the declarative region the contains the pragma.
11520 if Is_Entity_Name
(Arg1
) and then Present
(Entity
(Arg1
)) then
11521 Obj_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
11523 -- It is not efficient to examine preceding statements in order
11524 -- to detect duplicate pragmas as Boolean aspects may appear
11525 -- anywhere between the related object declaration and its
11526 -- freeze point. As an alternative, inspect the contents of the
11527 -- variable contract.
11529 if Ekind
(Obj_Id
) = E_Variable
then
11530 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11532 if Present
(Duplic
) then
11533 Error_Msg_Name_1
:= Pname
;
11534 Error_Msg_Sloc
:= Sloc
(Duplic
);
11535 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11537 -- Chain the pragma on the contract for further processing.
11538 -- This also aids in detecting duplicates.
11541 Add_Contract_Item
(N
, Obj_Id
);
11544 -- The minimum legality requirements have been met, do not
11545 -- fall through to the error message.
11551 -- If we get here, then the pragma applies to a non-object
11552 -- construct, issue a generic error (SPARK RM 7.1.3(2)).
11554 Error_Pragma
("pragma % must apply to a volatile object");
11555 end Async_Effective
;
11561 -- pragma Asynchronous (LOCAL_NAME);
11563 when Pragma_Asynchronous
=> Asynchronous
: declare
11569 Formal
: Entity_Id
;
11571 procedure Process_Async_Pragma
;
11572 -- Common processing for procedure and access-to-procedure case
11574 --------------------------
11575 -- Process_Async_Pragma --
11576 --------------------------
11578 procedure Process_Async_Pragma
is
11581 Set_Is_Asynchronous
(Nm
);
11585 -- The formals should be of mode IN (RM E.4.1(6))
11588 while Present
(S
) loop
11589 Formal
:= Defining_Identifier
(S
);
11591 if Nkind
(Formal
) = N_Defining_Identifier
11592 and then Ekind
(Formal
) /= E_In_Parameter
11595 ("pragma% procedure can only have IN parameter",
11602 Set_Is_Asynchronous
(Nm
);
11603 end Process_Async_Pragma
;
11605 -- Start of processing for pragma Asynchronous
11608 Check_Ada_83_Warning
;
11609 Check_No_Identifiers
;
11610 Check_Arg_Count
(1);
11611 Check_Arg_Is_Local_Name
(Arg1
);
11613 if Debug_Flag_U
then
11617 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11618 Analyze
(Get_Pragma_Arg
(Arg1
));
11619 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11621 if not Is_Remote_Call_Interface
(C_Ent
)
11622 and then not Is_Remote_Types
(C_Ent
)
11624 -- This pragma should only appear in an RCI or Remote Types
11625 -- unit (RM E.4.1(4)).
11628 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11631 if Ekind
(Nm
) = E_Procedure
11632 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11634 if not Is_Remote_Call_Interface
(Nm
) then
11636 ("pragma% cannot be applied on non-remote procedure",
11640 L
:= Parameter_Specifications
(Parent
(Nm
));
11641 Process_Async_Pragma
;
11644 elsif Ekind
(Nm
) = E_Function
then
11646 ("pragma% cannot be applied to function", Arg1
);
11648 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11649 if Is_Record_Type
(Nm
) then
11651 -- A record type that is the Equivalent_Type for a remote
11652 -- access-to-subprogram type.
11654 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11657 -- A non-expanded RAS type (distribution is not enabled)
11659 N
:= Declaration_Node
(Nm
);
11662 if Nkind
(N
) = N_Full_Type_Declaration
11663 and then Nkind
(Type_Definition
(N
)) =
11664 N_Access_Procedure_Definition
11666 L
:= Parameter_Specifications
(Type_Definition
(N
));
11667 Process_Async_Pragma
;
11669 if Is_Asynchronous
(Nm
)
11670 and then Expander_Active
11671 and then Get_PCS_Name
/= Name_No_DSA
11673 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11678 ("pragma% cannot reference access-to-function type",
11682 -- Only other possibility is Access-to-class-wide type
11684 elsif Is_Access_Type
(Nm
)
11685 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11687 Check_First_Subtype
(Arg1
);
11688 Set_Is_Asynchronous
(Nm
);
11689 if Expander_Active
then
11690 RACW_Type_Is_Asynchronous
(Nm
);
11694 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11702 -- pragma Atomic (LOCAL_NAME);
11704 when Pragma_Atomic
=>
11705 Process_Atomic_Shared_Volatile
;
11707 -----------------------
11708 -- Atomic_Components --
11709 -----------------------
11711 -- pragma Atomic_Components (array_LOCAL_NAME);
11713 -- This processing is shared by Volatile_Components
11715 when Pragma_Atomic_Components |
11716 Pragma_Volatile_Components
=>
11718 Atomic_Components
: declare
11725 Check_Ada_83_Warning
;
11726 Check_No_Identifiers
;
11727 Check_Arg_Count
(1);
11728 Check_Arg_Is_Local_Name
(Arg1
);
11729 E_Id
:= Get_Pragma_Arg
(Arg1
);
11731 if Etype
(E_Id
) = Any_Type
then
11735 E
:= Entity
(E_Id
);
11737 Check_Duplicate_Pragma
(E
);
11739 if Rep_Item_Too_Early
(E
, N
)
11741 Rep_Item_Too_Late
(E
, N
)
11746 D
:= Declaration_Node
(E
);
11749 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11751 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11752 and then Nkind
(D
) = N_Object_Declaration
11753 and then Nkind
(Object_Definition
(D
)) =
11754 N_Constrained_Array_Definition
)
11756 -- The flag is set on the object, or on the base type
11758 if Nkind
(D
) /= N_Object_Declaration
then
11759 E
:= Base_Type
(E
);
11762 Set_Has_Volatile_Components
(E
);
11764 if Prag_Id
= Pragma_Atomic_Components
then
11765 Set_Has_Atomic_Components
(E
);
11769 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11771 end Atomic_Components
;
11773 --------------------
11774 -- Attach_Handler --
11775 --------------------
11777 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11779 when Pragma_Attach_Handler
=>
11780 Check_Ada_83_Warning
;
11781 Check_No_Identifiers
;
11782 Check_Arg_Count
(2);
11784 if No_Run_Time_Mode
then
11785 Error_Msg_CRT
("Attach_Handler pragma", N
);
11787 Check_Interrupt_Or_Attach_Handler
;
11789 -- The expression that designates the attribute may depend on a
11790 -- discriminant, and is therefore a per-object expression, to
11791 -- be expanded in the init proc. If expansion is enabled, then
11792 -- perform semantic checks on a copy only.
11797 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11800 -- In Relaxed_RM_Semantics mode, we allow any static
11801 -- integer value, for compatibility with other compilers.
11803 if Relaxed_RM_Semantics
11804 and then Nkind
(Parg2
) = N_Integer_Literal
11806 Typ
:= Standard_Integer
;
11808 Typ
:= RTE
(RE_Interrupt_ID
);
11811 if Expander_Active
then
11812 Temp
:= New_Copy_Tree
(Parg2
);
11813 Set_Parent
(Temp
, N
);
11814 Preanalyze_And_Resolve
(Temp
, Typ
);
11817 Resolve
(Parg2
, Typ
);
11821 Process_Interrupt_Or_Attach_Handler
;
11824 --------------------
11825 -- C_Pass_By_Copy --
11826 --------------------
11828 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11830 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11836 Check_Valid_Configuration_Pragma
;
11837 Check_Arg_Count
(1);
11838 Check_Optional_Identifier
(Arg1
, "max_size");
11840 Arg
:= Get_Pragma_Arg
(Arg1
);
11841 Check_Arg_Is_Static_Expression
(Arg
, Any_Integer
);
11843 Val
:= Expr_Value
(Arg
);
11847 ("maximum size for pragma% must be positive", Arg1
);
11849 elsif UI_Is_In_Int_Range
(Val
) then
11850 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11852 -- If a giant value is given, Int'Last will do well enough.
11853 -- If sometime someone complains that a record larger than
11854 -- two gigabytes is not copied, we will worry about it then.
11857 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11859 end C_Pass_By_Copy
;
11865 -- pragma Check ([Name =>] CHECK_KIND,
11866 -- [Check =>] Boolean_EXPRESSION
11867 -- [,[Message =>] String_EXPRESSION]);
11869 -- CHECK_KIND ::= IDENTIFIER |
11872 -- Invariant'Class |
11873 -- Type_Invariant'Class
11875 -- The identifiers Assertions and Statement_Assertions are not
11876 -- allowed, since they have special meaning for Check_Policy.
11878 when Pragma_Check
=> Check
: declare
11886 Check_At_Least_N_Arguments
(2);
11887 Check_At_Most_N_Arguments
(3);
11888 Check_Optional_Identifier
(Arg1
, Name_Name
);
11889 Check_Optional_Identifier
(Arg2
, Name_Check
);
11891 if Arg_Count
= 3 then
11892 Check_Optional_Identifier
(Arg3
, Name_Message
);
11893 Str
:= Get_Pragma_Arg
(Arg3
);
11896 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11897 Check_Arg_Is_Identifier
(Arg1
);
11898 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11900 -- Check forbidden name Assertions or Statement_Assertions
11903 when Name_Assertions
=>
11905 ("""Assertions"" is not allowed as a check kind "
11906 & "for pragma%", Arg1
);
11908 when Name_Statement_Assertions
=>
11910 ("""Statement_Assertions"" is not allowed as a check kind "
11911 & "for pragma%", Arg1
);
11917 -- Check applicable policy. We skip this if Checked/Ignored status
11918 -- is already set (e.g. in the casse of a pragma from an aspect).
11920 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11923 -- For a non-source pragma that is a rewriting of another pragma,
11924 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11926 elsif Is_Rewrite_Substitution
(N
)
11927 and then Nkind
(Original_Node
(N
)) = N_Pragma
11928 and then Original_Node
(N
) /= N
11930 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11931 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11933 -- Otherwise query the applicable policy at this point
11936 case Check_Kind
(Cname
) is
11937 when Name_Ignore
=>
11938 Set_Is_Ignored
(N
, True);
11939 Set_Is_Checked
(N
, False);
11942 Set_Is_Ignored
(N
, False);
11943 Set_Is_Checked
(N
, True);
11945 -- For disable, rewrite pragma as null statement and skip
11946 -- rest of the analysis of the pragma.
11948 when Name_Disable
=>
11949 Rewrite
(N
, Make_Null_Statement
(Loc
));
11953 -- No other possibilities
11956 raise Program_Error
;
11960 -- If check kind was not Disable, then continue pragma analysis
11962 Expr
:= Get_Pragma_Arg
(Arg2
);
11964 -- Deal with SCO generation
11967 when Name_Predicate |
11970 -- Nothing to do: since checks occur in client units,
11971 -- the SCO for the aspect in the declaration unit is
11972 -- conservatively always enabled.
11978 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11980 -- Mark aspect/pragma SCO as enabled
11982 Set_SCO_Pragma_Enabled
(Loc
);
11986 -- Deal with analyzing the string argument.
11988 if Arg_Count
= 3 then
11990 -- If checks are not on we don't want any expansion (since
11991 -- such expansion would not get properly deleted) but
11992 -- we do want to analyze (to get proper references).
11993 -- The Preanalyze_And_Resolve routine does just what we want
11995 if Is_Ignored
(N
) then
11996 Preanalyze_And_Resolve
(Str
, Standard_String
);
11998 -- Otherwise we need a proper analysis and expansion
12001 Analyze_And_Resolve
(Str
, Standard_String
);
12005 -- Now you might think we could just do the same with the Boolean
12006 -- expression if checks are off (and expansion is on) and then
12007 -- rewrite the check as a null statement. This would work but we
12008 -- would lose the useful warnings about an assertion being bound
12009 -- to fail even if assertions are turned off.
12011 -- So instead we wrap the boolean expression in an if statement
12012 -- that looks like:
12014 -- if False and then condition then
12018 -- The reason we do this rewriting during semantic analysis rather
12019 -- than as part of normal expansion is that we cannot analyze and
12020 -- expand the code for the boolean expression directly, or it may
12021 -- cause insertion of actions that would escape the attempt to
12022 -- suppress the check code.
12024 -- Note that the Sloc for the if statement corresponds to the
12025 -- argument condition, not the pragma itself. The reason for
12026 -- this is that we may generate a warning if the condition is
12027 -- False at compile time, and we do not want to delete this
12028 -- warning when we delete the if statement.
12030 if Expander_Active
and Is_Ignored
(N
) then
12031 Eloc
:= Sloc
(Expr
);
12034 Make_If_Statement
(Eloc
,
12036 Make_And_Then
(Eloc
,
12037 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
12038 Right_Opnd
=> Expr
),
12039 Then_Statements
=> New_List
(
12040 Make_Null_Statement
(Eloc
))));
12042 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12044 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12046 -- Check is active or expansion not active. In these cases we can
12047 -- just go ahead and analyze the boolean with no worries.
12050 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12051 Analyze_And_Resolve
(Expr
, Any_Boolean
);
12052 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12056 --------------------------
12057 -- Check_Float_Overflow --
12058 --------------------------
12060 -- pragma Check_Float_Overflow;
12062 when Pragma_Check_Float_Overflow
=>
12064 Check_Valid_Configuration_Pragma
;
12065 Check_Arg_Count
(0);
12066 Check_Float_Overflow
:= True;
12072 -- pragma Check_Name (check_IDENTIFIER);
12074 when Pragma_Check_Name
=>
12076 Check_No_Identifiers
;
12077 Check_Valid_Configuration_Pragma
;
12078 Check_Arg_Count
(1);
12079 Check_Arg_Is_Identifier
(Arg1
);
12082 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
12085 for J
in Check_Names
.First
.. Check_Names
.Last
loop
12086 if Check_Names
.Table
(J
) = Nam
then
12091 Check_Names
.Append
(Nam
);
12098 -- This is the old style syntax, which is still allowed in all modes:
12100 -- pragma Check_Policy ([Name =>] CHECK_KIND
12101 -- [Policy =>] POLICY_IDENTIFIER);
12103 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12105 -- CHECK_KIND ::= IDENTIFIER |
12108 -- Type_Invariant'Class |
12111 -- This is the new style syntax, compatible with Assertion_Policy
12112 -- and also allowed in all modes.
12114 -- Pragma Check_Policy (
12115 -- CHECK_KIND => POLICY_IDENTIFIER
12116 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12118 -- Note: the identifiers Name and Policy are not allowed as
12119 -- Check_Kind values. This avoids ambiguities between the old and
12120 -- new form syntax.
12122 when Pragma_Check_Policy
=> Check_Policy
: declare
12127 Check_At_Least_N_Arguments
(1);
12129 -- A Check_Policy pragma can appear either as a configuration
12130 -- pragma, or in a declarative part or a package spec (see RM
12131 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12132 -- followed for Check_Policy).
12134 if not Is_Configuration_Pragma
then
12135 Check_Is_In_Decl_Part_Or_Package_Spec
;
12138 -- Figure out if we have the old or new syntax. We have the
12139 -- old syntax if the first argument has no identifier, or the
12140 -- identifier is Name.
12142 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
12143 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
12147 Check_Arg_Count
(2);
12148 Check_Optional_Identifier
(Arg1
, Name_Name
);
12149 Kind
:= Get_Pragma_Arg
(Arg1
);
12150 Rewrite_Assertion_Kind
(Kind
);
12151 Check_Arg_Is_Identifier
(Arg1
);
12153 -- Check forbidden check kind
12155 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
12156 Error_Msg_Name_2
:= Chars
(Kind
);
12158 ("pragma% does not allow% as check name", Arg1
);
12163 Check_Optional_Identifier
(Arg2
, Name_Policy
);
12164 Check_Arg_Is_One_Of
12166 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
12168 -- And chain pragma on the Check_Policy_List for search
12170 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
12171 Opt
.Check_Policy_List
:= N
;
12173 -- For the new syntax, what we do is to convert each argument to
12174 -- an old syntax equivalent. We do that because we want to chain
12175 -- old style Check_Policy pragmas for the search (we don't want
12176 -- to have to deal with multiple arguments in the search).
12186 while Present
(Arg
) loop
12187 LocP
:= Sloc
(Arg
);
12188 Argx
:= Get_Pragma_Arg
(Arg
);
12190 -- Kind must be specified
12192 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12193 or else Chars
(Arg
) = No_Name
12196 ("missing assertion kind for pragma%", Arg
);
12199 -- Construct equivalent old form syntax Check_Policy
12200 -- pragma and insert it to get remaining checks.
12204 Chars
=> Name_Check_Policy
,
12205 Pragma_Argument_Associations
=> New_List
(
12206 Make_Pragma_Argument_Association
(LocP
,
12208 Make_Identifier
(LocP
, Chars
(Arg
))),
12209 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12210 Expression
=> Argx
))));
12215 -- Rewrite original Check_Policy pragma to null, since we
12216 -- have converted it into a series of old syntax pragmas.
12218 Rewrite
(N
, Make_Null_Statement
(Loc
));
12224 ---------------------
12225 -- CIL_Constructor --
12226 ---------------------
12228 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12230 -- Processing for this pragma is shared with Java_Constructor
12236 -- pragma Comment (static_string_EXPRESSION)
12238 -- Processing for pragma Comment shares the circuitry for pragma
12239 -- Ident. The only differences are that Ident enforces a limit of 31
12240 -- characters on its argument, and also enforces limitations on
12241 -- placement for DEC compatibility. Pragma Comment shares neither of
12242 -- these restrictions.
12244 -------------------
12245 -- Common_Object --
12246 -------------------
12248 -- pragma Common_Object (
12249 -- [Internal =>] LOCAL_NAME
12250 -- [, [External =>] EXTERNAL_SYMBOL]
12251 -- [, [Size =>] EXTERNAL_SYMBOL]);
12253 -- Processing for this pragma is shared with Psect_Object
12255 ------------------------
12256 -- Compile_Time_Error --
12257 ------------------------
12259 -- pragma Compile_Time_Error
12260 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12262 when Pragma_Compile_Time_Error
=>
12264 Process_Compile_Time_Warning_Or_Error
;
12266 --------------------------
12267 -- Compile_Time_Warning --
12268 --------------------------
12270 -- pragma Compile_Time_Warning
12271 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12273 when Pragma_Compile_Time_Warning
=>
12275 Process_Compile_Time_Warning_Or_Error
;
12277 ---------------------------
12278 -- Compiler_Unit_Warning --
12279 ---------------------------
12281 -- pragma Compiler_Unit_Warning;
12285 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12286 -- errors not warnings. This means that we had introduced a big extra
12287 -- inertia to compiler changes, since even if we implemented a new
12288 -- feature, and even if all versions to be used for bootstrapping
12289 -- implemented this new feature, we could not use it, since old
12290 -- compilers would give errors for using this feature in units
12291 -- having Compiler_Unit pragmas.
12293 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12294 -- problem. We no longer have any units mentioning Compiler_Unit,
12295 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12296 -- and thus generates a warning which can be ignored. So that deals
12297 -- with the problem of old compilers not implementing the newer form
12300 -- Newer compilers recognize the new pragma, but generate warning
12301 -- messages instead of errors, which again can be ignored in the
12302 -- case of an old compiler which implements a wanted new feature
12303 -- but at the time felt like warning about it for older compilers.
12305 -- We retain Compiler_Unit so that new compilers can be used to build
12306 -- older run-times that use this pragma. That's an unusual case, but
12307 -- it's easy enough to handle, so why not?
12309 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12311 Check_Arg_Count
(0);
12312 Set_Is_Compiler_Unit
(Get_Source_Unit
(N
));
12314 -----------------------------
12315 -- Complete_Representation --
12316 -----------------------------
12318 -- pragma Complete_Representation;
12320 when Pragma_Complete_Representation
=>
12322 Check_Arg_Count
(0);
12324 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12326 ("pragma & must appear within record representation clause");
12329 ----------------------------
12330 -- Complex_Representation --
12331 ----------------------------
12333 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12335 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12342 Check_Arg_Count
(1);
12343 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12344 Check_Arg_Is_Local_Name
(Arg1
);
12345 E_Id
:= Get_Pragma_Arg
(Arg1
);
12347 if Etype
(E_Id
) = Any_Type
then
12351 E
:= Entity
(E_Id
);
12353 if not Is_Record_Type
(E
) then
12355 ("argument for pragma% must be record type", Arg1
);
12358 Ent
:= First_Entity
(E
);
12361 or else No
(Next_Entity
(Ent
))
12362 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12363 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12364 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12367 ("record for pragma% must have two fields of the same "
12368 & "floating-point type", Arg1
);
12371 Set_Has_Complex_Representation
(Base_Type
(E
));
12373 -- We need to treat the type has having a non-standard
12374 -- representation, for back-end purposes, even though in
12375 -- general a complex will have the default representation
12376 -- of a record with two real components.
12378 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12380 end Complex_Representation
;
12382 -------------------------
12383 -- Component_Alignment --
12384 -------------------------
12386 -- pragma Component_Alignment (
12387 -- [Form =>] ALIGNMENT_CHOICE
12388 -- [, [Name =>] type_LOCAL_NAME]);
12390 -- ALIGNMENT_CHOICE ::=
12392 -- | Component_Size_4
12396 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12397 Args
: Args_List
(1 .. 2);
12398 Names
: constant Name_List
(1 .. 2) := (
12402 Form
: Node_Id
renames Args
(1);
12403 Name
: Node_Id
renames Args
(2);
12405 Atype
: Component_Alignment_Kind
;
12410 Gather_Associations
(Names
, Args
);
12413 Error_Pragma
("missing Form argument for pragma%");
12416 Check_Arg_Is_Identifier
(Form
);
12418 -- Get proper alignment, note that Default = Component_Size on all
12419 -- machines we have so far, and we want to set this value rather
12420 -- than the default value to indicate that it has been explicitly
12421 -- set (and thus will not get overridden by the default component
12422 -- alignment for the current scope)
12424 if Chars
(Form
) = Name_Component_Size
then
12425 Atype
:= Calign_Component_Size
;
12427 elsif Chars
(Form
) = Name_Component_Size_4
then
12428 Atype
:= Calign_Component_Size_4
;
12430 elsif Chars
(Form
) = Name_Default
then
12431 Atype
:= Calign_Component_Size
;
12433 elsif Chars
(Form
) = Name_Storage_Unit
then
12434 Atype
:= Calign_Storage_Unit
;
12438 ("invalid Form parameter for pragma%", Form
);
12441 -- Case with no name, supplied, affects scope table entry
12445 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12447 -- Case of name supplied
12450 Check_Arg_Is_Local_Name
(Name
);
12452 Typ
:= Entity
(Name
);
12455 or else Rep_Item_Too_Early
(Typ
, N
)
12459 Typ
:= Underlying_Type
(Typ
);
12462 if not Is_Record_Type
(Typ
)
12463 and then not Is_Array_Type
(Typ
)
12466 ("Name parameter of pragma% must identify record or "
12467 & "array type", Name
);
12470 -- An explicit Component_Alignment pragma overrides an
12471 -- implicit pragma Pack, but not an explicit one.
12473 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12474 Set_Is_Packed
(Base_Type
(Typ
), False);
12475 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12478 end Component_AlignmentP
;
12480 --------------------
12481 -- Contract_Cases --
12482 --------------------
12484 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12486 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12488 -- CASE_GUARD ::= boolean_EXPRESSION | others
12490 -- CONSEQUENCE ::= boolean_EXPRESSION
12492 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12493 Subp_Decl
: Node_Id
;
12497 Check_Arg_Count
(1);
12498 Ensure_Aggregate_Form
(Arg1
);
12500 -- The pragma is analyzed at the end of the declarative part which
12501 -- contains the related subprogram. Reset the analyzed flag.
12503 Set_Analyzed
(N
, False);
12505 -- Ensure the proper placement of the pragma. Contract_Cases must
12506 -- be associated with a subprogram declaration or a body that acts
12510 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12512 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12515 -- Body acts as spec
12517 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12518 and then No
(Corresponding_Spec
(Subp_Decl
))
12522 -- Body stub acts as spec
12524 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12525 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12534 -- When the pragma appears on a subprogram body, perform the full
12537 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12538 Analyze_Contract_Cases_In_Decl_Part
(N
);
12540 -- When Contract_Cases applies to a subprogram compilation unit,
12541 -- the corresponding pragma is placed after the unit's declaration
12542 -- node and needs to be analyzed immediately.
12544 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12545 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12547 Analyze_Contract_Cases_In_Decl_Part
(N
);
12550 -- Chain the pragma on the contract for further processing
12552 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12553 end Contract_Cases
;
12559 -- pragma Controlled (first_subtype_LOCAL_NAME);
12561 when Pragma_Controlled
=> Controlled
: declare
12565 Check_No_Identifiers
;
12566 Check_Arg_Count
(1);
12567 Check_Arg_Is_Local_Name
(Arg1
);
12568 Arg
:= Get_Pragma_Arg
(Arg1
);
12570 if not Is_Entity_Name
(Arg
)
12571 or else not Is_Access_Type
(Entity
(Arg
))
12573 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12575 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12583 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12584 -- [Entity =>] LOCAL_NAME);
12586 when Pragma_Convention
=> Convention
: declare
12589 pragma Warnings
(Off
, C
);
12590 pragma Warnings
(Off
, E
);
12592 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12593 Check_Ada_83_Warning
;
12594 Check_Arg_Count
(2);
12595 Process_Convention
(C
, E
);
12598 ---------------------------
12599 -- Convention_Identifier --
12600 ---------------------------
12602 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12603 -- [Convention =>] convention_IDENTIFIER);
12605 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12611 Check_Arg_Order
((Name_Name
, Name_Convention
));
12612 Check_Arg_Count
(2);
12613 Check_Optional_Identifier
(Arg1
, Name_Name
);
12614 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12615 Check_Arg_Is_Identifier
(Arg1
);
12616 Check_Arg_Is_Identifier
(Arg2
);
12617 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12618 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12620 if Is_Convention_Name
(Cname
) then
12621 Record_Convention_Identifier
12622 (Idnam
, Get_Convention_Id
(Cname
));
12625 ("second arg for % pragma must be convention", Arg2
);
12627 end Convention_Identifier
;
12633 -- pragma CPP_Class ([Entity =>] local_NAME)
12635 when Pragma_CPP_Class
=> CPP_Class
: declare
12639 if Warn_On_Obsolescent_Feature
then
12641 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12642 & "effect; replace it by pragma import?j?", N
);
12645 Check_Arg_Count
(1);
12649 Chars
=> Name_Import
,
12650 Pragma_Argument_Associations
=> New_List
(
12651 Make_Pragma_Argument_Association
(Loc
,
12652 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12653 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12657 ---------------------
12658 -- CPP_Constructor --
12659 ---------------------
12661 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12662 -- [, [External_Name =>] static_string_EXPRESSION ]
12663 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12665 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12668 Def_Id
: Entity_Id
;
12669 Tag_Typ
: Entity_Id
;
12673 Check_At_Least_N_Arguments
(1);
12674 Check_At_Most_N_Arguments
(3);
12675 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12676 Check_Arg_Is_Local_Name
(Arg1
);
12678 Id
:= Get_Pragma_Arg
(Arg1
);
12679 Find_Program_Unit_Name
(Id
);
12681 -- If we did not find the name, we are done
12683 if Etype
(Id
) = Any_Type
then
12687 Def_Id
:= Entity
(Id
);
12689 -- Check if already defined as constructor
12691 if Is_Constructor
(Def_Id
) then
12693 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12697 if Ekind
(Def_Id
) = E_Function
12698 and then (Is_CPP_Class
(Etype
(Def_Id
))
12699 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12701 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12703 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12705 ("'C'P'P constructor must be defined in the scope of "
12706 & "its returned type", Arg1
);
12709 if Arg_Count
>= 2 then
12710 Set_Imported
(Def_Id
);
12711 Set_Is_Public
(Def_Id
);
12712 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12715 Set_Has_Completion
(Def_Id
);
12716 Set_Is_Constructor
(Def_Id
);
12717 Set_Convention
(Def_Id
, Convention_CPP
);
12719 -- Imported C++ constructors are not dispatching primitives
12720 -- because in C++ they don't have a dispatch table slot.
12721 -- However, in Ada the constructor has the profile of a
12722 -- function that returns a tagged type and therefore it has
12723 -- been treated as a primitive operation during semantic
12724 -- analysis. We now remove it from the list of primitive
12725 -- operations of the type.
12727 if Is_Tagged_Type
(Etype
(Def_Id
))
12728 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12729 and then Is_Dispatching_Operation
(Def_Id
)
12731 Tag_Typ
:= Etype
(Def_Id
);
12733 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12734 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12738 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12739 Set_Is_Dispatching_Operation
(Def_Id
, False);
12742 -- For backward compatibility, if the constructor returns a
12743 -- class wide type, and we internally change the return type to
12744 -- the corresponding root type.
12746 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12747 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12751 ("pragma% requires function returning a 'C'P'P_Class type",
12754 end CPP_Constructor
;
12760 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12764 if Warn_On_Obsolescent_Feature
then
12766 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12775 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12779 if Warn_On_Obsolescent_Feature
then
12781 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12790 -- pragma CPU (EXPRESSION);
12792 when Pragma_CPU
=> CPU
: declare
12793 P
: constant Node_Id
:= Parent
(N
);
12799 Check_No_Identifiers
;
12800 Check_Arg_Count
(1);
12804 if Nkind
(P
) = N_Subprogram_Body
then
12805 Check_In_Main_Program
;
12807 Arg
:= Get_Pragma_Arg
(Arg1
);
12808 Analyze_And_Resolve
(Arg
, Any_Integer
);
12810 Ent
:= Defining_Unit_Name
(Specification
(P
));
12812 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12813 Ent
:= Defining_Identifier
(Ent
);
12818 if not Is_Static_Expression
(Arg
) then
12819 Flag_Non_Static_Expr
12820 ("main subprogram affinity is not static!", Arg
);
12823 -- If constraint error, then we already signalled an error
12825 elsif Raises_Constraint_Error
(Arg
) then
12828 -- Otherwise check in range
12832 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12833 -- This is the entity System.Multiprocessors.CPU_Range;
12835 Val
: constant Uint
:= Expr_Value
(Arg
);
12838 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12840 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12843 ("main subprogram CPU is out of range", Arg1
);
12849 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12853 elsif Nkind
(P
) = N_Task_Definition
then
12854 Arg
:= Get_Pragma_Arg
(Arg1
);
12855 Ent
:= Defining_Identifier
(Parent
(P
));
12857 -- The expression must be analyzed in the special manner
12858 -- described in "Handling of Default and Per-Object
12859 -- Expressions" in sem.ads.
12861 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12863 -- Anything else is incorrect
12869 -- Check duplicate pragma before we chain the pragma in the Rep
12870 -- Item chain of Ent.
12872 Check_Duplicate_Pragma
(Ent
);
12873 Record_Rep_Item
(Ent
, N
);
12880 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12882 when Pragma_Debug
=> Debug
: declare
12889 -- The condition for executing the call is that the expander
12890 -- is active and that we are not ignoring this debug pragma.
12895 (Expander_Active
and then not Is_Ignored
(N
)),
12898 if not Is_Ignored
(N
) then
12899 Set_SCO_Pragma_Enabled
(Loc
);
12902 if Arg_Count
= 2 then
12904 Make_And_Then
(Loc
,
12905 Left_Opnd
=> Relocate_Node
(Cond
),
12906 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12907 Call
:= Get_Pragma_Arg
(Arg2
);
12909 Call
:= Get_Pragma_Arg
(Arg1
);
12913 N_Indexed_Component
,
12917 N_Selected_Component
)
12919 -- If this pragma Debug comes from source, its argument was
12920 -- parsed as a name form (which is syntactically identical).
12921 -- In a generic context a parameterless call will be left as
12922 -- an expanded name (if global) or selected_component if local.
12923 -- Change it to a procedure call statement now.
12925 Change_Name_To_Procedure_Call_Statement
(Call
);
12927 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12929 -- Already in the form of a procedure call statement: nothing
12930 -- to do (could happen in case of an internally generated
12936 -- All other cases: diagnose error
12939 ("argument of pragma ""Debug"" is not procedure call",
12944 -- Rewrite into a conditional with an appropriate condition. We
12945 -- wrap the procedure call in a block so that overhead from e.g.
12946 -- use of the secondary stack does not generate execution overhead
12947 -- for suppressed conditions.
12949 -- Normally the analysis that follows will freeze the subprogram
12950 -- being called. However, if the call is to a null procedure,
12951 -- we want to freeze it before creating the block, because the
12952 -- analysis that follows may be done with expansion disabled, in
12953 -- which case the body will not be generated, leading to spurious
12956 if Nkind
(Call
) = N_Procedure_Call_Statement
12957 and then Is_Entity_Name
(Name
(Call
))
12959 Analyze
(Name
(Call
));
12960 Freeze_Before
(N
, Entity
(Name
(Call
)));
12964 Make_Implicit_If_Statement
(N
,
12966 Then_Statements
=> New_List
(
12967 Make_Block_Statement
(Loc
,
12968 Handled_Statement_Sequence
=>
12969 Make_Handled_Sequence_Of_Statements
(Loc
,
12970 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12973 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12974 -- after analysis of the normally rewritten node, to capture all
12975 -- references to entities, which avoids issuing wrong warnings
12976 -- about unused entities.
12978 if GNATprove_Mode
then
12979 Rewrite
(N
, Make_Null_Statement
(Loc
));
12987 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12989 when Pragma_Debug_Policy
=>
12991 Check_Arg_Count
(1);
12992 Check_No_Identifiers
;
12993 Check_Arg_Is_Identifier
(Arg1
);
12995 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12996 -- rewrite it that way, and let the rest of the checking come
12997 -- from analyzing the rewritten pragma.
13001 Chars
=> Name_Check_Policy
,
13002 Pragma_Argument_Associations
=> New_List
(
13003 Make_Pragma_Argument_Association
(Loc
,
13004 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
13006 Make_Pragma_Argument_Association
(Loc
,
13007 Expression
=> Get_Pragma_Arg
(Arg1
)))));
13014 -- pragma Depends (DEPENDENCY_RELATION);
13016 -- DEPENDENCY_RELATION ::=
13018 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
13020 -- DEPENDENCY_CLAUSE ::=
13021 -- OUTPUT_LIST =>[+] INPUT_LIST
13022 -- | NULL_DEPENDENCY_CLAUSE
13024 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13026 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13028 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13030 -- OUTPUT ::= NAME | FUNCTION_RESULT
13033 -- where FUNCTION_RESULT is a function Result attribute_reference
13035 when Pragma_Depends
=> Depends
: declare
13036 Subp_Decl
: Node_Id
;
13040 Check_Arg_Count
(1);
13041 Ensure_Aggregate_Form
(Arg1
);
13043 -- Ensure the proper placement of the pragma. Depends must be
13044 -- associated with a subprogram declaration or a body that acts
13048 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
13050 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13053 -- Body acts as spec
13055 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13056 and then No
(Corresponding_Spec
(Subp_Decl
))
13060 -- Body stub acts as spec
13062 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13063 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13072 -- When the pragma appears on a subprogram body, perform the full
13075 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
13076 Analyze_Depends_In_Decl_Part
(N
);
13078 -- When Depends applies to a subprogram compilation unit, the
13079 -- corresponding pragma is placed after the unit's declaration
13080 -- node and needs to be analyzed immediately.
13082 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13083 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
13085 Analyze_Depends_In_Decl_Part
(N
);
13088 -- Chain the pragma on the contract for further processing
13090 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13093 ---------------------
13094 -- Detect_Blocking --
13095 ---------------------
13097 -- pragma Detect_Blocking;
13099 when Pragma_Detect_Blocking
=>
13101 Check_Arg_Count
(0);
13102 Check_Valid_Configuration_Pragma
;
13103 Detect_Blocking
:= True;
13105 --------------------------
13106 -- Default_Storage_Pool --
13107 --------------------------
13109 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13111 when Pragma_Default_Storage_Pool
=>
13113 Check_Arg_Count
(1);
13115 -- Default_Storage_Pool can appear as a configuration pragma, or
13116 -- in a declarative part or a package spec.
13118 if not Is_Configuration_Pragma
then
13119 Check_Is_In_Decl_Part_Or_Package_Spec
;
13122 -- Case of Default_Storage_Pool (null);
13124 if Nkind
(Expression
(Arg1
)) = N_Null
then
13125 Analyze
(Expression
(Arg1
));
13127 -- This is an odd case, this is not really an expression, so
13128 -- we don't have a type for it. So just set the type to Empty.
13130 Set_Etype
(Expression
(Arg1
), Empty
);
13132 -- Case of Default_Storage_Pool (storage_pool_NAME);
13135 -- If it's a configuration pragma, then the only allowed
13136 -- argument is "null".
13138 if Is_Configuration_Pragma
then
13139 Error_Pragma_Arg
("NULL expected", Arg1
);
13142 -- The expected type for a non-"null" argument is
13143 -- Root_Storage_Pool'Class.
13145 Analyze_And_Resolve
13146 (Get_Pragma_Arg
(Arg1
),
13147 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
13150 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
13151 -- for an access type will use this information to set the
13152 -- appropriate attributes of the access type.
13154 Default_Pool
:= Expression
(Arg1
);
13156 ------------------------------------
13157 -- Disable_Atomic_Synchronization --
13158 ------------------------------------
13160 -- pragma Disable_Atomic_Synchronization [(Entity)];
13162 when Pragma_Disable_Atomic_Synchronization
=>
13164 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13166 -------------------
13167 -- Discard_Names --
13168 -------------------
13170 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13172 when Pragma_Discard_Names
=> Discard_Names
: declare
13177 Check_Ada_83_Warning
;
13179 -- Deal with configuration pragma case
13181 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13182 Global_Discard_Names
:= True;
13185 -- Otherwise, check correct appropriate context
13188 Check_Is_In_Decl_Part_Or_Package_Spec
;
13190 if Arg_Count
= 0 then
13192 -- If there is no parameter, then from now on this pragma
13193 -- applies to any enumeration, exception or tagged type
13194 -- defined in the current declarative part, and recursively
13195 -- to any nested scope.
13197 Set_Discard_Names
(Current_Scope
);
13201 Check_Arg_Count
(1);
13202 Check_Optional_Identifier
(Arg1
, Name_On
);
13203 Check_Arg_Is_Local_Name
(Arg1
);
13205 E_Id
:= Get_Pragma_Arg
(Arg1
);
13207 if Etype
(E_Id
) = Any_Type
then
13210 E
:= Entity
(E_Id
);
13213 if (Is_First_Subtype
(E
)
13215 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13216 or else Ekind
(E
) = E_Exception
13218 Set_Discard_Names
(E
);
13219 Record_Rep_Item
(E
, N
);
13223 ("inappropriate entity for pragma%", Arg1
);
13230 ------------------------
13231 -- Dispatching_Domain --
13232 ------------------------
13234 -- pragma Dispatching_Domain (EXPRESSION);
13236 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13237 P
: constant Node_Id
:= Parent
(N
);
13243 Check_No_Identifiers
;
13244 Check_Arg_Count
(1);
13246 -- This pragma is born obsolete, but not the aspect
13248 if not From_Aspect_Specification
(N
) then
13250 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13253 if Nkind
(P
) = N_Task_Definition
then
13254 Arg
:= Get_Pragma_Arg
(Arg1
);
13255 Ent
:= Defining_Identifier
(Parent
(P
));
13257 -- The expression must be analyzed in the special manner
13258 -- described in "Handling of Default and Per-Object
13259 -- Expressions" in sem.ads.
13261 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13263 -- Check duplicate pragma before we chain the pragma in the Rep
13264 -- Item chain of Ent.
13266 Check_Duplicate_Pragma
(Ent
);
13267 Record_Rep_Item
(Ent
, N
);
13269 -- Anything else is incorrect
13274 end Dispatching_Domain
;
13280 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13282 when Pragma_Elaborate
=> Elaborate
: declare
13287 -- Pragma must be in context items list of a compilation unit
13289 if not Is_In_Context_Clause
then
13293 -- Must be at least one argument
13295 if Arg_Count
= 0 then
13296 Error_Pragma
("pragma% requires at least one argument");
13299 -- In Ada 83 mode, there can be no items following it in the
13300 -- context list except other pragmas and implicit with clauses
13301 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13302 -- placement rule does not apply.
13304 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13306 while Present
(Citem
) loop
13307 if Nkind
(Citem
) = N_Pragma
13308 or else (Nkind
(Citem
) = N_With_Clause
13309 and then Implicit_With
(Citem
))
13314 ("(Ada 83) pragma% must be at end of context clause");
13321 -- Finally, the arguments must all be units mentioned in a with
13322 -- clause in the same context clause. Note we already checked (in
13323 -- Par.Prag) that the arguments are all identifiers or selected
13327 Outer
: while Present
(Arg
) loop
13328 Citem
:= First
(List_Containing
(N
));
13329 Inner
: while Citem
/= N
loop
13330 if Nkind
(Citem
) = N_With_Clause
13331 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13333 Set_Elaborate_Present
(Citem
, True);
13334 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13335 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
13337 -- With the pragma present, elaboration calls on
13338 -- subprograms from the named unit need no further
13339 -- checks, as long as the pragma appears in the current
13340 -- compilation unit. If the pragma appears in some unit
13341 -- in the context, there might still be a need for an
13342 -- Elaborate_All_Desirable from the current compilation
13343 -- to the named unit, so we keep the check enabled.
13345 if In_Extended_Main_Source_Unit
(N
) then
13346 Set_Suppress_Elaboration_Warnings
13347 (Entity
(Name
(Citem
)));
13358 ("argument of pragma% is not withed unit", Arg
);
13364 -- Give a warning if operating in static mode with one of the
13365 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13367 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
13369 ("?l?use of pragma Elaborate may not be safe", N
);
13371 ("?l?use pragma Elaborate_All instead if possible", N
);
13375 -------------------
13376 -- Elaborate_All --
13377 -------------------
13379 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13381 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13386 Check_Ada_83_Warning
;
13388 -- Pragma must be in context items list of a compilation unit
13390 if not Is_In_Context_Clause
then
13394 -- Must be at least one argument
13396 if Arg_Count
= 0 then
13397 Error_Pragma
("pragma% requires at least one argument");
13400 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13401 -- have to appear at the end of the context clause, but may
13402 -- appear mixed in with other items, even in Ada 83 mode.
13404 -- Final check: the arguments must all be units mentioned in
13405 -- a with clause in the same context clause. Note that we
13406 -- already checked (in Par.Prag) that all the arguments are
13407 -- either identifiers or selected components.
13410 Outr
: while Present
(Arg
) loop
13411 Citem
:= First
(List_Containing
(N
));
13412 Innr
: while Citem
/= N
loop
13413 if Nkind
(Citem
) = N_With_Clause
13414 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13416 Set_Elaborate_All_Present
(Citem
, True);
13417 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13419 -- Suppress warnings and elaboration checks on the named
13420 -- unit if the pragma is in the current compilation, as
13421 -- for pragma Elaborate.
13423 if In_Extended_Main_Source_Unit
(N
) then
13424 Set_Suppress_Elaboration_Warnings
13425 (Entity
(Name
(Citem
)));
13434 Set_Error_Posted
(N
);
13436 ("argument of pragma% is not withed unit", Arg
);
13443 --------------------
13444 -- Elaborate_Body --
13445 --------------------
13447 -- pragma Elaborate_Body [( library_unit_NAME )];
13449 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13450 Cunit_Node
: Node_Id
;
13451 Cunit_Ent
: Entity_Id
;
13454 Check_Ada_83_Warning
;
13455 Check_Valid_Library_Unit_Pragma
;
13457 if Nkind
(N
) = N_Null_Statement
then
13461 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13462 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13464 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13467 Error_Pragma
("pragma% must refer to a spec, not a body");
13469 Set_Body_Required
(Cunit_Node
, True);
13470 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13472 -- If we are in dynamic elaboration mode, then we suppress
13473 -- elaboration warnings for the unit, since it is definitely
13474 -- fine NOT to do dynamic checks at the first level (and such
13475 -- checks will be suppressed because no elaboration boolean
13476 -- is created for Elaborate_Body packages).
13478 -- But in the static model of elaboration, Elaborate_Body is
13479 -- definitely NOT good enough to ensure elaboration safety on
13480 -- its own, since the body may WITH other units that are not
13481 -- safe from an elaboration point of view, so a client must
13482 -- still do an Elaborate_All on such units.
13484 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13485 -- Elaborate_Body always suppressed elab warnings.
13487 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13488 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13491 end Elaborate_Body
;
13493 ------------------------
13494 -- Elaboration_Checks --
13495 ------------------------
13497 -- pragma Elaboration_Checks (Static | Dynamic);
13499 when Pragma_Elaboration_Checks
=>
13501 Check_Arg_Count
(1);
13502 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13503 Dynamic_Elaboration_Checks
:=
13504 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
13510 -- pragma Eliminate (
13511 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13512 -- [,[Entity =>] IDENTIFIER |
13513 -- SELECTED_COMPONENT |
13515 -- [, OVERLOADING_RESOLUTION]);
13517 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13520 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13521 -- FUNCTION_PROFILE
13523 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13525 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13526 -- Result_Type => result_SUBTYPE_NAME]
13528 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13529 -- SUBTYPE_NAME ::= STRING_LITERAL
13531 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13532 -- SOURCE_TRACE ::= STRING_LITERAL
13534 when Pragma_Eliminate
=> Eliminate
: declare
13535 Args
: Args_List
(1 .. 5);
13536 Names
: constant Name_List
(1 .. 5) := (
13539 Name_Parameter_Types
,
13541 Name_Source_Location
);
13543 Unit_Name
: Node_Id
renames Args
(1);
13544 Entity
: Node_Id
renames Args
(2);
13545 Parameter_Types
: Node_Id
renames Args
(3);
13546 Result_Type
: Node_Id
renames Args
(4);
13547 Source_Location
: Node_Id
renames Args
(5);
13551 Check_Valid_Configuration_Pragma
;
13552 Gather_Associations
(Names
, Args
);
13554 if No
(Unit_Name
) then
13555 Error_Pragma
("missing Unit_Name argument for pragma%");
13559 and then (Present
(Parameter_Types
)
13561 Present
(Result_Type
)
13563 Present
(Source_Location
))
13565 Error_Pragma
("missing Entity argument for pragma%");
13568 if (Present
(Parameter_Types
)
13570 Present
(Result_Type
))
13572 Present
(Source_Location
)
13575 ("parameter profile and source location cannot be used "
13576 & "together in pragma%");
13579 Process_Eliminate_Pragma
13588 -----------------------------------
13589 -- Enable_Atomic_Synchronization --
13590 -----------------------------------
13592 -- pragma Enable_Atomic_Synchronization [(Entity)];
13594 when Pragma_Enable_Atomic_Synchronization
=>
13596 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13603 -- [ Convention =>] convention_IDENTIFIER,
13604 -- [ Entity =>] local_NAME
13605 -- [, [External_Name =>] static_string_EXPRESSION ]
13606 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13608 when Pragma_Export
=> Export
: declare
13610 Def_Id
: Entity_Id
;
13612 pragma Warnings
(Off
, C
);
13615 Check_Ada_83_Warning
;
13619 Name_External_Name
,
13622 Check_At_Least_N_Arguments
(2);
13623 Check_At_Most_N_Arguments
(4);
13625 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13626 -- pragma Export (Entity, "external name");
13628 if Relaxed_RM_Semantics
13629 and then Arg_Count
= 2
13630 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13633 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13636 if not Is_Entity_Name
(Def_Id
) then
13637 Error_Pragma_Arg
("entity name required", Arg1
);
13640 Def_Id
:= Entity
(Def_Id
);
13641 Set_Exported
(Def_Id
, Arg1
);
13644 Process_Convention
(C
, Def_Id
);
13646 if Ekind
(Def_Id
) /= E_Constant
then
13647 Note_Possible_Modification
13648 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13651 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13652 Set_Exported
(Def_Id
, Arg2
);
13655 -- If the entity is a deferred constant, propagate the information
13656 -- to the full view, because gigi elaborates the full view only.
13658 if Ekind
(Def_Id
) = E_Constant
13659 and then Present
(Full_View
(Def_Id
))
13662 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13664 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13665 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13666 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13671 ----------------------
13672 -- Export_Exception --
13673 ----------------------
13675 -- pragma Export_Exception (
13676 -- [Internal =>] LOCAL_NAME
13677 -- [, [External =>] EXTERNAL_SYMBOL]
13678 -- [, [Form =>] Ada | VMS]
13679 -- [, [Code =>] static_integer_EXPRESSION]);
13681 when Pragma_Export_Exception
=> Export_Exception
: declare
13682 Args
: Args_List
(1 .. 4);
13683 Names
: constant Name_List
(1 .. 4) := (
13689 Internal
: Node_Id
renames Args
(1);
13690 External
: Node_Id
renames Args
(2);
13691 Form
: Node_Id
renames Args
(3);
13692 Code
: Node_Id
renames Args
(4);
13697 if Inside_A_Generic
then
13698 Error_Pragma
("pragma% cannot be used for generic entities");
13701 Gather_Associations
(Names
, Args
);
13702 Process_Extended_Import_Export_Exception_Pragma
(
13703 Arg_Internal
=> Internal
,
13704 Arg_External
=> External
,
13708 if not Is_VMS_Exception
(Entity
(Internal
)) then
13709 Set_Exported
(Entity
(Internal
), Internal
);
13711 end Export_Exception
;
13713 ---------------------
13714 -- Export_Function --
13715 ---------------------
13717 -- pragma Export_Function (
13718 -- [Internal =>] LOCAL_NAME
13719 -- [, [External =>] EXTERNAL_SYMBOL]
13720 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13721 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13722 -- [, [Mechanism =>] MECHANISM]
13723 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13725 -- EXTERNAL_SYMBOL ::=
13727 -- | static_string_EXPRESSION
13729 -- PARAMETER_TYPES ::=
13731 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13733 -- TYPE_DESIGNATOR ::=
13735 -- | subtype_Name ' Access
13739 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13741 -- MECHANISM_ASSOCIATION ::=
13742 -- [formal_parameter_NAME =>] MECHANISM_NAME
13744 -- MECHANISM_NAME ::=
13747 -- | Descriptor [([Class =>] CLASS_NAME)]
13749 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13751 when Pragma_Export_Function
=> Export_Function
: declare
13752 Args
: Args_List
(1 .. 6);
13753 Names
: constant Name_List
(1 .. 6) := (
13756 Name_Parameter_Types
,
13759 Name_Result_Mechanism
);
13761 Internal
: Node_Id
renames Args
(1);
13762 External
: Node_Id
renames Args
(2);
13763 Parameter_Types
: Node_Id
renames Args
(3);
13764 Result_Type
: Node_Id
renames Args
(4);
13765 Mechanism
: Node_Id
renames Args
(5);
13766 Result_Mechanism
: Node_Id
renames Args
(6);
13770 Gather_Associations
(Names
, Args
);
13771 Process_Extended_Import_Export_Subprogram_Pragma
(
13772 Arg_Internal
=> Internal
,
13773 Arg_External
=> External
,
13774 Arg_Parameter_Types
=> Parameter_Types
,
13775 Arg_Result_Type
=> Result_Type
,
13776 Arg_Mechanism
=> Mechanism
,
13777 Arg_Result_Mechanism
=> Result_Mechanism
);
13778 end Export_Function
;
13780 -------------------
13781 -- Export_Object --
13782 -------------------
13784 -- pragma Export_Object (
13785 -- [Internal =>] LOCAL_NAME
13786 -- [, [External =>] EXTERNAL_SYMBOL]
13787 -- [, [Size =>] EXTERNAL_SYMBOL]);
13789 -- EXTERNAL_SYMBOL ::=
13791 -- | static_string_EXPRESSION
13793 -- PARAMETER_TYPES ::=
13795 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13797 -- TYPE_DESIGNATOR ::=
13799 -- | subtype_Name ' Access
13803 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13805 -- MECHANISM_ASSOCIATION ::=
13806 -- [formal_parameter_NAME =>] MECHANISM_NAME
13808 -- MECHANISM_NAME ::=
13811 -- | Descriptor [([Class =>] CLASS_NAME)]
13813 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13815 when Pragma_Export_Object
=> Export_Object
: declare
13816 Args
: Args_List
(1 .. 3);
13817 Names
: constant Name_List
(1 .. 3) := (
13822 Internal
: Node_Id
renames Args
(1);
13823 External
: Node_Id
renames Args
(2);
13824 Size
: Node_Id
renames Args
(3);
13828 Gather_Associations
(Names
, Args
);
13829 Process_Extended_Import_Export_Object_Pragma
(
13830 Arg_Internal
=> Internal
,
13831 Arg_External
=> External
,
13835 ----------------------
13836 -- Export_Procedure --
13837 ----------------------
13839 -- pragma Export_Procedure (
13840 -- [Internal =>] LOCAL_NAME
13841 -- [, [External =>] EXTERNAL_SYMBOL]
13842 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13843 -- [, [Mechanism =>] MECHANISM]);
13845 -- EXTERNAL_SYMBOL ::=
13847 -- | static_string_EXPRESSION
13849 -- PARAMETER_TYPES ::=
13851 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13853 -- TYPE_DESIGNATOR ::=
13855 -- | subtype_Name ' Access
13859 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13861 -- MECHANISM_ASSOCIATION ::=
13862 -- [formal_parameter_NAME =>] MECHANISM_NAME
13864 -- MECHANISM_NAME ::=
13867 -- | Descriptor [([Class =>] CLASS_NAME)]
13869 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13871 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13872 Args
: Args_List
(1 .. 4);
13873 Names
: constant Name_List
(1 .. 4) := (
13876 Name_Parameter_Types
,
13879 Internal
: Node_Id
renames Args
(1);
13880 External
: Node_Id
renames Args
(2);
13881 Parameter_Types
: Node_Id
renames Args
(3);
13882 Mechanism
: Node_Id
renames Args
(4);
13886 Gather_Associations
(Names
, Args
);
13887 Process_Extended_Import_Export_Subprogram_Pragma
(
13888 Arg_Internal
=> Internal
,
13889 Arg_External
=> External
,
13890 Arg_Parameter_Types
=> Parameter_Types
,
13891 Arg_Mechanism
=> Mechanism
);
13892 end Export_Procedure
;
13898 -- pragma Export_Value (
13899 -- [Value =>] static_integer_EXPRESSION,
13900 -- [Link_Name =>] static_string_EXPRESSION);
13902 when Pragma_Export_Value
=>
13904 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13905 Check_Arg_Count
(2);
13907 Check_Optional_Identifier
(Arg1
, Name_Value
);
13908 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
13910 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13911 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
13913 -----------------------------
13914 -- Export_Valued_Procedure --
13915 -----------------------------
13917 -- pragma Export_Valued_Procedure (
13918 -- [Internal =>] LOCAL_NAME
13919 -- [, [External =>] EXTERNAL_SYMBOL,]
13920 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13921 -- [, [Mechanism =>] MECHANISM]);
13923 -- EXTERNAL_SYMBOL ::=
13925 -- | static_string_EXPRESSION
13927 -- PARAMETER_TYPES ::=
13929 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13931 -- TYPE_DESIGNATOR ::=
13933 -- | subtype_Name ' Access
13937 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13939 -- MECHANISM_ASSOCIATION ::=
13940 -- [formal_parameter_NAME =>] MECHANISM_NAME
13942 -- MECHANISM_NAME ::=
13945 -- | Descriptor [([Class =>] CLASS_NAME)]
13947 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13949 when Pragma_Export_Valued_Procedure
=>
13950 Export_Valued_Procedure
: declare
13951 Args
: Args_List
(1 .. 4);
13952 Names
: constant Name_List
(1 .. 4) := (
13955 Name_Parameter_Types
,
13958 Internal
: Node_Id
renames Args
(1);
13959 External
: Node_Id
renames Args
(2);
13960 Parameter_Types
: Node_Id
renames Args
(3);
13961 Mechanism
: Node_Id
renames Args
(4);
13965 Gather_Associations
(Names
, Args
);
13966 Process_Extended_Import_Export_Subprogram_Pragma
(
13967 Arg_Internal
=> Internal
,
13968 Arg_External
=> External
,
13969 Arg_Parameter_Types
=> Parameter_Types
,
13970 Arg_Mechanism
=> Mechanism
);
13971 end Export_Valued_Procedure
;
13973 -------------------
13974 -- Extend_System --
13975 -------------------
13977 -- pragma Extend_System ([Name =>] Identifier);
13979 when Pragma_Extend_System
=> Extend_System
: declare
13982 Check_Valid_Configuration_Pragma
;
13983 Check_Arg_Count
(1);
13984 Check_Optional_Identifier
(Arg1
, Name_Name
);
13985 Check_Arg_Is_Identifier
(Arg1
);
13987 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13990 and then Name_Buffer
(1 .. 4) = "aux_"
13992 if Present
(System_Extend_Pragma_Arg
) then
13993 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13994 Chars
(Expression
(System_Extend_Pragma_Arg
))
13998 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13999 Error_Pragma
("pragma% conflicts with that #");
14003 System_Extend_Pragma_Arg
:= Arg1
;
14005 if not GNAT_Mode
then
14006 System_Extend_Unit
:= Arg1
;
14010 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
14014 ------------------------
14015 -- Extensions_Allowed --
14016 ------------------------
14018 -- pragma Extensions_Allowed (ON | OFF);
14020 when Pragma_Extensions_Allowed
=>
14022 Check_Arg_Count
(1);
14023 Check_No_Identifiers
;
14024 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14026 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14027 Extensions_Allowed
:= True;
14028 Ada_Version
:= Ada_Version_Type
'Last;
14031 Extensions_Allowed
:= False;
14032 Ada_Version
:= Ada_Version_Explicit
;
14033 Ada_Version_Pragma
:= Empty
;
14040 -- pragma External (
14041 -- [ Convention =>] convention_IDENTIFIER,
14042 -- [ Entity =>] local_NAME
14043 -- [, [External_Name =>] static_string_EXPRESSION ]
14044 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14046 when Pragma_External
=> External
: declare
14047 Def_Id
: Entity_Id
;
14050 pragma Warnings
(Off
, C
);
14057 Name_External_Name
,
14059 Check_At_Least_N_Arguments
(2);
14060 Check_At_Most_N_Arguments
(4);
14061 Process_Convention
(C
, Def_Id
);
14062 Note_Possible_Modification
14063 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14064 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14065 Set_Exported
(Def_Id
, Arg2
);
14068 --------------------------
14069 -- External_Name_Casing --
14070 --------------------------
14072 -- pragma External_Name_Casing (
14073 -- UPPERCASE | LOWERCASE
14074 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14076 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14079 Check_No_Identifiers
;
14081 if Arg_Count
= 2 then
14082 Check_Arg_Is_One_Of
14083 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14085 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14087 Opt
.External_Name_Exp_Casing
:= As_Is
;
14089 when Name_Uppercase
=>
14090 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14092 when Name_Lowercase
=>
14093 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14100 Check_Arg_Count
(1);
14103 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14105 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14106 when Name_Uppercase
=>
14107 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14109 when Name_Lowercase
=>
14110 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14115 end External_Name_Casing
;
14121 -- pragma Fast_Math;
14123 when Pragma_Fast_Math
=>
14125 Check_No_Identifiers
;
14126 Check_Valid_Configuration_Pragma
;
14129 --------------------------
14130 -- Favor_Top_Level --
14131 --------------------------
14133 -- pragma Favor_Top_Level (type_NAME);
14135 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14136 Named_Entity
: Entity_Id
;
14140 Check_No_Identifiers
;
14141 Check_Arg_Count
(1);
14142 Check_Arg_Is_Local_Name
(Arg1
);
14143 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14145 -- If it's an access-to-subprogram type (in particular, not a
14146 -- subtype), set the flag on that type.
14148 if Is_Access_Subprogram_Type
(Named_Entity
) then
14149 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14151 -- Otherwise it's an error (name denotes the wrong sort of entity)
14155 ("access-to-subprogram type expected",
14156 Get_Pragma_Arg
(Arg1
));
14158 end Favor_Top_Level
;
14160 ---------------------------
14161 -- Finalize_Storage_Only --
14162 ---------------------------
14164 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14166 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14167 Assoc
: constant Node_Id
:= Arg1
;
14168 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14173 Check_No_Identifiers
;
14174 Check_Arg_Count
(1);
14175 Check_Arg_Is_Local_Name
(Arg1
);
14177 Find_Type
(Type_Id
);
14178 Typ
:= Entity
(Type_Id
);
14181 or else Rep_Item_Too_Early
(Typ
, N
)
14185 Typ
:= Underlying_Type
(Typ
);
14188 if not Is_Controlled
(Typ
) then
14189 Error_Pragma
("pragma% must specify controlled type");
14192 Check_First_Subtype
(Arg1
);
14194 if Finalize_Storage_Only
(Typ
) then
14195 Error_Pragma
("duplicate pragma%, only one allowed");
14197 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14198 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14200 end Finalize_Storage
;
14202 --------------------------
14203 -- Float_Representation --
14204 --------------------------
14206 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
14208 -- FLOAT_REP ::= VAX_Float | IEEE_Float
14210 when Pragma_Float_Representation
=> Float_Representation
: declare
14218 if Arg_Count
= 1 then
14219 Check_Valid_Configuration_Pragma
;
14221 Check_Arg_Count
(2);
14222 Check_Optional_Identifier
(Arg2
, Name_Entity
);
14223 Check_Arg_Is_Local_Name
(Arg2
);
14226 Check_No_Identifier
(Arg1
);
14227 Check_Arg_Is_One_Of
(Arg1
, Name_VAX_Float
, Name_IEEE_Float
);
14229 if not OpenVMS_On_Target
then
14230 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
14232 ("??pragma% ignored (applies only to Open'V'M'S)");
14238 -- One argument case
14240 if Arg_Count
= 1 then
14241 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
14242 if Opt
.Float_Format
= 'I' then
14243 Error_Pragma
("'I'E'E'E format previously specified");
14246 Opt
.Float_Format
:= 'V';
14249 if Opt
.Float_Format
= 'V' then
14250 Error_Pragma
("'V'A'X format previously specified");
14253 Opt
.Float_Format
:= 'I';
14256 Set_Standard_Fpt_Formats
;
14258 -- Two argument case
14261 Argx
:= Get_Pragma_Arg
(Arg2
);
14263 if not Is_Entity_Name
(Argx
)
14264 or else not Is_Floating_Point_Type
(Entity
(Argx
))
14267 ("second argument of% pragma must be floating-point type",
14271 Ent
:= Entity
(Argx
);
14272 Digs
:= UI_To_Int
(Digits_Value
(Ent
));
14274 -- Two arguments, VAX_Float case
14276 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
14278 when 6 => Set_F_Float
(Ent
);
14279 when 9 => Set_D_Float
(Ent
);
14280 when 15 => Set_G_Float
(Ent
);
14284 ("wrong digits value, must be 6,9 or 15", Arg2
);
14287 -- Two arguments, IEEE_Float case
14291 when 6 => Set_IEEE_Short
(Ent
);
14292 when 15 => Set_IEEE_Long
(Ent
);
14296 ("wrong digits value, must be 6 or 15", Arg2
);
14300 end Float_Representation
;
14306 -- pragma Global (GLOBAL_SPECIFICATION);
14308 -- GLOBAL_SPECIFICATION ::=
14311 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14313 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14315 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14316 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14317 -- GLOBAL_ITEM ::= NAME
14319 when Pragma_Global
=> Global
: declare
14320 Subp_Decl
: Node_Id
;
14324 Check_Arg_Count
(1);
14325 Ensure_Aggregate_Form
(Arg1
);
14327 -- Ensure the proper placement of the pragma. Global must be
14328 -- associated with a subprogram declaration or a body that acts
14332 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14334 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14337 -- Body acts as spec
14339 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14340 and then No
(Corresponding_Spec
(Subp_Decl
))
14344 -- Body stub acts as spec
14346 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14347 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14356 -- When the pragma appears on a subprogram body, perform the full
14359 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14360 Analyze_Global_In_Decl_Part
(N
);
14362 -- When Global applies to a subprogram compilation unit, the
14363 -- corresponding pragma is placed after the unit's declaration
14364 -- node and needs to be analyzed immediately.
14366 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14367 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14369 Analyze_Global_In_Decl_Part
(N
);
14372 -- Chain the pragma on the contract for further processing
14374 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14381 -- pragma Ident (static_string_EXPRESSION)
14383 -- Note: pragma Comment shares this processing. Pragma Comment is
14384 -- identical to Ident, except that the restriction of the argument to
14385 -- 31 characters and the placement restrictions are not enforced for
14388 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14393 Check_Arg_Count
(1);
14394 Check_No_Identifiers
;
14395 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
14398 -- For pragma Ident, preserve DEC compatibility by requiring the
14399 -- pragma to appear in a declarative part or package spec.
14401 if Prag_Id
= Pragma_Ident
then
14402 Check_Is_In_Decl_Part_Or_Package_Spec
;
14405 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14412 GP
:= Parent
(Parent
(N
));
14414 if Nkind_In
(GP
, N_Package_Declaration
,
14415 N_Generic_Package_Declaration
)
14420 -- If we have a compilation unit, then record the ident value,
14421 -- checking for improper duplication.
14423 if Nkind
(GP
) = N_Compilation_Unit
then
14424 CS
:= Ident_String
(Current_Sem_Unit
);
14426 if Present
(CS
) then
14428 -- For Ident, we do not permit multiple instances
14430 if Prag_Id
= Pragma_Ident
then
14431 Error_Pragma
("duplicate% pragma not permitted");
14433 -- For Comment, we concatenate the string, unless we want
14434 -- to preserve the tree structure for ASIS.
14436 elsif not ASIS_Mode
then
14437 Start_String
(Strval
(CS
));
14438 Store_String_Char
(' ');
14439 Store_String_Chars
(Strval
(Str
));
14440 Set_Strval
(CS
, End_String
);
14444 -- In VMS, the effect of IDENT is achieved by passing
14445 -- --identification=name as a --for-linker switch.
14447 if OpenVMS_On_Target
then
14450 ("--for-linker=--identification=");
14451 String_To_Name_Buffer
(Strval
(Str
));
14452 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
14454 -- Only the last processed IDENT is saved. The main
14455 -- purpose is so an IDENT associated with a main
14456 -- procedure will be used in preference to an IDENT
14457 -- associated with a with'd package.
14459 Replace_Linker_Option_String
14460 (End_String
, "--for-linker=--identification=");
14463 Set_Ident_String
(Current_Sem_Unit
, Str
);
14466 -- For subunits, we just ignore the Ident, since in GNAT these
14467 -- are not separate object files, and hence not separate units
14468 -- in the unit table.
14470 elsif Nkind
(GP
) = N_Subunit
then
14473 -- Otherwise we have a misplaced pragma Ident, but we ignore
14474 -- this if we are in an instantiation, since it comes from
14475 -- a generic, and has no relevance to the instantiation.
14477 elsif Prag_Id
= Pragma_Ident
then
14478 if Instantiation_Location
(Loc
) = No_Location
then
14479 Error_Pragma
("pragma% only allowed at outer level");
14485 ----------------------------
14486 -- Implementation_Defined --
14487 ----------------------------
14489 -- pragma Implementation_Defined (local_NAME);
14491 -- Marks previously declared entity as implementation defined. For
14492 -- an overloaded entity, applies to the most recent homonym.
14494 -- pragma Implementation_Defined;
14496 -- The form with no arguments appears anywhere within a scope, most
14497 -- typically a package spec, and indicates that all entities that are
14498 -- defined within the package spec are Implementation_Defined.
14500 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14505 Check_No_Identifiers
;
14507 -- Form with no arguments
14509 if Arg_Count
= 0 then
14510 Set_Is_Implementation_Defined
(Current_Scope
);
14512 -- Form with one argument
14515 Check_Arg_Count
(1);
14516 Check_Arg_Is_Local_Name
(Arg1
);
14517 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14518 Set_Is_Implementation_Defined
(Ent
);
14520 end Implementation_Defined
;
14526 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14528 -- IMPLEMENTATION_KIND ::=
14529 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14531 -- "By_Any" and "Optional" are treated as synonyms in order to
14532 -- support Ada 2012 aspect Synchronization.
14534 when Pragma_Implemented
=> Implemented
: declare
14535 Proc_Id
: Entity_Id
;
14540 Check_Arg_Count
(2);
14541 Check_No_Identifiers
;
14542 Check_Arg_Is_Identifier
(Arg1
);
14543 Check_Arg_Is_Local_Name
(Arg1
);
14544 Check_Arg_Is_One_Of
(Arg2
,
14547 Name_By_Protected_Procedure
,
14550 -- Extract the name of the local procedure
14552 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14554 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14555 -- primitive procedure of a synchronized tagged type.
14557 if Ekind
(Proc_Id
) = E_Procedure
14558 and then Is_Primitive
(Proc_Id
)
14559 and then Present
(First_Formal
(Proc_Id
))
14561 Typ
:= Etype
(First_Formal
(Proc_Id
));
14563 if Is_Tagged_Type
(Typ
)
14566 -- Check for a protected, a synchronized or a task interface
14568 ((Is_Interface
(Typ
)
14569 and then Is_Synchronized_Interface
(Typ
))
14571 -- Check for a protected type or a task type that implements
14575 (Is_Concurrent_Record_Type
(Typ
)
14576 and then Present
(Interfaces
(Typ
)))
14578 -- Check for a private record extension with keyword
14582 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14583 E_Record_Subtype_With_Private
)
14584 and then Synchronized_Present
(Parent
(Typ
))))
14589 ("controlling formal must be of synchronized tagged type",
14594 -- Procedures declared inside a protected type must be accepted
14596 elsif Ekind
(Proc_Id
) = E_Procedure
14597 and then Is_Protected_Type
(Scope
(Proc_Id
))
14601 -- The first argument is not a primitive procedure
14605 ("pragma % must be applied to a primitive procedure", Arg1
);
14609 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14610 -- By_Protected_Procedure to the primitive procedure of a task
14613 if Chars
(Arg2
) = Name_By_Protected_Procedure
14614 and then Is_Interface
(Typ
)
14615 and then Is_Task_Interface
(Typ
)
14618 ("implementation kind By_Protected_Procedure cannot be "
14619 & "applied to a task interface primitive", Arg2
);
14623 Record_Rep_Item
(Proc_Id
, N
);
14626 ----------------------
14627 -- Implicit_Packing --
14628 ----------------------
14630 -- pragma Implicit_Packing;
14632 when Pragma_Implicit_Packing
=>
14634 Check_Arg_Count
(0);
14635 Implicit_Packing
:= True;
14642 -- [Convention =>] convention_IDENTIFIER,
14643 -- [Entity =>] local_NAME
14644 -- [, [External_Name =>] static_string_EXPRESSION ]
14645 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14647 when Pragma_Import
=>
14648 Check_Ada_83_Warning
;
14652 Name_External_Name
,
14655 Check_At_Least_N_Arguments
(2);
14656 Check_At_Most_N_Arguments
(4);
14657 Process_Import_Or_Interface
;
14659 ----------------------
14660 -- Import_Exception --
14661 ----------------------
14663 -- pragma Import_Exception (
14664 -- [Internal =>] LOCAL_NAME
14665 -- [, [External =>] EXTERNAL_SYMBOL]
14666 -- [, [Form =>] Ada | VMS]
14667 -- [, [Code =>] static_integer_EXPRESSION]);
14669 when Pragma_Import_Exception
=> Import_Exception
: declare
14670 Args
: Args_List
(1 .. 4);
14671 Names
: constant Name_List
(1 .. 4) := (
14677 Internal
: Node_Id
renames Args
(1);
14678 External
: Node_Id
renames Args
(2);
14679 Form
: Node_Id
renames Args
(3);
14680 Code
: Node_Id
renames Args
(4);
14684 Gather_Associations
(Names
, Args
);
14686 if Present
(External
) and then Present
(Code
) then
14688 ("cannot give both External and Code options for pragma%");
14691 Process_Extended_Import_Export_Exception_Pragma
(
14692 Arg_Internal
=> Internal
,
14693 Arg_External
=> External
,
14697 if not Is_VMS_Exception
(Entity
(Internal
)) then
14698 Set_Imported
(Entity
(Internal
));
14700 end Import_Exception
;
14702 ---------------------
14703 -- Import_Function --
14704 ---------------------
14706 -- pragma Import_Function (
14707 -- [Internal =>] LOCAL_NAME,
14708 -- [, [External =>] EXTERNAL_SYMBOL]
14709 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14710 -- [, [Result_Type =>] SUBTYPE_MARK]
14711 -- [, [Mechanism =>] MECHANISM]
14712 -- [, [Result_Mechanism =>] MECHANISM_NAME]
14713 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14715 -- EXTERNAL_SYMBOL ::=
14717 -- | static_string_EXPRESSION
14719 -- PARAMETER_TYPES ::=
14721 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14723 -- TYPE_DESIGNATOR ::=
14725 -- | subtype_Name ' Access
14729 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14731 -- MECHANISM_ASSOCIATION ::=
14732 -- [formal_parameter_NAME =>] MECHANISM_NAME
14734 -- MECHANISM_NAME ::=
14737 -- | Descriptor [([Class =>] CLASS_NAME)]
14739 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14741 when Pragma_Import_Function
=> Import_Function
: declare
14742 Args
: Args_List
(1 .. 7);
14743 Names
: constant Name_List
(1 .. 7) := (
14746 Name_Parameter_Types
,
14749 Name_Result_Mechanism
,
14750 Name_First_Optional_Parameter
);
14752 Internal
: Node_Id
renames Args
(1);
14753 External
: Node_Id
renames Args
(2);
14754 Parameter_Types
: Node_Id
renames Args
(3);
14755 Result_Type
: Node_Id
renames Args
(4);
14756 Mechanism
: Node_Id
renames Args
(5);
14757 Result_Mechanism
: Node_Id
renames Args
(6);
14758 First_Optional_Parameter
: Node_Id
renames Args
(7);
14762 Gather_Associations
(Names
, Args
);
14763 Process_Extended_Import_Export_Subprogram_Pragma
(
14764 Arg_Internal
=> Internal
,
14765 Arg_External
=> External
,
14766 Arg_Parameter_Types
=> Parameter_Types
,
14767 Arg_Result_Type
=> Result_Type
,
14768 Arg_Mechanism
=> Mechanism
,
14769 Arg_Result_Mechanism
=> Result_Mechanism
,
14770 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
14771 end Import_Function
;
14773 -------------------
14774 -- Import_Object --
14775 -------------------
14777 -- pragma Import_Object (
14778 -- [Internal =>] LOCAL_NAME
14779 -- [, [External =>] EXTERNAL_SYMBOL]
14780 -- [, [Size =>] EXTERNAL_SYMBOL]);
14782 -- EXTERNAL_SYMBOL ::=
14784 -- | static_string_EXPRESSION
14786 when Pragma_Import_Object
=> Import_Object
: declare
14787 Args
: Args_List
(1 .. 3);
14788 Names
: constant Name_List
(1 .. 3) := (
14793 Internal
: Node_Id
renames Args
(1);
14794 External
: Node_Id
renames Args
(2);
14795 Size
: Node_Id
renames Args
(3);
14799 Gather_Associations
(Names
, Args
);
14800 Process_Extended_Import_Export_Object_Pragma
(
14801 Arg_Internal
=> Internal
,
14802 Arg_External
=> External
,
14806 ----------------------
14807 -- Import_Procedure --
14808 ----------------------
14810 -- pragma Import_Procedure (
14811 -- [Internal =>] LOCAL_NAME
14812 -- [, [External =>] EXTERNAL_SYMBOL]
14813 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14814 -- [, [Mechanism =>] MECHANISM]
14815 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14817 -- EXTERNAL_SYMBOL ::=
14819 -- | static_string_EXPRESSION
14821 -- PARAMETER_TYPES ::=
14823 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14825 -- TYPE_DESIGNATOR ::=
14827 -- | subtype_Name ' Access
14831 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14833 -- MECHANISM_ASSOCIATION ::=
14834 -- [formal_parameter_NAME =>] MECHANISM_NAME
14836 -- MECHANISM_NAME ::=
14839 -- | Descriptor [([Class =>] CLASS_NAME)]
14841 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14843 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14844 Args
: Args_List
(1 .. 5);
14845 Names
: constant Name_List
(1 .. 5) := (
14848 Name_Parameter_Types
,
14850 Name_First_Optional_Parameter
);
14852 Internal
: Node_Id
renames Args
(1);
14853 External
: Node_Id
renames Args
(2);
14854 Parameter_Types
: Node_Id
renames Args
(3);
14855 Mechanism
: Node_Id
renames Args
(4);
14856 First_Optional_Parameter
: Node_Id
renames Args
(5);
14860 Gather_Associations
(Names
, Args
);
14861 Process_Extended_Import_Export_Subprogram_Pragma
(
14862 Arg_Internal
=> Internal
,
14863 Arg_External
=> External
,
14864 Arg_Parameter_Types
=> Parameter_Types
,
14865 Arg_Mechanism
=> Mechanism
,
14866 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
14867 end Import_Procedure
;
14869 -----------------------------
14870 -- Import_Valued_Procedure --
14871 -----------------------------
14873 -- pragma Import_Valued_Procedure (
14874 -- [Internal =>] LOCAL_NAME
14875 -- [, [External =>] EXTERNAL_SYMBOL]
14876 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14877 -- [, [Mechanism =>] MECHANISM]
14878 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14880 -- EXTERNAL_SYMBOL ::=
14882 -- | static_string_EXPRESSION
14884 -- PARAMETER_TYPES ::=
14886 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14888 -- TYPE_DESIGNATOR ::=
14890 -- | subtype_Name ' Access
14894 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14896 -- MECHANISM_ASSOCIATION ::=
14897 -- [formal_parameter_NAME =>] MECHANISM_NAME
14899 -- MECHANISM_NAME ::=
14902 -- | Descriptor [([Class =>] CLASS_NAME)]
14904 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14906 when Pragma_Import_Valued_Procedure
=>
14907 Import_Valued_Procedure
: declare
14908 Args
: Args_List
(1 .. 5);
14909 Names
: constant Name_List
(1 .. 5) := (
14912 Name_Parameter_Types
,
14914 Name_First_Optional_Parameter
);
14916 Internal
: Node_Id
renames Args
(1);
14917 External
: Node_Id
renames Args
(2);
14918 Parameter_Types
: Node_Id
renames Args
(3);
14919 Mechanism
: Node_Id
renames Args
(4);
14920 First_Optional_Parameter
: Node_Id
renames Args
(5);
14924 Gather_Associations
(Names
, Args
);
14925 Process_Extended_Import_Export_Subprogram_Pragma
(
14926 Arg_Internal
=> Internal
,
14927 Arg_External
=> External
,
14928 Arg_Parameter_Types
=> Parameter_Types
,
14929 Arg_Mechanism
=> Mechanism
,
14930 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
14931 end Import_Valued_Procedure
;
14937 -- pragma Independent (LOCAL_NAME);
14939 when Pragma_Independent
=> Independent
: declare
14946 Check_Ada_83_Warning
;
14948 Check_No_Identifiers
;
14949 Check_Arg_Count
(1);
14950 Check_Arg_Is_Local_Name
(Arg1
);
14951 E_Id
:= Get_Pragma_Arg
(Arg1
);
14953 if Etype
(E_Id
) = Any_Type
then
14957 E
:= Entity
(E_Id
);
14958 D
:= Declaration_Node
(E
);
14961 -- Check duplicate before we chain ourselves
14963 Check_Duplicate_Pragma
(E
);
14965 -- Check appropriate entity
14967 if Is_Type
(E
) then
14968 if Rep_Item_Too_Early
(E
, N
)
14970 Rep_Item_Too_Late
(E
, N
)
14974 Check_First_Subtype
(Arg1
);
14977 elsif K
= N_Object_Declaration
14978 or else (K
= N_Component_Declaration
14979 and then Original_Record_Component
(E
) = E
)
14981 if Rep_Item_Too_Late
(E
, N
) then
14987 ("inappropriate entity for pragma%", Arg1
);
14990 Independence_Checks
.Append
((N
, E
));
14993 ----------------------------
14994 -- Independent_Components --
14995 ----------------------------
14997 -- pragma Atomic_Components (array_LOCAL_NAME);
14999 -- This processing is shared by Volatile_Components
15001 when Pragma_Independent_Components
=> Independent_Components
: declare
15008 Check_Ada_83_Warning
;
15010 Check_No_Identifiers
;
15011 Check_Arg_Count
(1);
15012 Check_Arg_Is_Local_Name
(Arg1
);
15013 E_Id
:= Get_Pragma_Arg
(Arg1
);
15015 if Etype
(E_Id
) = Any_Type
then
15019 E
:= Entity
(E_Id
);
15021 -- Check duplicate before we chain ourselves
15023 Check_Duplicate_Pragma
(E
);
15025 -- Check appropriate entity
15027 if Rep_Item_Too_Early
(E
, N
)
15029 Rep_Item_Too_Late
(E
, N
)
15034 D
:= Declaration_Node
(E
);
15037 if K
= N_Full_Type_Declaration
15038 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15040 Independence_Checks
.Append
((N
, E
));
15041 Set_Has_Independent_Components
(Base_Type
(E
));
15043 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15044 and then Nkind
(D
) = N_Object_Declaration
15045 and then Nkind
(Object_Definition
(D
)) =
15046 N_Constrained_Array_Definition
15048 Independence_Checks
.Append
((N
, E
));
15049 Set_Has_Independent_Components
(E
);
15052 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15054 end Independent_Components
;
15056 -----------------------
15057 -- Initial_Condition --
15058 -----------------------
15060 -- pragma Initial_Condition (boolean_EXPRESSION);
15062 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15063 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15064 Pack_Id
: Entity_Id
;
15069 Check_Arg_Count
(1);
15071 -- Ensure the proper placement of the pragma. Initial_Condition
15072 -- must be associated with a package declaration.
15074 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15075 N_Package_Declaration
)
15082 while Present
(Stmt
) loop
15084 -- Skip prior pragmas, but check for duplicates
15086 if Nkind
(Stmt
) = N_Pragma
then
15087 if Pragma_Name
(Stmt
) = Pname
then
15088 Error_Msg_Name_1
:= Pname
;
15089 Error_Msg_Sloc
:= Sloc
(Stmt
);
15090 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15093 -- Skip internally generated code
15095 elsif not Comes_From_Source
(Stmt
) then
15098 -- The pragma does not apply to a legal construct, issue an
15099 -- error and stop the analysis.
15106 Stmt
:= Prev
(Stmt
);
15109 -- The pragma must be analyzed at the end of the visible
15110 -- declarations of the related package. Save the pragma for later
15111 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15112 -- the contract of the package.
15114 Pack_Id
:= Defining_Entity
(Context
);
15115 Add_Contract_Item
(N
, Pack_Id
);
15117 -- Verify the declaration order of pragma Initial_Condition with
15118 -- respect to pragmas Abstract_State and Initializes when SPARK
15119 -- checks are enabled.
15121 if SPARK_Mode
/= Off
then
15122 Check_Declaration_Order
15123 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15126 Check_Declaration_Order
15127 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
15130 end Initial_Condition
;
15132 ------------------------
15133 -- Initialize_Scalars --
15134 ------------------------
15136 -- pragma Initialize_Scalars;
15138 when Pragma_Initialize_Scalars
=>
15140 Check_Arg_Count
(0);
15141 Check_Valid_Configuration_Pragma
;
15142 Check_Restriction
(No_Initialize_Scalars
, N
);
15144 -- Initialize_Scalars creates false positives in CodePeer, and
15145 -- incorrect negative results in GNATprove mode, so ignore this
15146 -- pragma in these modes.
15148 if not Restriction_Active
(No_Initialize_Scalars
)
15149 and then not (CodePeer_Mode
or GNATprove_Mode
)
15151 Init_Or_Norm_Scalars
:= True;
15152 Initialize_Scalars
:= True;
15159 -- pragma Initializes (INITIALIZATION_SPEC);
15161 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15163 -- INITIALIZATION_LIST ::=
15164 -- INITIALIZATION_ITEM
15165 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15167 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15172 -- | (INPUT {, INPUT})
15176 when Pragma_Initializes
=> Initializes
: declare
15177 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15178 Pack_Id
: Entity_Id
;
15183 Check_Arg_Count
(1);
15184 Ensure_Aggregate_Form
(Arg1
);
15186 -- Ensure the proper placement of the pragma. Initializes must be
15187 -- associated with a package declaration.
15189 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15190 N_Package_Declaration
)
15197 while Present
(Stmt
) loop
15199 -- Skip prior pragmas, but check for duplicates
15201 if Nkind
(Stmt
) = N_Pragma
then
15202 if Pragma_Name
(Stmt
) = Pname
then
15203 Error_Msg_Name_1
:= Pname
;
15204 Error_Msg_Sloc
:= Sloc
(Stmt
);
15205 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15208 -- Skip internally generated code
15210 elsif not Comes_From_Source
(Stmt
) then
15213 -- The pragma does not apply to a legal construct, issue an
15214 -- error and stop the analysis.
15221 Stmt
:= Prev
(Stmt
);
15224 -- The pragma must be analyzed at the end of the visible
15225 -- declarations of the related package. Save the pragma for later
15226 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15227 -- contract of the package.
15229 Pack_Id
:= Defining_Entity
(Context
);
15230 Add_Contract_Item
(N
, Pack_Id
);
15232 -- Verify the declaration order of pragmas Abstract_State and
15233 -- Initializes when SPARK checks are enabled.
15235 if SPARK_Mode
/= Off
then
15236 Check_Declaration_Order
15237 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15246 -- pragma Inline ( NAME {, NAME} );
15248 when Pragma_Inline
=>
15250 -- Inline status is Enabled if inlining option is active
15252 if Inline_Active
then
15253 Process_Inline
(Enabled
);
15255 Process_Inline
(Disabled
);
15258 -------------------
15259 -- Inline_Always --
15260 -------------------
15262 -- pragma Inline_Always ( NAME {, NAME} );
15264 when Pragma_Inline_Always
=>
15267 -- Pragma always active unless in CodePeer or GNATprove mode,
15268 -- since this causes walk order issues.
15270 if not (CodePeer_Mode
or GNATprove_Mode
) then
15271 Process_Inline
(Enabled
);
15274 --------------------
15275 -- Inline_Generic --
15276 --------------------
15278 -- pragma Inline_Generic (NAME {, NAME});
15280 when Pragma_Inline_Generic
=>
15282 Process_Generic_List
;
15284 ----------------------
15285 -- Inspection_Point --
15286 ----------------------
15288 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15290 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15295 if Arg_Count
> 0 then
15298 Exp
:= Get_Pragma_Arg
(Arg
);
15301 if not Is_Entity_Name
(Exp
)
15302 or else not Is_Object
(Entity
(Exp
))
15304 Error_Pragma_Arg
("object name required", Arg
);
15308 exit when No
(Arg
);
15311 end Inspection_Point
;
15317 -- pragma Interface (
15318 -- [ Convention =>] convention_IDENTIFIER,
15319 -- [ Entity =>] local_NAME
15320 -- [, [External_Name =>] static_string_EXPRESSION ]
15321 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15323 when Pragma_Interface
=>
15328 Name_External_Name
,
15330 Check_At_Least_N_Arguments
(2);
15331 Check_At_Most_N_Arguments
(4);
15332 Process_Import_Or_Interface
;
15334 -- In Ada 2005, the permission to use Interface (a reserved word)
15335 -- as a pragma name is considered an obsolescent feature, and this
15336 -- pragma was already obsolescent in Ada 95.
15338 if Ada_Version
>= Ada_95
then
15340 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15342 if Warn_On_Obsolescent_Feature
then
15344 ("pragma Interface is an obsolescent feature?j?", N
);
15346 ("|use pragma Import instead?j?", N
);
15350 --------------------
15351 -- Interface_Name --
15352 --------------------
15354 -- pragma Interface_Name (
15355 -- [ Entity =>] local_NAME
15356 -- [,[External_Name =>] static_string_EXPRESSION ]
15357 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15359 when Pragma_Interface_Name
=> Interface_Name
: declare
15361 Def_Id
: Entity_Id
;
15362 Hom_Id
: Entity_Id
;
15368 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15369 Check_At_Least_N_Arguments
(2);
15370 Check_At_Most_N_Arguments
(3);
15371 Id
:= Get_Pragma_Arg
(Arg1
);
15374 -- This is obsolete from Ada 95 on, but it is an implementation
15375 -- defined pragma, so we do not consider that it violates the
15376 -- restriction (No_Obsolescent_Features).
15378 if Ada_Version
>= Ada_95
then
15379 if Warn_On_Obsolescent_Feature
then
15381 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15383 ("|use pragma Import instead?j?", N
);
15387 if not Is_Entity_Name
(Id
) then
15389 ("first argument for pragma% must be entity name", Arg1
);
15390 elsif Etype
(Id
) = Any_Type
then
15393 Def_Id
:= Entity
(Id
);
15396 -- Special DEC-compatible processing for the object case, forces
15397 -- object to be imported.
15399 if Ekind
(Def_Id
) = E_Variable
then
15400 Kill_Size_Check_Code
(Def_Id
);
15401 Note_Possible_Modification
(Id
, Sure
=> False);
15403 -- Initialization is not allowed for imported variable
15405 if Present
(Expression
(Parent
(Def_Id
)))
15406 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15408 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15410 ("no initialization allowed for declaration of& #",
15414 -- For compatibility, support VADS usage of providing both
15415 -- pragmas Interface and Interface_Name to obtain the effect
15416 -- of a single Import pragma.
15418 if Is_Imported
(Def_Id
)
15419 and then Present
(First_Rep_Item
(Def_Id
))
15420 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15422 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15426 Set_Imported
(Def_Id
);
15429 Set_Is_Public
(Def_Id
);
15430 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15433 -- Otherwise must be subprogram
15435 elsif not Is_Subprogram
(Def_Id
) then
15437 ("argument of pragma% is not subprogram", Arg1
);
15440 Check_At_Most_N_Arguments
(3);
15444 -- Loop through homonyms
15447 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15449 if Is_Imported
(Def_Id
) then
15450 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15454 exit when From_Aspect_Specification
(N
);
15455 Hom_Id
:= Homonym
(Hom_Id
);
15457 exit when No
(Hom_Id
)
15458 or else Scope
(Hom_Id
) /= Current_Scope
;
15463 ("argument of pragma% is not imported subprogram",
15467 end Interface_Name
;
15469 -----------------------
15470 -- Interrupt_Handler --
15471 -----------------------
15473 -- pragma Interrupt_Handler (handler_NAME);
15475 when Pragma_Interrupt_Handler
=>
15476 Check_Ada_83_Warning
;
15477 Check_Arg_Count
(1);
15478 Check_No_Identifiers
;
15480 if No_Run_Time_Mode
then
15481 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15483 Check_Interrupt_Or_Attach_Handler
;
15484 Process_Interrupt_Or_Attach_Handler
;
15487 ------------------------
15488 -- Interrupt_Priority --
15489 ------------------------
15491 -- pragma Interrupt_Priority [(EXPRESSION)];
15493 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15494 P
: constant Node_Id
:= Parent
(N
);
15499 Check_Ada_83_Warning
;
15501 if Arg_Count
/= 0 then
15502 Arg
:= Get_Pragma_Arg
(Arg1
);
15503 Check_Arg_Count
(1);
15504 Check_No_Identifiers
;
15506 -- The expression must be analyzed in the special manner
15507 -- described in "Handling of Default and Per-Object
15508 -- Expressions" in sem.ads.
15510 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15513 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15518 Ent
:= Defining_Identifier
(Parent
(P
));
15520 -- Check duplicate pragma before we chain the pragma in the Rep
15521 -- Item chain of Ent.
15523 Check_Duplicate_Pragma
(Ent
);
15524 Record_Rep_Item
(Ent
, N
);
15526 end Interrupt_Priority
;
15528 ---------------------
15529 -- Interrupt_State --
15530 ---------------------
15532 -- pragma Interrupt_State (
15533 -- [Name =>] INTERRUPT_ID,
15534 -- [State =>] INTERRUPT_STATE);
15536 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15537 -- INTERRUPT_STATE => System | Runtime | User
15539 -- Note: if the interrupt id is given as an identifier, then it must
15540 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15541 -- given as a static integer expression which must be in the range of
15542 -- Ada.Interrupts.Interrupt_ID.
15544 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15545 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15546 -- This is the entity Ada.Interrupts.Interrupt_ID;
15548 State_Type
: Character;
15549 -- Set to 's'/'r'/'u' for System/Runtime/User
15552 -- Index to entry in Interrupt_States table
15555 -- Value of interrupt
15557 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15558 -- The first argument to the pragma
15560 Int_Ent
: Entity_Id
;
15561 -- Interrupt entity in Ada.Interrupts.Names
15565 Check_Arg_Order
((Name_Name
, Name_State
));
15566 Check_Arg_Count
(2);
15568 Check_Optional_Identifier
(Arg1
, Name_Name
);
15569 Check_Optional_Identifier
(Arg2
, Name_State
);
15570 Check_Arg_Is_Identifier
(Arg2
);
15572 -- First argument is identifier
15574 if Nkind
(Arg1X
) = N_Identifier
then
15576 -- Search list of names in Ada.Interrupts.Names
15578 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15580 if No
(Int_Ent
) then
15581 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15583 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15584 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15588 Next_Entity
(Int_Ent
);
15591 -- First argument is not an identifier, so it must be a static
15592 -- expression of type Ada.Interrupts.Interrupt_ID.
15595 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
15596 Int_Val
:= Expr_Value
(Arg1X
);
15598 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15600 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15603 ("value not in range of type "
15604 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15610 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15611 when Name_Runtime
=> State_Type
:= 'r';
15612 when Name_System
=> State_Type
:= 's';
15613 when Name_User
=> State_Type
:= 'u';
15616 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15619 -- Check if entry is already stored
15621 IST_Num
:= Interrupt_States
.First
;
15623 -- If entry not found, add it
15625 if IST_Num
> Interrupt_States
.Last
then
15626 Interrupt_States
.Append
15627 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15628 Interrupt_State
=> State_Type
,
15629 Pragma_Loc
=> Loc
));
15632 -- Case of entry for the same entry
15634 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15637 -- If state matches, done, no need to make redundant entry
15640 State_Type
= Interrupt_States
.Table
(IST_Num
).
15643 -- Otherwise if state does not match, error
15646 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15648 ("state conflicts with that given #", Arg2
);
15652 IST_Num
:= IST_Num
+ 1;
15654 end Interrupt_State
;
15660 -- pragma Invariant
15661 -- ([Entity =>] type_LOCAL_NAME,
15662 -- [Check =>] EXPRESSION
15663 -- [,[Message =>] String_Expression]);
15665 when Pragma_Invariant
=> Invariant
: declare
15671 pragma Unreferenced
(Discard
);
15675 Check_At_Least_N_Arguments
(2);
15676 Check_At_Most_N_Arguments
(3);
15677 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15678 Check_Optional_Identifier
(Arg2
, Name_Check
);
15680 if Arg_Count
= 3 then
15681 Check_Optional_Identifier
(Arg3
, Name_Message
);
15682 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
15685 Check_Arg_Is_Local_Name
(Arg1
);
15687 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15688 Find_Type
(Type_Id
);
15689 Typ
:= Entity
(Type_Id
);
15691 if Typ
= Any_Type
then
15694 -- An invariant must apply to a private type, or appear in the
15695 -- private part of a package spec and apply to a completion.
15696 -- a class-wide invariant can only appear on a private declaration
15697 -- or private extension, not a completion.
15699 elsif Ekind_In
(Typ
, E_Private_Type
,
15700 E_Record_Type_With_Private
,
15701 E_Limited_Private_Type
)
15705 elsif In_Private_Part
(Current_Scope
)
15706 and then Has_Private_Declaration
(Typ
)
15707 and then not Class_Present
(N
)
15711 elsif In_Private_Part
(Current_Scope
) then
15713 ("pragma% only allowed for private type declared in "
15714 & "visible part", Arg1
);
15718 ("pragma% only allowed for private type", Arg1
);
15721 -- Note that the type has at least one invariant, and also that
15722 -- it has inheritable invariants if we have Invariant'Class
15723 -- or Type_Invariant'Class. Build the corresponding invariant
15724 -- procedure declaration, so that calls to it can be generated
15725 -- before the body is built (e.g. within an expression function).
15727 PDecl
:= Build_Invariant_Procedure_Declaration
(Typ
);
15729 Insert_After
(N
, PDecl
);
15732 if Class_Present
(N
) then
15733 Set_Has_Inheritable_Invariants
(Typ
);
15736 -- The remaining processing is simply to link the pragma on to
15737 -- the rep item chain, for processing when the type is frozen.
15738 -- This is accomplished by a call to Rep_Item_Too_Late.
15740 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15743 ----------------------
15744 -- Java_Constructor --
15745 ----------------------
15747 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15749 -- Also handles pragma CIL_Constructor
15751 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15752 Java_Constructor
: declare
15753 Convention
: Convention_Id
;
15754 Def_Id
: Entity_Id
;
15755 Hom_Id
: Entity_Id
;
15757 This_Formal
: Entity_Id
;
15761 Check_Arg_Count
(1);
15762 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15763 Check_Arg_Is_Local_Name
(Arg1
);
15765 Id
:= Get_Pragma_Arg
(Arg1
);
15766 Find_Program_Unit_Name
(Id
);
15768 -- If we did not find the name, we are done
15770 if Etype
(Id
) = Any_Type
then
15774 -- Check wrong use of pragma in wrong VM target
15776 if VM_Target
= No_VM
then
15779 elsif VM_Target
= CLI_Target
15780 and then Prag_Id
= Pragma_Java_Constructor
15782 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15784 elsif VM_Target
= JVM_Target
15785 and then Prag_Id
= Pragma_CIL_Constructor
15787 Error_Pragma
("must use pragma 'Java_'Constructor");
15791 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15792 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15793 when others => null;
15796 Hom_Id
:= Entity
(Id
);
15798 -- Loop through homonyms
15801 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15803 -- The constructor is required to be a function
15805 if Ekind
(Def_Id
) /= E_Function
then
15806 if VM_Target
= JVM_Target
then
15808 ("pragma% requires function returning a 'Java access "
15812 ("pragma% requires function returning a 'C'I'L access "
15817 -- Check arguments: For tagged type the first formal must be
15818 -- named "this" and its type must be a named access type
15819 -- designating a class-wide tagged type that has convention
15820 -- CIL/Java. The first formal must also have a null default
15821 -- value. For example:
15823 -- type Typ is tagged ...
15824 -- type Ref is access all Typ;
15825 -- pragma Convention (CIL, Typ);
15827 -- function New_Typ (This : Ref) return Ref;
15828 -- function New_Typ (This : Ref; I : Integer) return Ref;
15829 -- pragma Cil_Constructor (New_Typ);
15831 -- Reason: The first formal must NOT be a primitive of the
15834 -- This rule also applies to constructors of delegates used
15835 -- to interface with standard target libraries. For example:
15837 -- type Delegate is access procedure ...
15838 -- pragma Import (CIL, Delegate, ...);
15840 -- function new_Delegate
15841 -- (This : Delegate := null; ... ) return Delegate;
15843 -- For value-types this rule does not apply.
15845 if not Is_Value_Type
(Etype
(Def_Id
)) then
15846 if No
(First_Formal
(Def_Id
)) then
15847 Error_Msg_Name_1
:= Pname
;
15848 Error_Msg_N
("% function must have parameters", Def_Id
);
15852 -- In the JRE library we have several occurrences in which
15853 -- the "this" parameter is not the first formal.
15855 This_Formal
:= First_Formal
(Def_Id
);
15857 -- In the JRE library we have several occurrences in which
15858 -- the "this" parameter is not the first formal. Search for
15861 if VM_Target
= JVM_Target
then
15862 while Present
(This_Formal
)
15863 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15865 Next_Formal
(This_Formal
);
15868 if No
(This_Formal
) then
15869 This_Formal
:= First_Formal
(Def_Id
);
15873 -- Warning: The first parameter should be named "this".
15874 -- We temporarily allow it because we have the following
15875 -- case in the Java runtime (file s-osinte.ads) ???
15877 -- function new_Thread
15878 -- (Self_Id : System.Address) return Thread_Id;
15879 -- pragma Java_Constructor (new_Thread);
15881 if VM_Target
= JVM_Target
15882 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15884 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15888 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15889 Error_Msg_Name_1
:= Pname
;
15891 ("first formal of % function must be named `this`",
15892 Parent
(This_Formal
));
15894 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15895 Error_Msg_Name_1
:= Pname
;
15897 ("first formal of % function must be an access type",
15898 Parameter_Type
(Parent
(This_Formal
)));
15900 -- For delegates the type of the first formal must be a
15901 -- named access-to-subprogram type (see previous example)
15903 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15904 and then Ekind
(Etype
(This_Formal
))
15905 /= E_Access_Subprogram_Type
15907 Error_Msg_Name_1
:= Pname
;
15909 ("first formal of % function must be a named access "
15910 & "to subprogram type",
15911 Parameter_Type
(Parent
(This_Formal
)));
15913 -- Warning: We should reject anonymous access types because
15914 -- the constructor must not be handled as a primitive of the
15915 -- tagged type. We temporarily allow it because this profile
15916 -- is currently generated by cil2ada???
15918 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15919 and then not Ekind_In
(Etype
(This_Formal
),
15921 E_General_Access_Type
,
15922 E_Anonymous_Access_Type
)
15924 Error_Msg_Name_1
:= Pname
;
15926 ("first formal of % function must be a named access "
15927 & "type", Parameter_Type
(Parent
(This_Formal
)));
15929 elsif Atree
.Convention
15930 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15932 Error_Msg_Name_1
:= Pname
;
15934 if Convention
= Convention_Java
then
15936 ("pragma% requires convention 'Cil in designated "
15937 & "type", Parameter_Type
(Parent
(This_Formal
)));
15940 ("pragma% requires convention 'Java in designated "
15941 & "type", Parameter_Type
(Parent
(This_Formal
)));
15944 elsif No
(Expression
(Parent
(This_Formal
)))
15945 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15947 Error_Msg_Name_1
:= Pname
;
15949 ("pragma% requires first formal with default `null`",
15950 Parameter_Type
(Parent
(This_Formal
)));
15954 -- Check result type: the constructor must be a function
15956 -- * a value type (only allowed in the CIL compiler)
15957 -- * an access-to-subprogram type with convention Java/CIL
15958 -- * an access-type designating a type that has convention
15961 if Is_Value_Type
(Etype
(Def_Id
)) then
15964 -- Access-to-subprogram type with convention Java/CIL
15966 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15967 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15968 if Convention
= Convention_Java
then
15970 ("pragma% requires function returning a 'Java "
15971 & "access type", Arg1
);
15973 pragma Assert
(Convention
= Convention_CIL
);
15975 ("pragma% requires function returning a 'C'I'L "
15976 & "access type", Arg1
);
15980 elsif Ekind
(Etype
(Def_Id
)) in Access_Kind
then
15981 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15982 E_General_Access_Type
)
15985 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15987 Error_Msg_Name_1
:= Pname
;
15989 if Convention
= Convention_Java
then
15991 ("pragma% requires function returning a named "
15992 & "'Java access type", Arg1
);
15995 ("pragma% requires function returning a named "
15996 & "'C'I'L access type", Arg1
);
16001 Set_Is_Constructor
(Def_Id
);
16002 Set_Convention
(Def_Id
, Convention
);
16003 Set_Is_Imported
(Def_Id
);
16005 exit when From_Aspect_Specification
(N
);
16006 Hom_Id
:= Homonym
(Hom_Id
);
16008 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
16010 end Java_Constructor
;
16012 ----------------------
16013 -- Java_Interface --
16014 ----------------------
16016 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16018 when Pragma_Java_Interface
=> Java_Interface
: declare
16024 Check_Arg_Count
(1);
16025 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16026 Check_Arg_Is_Local_Name
(Arg1
);
16028 Arg
:= Get_Pragma_Arg
(Arg1
);
16031 if Etype
(Arg
) = Any_Type
then
16035 if not Is_Entity_Name
(Arg
)
16036 or else not Is_Type
(Entity
(Arg
))
16038 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
16041 Typ
:= Underlying_Type
(Entity
(Arg
));
16043 -- For now simply check some of the semantic constraints on the
16044 -- type. This currently leaves out some restrictions on interface
16045 -- types, namely that the parent type must be java.lang.Object.Typ
16046 -- and that all primitives of the type should be declared
16049 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
16051 ("pragma% requires an abstract tagged type", Arg1
);
16053 elsif not Has_Discriminants
(Typ
)
16054 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
16055 /= E_Anonymous_Access_Type
16057 not Is_Class_Wide_Type
16058 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
16061 ("type must have a class-wide access discriminant", Arg1
);
16063 end Java_Interface
;
16069 -- pragma Keep_Names ([On => ] local_NAME);
16071 when Pragma_Keep_Names
=> Keep_Names
: declare
16076 Check_Arg_Count
(1);
16077 Check_Optional_Identifier
(Arg1
, Name_On
);
16078 Check_Arg_Is_Local_Name
(Arg1
);
16080 Arg
:= Get_Pragma_Arg
(Arg1
);
16083 if Etype
(Arg
) = Any_Type
then
16087 if not Is_Entity_Name
(Arg
)
16088 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16091 ("pragma% requires a local enumeration type", Arg1
);
16094 Set_Discard_Names
(Entity
(Arg
), False);
16101 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16103 when Pragma_License
=>
16105 Check_Arg_Count
(1);
16106 Check_No_Identifiers
;
16107 Check_Valid_Configuration_Pragma
;
16108 Check_Arg_Is_Identifier
(Arg1
);
16111 Sind
: constant Source_File_Index
:=
16112 Source_Index
(Current_Sem_Unit
);
16115 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16117 Set_License
(Sind
, GPL
);
16119 when Name_Modified_GPL
=>
16120 Set_License
(Sind
, Modified_GPL
);
16122 when Name_Restricted
=>
16123 Set_License
(Sind
, Restricted
);
16125 when Name_Unrestricted
=>
16126 Set_License
(Sind
, Unrestricted
);
16129 Error_Pragma_Arg
("invalid license name", Arg1
);
16137 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16139 when Pragma_Link_With
=> Link_With
: declare
16145 if Operating_Mode
= Generate_Code
16146 and then In_Extended_Main_Source_Unit
(N
)
16148 Check_At_Least_N_Arguments
(1);
16149 Check_No_Identifiers
;
16150 Check_Is_In_Decl_Part_Or_Package_Spec
;
16151 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
16155 while Present
(Arg
) loop
16156 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
16158 -- Store argument, converting sequences of spaces to a
16159 -- single null character (this is one of the differences
16160 -- in processing between Link_With and Linker_Options).
16162 Arg_Store
: declare
16163 C
: constant Char_Code
:= Get_Char_Code
(' ');
16164 S
: constant String_Id
:=
16165 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16166 L
: constant Nat
:= String_Length
(S
);
16169 procedure Skip_Spaces
;
16170 -- Advance F past any spaces
16176 procedure Skip_Spaces
is
16178 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16183 -- Start of processing for Arg_Store
16186 Skip_Spaces
; -- skip leading spaces
16188 -- Loop through characters, changing any embedded
16189 -- sequence of spaces to a single null character (this
16190 -- is how Link_With/Linker_Options differ)
16193 if Get_String_Char
(S
, F
) = C
then
16196 Store_String_Char
(ASCII
.NUL
);
16199 Store_String_Char
(Get_String_Char
(S
, F
));
16207 if Present
(Arg
) then
16208 Store_String_Char
(ASCII
.NUL
);
16212 Store_Linker_Option_String
(End_String
);
16220 -- pragma Linker_Alias (
16221 -- [Entity =>] LOCAL_NAME
16222 -- [Target =>] static_string_EXPRESSION);
16224 when Pragma_Linker_Alias
=>
16226 Check_Arg_Order
((Name_Entity
, Name_Target
));
16227 Check_Arg_Count
(2);
16228 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16229 Check_Optional_Identifier
(Arg2
, Name_Target
);
16230 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16231 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
16233 -- The only processing required is to link this item on to the
16234 -- list of rep items for the given entity. This is accomplished
16235 -- by the call to Rep_Item_Too_Late (when no error is detected
16236 -- and False is returned).
16238 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16241 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16244 ------------------------
16245 -- Linker_Constructor --
16246 ------------------------
16248 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16250 -- Code is shared with Linker_Destructor
16252 -----------------------
16253 -- Linker_Destructor --
16254 -----------------------
16256 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16258 when Pragma_Linker_Constructor |
16259 Pragma_Linker_Destructor
=>
16260 Linker_Constructor
: declare
16266 Check_Arg_Count
(1);
16267 Check_No_Identifiers
;
16268 Check_Arg_Is_Local_Name
(Arg1
);
16269 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16271 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16273 if not Is_Library_Level_Entity
(Proc
) then
16275 ("argument for pragma% must be library level entity", Arg1
);
16278 -- The only processing required is to link this item on to the
16279 -- list of rep items for the given entity. This is accomplished
16280 -- by the call to Rep_Item_Too_Late (when no error is detected
16281 -- and False is returned).
16283 if Rep_Item_Too_Late
(Proc
, N
) then
16286 Set_Has_Gigi_Rep_Item
(Proc
);
16288 end Linker_Constructor
;
16290 --------------------
16291 -- Linker_Options --
16292 --------------------
16294 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16296 when Pragma_Linker_Options
=> Linker_Options
: declare
16300 Check_Ada_83_Warning
;
16301 Check_No_Identifiers
;
16302 Check_Arg_Count
(1);
16303 Check_Is_In_Decl_Part_Or_Package_Spec
;
16304 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
16305 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16308 while Present
(Arg
) loop
16309 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
16310 Store_String_Char
(ASCII
.NUL
);
16312 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16316 if Operating_Mode
= Generate_Code
16317 and then In_Extended_Main_Source_Unit
(N
)
16319 Store_Linker_Option_String
(End_String
);
16321 end Linker_Options
;
16323 --------------------
16324 -- Linker_Section --
16325 --------------------
16327 -- pragma Linker_Section (
16328 -- [Entity =>] LOCAL_NAME
16329 -- [Section =>] static_string_EXPRESSION);
16331 when Pragma_Linker_Section
=> Linker_Section
: declare
16337 Check_Arg_Order
((Name_Entity
, Name_Section
));
16338 Check_Arg_Count
(2);
16339 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16340 Check_Optional_Identifier
(Arg2
, Name_Section
);
16341 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16342 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
16344 -- Check kind of entity
16346 Arg
:= Get_Pragma_Arg
(Arg1
);
16347 Ent
:= Entity
(Arg
);
16349 case Ekind
(Ent
) is
16351 -- Objects (constants and variables) and types. For these cases
16352 -- all we need to do is to set the Linker_Section_pragma field.
16354 when E_Constant | E_Variable | Type_Kind
=>
16355 Set_Linker_Section_Pragma
(Ent
, N
);
16359 when Subprogram_Kind
=>
16361 -- Aspect case, entity already set
16363 if From_Aspect_Specification
(N
) then
16364 Set_Linker_Section_Pragma
16365 (Entity
(Corresponding_Aspect
(N
)), N
);
16367 -- Pragma case, we must climb the homonym chain, but skip
16368 -- any for which the linker section is already set.
16372 if No
(Linker_Section_Pragma
(Ent
)) then
16373 Set_Linker_Section_Pragma
(Ent
, N
);
16376 Ent
:= Homonym
(Ent
);
16378 or else Scope
(Ent
) /= Current_Scope
;
16382 -- All other cases are illegal
16386 ("pragma% applies only to objects, subprograms, and types",
16389 end Linker_Section
;
16395 -- pragma List (On | Off)
16397 -- There is nothing to do here, since we did all the processing for
16398 -- this pragma in Par.Prag (so that it works properly even in syntax
16401 when Pragma_List
=>
16408 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16410 when Pragma_Lock_Free
=> Lock_Free
: declare
16411 P
: constant Node_Id
:= Parent
(N
);
16417 Check_No_Identifiers
;
16418 Check_At_Most_N_Arguments
(1);
16420 -- Protected definition case
16422 if Nkind
(P
) = N_Protected_Definition
then
16423 Ent
:= Defining_Identifier
(Parent
(P
));
16427 if Arg_Count
= 1 then
16428 Arg
:= Get_Pragma_Arg
(Arg1
);
16429 Val
:= Is_True
(Static_Boolean
(Arg
));
16431 -- No arguments (expression is considered to be True)
16437 -- Check duplicate pragma before we chain the pragma in the Rep
16438 -- Item chain of Ent.
16440 Check_Duplicate_Pragma
(Ent
);
16441 Record_Rep_Item
(Ent
, N
);
16442 Set_Uses_Lock_Free
(Ent
, Val
);
16444 -- Anything else is incorrect placement
16451 --------------------
16452 -- Locking_Policy --
16453 --------------------
16455 -- pragma Locking_Policy (policy_IDENTIFIER);
16457 when Pragma_Locking_Policy
=> declare
16458 subtype LP_Range
is Name_Id
16459 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16464 Check_Ada_83_Warning
;
16465 Check_Arg_Count
(1);
16466 Check_No_Identifiers
;
16467 Check_Arg_Is_Locking_Policy
(Arg1
);
16468 Check_Valid_Configuration_Pragma
;
16469 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16472 when Name_Ceiling_Locking
=>
16474 when Name_Inheritance_Locking
=>
16476 when Name_Concurrent_Readers_Locking
=>
16480 if Locking_Policy
/= ' '
16481 and then Locking_Policy
/= LP
16483 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16484 Error_Pragma
("locking policy incompatible with policy#");
16486 -- Set new policy, but always preserve System_Location since we
16487 -- like the error message with the run time name.
16490 Locking_Policy
:= LP
;
16492 if Locking_Policy_Sloc
/= System_Location
then
16493 Locking_Policy_Sloc
:= Loc
;
16502 -- pragma Long_Float (D_Float | G_Float);
16504 when Pragma_Long_Float
=> Long_Float : declare
16507 Check_Valid_Configuration_Pragma
;
16508 Check_Arg_Count
(1);
16509 Check_No_Identifier
(Arg1
);
16510 Check_Arg_Is_One_Of
(Arg1
, Name_D_Float
, Name_G_Float
);
16512 if not OpenVMS_On_Target
then
16513 Error_Pragma
("??pragma% ignored (applies only to Open'V'M'S)");
16518 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_D_Float
then
16519 if Opt
.Float_Format_Long
= 'G' then
16521 ("G_Float previously specified", Arg1
);
16523 elsif Current_Sem_Unit
/= Main_Unit
16524 and then Opt
.Float_Format_Long
/= 'D'
16527 ("main unit not compiled with pragma Long_Float (D_Float)",
16528 "\pragma% must be used consistently for whole partition",
16532 Opt
.Float_Format_Long
:= 'D';
16535 -- G_Float case (this is the default, does not need overriding)
16538 if Opt
.Float_Format_Long
= 'D' then
16539 Error_Pragma
("D_Float previously specified");
16541 elsif Current_Sem_Unit
/= Main_Unit
16542 and then Opt
.Float_Format_Long
/= 'G'
16545 ("main unit not compiled with pragma Long_Float (G_Float)",
16546 "\pragma% must be used consistently for whole partition",
16550 Opt
.Float_Format_Long
:= 'G';
16554 Set_Standard_Fpt_Formats
;
16557 -------------------
16558 -- Loop_Optimize --
16559 -------------------
16561 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16563 -- OPTIMIZATION_HINT ::=
16564 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16566 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16571 Check_At_Least_N_Arguments
(1);
16572 Check_No_Identifiers
;
16574 Hint
:= First
(Pragma_Argument_Associations
(N
));
16575 while Present
(Hint
) loop
16576 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16577 Name_No_Unroll
, Name_Unroll
, Name_No_Vector
, Name_Vector
);
16581 Check_Loop_Pragma_Placement
;
16588 -- pragma Loop_Variant
16589 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16591 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16593 -- CHANGE_DIRECTION ::= Increases | Decreases
16595 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16600 Check_At_Least_N_Arguments
(1);
16601 Check_Loop_Pragma_Placement
;
16603 -- Process all increasing / decreasing expressions
16605 Variant
:= First
(Pragma_Argument_Associations
(N
));
16606 while Present
(Variant
) loop
16607 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16610 Error_Pragma_Arg
("wrong change modifier", Variant
);
16613 Preanalyze_Assert_Expression
16614 (Expression
(Variant
), Any_Discrete
);
16620 -----------------------
16621 -- Machine_Attribute --
16622 -----------------------
16624 -- pragma Machine_Attribute (
16625 -- [Entity =>] LOCAL_NAME,
16626 -- [Attribute_Name =>] static_string_EXPRESSION
16627 -- [, [Info =>] static_EXPRESSION] );
16629 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16630 Def_Id
: Entity_Id
;
16634 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16636 if Arg_Count
= 3 then
16637 Check_Optional_Identifier
(Arg3
, Name_Info
);
16638 Check_Arg_Is_Static_Expression
(Arg3
);
16640 Check_Arg_Count
(2);
16643 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16644 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16645 Check_Arg_Is_Local_Name
(Arg1
);
16646 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
16647 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16649 if Is_Access_Type
(Def_Id
) then
16650 Def_Id
:= Designated_Type
(Def_Id
);
16653 if Rep_Item_Too_Early
(Def_Id
, N
) then
16657 Def_Id
:= Underlying_Type
(Def_Id
);
16659 -- The only processing required is to link this item on to the
16660 -- list of rep items for the given entity. This is accomplished
16661 -- by the call to Rep_Item_Too_Late (when no error is detected
16662 -- and False is returned).
16664 if Rep_Item_Too_Late
(Def_Id
, N
) then
16667 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16669 end Machine_Attribute
;
16676 -- (MAIN_OPTION [, MAIN_OPTION]);
16679 -- [STACK_SIZE =>] static_integer_EXPRESSION
16680 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16681 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16683 when Pragma_Main
=> Main
: declare
16684 Args
: Args_List
(1 .. 3);
16685 Names
: constant Name_List
(1 .. 3) := (
16687 Name_Task_Stack_Size_Default
,
16688 Name_Time_Slicing_Enabled
);
16694 Gather_Associations
(Names
, Args
);
16696 for J
in 1 .. 2 loop
16697 if Present
(Args
(J
)) then
16698 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
16702 if Present
(Args
(3)) then
16703 Check_Arg_Is_Static_Expression
(Args
(3), Standard_Boolean
);
16707 while Present
(Nod
) loop
16708 if Nkind
(Nod
) = N_Pragma
16709 and then Pragma_Name
(Nod
) = Name_Main
16711 Error_Msg_Name_1
:= Pname
;
16712 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16723 -- pragma Main_Storage
16724 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16726 -- MAIN_STORAGE_OPTION ::=
16727 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16728 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16730 when Pragma_Main_Storage
=> Main_Storage
: declare
16731 Args
: Args_List
(1 .. 2);
16732 Names
: constant Name_List
(1 .. 2) := (
16733 Name_Working_Storage
,
16740 Gather_Associations
(Names
, Args
);
16742 for J
in 1 .. 2 loop
16743 if Present
(Args
(J
)) then
16744 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
16748 Check_In_Main_Program
;
16751 while Present
(Nod
) loop
16752 if Nkind
(Nod
) = N_Pragma
16753 and then Pragma_Name
(Nod
) = Name_Main_Storage
16755 Error_Msg_Name_1
:= Pname
;
16756 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16767 -- pragma Memory_Size (NUMERIC_LITERAL)
16769 when Pragma_Memory_Size
=>
16772 -- Memory size is simply ignored
16774 Check_No_Identifiers
;
16775 Check_Arg_Count
(1);
16776 Check_Arg_Is_Integer_Literal
(Arg1
);
16784 -- The only correct use of this pragma is on its own in a file, in
16785 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16786 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16787 -- check for a file containing nothing but a No_Body pragma). If we
16788 -- attempt to process it during normal semantics processing, it means
16789 -- it was misplaced.
16791 when Pragma_No_Body
=>
16799 -- pragma No_Inline ( NAME {, NAME} );
16801 when Pragma_No_Inline
=>
16803 Process_Inline
(Suppressed
);
16809 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16811 when Pragma_No_Return
=> No_Return
: declare
16819 Check_At_Least_N_Arguments
(1);
16821 -- Loop through arguments of pragma
16824 while Present
(Arg
) loop
16825 Check_Arg_Is_Local_Name
(Arg
);
16826 Id
:= Get_Pragma_Arg
(Arg
);
16829 if not Is_Entity_Name
(Id
) then
16830 Error_Pragma_Arg
("entity name required", Arg
);
16833 if Etype
(Id
) = Any_Type
then
16837 -- Loop to find matching procedures
16842 and then Scope
(E
) = Current_Scope
16844 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16847 -- Set flag on any alias as well
16849 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16850 Set_No_Return
(Alias
(E
));
16856 exit when From_Aspect_Specification
(N
);
16860 -- If entity in not in current scope it may be the enclosing
16861 -- suprogram body to which the aspect applies.
16864 if Entity
(Id
) = Current_Scope
16865 and then From_Aspect_Specification
(N
)
16867 Set_No_Return
(Entity
(Id
));
16869 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16881 -- pragma No_Run_Time;
16883 -- Note: this pragma is retained for backwards compatibility. See
16884 -- body of Rtsfind for full details on its handling.
16886 when Pragma_No_Run_Time
=>
16888 Check_Valid_Configuration_Pragma
;
16889 Check_Arg_Count
(0);
16891 No_Run_Time_Mode
:= True;
16892 Configurable_Run_Time_Mode
:= True;
16894 -- Set Duration to 32 bits if word size is 32
16896 if Ttypes
.System_Word_Size
= 32 then
16897 Duration_32_Bits_On_Target
:= True;
16900 -- Set appropriate restrictions
16902 Set_Restriction
(No_Finalization
, N
);
16903 Set_Restriction
(No_Exception_Handlers
, N
);
16904 Set_Restriction
(Max_Tasks
, N
, 0);
16905 Set_Restriction
(No_Tasking
, N
);
16907 ------------------------
16908 -- No_Strict_Aliasing --
16909 ------------------------
16911 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16913 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16918 Check_At_Most_N_Arguments
(1);
16920 if Arg_Count
= 0 then
16921 Check_Valid_Configuration_Pragma
;
16922 Opt
.No_Strict_Aliasing
:= True;
16925 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16926 Check_Arg_Is_Local_Name
(Arg1
);
16927 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16929 if E_Id
= Any_Type
then
16931 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16932 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16935 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16937 end No_Strict_Aliasing
;
16939 -----------------------
16940 -- Normalize_Scalars --
16941 -----------------------
16943 -- pragma Normalize_Scalars;
16945 when Pragma_Normalize_Scalars
=>
16946 Check_Ada_83_Warning
;
16947 Check_Arg_Count
(0);
16948 Check_Valid_Configuration_Pragma
;
16950 -- Normalize_Scalars creates false positives in CodePeer, and
16951 -- incorrect negative results in GNATprove mode, so ignore this
16952 -- pragma in these modes.
16954 if not (CodePeer_Mode
or GNATprove_Mode
) then
16955 Normalize_Scalars
:= True;
16956 Init_Or_Norm_Scalars
:= True;
16963 -- pragma Obsolescent;
16965 -- pragma Obsolescent (
16966 -- [Message =>] static_string_EXPRESSION
16967 -- [,[Version =>] Ada_05]]);
16969 -- pragma Obsolescent (
16970 -- [Entity =>] NAME
16971 -- [,[Message =>] static_string_EXPRESSION
16972 -- [,[Version =>] Ada_05]] );
16974 when Pragma_Obsolescent
=> Obsolescent
: declare
16978 procedure Set_Obsolescent
(E
: Entity_Id
);
16979 -- Given an entity Ent, mark it as obsolescent if appropriate
16981 ---------------------
16982 -- Set_Obsolescent --
16983 ---------------------
16985 procedure Set_Obsolescent
(E
: Entity_Id
) is
16994 -- Entity name was given
16996 if Present
(Ename
) then
16998 -- If entity name matches, we are fine. Save entity in
16999 -- pragma argument, for ASIS use.
17001 if Chars
(Ename
) = Chars
(Ent
) then
17002 Set_Entity
(Ename
, Ent
);
17003 Generate_Reference
(Ent
, Ename
);
17005 -- If entity name does not match, only possibility is an
17006 -- enumeration literal from an enumeration type declaration.
17008 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17010 ("pragma % entity name does not match declaration");
17013 Ent
:= First_Literal
(E
);
17017 ("pragma % entity name does not match any "
17018 & "enumeration literal");
17020 elsif Chars
(Ent
) = Chars
(Ename
) then
17021 Set_Entity
(Ename
, Ent
);
17022 Generate_Reference
(Ent
, Ename
);
17026 Ent
:= Next_Literal
(Ent
);
17032 -- Ent points to entity to be marked
17034 if Arg_Count
>= 1 then
17036 -- Deal with static string argument
17038 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
17039 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17041 for J
in 1 .. String_Length
(S
) loop
17042 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17044 ("pragma% argument does not allow wide characters",
17049 Obsolescent_Warnings
.Append
17050 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17052 -- Check for Ada_05 parameter
17054 if Arg_Count
/= 1 then
17055 Check_Arg_Count
(2);
17058 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17061 Check_Arg_Is_Identifier
(Argx
);
17063 if Chars
(Argx
) /= Name_Ada_05
then
17064 Error_Msg_Name_2
:= Name_Ada_05
;
17066 ("only allowed argument for pragma% is %", Argx
);
17069 if Ada_Version_Explicit
< Ada_2005
17070 or else not Warn_On_Ada_2005_Compatibility
17078 -- Set flag if pragma active
17081 Set_Is_Obsolescent
(Ent
);
17085 end Set_Obsolescent
;
17087 -- Start of processing for pragma Obsolescent
17092 Check_At_Most_N_Arguments
(3);
17094 -- See if first argument specifies an entity name
17098 (Chars
(Arg1
) = Name_Entity
17100 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17102 N_Operator_Symbol
))
17104 Ename
:= Get_Pragma_Arg
(Arg1
);
17106 -- Eliminate first argument, so we can share processing
17110 Arg_Count
:= Arg_Count
- 1;
17112 -- No Entity name argument given
17118 if Arg_Count
>= 1 then
17119 Check_Optional_Identifier
(Arg1
, Name_Message
);
17121 if Arg_Count
= 2 then
17122 Check_Optional_Identifier
(Arg2
, Name_Version
);
17126 -- Get immediately preceding declaration
17129 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17133 -- Cases where we do not follow anything other than another pragma
17137 -- First case: library level compilation unit declaration with
17138 -- the pragma immediately following the declaration.
17140 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17142 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17145 -- Case 2: library unit placement for package
17149 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17151 if Is_Package_Or_Generic_Package
(Ent
) then
17152 Set_Obsolescent
(Ent
);
17158 -- Cases where we must follow a declaration
17161 if Nkind
(Decl
) not in N_Declaration
17162 and then Nkind
(Decl
) not in N_Later_Decl_Item
17163 and then Nkind
(Decl
) not in N_Generic_Declaration
17164 and then Nkind
(Decl
) not in N_Renaming_Declaration
17167 ("pragma% misplaced, "
17168 & "must immediately follow a declaration");
17171 Set_Obsolescent
(Defining_Entity
(Decl
));
17181 -- pragma Optimize (Time | Space | Off);
17183 -- The actual check for optimize is done in Gigi. Note that this
17184 -- pragma does not actually change the optimization setting, it
17185 -- simply checks that it is consistent with the pragma.
17187 when Pragma_Optimize
=>
17188 Check_No_Identifiers
;
17189 Check_Arg_Count
(1);
17190 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17192 ------------------------
17193 -- Optimize_Alignment --
17194 ------------------------
17196 -- pragma Optimize_Alignment (Time | Space | Off);
17198 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17200 Check_No_Identifiers
;
17201 Check_Arg_Count
(1);
17202 Check_Valid_Configuration_Pragma
;
17205 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17209 Opt
.Optimize_Alignment
:= 'T';
17211 Opt
.Optimize_Alignment
:= 'S';
17213 Opt
.Optimize_Alignment
:= 'O';
17215 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17219 -- Set indication that mode is set locally. If we are in fact in a
17220 -- configuration pragma file, this setting is harmless since the
17221 -- switch will get reset anyway at the start of each unit.
17223 Optimize_Alignment_Local
:= True;
17224 end Optimize_Alignment
;
17230 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17232 when Pragma_Ordered
=> Ordered
: declare
17233 Assoc
: constant Node_Id
:= Arg1
;
17239 Check_No_Identifiers
;
17240 Check_Arg_Count
(1);
17241 Check_Arg_Is_Local_Name
(Arg1
);
17243 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17244 Find_Type
(Type_Id
);
17245 Typ
:= Entity
(Type_Id
);
17247 if Typ
= Any_Type
then
17250 Typ
:= Underlying_Type
(Typ
);
17253 if not Is_Enumeration_Type
(Typ
) then
17254 Error_Pragma
("pragma% must specify enumeration type");
17257 Check_First_Subtype
(Arg1
);
17258 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17261 -------------------
17262 -- Overflow_Mode --
17263 -------------------
17265 -- pragma Overflow_Mode
17266 -- ([General => ] MODE [, [Assertions => ] MODE]);
17268 -- MODE := STRICT | MINIMIZED | ELIMINATED
17270 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17271 -- since System.Bignums makes this assumption. This is true of nearly
17272 -- all (all?) targets.
17274 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17275 function Get_Overflow_Mode
17277 Arg
: Node_Id
) return Overflow_Mode_Type
;
17278 -- Function to process one pragma argument, Arg. If an identifier
17279 -- is present, it must be Name. Mode type is returned if a valid
17280 -- argument exists, otherwise an error is signalled.
17282 -----------------------
17283 -- Get_Overflow_Mode --
17284 -----------------------
17286 function Get_Overflow_Mode
17288 Arg
: Node_Id
) return Overflow_Mode_Type
17290 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17293 Check_Optional_Identifier
(Arg
, Name
);
17294 Check_Arg_Is_Identifier
(Argx
);
17296 if Chars
(Argx
) = Name_Strict
then
17299 elsif Chars
(Argx
) = Name_Minimized
then
17302 elsif Chars
(Argx
) = Name_Eliminated
then
17303 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17305 ("Eliminated not implemented on this target", Argx
);
17311 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17313 end Get_Overflow_Mode
;
17315 -- Start of processing for Overflow_Mode
17319 Check_At_Least_N_Arguments
(1);
17320 Check_At_Most_N_Arguments
(2);
17322 -- Process first argument
17324 Scope_Suppress
.Overflow_Mode_General
:=
17325 Get_Overflow_Mode
(Name_General
, Arg1
);
17327 -- Case of only one argument
17329 if Arg_Count
= 1 then
17330 Scope_Suppress
.Overflow_Mode_Assertions
:=
17331 Scope_Suppress
.Overflow_Mode_General
;
17333 -- Case of two arguments present
17336 Scope_Suppress
.Overflow_Mode_Assertions
:=
17337 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17341 --------------------------
17342 -- Overriding Renamings --
17343 --------------------------
17345 -- pragma Overriding_Renamings;
17347 when Pragma_Overriding_Renamings
=>
17349 Check_Arg_Count
(0);
17350 Check_Valid_Configuration_Pragma
;
17351 Overriding_Renamings
:= True;
17357 -- pragma Pack (first_subtype_LOCAL_NAME);
17359 when Pragma_Pack
=> Pack
: declare
17360 Assoc
: constant Node_Id
:= Arg1
;
17364 Ignore
: Boolean := False;
17367 Check_No_Identifiers
;
17368 Check_Arg_Count
(1);
17369 Check_Arg_Is_Local_Name
(Arg1
);
17371 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17372 Find_Type
(Type_Id
);
17373 Typ
:= Entity
(Type_Id
);
17376 or else Rep_Item_Too_Early
(Typ
, N
)
17380 Typ
:= Underlying_Type
(Typ
);
17383 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17384 Error_Pragma
("pragma% must specify array or record type");
17387 Check_First_Subtype
(Arg1
);
17388 Check_Duplicate_Pragma
(Typ
);
17392 if Is_Array_Type
(Typ
) then
17393 Ctyp
:= Component_Type
(Typ
);
17395 -- Ignore pack that does nothing
17397 if Known_Static_Esize
(Ctyp
)
17398 and then Known_Static_RM_Size
(Ctyp
)
17399 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17400 and then Addressable
(Esize
(Ctyp
))
17405 -- Process OK pragma Pack. Note that if there is a separate
17406 -- component clause present, the Pack will be cancelled. This
17407 -- processing is in Freeze.
17409 if not Rep_Item_Too_Late
(Typ
, N
) then
17411 -- In CodePeer mode, we do not need complex front-end
17412 -- expansions related to pragma Pack, so disable handling
17415 if CodePeer_Mode
then
17418 -- Don't attempt any packing for VM targets. We possibly
17419 -- could deal with some cases of array bit-packing, but we
17420 -- don't bother, since this is not a typical kind of
17421 -- representation in the VM context anyway (and would not
17422 -- for example work nicely with the debugger).
17424 elsif VM_Target
/= No_VM
then
17425 if not GNAT_Mode
then
17427 ("??pragma% ignored in this configuration");
17430 -- Normal case where we do the pack action
17434 Set_Is_Packed
(Base_Type
(Typ
));
17435 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17438 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17442 -- For record types, the pack is always effective
17444 else pragma Assert
(Is_Record_Type
(Typ
));
17445 if not Rep_Item_Too_Late
(Typ
, N
) then
17447 -- Ignore pack request with warning in VM mode (skip warning
17448 -- if we are compiling GNAT run time library).
17450 if VM_Target
/= No_VM
then
17451 if not GNAT_Mode
then
17453 ("??pragma% ignored in this configuration");
17456 -- Normal case of pack request active
17459 Set_Is_Packed
(Base_Type
(Typ
));
17460 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17461 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17473 -- There is nothing to do here, since we did all the processing for
17474 -- this pragma in Par.Prag (so that it works properly even in syntax
17477 when Pragma_Page
=>
17484 -- pragma Part_Of (ABSTRACT_STATE);
17486 -- ABSTRACT_STATE ::= name
17488 when Pragma_Part_Of
=> Part_Of
: declare
17489 procedure Propagate_Part_Of
17490 (Pack_Id
: Entity_Id
;
17491 State_Id
: Entity_Id
;
17492 Instance
: Node_Id
);
17493 -- Propagate the Part_Of indicator to all abstract states and
17494 -- variables declared in the visible state space of a package
17495 -- denoted by Pack_Id. State_Id is the encapsulating state.
17496 -- Instance is the package instantiation node.
17498 -----------------------
17499 -- Propagate_Part_Of --
17500 -----------------------
17502 procedure Propagate_Part_Of
17503 (Pack_Id
: Entity_Id
;
17504 State_Id
: Entity_Id
;
17505 Instance
: Node_Id
)
17507 Has_Item
: Boolean := False;
17508 -- Flag set when the visible state space contains at least one
17509 -- abstract state or variable.
17511 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17512 -- Propagate the Part_Of indicator to all abstract states and
17513 -- variables declared in the visible state space of a package
17514 -- denoted by Pack_Id.
17516 -----------------------
17517 -- Propagate_Part_Of --
17518 -----------------------
17520 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17521 Item_Id
: Entity_Id
;
17524 -- Traverse the entity chain of the package and set relevant
17525 -- attributes of abstract states and variables declared in
17526 -- the visible state space of the package.
17528 Item_Id
:= First_Entity
(Pack_Id
);
17529 while Present
(Item_Id
)
17530 and then not In_Private_Part
(Item_Id
)
17532 -- Do not consider internally generated items
17534 if not Comes_From_Source
(Item_Id
) then
17537 -- The Part_Of indicator turns an abstract state or
17538 -- variable into a constituent of the encapsulating
17541 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17546 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17547 Set_Encapsulating_State
(Item_Id
, State_Id
);
17549 -- Recursively handle nested packages and instantiations
17551 elsif Ekind
(Item_Id
) = E_Package
then
17552 Propagate_Part_Of
(Item_Id
);
17555 Next_Entity
(Item_Id
);
17557 end Propagate_Part_Of
;
17559 -- Start of processing for Propagate_Part_Of
17562 Propagate_Part_Of
(Pack_Id
);
17564 -- Detect a package instantiation that is subject to a Part_Of
17565 -- indicator, but has no visible state.
17567 if not Has_Item
then
17569 ("package instantiation & has Part_Of indicator but "
17570 & "lacks visible state", Instance
, Pack_Id
);
17572 end Propagate_Part_Of
;
17576 Item_Id
: Entity_Id
;
17579 State_Id
: Entity_Id
;
17582 -- Start of processing for Part_Of
17586 Check_Arg_Count
(1);
17588 -- Ensure the proper placement of the pragma. Part_Of must appear
17589 -- on a variable declaration or a package instantiation.
17592 while Present
(Stmt
) loop
17594 -- Skip prior pragmas, but check for duplicates
17596 if Nkind
(Stmt
) = N_Pragma
then
17597 if Pragma_Name
(Stmt
) = Pname
then
17598 Error_Msg_Name_1
:= Pname
;
17599 Error_Msg_Sloc
:= Sloc
(Stmt
);
17600 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17603 -- Skip internally generated code
17605 elsif not Comes_From_Source
(Stmt
) then
17608 -- The pragma applies to an object declaration (possibly a
17609 -- variable) or a package instantiation. Stop the traversal
17610 -- and continue the analysis.
17612 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17613 N_Package_Instantiation
)
17617 -- The pragma does not apply to a legal construct, issue an
17618 -- error and stop the analysis.
17625 Stmt
:= Prev
(Stmt
);
17628 -- When the context is an object declaration, ensure that we are
17629 -- dealing with a variable.
17631 if Nkind
(Stmt
) = N_Object_Declaration
17632 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17634 Error_Msg_N
("indicator Part_Of must apply to a variable", N
);
17638 -- Extract the entity of the related object declaration or package
17639 -- instantiation. In the case of the instantiation, use the entity
17640 -- of the instance spec.
17642 if Nkind
(Stmt
) = N_Package_Instantiation
then
17643 Stmt
:= Instance_Spec
(Stmt
);
17646 Item_Id
:= Defining_Entity
(Stmt
);
17647 State
:= Get_Pragma_Arg
(Arg1
);
17649 -- Detect any discrepancies between the placement of the object
17650 -- or package instantiation with respect to state space and the
17651 -- encapsulating state.
17654 (Item_Id
=> Item_Id
,
17660 State_Id
:= Entity
(State
);
17662 -- Add the pragma to the contract of the item. This aids with
17663 -- the detection of a missing but required Part_Of indicator.
17665 Add_Contract_Item
(N
, Item_Id
);
17667 -- The Part_Of indicator turns a variable into a constituent
17668 -- of the encapsulating state.
17670 if Ekind
(Item_Id
) = E_Variable
then
17671 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17672 Set_Encapsulating_State
(Item_Id
, State_Id
);
17674 -- Propagate the Part_Of indicator to the visible state space
17675 -- of the package instantiation.
17679 (Pack_Id
=> Item_Id
,
17680 State_Id
=> State_Id
,
17686 ----------------------------------
17687 -- Partition_Elaboration_Policy --
17688 ----------------------------------
17690 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17692 when Pragma_Partition_Elaboration_Policy
=> declare
17693 subtype PEP_Range
is Name_Id
17694 range First_Partition_Elaboration_Policy_Name
17695 .. Last_Partition_Elaboration_Policy_Name
;
17696 PEP_Val
: PEP_Range
;
17701 Check_Arg_Count
(1);
17702 Check_No_Identifiers
;
17703 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17704 Check_Valid_Configuration_Pragma
;
17705 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17708 when Name_Concurrent
=>
17710 when Name_Sequential
=>
17714 if Partition_Elaboration_Policy
/= ' '
17715 and then Partition_Elaboration_Policy
/= PEP
17717 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17719 ("partition elaboration policy incompatible with policy#");
17721 -- Set new policy, but always preserve System_Location since we
17722 -- like the error message with the run time name.
17725 Partition_Elaboration_Policy
:= PEP
;
17727 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17728 Partition_Elaboration_Policy_Sloc
:= Loc
;
17737 -- pragma Passive [(PASSIVE_FORM)];
17739 -- PASSIVE_FORM ::= Semaphore | No
17741 when Pragma_Passive
=>
17744 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17745 Error_Pragma
("pragma% must be within task definition");
17748 if Arg_Count
/= 0 then
17749 Check_Arg_Count
(1);
17750 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17753 ----------------------------------
17754 -- Preelaborable_Initialization --
17755 ----------------------------------
17757 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17759 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17764 Check_Arg_Count
(1);
17765 Check_No_Identifiers
;
17766 Check_Arg_Is_Identifier
(Arg1
);
17767 Check_Arg_Is_Local_Name
(Arg1
);
17768 Check_First_Subtype
(Arg1
);
17769 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17771 -- The pragma may come from an aspect on a private declaration,
17772 -- even if the freeze point at which this is analyzed in the
17773 -- private part after the full view.
17775 if Has_Private_Declaration
(Ent
)
17776 and then From_Aspect_Specification
(N
)
17780 elsif Is_Private_Type
(Ent
)
17781 or else Is_Protected_Type
(Ent
)
17782 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17788 ("pragma % can only be applied to private, formal derived or "
17789 & "protected type",
17793 -- Give an error if the pragma is applied to a protected type that
17794 -- does not qualify (due to having entries, or due to components
17795 -- that do not qualify).
17797 if Is_Protected_Type
(Ent
)
17798 and then not Has_Preelaborable_Initialization
(Ent
)
17801 ("protected type & does not have preelaborable "
17802 & "initialization", Ent
);
17804 -- Otherwise mark the type as definitely having preelaborable
17808 Set_Known_To_Have_Preelab_Init
(Ent
);
17811 if Has_Pragma_Preelab_Init
(Ent
)
17812 and then Warn_On_Redundant_Constructs
17814 Error_Pragma
("?r?duplicate pragma%!");
17816 Set_Has_Pragma_Preelab_Init
(Ent
);
17820 --------------------
17821 -- Persistent_BSS --
17822 --------------------
17824 -- pragma Persistent_BSS [(object_NAME)];
17826 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17833 Check_At_Most_N_Arguments
(1);
17835 -- Case of application to specific object (one argument)
17837 if Arg_Count
= 1 then
17838 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17840 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17842 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17845 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17848 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17849 Decl
:= Parent
(Ent
);
17851 -- Check for duplication before inserting in list of
17852 -- representation items.
17854 Check_Duplicate_Pragma
(Ent
);
17856 if Rep_Item_Too_Late
(Ent
, N
) then
17860 if Present
(Expression
(Decl
)) then
17862 ("object for pragma% cannot have initialization", Arg1
);
17865 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17867 ("object type for pragma% is not potentially persistent",
17872 Make_Linker_Section_Pragma
17873 (Ent
, Sloc
(N
), ".persistent.bss");
17874 Insert_After
(N
, Prag
);
17877 -- Case of use as configuration pragma with no arguments
17880 Check_Valid_Configuration_Pragma
;
17881 Persistent_BSS_Mode
:= True;
17883 end Persistent_BSS
;
17889 -- pragma Polling (ON | OFF);
17891 when Pragma_Polling
=>
17893 Check_Arg_Count
(1);
17894 Check_No_Identifiers
;
17895 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17896 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17902 -- pragma Post (Boolean_EXPRESSION);
17903 -- pragma Post_Class (Boolean_EXPRESSION);
17905 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
17906 PC_Pragma
: Node_Id
;
17910 Check_Arg_Count
(1);
17911 Check_No_Identifiers
;
17914 -- Rewrite Post[_Class] pragma as Precondition pragma setting the
17915 -- flag Class_Present to True for the Post_Class case.
17917 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
17918 PC_Pragma
:= New_Copy
(N
);
17919 Set_Pragma_Identifier
17920 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
17921 Rewrite
(N
, PC_Pragma
);
17922 Set_Analyzed
(N
, False);
17926 -------------------
17927 -- Postcondition --
17928 -------------------
17930 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17931 -- [,[Message =>] String_EXPRESSION]);
17933 when Pragma_Postcondition
=> Postcondition
: declare
17938 Check_At_Least_N_Arguments
(1);
17939 Check_At_Most_N_Arguments
(2);
17940 Check_Optional_Identifier
(Arg1
, Name_Check
);
17942 -- Verify the proper placement of the pragma. The remainder of the
17943 -- processing is found in Sem_Ch6/Sem_Ch7.
17945 Check_Precondition_Postcondition
(In_Body
);
17947 -- When the pragma is a source construct appearing inside a body,
17948 -- preanalyze the boolean_expression to detect illegal forward
17952 -- pragma Postcondition (X'Old ...);
17955 if Comes_From_Source
(N
) and then In_Body
then
17956 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
17964 -- pragma Pre (Boolean_EXPRESSION);
17965 -- pragma Pre_Class (Boolean_EXPRESSION);
17967 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
17968 PC_Pragma
: Node_Id
;
17972 Check_Arg_Count
(1);
17973 Check_No_Identifiers
;
17976 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
17977 -- flag Class_Present to True for the Pre_Class case.
17979 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
17980 PC_Pragma
:= New_Copy
(N
);
17981 Set_Pragma_Identifier
17982 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
17983 Rewrite
(N
, PC_Pragma
);
17984 Set_Analyzed
(N
, False);
17992 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
17993 -- [,[Message =>] String_EXPRESSION]);
17995 when Pragma_Precondition
=> Precondition
: declare
18000 Check_At_Least_N_Arguments
(1);
18001 Check_At_Most_N_Arguments
(2);
18002 Check_Optional_Identifier
(Arg1
, Name_Check
);
18003 Check_Precondition_Postcondition
(In_Body
);
18005 -- If in spec, nothing more to do. If in body, then we convert
18006 -- the pragma to an equivalent pragma Check. That works fine since
18007 -- pragma Check will analyze the condition in the proper context.
18009 -- The form of the pragma Check is either:
18011 -- pragma Check (Precondition, cond [, msg])
18013 -- pragma Check (Pre, cond [, msg])
18015 -- We use the Pre form if this pragma derived from a Pre aspect.
18016 -- This is needed to make sure that the right set of Policy
18017 -- pragmas are checked.
18021 -- Rewrite as Check pragma
18025 Chars
=> Name_Check
,
18026 Pragma_Argument_Associations
=> New_List
(
18027 Make_Pragma_Argument_Association
(Loc
,
18028 Expression
=> Make_Identifier
(Loc
, Pname
)),
18030 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
18032 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
18034 if Arg_Count
= 2 then
18035 Append_To
(Pragma_Argument_Associations
(N
),
18036 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
18038 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
18049 -- pragma Predicate
18050 -- ([Entity =>] type_LOCAL_NAME,
18051 -- [Check =>] boolean_EXPRESSION);
18053 when Pragma_Predicate
=> Predicate
: declare
18058 pragma Unreferenced
(Discard
);
18062 Check_Arg_Count
(2);
18063 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18064 Check_Optional_Identifier
(Arg2
, Name_Check
);
18066 Check_Arg_Is_Local_Name
(Arg1
);
18068 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18069 Find_Type
(Type_Id
);
18070 Typ
:= Entity
(Type_Id
);
18072 if Typ
= Any_Type
then
18076 -- The remaining processing is simply to link the pragma on to
18077 -- the rep item chain, for processing when the type is frozen.
18078 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18079 -- mark the type as having predicates.
18081 Set_Has_Predicates
(Typ
);
18082 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18089 -- pragma Preelaborate [(library_unit_NAME)];
18091 -- Set the flag Is_Preelaborated of program unit name entity
18093 when Pragma_Preelaborate
=> Preelaborate
: declare
18094 Pa
: constant Node_Id
:= Parent
(N
);
18095 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18099 Check_Ada_83_Warning
;
18100 Check_Valid_Library_Unit_Pragma
;
18102 if Nkind
(N
) = N_Null_Statement
then
18106 Ent
:= Find_Lib_Unit_Name
;
18107 Check_Duplicate_Pragma
(Ent
);
18109 -- This filters out pragmas inside generic parents that show up
18110 -- inside instantiations. Pragmas that come from aspects in the
18111 -- unit are not ignored.
18113 if Present
(Ent
) then
18114 if Pk
= N_Package_Specification
18115 and then Present
(Generic_Parent
(Pa
))
18116 and then not From_Aspect_Specification
(N
)
18121 if not Debug_Flag_U
then
18122 Set_Is_Preelaborated
(Ent
);
18123 Set_Suppress_Elaboration_Warnings
(Ent
);
18129 ---------------------
18130 -- Preelaborate_05 --
18131 ---------------------
18133 -- pragma Preelaborate_05 [(library_unit_NAME)];
18135 -- This pragma is useable only in GNAT_Mode, where it is used like
18136 -- pragma Preelaborate but it is only effective in Ada 2005 mode
18137 -- (otherwise it is ignored). This is used to implement AI-362 which
18138 -- recategorizes some run-time packages in Ada 2005 mode.
18140 when Pragma_Preelaborate_05
=> Preelaborate_05
: declare
18145 Check_Valid_Library_Unit_Pragma
;
18147 if not GNAT_Mode
then
18148 Error_Pragma
("pragma% only available in GNAT mode");
18151 if Nkind
(N
) = N_Null_Statement
then
18155 -- This is one of the few cases where we need to test the value of
18156 -- Ada_Version_Explicit rather than Ada_Version (which is always
18157 -- set to Ada_2012 in a predefined unit), we need to know the
18158 -- explicit version set to know if this pragma is active.
18160 if Ada_Version_Explicit
>= Ada_2005
then
18161 Ent
:= Find_Lib_Unit_Name
;
18162 Set_Is_Preelaborated
(Ent
);
18163 Set_Suppress_Elaboration_Warnings
(Ent
);
18165 end Preelaborate_05
;
18171 -- pragma Priority (EXPRESSION);
18173 when Pragma_Priority
=> Priority
: declare
18174 P
: constant Node_Id
:= Parent
(N
);
18179 Check_No_Identifiers
;
18180 Check_Arg_Count
(1);
18184 if Nkind
(P
) = N_Subprogram_Body
then
18185 Check_In_Main_Program
;
18187 Ent
:= Defining_Unit_Name
(Specification
(P
));
18189 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18190 Ent
:= Defining_Identifier
(Ent
);
18193 Arg
:= Get_Pragma_Arg
(Arg1
);
18194 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18198 if not Is_Static_Expression
(Arg
) then
18199 Flag_Non_Static_Expr
18200 ("main subprogram priority is not static!", Arg
);
18203 -- If constraint error, then we already signalled an error
18205 elsif Raises_Constraint_Error
(Arg
) then
18208 -- Otherwise check in range except if Relaxed_RM_Semantics
18209 -- where we ignore the value if out of range.
18213 Val
: constant Uint
:= Expr_Value
(Arg
);
18215 if not Relaxed_RM_Semantics
18218 or else Val
> Expr_Value
(Expression
18219 (Parent
(RTE
(RE_Max_Priority
)))))
18222 ("main subprogram priority is out of range", Arg1
);
18225 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18230 -- Load an arbitrary entity from System.Tasking.Stages or
18231 -- System.Tasking.Restricted.Stages (depending on the
18232 -- supported profile) to make sure that one of these packages
18233 -- is implicitly with'ed, since we need to have the tasking
18234 -- run time active for the pragma Priority to have any effect.
18235 -- Previously with with'ed the package System.Tasking, but
18236 -- this package does not trigger the required initialization
18237 -- of the run-time library.
18240 Discard
: Entity_Id
;
18241 pragma Warnings
(Off
, Discard
);
18243 if Restricted_Profile
then
18244 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18246 Discard
:= RTE
(RE_Activate_Tasks
);
18250 -- Task or Protected, must be of type Integer
18252 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18253 Arg
:= Get_Pragma_Arg
(Arg1
);
18254 Ent
:= Defining_Identifier
(Parent
(P
));
18256 -- The expression must be analyzed in the special manner
18257 -- described in "Handling of Default and Per-Object
18258 -- Expressions" in sem.ads.
18260 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18262 if not Is_Static_Expression
(Arg
) then
18263 Check_Restriction
(Static_Priorities
, Arg
);
18266 -- Anything else is incorrect
18272 -- Check duplicate pragma before we chain the pragma in the Rep
18273 -- Item chain of Ent.
18275 Check_Duplicate_Pragma
(Ent
);
18276 Record_Rep_Item
(Ent
, N
);
18279 -----------------------------------
18280 -- Priority_Specific_Dispatching --
18281 -----------------------------------
18283 -- pragma Priority_Specific_Dispatching (
18284 -- policy_IDENTIFIER,
18285 -- first_priority_EXPRESSION,
18286 -- last_priority_EXPRESSION);
18288 when Pragma_Priority_Specific_Dispatching
=>
18289 Priority_Specific_Dispatching
: declare
18290 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18291 -- This is the entity System.Any_Priority;
18294 Lower_Bound
: Node_Id
;
18295 Upper_Bound
: Node_Id
;
18301 Check_Arg_Count
(3);
18302 Check_No_Identifiers
;
18303 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18304 Check_Valid_Configuration_Pragma
;
18305 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18306 DP
:= Fold_Upper
(Name_Buffer
(1));
18308 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18309 Check_Arg_Is_Static_Expression
(Lower_Bound
, Standard_Integer
);
18310 Lower_Val
:= Expr_Value
(Lower_Bound
);
18312 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18313 Check_Arg_Is_Static_Expression
(Upper_Bound
, Standard_Integer
);
18314 Upper_Val
:= Expr_Value
(Upper_Bound
);
18316 -- It is not allowed to use Task_Dispatching_Policy and
18317 -- Priority_Specific_Dispatching in the same partition.
18319 if Task_Dispatching_Policy
/= ' ' then
18320 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18322 ("pragma% incompatible with Task_Dispatching_Policy#");
18324 -- Check lower bound in range
18326 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18328 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18331 ("first_priority is out of range", Arg2
);
18333 -- Check upper bound in range
18335 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18337 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18340 ("last_priority is out of range", Arg3
);
18342 -- Check that the priority range is valid
18344 elsif Lower_Val
> Upper_Val
then
18346 ("last_priority_expression must be greater than or equal to "
18347 & "first_priority_expression");
18349 -- Store the new policy, but always preserve System_Location since
18350 -- we like the error message with the run-time name.
18353 -- Check overlapping in the priority ranges specified in other
18354 -- Priority_Specific_Dispatching pragmas within the same
18355 -- partition. We can only check those we know about.
18358 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18360 if Specific_Dispatching
.Table
(J
).First_Priority
in
18361 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18362 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18363 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18366 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18368 ("priority range overlaps with "
18369 & "Priority_Specific_Dispatching#");
18373 -- The use of Priority_Specific_Dispatching is incompatible
18374 -- with Task_Dispatching_Policy.
18376 if Task_Dispatching_Policy
/= ' ' then
18377 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18379 ("Priority_Specific_Dispatching incompatible "
18380 & "with Task_Dispatching_Policy#");
18383 -- The use of Priority_Specific_Dispatching forces ceiling
18386 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18387 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18389 ("Priority_Specific_Dispatching incompatible "
18390 & "with Locking_Policy#");
18392 -- Set the Ceiling_Locking policy, but preserve System_Location
18393 -- since we like the error message with the run time name.
18396 Locking_Policy
:= 'C';
18398 if Locking_Policy_Sloc
/= System_Location
then
18399 Locking_Policy_Sloc
:= Loc
;
18403 -- Add entry in the table
18405 Specific_Dispatching
.Append
18406 ((Dispatching_Policy
=> DP
,
18407 First_Priority
=> UI_To_Int
(Lower_Val
),
18408 Last_Priority
=> UI_To_Int
(Upper_Val
),
18409 Pragma_Loc
=> Loc
));
18411 end Priority_Specific_Dispatching
;
18417 -- pragma Profile (profile_IDENTIFIER);
18419 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18421 when Pragma_Profile
=>
18423 Check_Arg_Count
(1);
18424 Check_Valid_Configuration_Pragma
;
18425 Check_No_Identifiers
;
18428 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18431 if Chars
(Argx
) = Name_Ravenscar
then
18432 Set_Ravenscar_Profile
(N
);
18434 elsif Chars
(Argx
) = Name_Restricted
then
18435 Set_Profile_Restrictions
18437 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18439 elsif Chars
(Argx
) = Name_Rational
then
18440 Set_Rational_Profile
;
18442 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18443 Set_Profile_Restrictions
18444 (No_Implementation_Extensions
,
18445 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18448 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18452 ----------------------
18453 -- Profile_Warnings --
18454 ----------------------
18456 -- pragma Profile_Warnings (profile_IDENTIFIER);
18458 -- profile_IDENTIFIER => Restricted | Ravenscar
18460 when Pragma_Profile_Warnings
=>
18462 Check_Arg_Count
(1);
18463 Check_Valid_Configuration_Pragma
;
18464 Check_No_Identifiers
;
18467 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18470 if Chars
(Argx
) = Name_Ravenscar
then
18471 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18473 elsif Chars
(Argx
) = Name_Restricted
then
18474 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18476 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18477 Set_Profile_Restrictions
18478 (No_Implementation_Extensions
, N
, Warn
=> True);
18481 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18485 --------------------------
18486 -- Propagate_Exceptions --
18487 --------------------------
18489 -- pragma Propagate_Exceptions;
18491 -- Note: this pragma is obsolete and has no effect
18493 when Pragma_Propagate_Exceptions
=>
18495 Check_Arg_Count
(0);
18497 if Warn_On_Obsolescent_Feature
then
18499 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18500 "and has no effect?j?", N
);
18503 -----------------------------
18504 -- Provide_Shift_Operators --
18505 -----------------------------
18507 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18509 when Pragma_Provide_Shift_Operators
=>
18510 Provide_Shift_Operators
: declare
18513 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18514 -- Insert declaration and pragma Instrinsic for named shift op
18516 ----------------------------
18517 -- Declare_Shift_Operator --
18518 ----------------------------
18520 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18526 Make_Subprogram_Declaration
(Loc
,
18527 Make_Function_Specification
(Loc
,
18528 Defining_Unit_Name
=>
18529 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18531 Result_Definition
=>
18532 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18534 Parameter_Specifications
=> New_List
(
18535 Make_Parameter_Specification
(Loc
,
18536 Defining_Identifier
=>
18537 Make_Defining_Identifier
(Loc
, Name_Value
),
18539 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18541 Make_Parameter_Specification
(Loc
,
18542 Defining_Identifier
=>
18543 Make_Defining_Identifier
(Loc
, Name_Amount
),
18545 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18549 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18550 Pragma_Argument_Associations
=> New_List
(
18551 Make_Pragma_Argument_Association
(Loc
,
18552 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18553 Make_Pragma_Argument_Association
(Loc
,
18554 Expression
=> Make_Identifier
(Loc
, Nam
))));
18556 Insert_After
(N
, Import
);
18557 Insert_After
(N
, Func
);
18558 end Declare_Shift_Operator
;
18560 -- Start of processing for Provide_Shift_Operators
18564 Check_Arg_Count
(1);
18565 Check_Arg_Is_Local_Name
(Arg1
);
18567 Arg1
:= Get_Pragma_Arg
(Arg1
);
18569 -- We must have an entity name
18571 if not Is_Entity_Name
(Arg1
) then
18573 ("pragma % must apply to integer first subtype", Arg1
);
18576 -- If no Entity, means there was a prior error so ignore
18578 if Present
(Entity
(Arg1
)) then
18579 Ent
:= Entity
(Arg1
);
18581 -- Apply error checks
18583 if not Is_First_Subtype
(Ent
) then
18585 ("cannot apply pragma %",
18586 "\& is not a first subtype",
18589 elsif not Is_Integer_Type
(Ent
) then
18591 ("cannot apply pragma %",
18592 "\& is not an integer type",
18595 elsif Has_Shift_Operator
(Ent
) then
18597 ("cannot apply pragma %",
18598 "\& already has declared shift operators",
18601 elsif Is_Frozen
(Ent
) then
18603 ("pragma % appears too late",
18604 "\& is already frozen",
18608 -- Now declare the operators. We do this during analysis rather
18609 -- than expansion, since we want the operators available if we
18610 -- are operating in -gnatc or ASIS mode.
18612 Declare_Shift_Operator
(Name_Rotate_Left
);
18613 Declare_Shift_Operator
(Name_Rotate_Right
);
18614 Declare_Shift_Operator
(Name_Shift_Left
);
18615 Declare_Shift_Operator
(Name_Shift_Right
);
18616 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18618 end Provide_Shift_Operators
;
18624 -- pragma Psect_Object (
18625 -- [Internal =>] LOCAL_NAME,
18626 -- [, [External =>] EXTERNAL_SYMBOL]
18627 -- [, [Size =>] EXTERNAL_SYMBOL]);
18629 when Pragma_Psect_Object | Pragma_Common_Object
=>
18630 Psect_Object
: declare
18631 Args
: Args_List
(1 .. 3);
18632 Names
: constant Name_List
(1 .. 3) := (
18637 Internal
: Node_Id
renames Args
(1);
18638 External
: Node_Id
renames Args
(2);
18639 Size
: Node_Id
renames Args
(3);
18641 Def_Id
: Entity_Id
;
18643 procedure Check_Too_Long
(Arg
: Node_Id
);
18644 -- Posts message if the argument is an identifier with more
18645 -- than 31 characters, or a string literal with more than
18646 -- 31 characters, and we are operating under VMS
18648 --------------------
18649 -- Check_Too_Long --
18650 --------------------
18652 procedure Check_Too_Long
(Arg
: Node_Id
) is
18653 X
: constant Node_Id
:= Original_Node
(Arg
);
18656 if not Nkind_In
(X
, N_String_Literal
, N_Identifier
) then
18658 ("inappropriate argument for pragma %", Arg
);
18661 if OpenVMS_On_Target
then
18662 if (Nkind
(X
) = N_String_Literal
18663 and then String_Length
(Strval
(X
)) > 31)
18665 (Nkind
(X
) = N_Identifier
18666 and then Length_Of_Name
(Chars
(X
)) > 31)
18669 ("argument for pragma % is longer than 31 characters",
18673 end Check_Too_Long
;
18675 -- Start of processing for Common_Object/Psect_Object
18679 Gather_Associations
(Names
, Args
);
18680 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18682 Def_Id
:= Entity
(Internal
);
18684 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18686 ("pragma% must designate an object", Internal
);
18689 Check_Too_Long
(Internal
);
18691 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18693 ("cannot use pragma% for imported/exported object",
18697 if Is_Concurrent_Type
(Etype
(Internal
)) then
18699 ("cannot specify pragma % for task/protected object",
18703 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18705 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18707 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18710 if Ekind
(Def_Id
) = E_Constant
then
18712 ("cannot specify pragma % for a constant", Internal
);
18715 if Is_Record_Type
(Etype
(Internal
)) then
18721 Ent
:= First_Entity
(Etype
(Internal
));
18722 while Present
(Ent
) loop
18723 Decl
:= Declaration_Node
(Ent
);
18725 if Ekind
(Ent
) = E_Component
18726 and then Nkind
(Decl
) = N_Component_Declaration
18727 and then Present
(Expression
(Decl
))
18728 and then Warn_On_Export_Import
18731 ("?x?object for pragma % has defaults", Internal
);
18741 if Present
(Size
) then
18742 Check_Too_Long
(Size
);
18745 if Present
(External
) then
18746 Check_Arg_Is_External_Name
(External
);
18747 Check_Too_Long
(External
);
18750 -- If all error tests pass, link pragma on to the rep item chain
18752 Record_Rep_Item
(Def_Id
, N
);
18759 -- pragma Pure [(library_unit_NAME)];
18761 when Pragma_Pure
=> Pure
: declare
18765 Check_Ada_83_Warning
;
18766 Check_Valid_Library_Unit_Pragma
;
18768 if Nkind
(N
) = N_Null_Statement
then
18772 Ent
:= Find_Lib_Unit_Name
;
18774 Set_Has_Pragma_Pure
(Ent
);
18775 Set_Suppress_Elaboration_Warnings
(Ent
);
18782 -- pragma Pure_05 [(library_unit_NAME)];
18784 -- This pragma is useable only in GNAT_Mode, where it is used like
18785 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
18786 -- it is ignored). It may be used after a pragma Preelaborate, in
18787 -- which case it overrides the effect of the pragma Preelaborate.
18788 -- This is used to implement AI-362 which recategorizes some run-time
18789 -- packages in Ada 2005 mode.
18791 when Pragma_Pure_05
=> Pure_05
: declare
18796 Check_Valid_Library_Unit_Pragma
;
18798 if not GNAT_Mode
then
18799 Error_Pragma
("pragma% only available in GNAT mode");
18802 if Nkind
(N
) = N_Null_Statement
then
18806 -- This is one of the few cases where we need to test the value of
18807 -- Ada_Version_Explicit rather than Ada_Version (which is always
18808 -- set to Ada_2012 in a predefined unit), we need to know the
18809 -- explicit version set to know if this pragma is active.
18811 if Ada_Version_Explicit
>= Ada_2005
then
18812 Ent
:= Find_Lib_Unit_Name
;
18813 Set_Is_Preelaborated
(Ent
, False);
18815 Set_Suppress_Elaboration_Warnings
(Ent
);
18823 -- pragma Pure_12 [(library_unit_NAME)];
18825 -- This pragma is useable only in GNAT_Mode, where it is used like
18826 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise
18827 -- it is ignored). It may be used after a pragma Preelaborate, in
18828 -- which case it overrides the effect of the pragma Preelaborate.
18829 -- This is used to implement AI05-0212 which recategorizes some
18830 -- run-time packages in Ada 2012 mode.
18832 when Pragma_Pure_12
=> Pure_12
: declare
18837 Check_Valid_Library_Unit_Pragma
;
18839 if not GNAT_Mode
then
18840 Error_Pragma
("pragma% only available in GNAT mode");
18843 if Nkind
(N
) = N_Null_Statement
then
18847 -- This is one of the few cases where we need to test the value of
18848 -- Ada_Version_Explicit rather than Ada_Version (which is always
18849 -- set to Ada_2012 in a predefined unit), we need to know the
18850 -- explicit version set to know if this pragma is active.
18852 if Ada_Version_Explicit
>= Ada_2012
then
18853 Ent
:= Find_Lib_Unit_Name
;
18854 Set_Is_Preelaborated
(Ent
, False);
18856 Set_Suppress_Elaboration_Warnings
(Ent
);
18860 -------------------
18861 -- Pure_Function --
18862 -------------------
18864 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18866 when Pragma_Pure_Function
=> Pure_Function
: declare
18869 Def_Id
: Entity_Id
;
18870 Effective
: Boolean := False;
18874 Check_Arg_Count
(1);
18875 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18876 Check_Arg_Is_Local_Name
(Arg1
);
18877 E_Id
:= Get_Pragma_Arg
(Arg1
);
18879 if Error_Posted
(E_Id
) then
18883 -- Loop through homonyms (overloadings) of referenced entity
18885 E
:= Entity
(E_Id
);
18887 if Present
(E
) then
18889 Def_Id
:= Get_Base_Subprogram
(E
);
18891 if not Ekind_In
(Def_Id
, E_Function
,
18892 E_Generic_Function
,
18896 ("pragma% requires a function name", Arg1
);
18899 Set_Is_Pure
(Def_Id
);
18901 if not Has_Pragma_Pure_Function
(Def_Id
) then
18902 Set_Has_Pragma_Pure_Function
(Def_Id
);
18906 exit when From_Aspect_Specification
(N
);
18908 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18912 and then Warn_On_Redundant_Constructs
18915 ("pragma Pure_Function on& is redundant?r?",
18921 --------------------
18922 -- Queuing_Policy --
18923 --------------------
18925 -- pragma Queuing_Policy (policy_IDENTIFIER);
18927 when Pragma_Queuing_Policy
=> declare
18931 Check_Ada_83_Warning
;
18932 Check_Arg_Count
(1);
18933 Check_No_Identifiers
;
18934 Check_Arg_Is_Queuing_Policy
(Arg1
);
18935 Check_Valid_Configuration_Pragma
;
18936 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18937 QP
:= Fold_Upper
(Name_Buffer
(1));
18939 if Queuing_Policy
/= ' '
18940 and then Queuing_Policy
/= QP
18942 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18943 Error_Pragma
("queuing policy incompatible with policy#");
18945 -- Set new policy, but always preserve System_Location since we
18946 -- like the error message with the run time name.
18949 Queuing_Policy
:= QP
;
18951 if Queuing_Policy_Sloc
/= System_Location
then
18952 Queuing_Policy_Sloc
:= Loc
;
18961 -- pragma Rational, for compatibility with foreign compiler
18963 when Pragma_Rational
=>
18964 Set_Rational_Profile
;
18966 ------------------------------------
18967 -- Refined_Depends/Refined_Global --
18968 ------------------------------------
18970 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18972 -- DEPENDENCY_RELATION ::=
18974 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18976 -- DEPENDENCY_CLAUSE ::=
18977 -- OUTPUT_LIST =>[+] INPUT_LIST
18978 -- | NULL_DEPENDENCY_CLAUSE
18980 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18982 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18984 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18986 -- OUTPUT ::= NAME | FUNCTION_RESULT
18989 -- where FUNCTION_RESULT is a function Result attribute_reference
18991 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18993 -- GLOBAL_SPECIFICATION ::=
18996 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18998 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19000 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19001 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19002 -- GLOBAL_ITEM ::= NAME
19004 when Pragma_Refined_Depends |
19005 Pragma_Refined_Global
=> Refined_Depends_Global
:
19007 Body_Id
: Entity_Id
;
19009 Spec_Id
: Entity_Id
;
19012 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
19014 -- Save the pragma in the contract of the subprogram body. The
19015 -- remaining analysis is performed at the end of the enclosing
19019 Add_Contract_Item
(N
, Body_Id
);
19021 end Refined_Depends_Global
;
19027 -- pragma Refined_Post (boolean_EXPRESSION);
19029 when Pragma_Refined_Post
=> Refined_Post
: declare
19030 Body_Id
: Entity_Id
;
19032 Result_Seen
: Boolean := False;
19033 Spec_Id
: Entity_Id
;
19036 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
19038 -- Analyze the boolean expression as a "spec expression"
19041 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
19043 -- Verify that the refined postcondition mentions attribute
19044 -- 'Result and its expression introduces a post-state.
19046 if Warn_On_Suspicious_Contract
19047 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
19049 Check_Result_And_Post_State
(N
, Result_Seen
);
19051 if not Result_Seen
then
19053 ("pragma % does not mention function result?T?");
19057 -- Chain the pragma on the contract for easy retrieval
19059 Add_Contract_Item
(N
, Body_Id
);
19063 -------------------
19064 -- Refined_State --
19065 -------------------
19067 -- pragma Refined_State (REFINEMENT_LIST);
19069 -- REFINEMENT_LIST ::=
19070 -- REFINEMENT_CLAUSE
19071 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19073 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19075 -- CONSTITUENT_LIST ::=
19078 -- | (CONSTITUENT {, CONSTITUENT})
19080 -- CONSTITUENT ::= object_NAME | state_NAME
19082 when Pragma_Refined_State
=> Refined_State
: declare
19083 Context
: constant Node_Id
:= Parent
(N
);
19084 Spec_Id
: Entity_Id
;
19089 Check_Arg_Count
(1);
19091 -- Ensure the proper placement of the pragma. Refined states must
19092 -- be associated with a package body.
19094 if Nkind
(Context
) /= N_Package_Body
then
19100 while Present
(Stmt
) loop
19102 -- Skip prior pragmas, but check for duplicates
19104 if Nkind
(Stmt
) = N_Pragma
then
19105 if Pragma_Name
(Stmt
) = Pname
then
19106 Error_Msg_Name_1
:= Pname
;
19107 Error_Msg_Sloc
:= Sloc
(Stmt
);
19108 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
19111 -- Skip internally generated code
19113 elsif not Comes_From_Source
(Stmt
) then
19116 -- The pragma does not apply to a legal construct, issue an
19117 -- error and stop the analysis.
19124 Stmt
:= Prev
(Stmt
);
19127 Spec_Id
:= Corresponding_Spec
(Context
);
19129 -- State refinement is allowed only when the corresponding package
19130 -- declaration has non-null pragma Abstract_State. Refinement not
19131 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19133 if SPARK_Mode
/= Off
19135 (No
(Abstract_States
(Spec_Id
))
19136 or else Has_Null_Abstract_State
(Spec_Id
))
19139 ("useless refinement, package & does not define abstract "
19140 & "states", N
, Spec_Id
);
19144 -- The pragma must be analyzed at the end of the declarations as
19145 -- it has visibility over the whole declarative region. Save the
19146 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19147 -- adding it to the contract of the package body.
19149 Add_Contract_Item
(N
, Defining_Entity
(Context
));
19152 -----------------------
19153 -- Relative_Deadline --
19154 -----------------------
19156 -- pragma Relative_Deadline (time_span_EXPRESSION);
19158 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19159 P
: constant Node_Id
:= Parent
(N
);
19164 Check_No_Identifiers
;
19165 Check_Arg_Count
(1);
19167 Arg
:= Get_Pragma_Arg
(Arg1
);
19169 -- The expression must be analyzed in the special manner described
19170 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19172 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19176 if Nkind
(P
) = N_Subprogram_Body
then
19177 Check_In_Main_Program
;
19179 -- Only Task and subprogram cases allowed
19181 elsif Nkind
(P
) /= N_Task_Definition
then
19185 -- Check duplicate pragma before we set the corresponding flag
19187 if Has_Relative_Deadline_Pragma
(P
) then
19188 Error_Pragma
("duplicate pragma% not allowed");
19191 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19192 -- Relative_Deadline pragma node cannot be inserted in the Rep
19193 -- Item chain of Ent since it is rewritten by the expander as a
19194 -- procedure call statement that will break the chain.
19196 Set_Has_Relative_Deadline_Pragma
(P
, True);
19197 end Relative_Deadline
;
19199 ------------------------
19200 -- Remote_Access_Type --
19201 ------------------------
19203 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19205 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19210 Check_Arg_Count
(1);
19211 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19212 Check_Arg_Is_Local_Name
(Arg1
);
19214 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19216 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19217 and then Ekind
(E
) = E_General_Access_Type
19218 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19219 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19221 and then Is_Valid_Remote_Object_Type
19222 (Root_Type
(Directly_Designated_Type
(E
)))
19224 Set_Is_Remote_Types
(E
);
19228 ("pragma% applies only to formal access to classwide types",
19231 end Remote_Access_Type
;
19233 ---------------------------
19234 -- Remote_Call_Interface --
19235 ---------------------------
19237 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19239 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19240 Cunit_Node
: Node_Id
;
19241 Cunit_Ent
: Entity_Id
;
19245 Check_Ada_83_Warning
;
19246 Check_Valid_Library_Unit_Pragma
;
19248 if Nkind
(N
) = N_Null_Statement
then
19252 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19253 K
:= Nkind
(Unit
(Cunit_Node
));
19254 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19256 if K
= N_Package_Declaration
19257 or else K
= N_Generic_Package_Declaration
19258 or else K
= N_Subprogram_Declaration
19259 or else K
= N_Generic_Subprogram_Declaration
19260 or else (K
= N_Subprogram_Body
19261 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19266 "pragma% must apply to package or subprogram declaration");
19269 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19270 end Remote_Call_Interface
;
19276 -- pragma Remote_Types [(library_unit_NAME)];
19278 when Pragma_Remote_Types
=> Remote_Types
: declare
19279 Cunit_Node
: Node_Id
;
19280 Cunit_Ent
: Entity_Id
;
19283 Check_Ada_83_Warning
;
19284 Check_Valid_Library_Unit_Pragma
;
19286 if Nkind
(N
) = N_Null_Statement
then
19290 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19291 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19293 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19294 N_Generic_Package_Declaration
)
19297 ("pragma% can only apply to a package declaration");
19300 Set_Is_Remote_Types
(Cunit_Ent
);
19307 -- pragma Ravenscar;
19309 when Pragma_Ravenscar
=>
19311 Check_Arg_Count
(0);
19312 Check_Valid_Configuration_Pragma
;
19313 Set_Ravenscar_Profile
(N
);
19315 if Warn_On_Obsolescent_Feature
then
19317 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19319 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19322 -------------------------
19323 -- Restricted_Run_Time --
19324 -------------------------
19326 -- pragma Restricted_Run_Time;
19328 when Pragma_Restricted_Run_Time
=>
19330 Check_Arg_Count
(0);
19331 Check_Valid_Configuration_Pragma
;
19332 Set_Profile_Restrictions
19333 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19335 if Warn_On_Obsolescent_Feature
then
19337 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19340 ("|use pragma Profile (Restricted) instead?j?", N
);
19347 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19350 -- restriction_IDENTIFIER
19351 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19353 when Pragma_Restrictions
=>
19354 Process_Restrictions_Or_Restriction_Warnings
19355 (Warn
=> Treat_Restrictions_As_Warnings
);
19357 --------------------------
19358 -- Restriction_Warnings --
19359 --------------------------
19361 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19364 -- restriction_IDENTIFIER
19365 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19367 when Pragma_Restriction_Warnings
=>
19369 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19375 -- pragma Reviewable;
19377 when Pragma_Reviewable
=>
19378 Check_Ada_83_Warning
;
19379 Check_Arg_Count
(0);
19381 -- Call dummy debugging function rv. This is done to assist front
19382 -- end debugging. By placing a Reviewable pragma in the source
19383 -- program, a breakpoint on rv catches this place in the source,
19384 -- allowing convenient stepping to the point of interest.
19388 --------------------------
19389 -- Short_Circuit_And_Or --
19390 --------------------------
19392 -- pragma Short_Circuit_And_Or;
19394 when Pragma_Short_Circuit_And_Or
=>
19396 Check_Arg_Count
(0);
19397 Check_Valid_Configuration_Pragma
;
19398 Short_Circuit_And_Or
:= True;
19400 -------------------
19401 -- Share_Generic --
19402 -------------------
19404 -- pragma Share_Generic (GNAME {, GNAME});
19406 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19408 when Pragma_Share_Generic
=>
19410 Process_Generic_List
;
19416 -- pragma Shared (LOCAL_NAME);
19418 when Pragma_Shared
=>
19420 Process_Atomic_Shared_Volatile
;
19422 --------------------
19423 -- Shared_Passive --
19424 --------------------
19426 -- pragma Shared_Passive [(library_unit_NAME)];
19428 -- Set the flag Is_Shared_Passive of program unit name entity
19430 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19431 Cunit_Node
: Node_Id
;
19432 Cunit_Ent
: Entity_Id
;
19435 Check_Ada_83_Warning
;
19436 Check_Valid_Library_Unit_Pragma
;
19438 if Nkind
(N
) = N_Null_Statement
then
19442 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19443 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19445 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19446 N_Generic_Package_Declaration
)
19449 ("pragma% can only apply to a package declaration");
19452 Set_Is_Shared_Passive
(Cunit_Ent
);
19453 end Shared_Passive
;
19455 -----------------------
19456 -- Short_Descriptors --
19457 -----------------------
19459 -- pragma Short_Descriptors;
19461 when Pragma_Short_Descriptors
=>
19463 Check_Arg_Count
(0);
19464 Check_Valid_Configuration_Pragma
;
19465 Short_Descriptors
:= True;
19467 ------------------------------
19468 -- Simple_Storage_Pool_Type --
19469 ------------------------------
19471 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19473 when Pragma_Simple_Storage_Pool_Type
=>
19474 Simple_Storage_Pool_Type
: declare
19480 Check_Arg_Count
(1);
19481 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19483 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19484 Find_Type
(Type_Id
);
19485 Typ
:= Entity
(Type_Id
);
19487 if Typ
= Any_Type
then
19491 -- We require the pragma to apply to a type declared in a package
19492 -- declaration, but not (immediately) within a package body.
19494 if Ekind
(Current_Scope
) /= E_Package
19495 or else In_Package_Body
(Current_Scope
)
19498 ("pragma% can only apply to type declared immediately "
19499 & "within a package declaration");
19502 -- A simple storage pool type must be an immutably limited record
19503 -- or private type. If the pragma is given for a private type,
19504 -- the full type is similarly restricted (which is checked later
19505 -- in Freeze_Entity).
19507 if Is_Record_Type
(Typ
)
19508 and then not Is_Limited_View
(Typ
)
19511 ("pragma% can only apply to explicitly limited record type");
19513 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19515 ("pragma% can only apply to a private type that is limited");
19517 elsif not Is_Record_Type
(Typ
)
19518 and then not Is_Private_Type
(Typ
)
19521 ("pragma% can only apply to limited record or private type");
19524 Record_Rep_Item
(Typ
, N
);
19525 end Simple_Storage_Pool_Type
;
19527 ----------------------
19528 -- Source_File_Name --
19529 ----------------------
19531 -- There are five forms for this pragma:
19533 -- pragma Source_File_Name (
19534 -- [UNIT_NAME =>] unit_NAME,
19535 -- BODY_FILE_NAME => STRING_LITERAL
19536 -- [, [INDEX =>] INTEGER_LITERAL]);
19538 -- pragma Source_File_Name (
19539 -- [UNIT_NAME =>] unit_NAME,
19540 -- SPEC_FILE_NAME => STRING_LITERAL
19541 -- [, [INDEX =>] INTEGER_LITERAL]);
19543 -- pragma Source_File_Name (
19544 -- BODY_FILE_NAME => STRING_LITERAL
19545 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19546 -- [, CASING => CASING_SPEC]);
19548 -- pragma Source_File_Name (
19549 -- SPEC_FILE_NAME => STRING_LITERAL
19550 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19551 -- [, CASING => CASING_SPEC]);
19553 -- pragma Source_File_Name (
19554 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19555 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19556 -- [, CASING => CASING_SPEC]);
19558 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19560 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19561 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19562 -- only be used when no project file is used, while SFNP can only be
19563 -- used when a project file is used.
19565 -- No processing here. Processing was completed during parsing, since
19566 -- we need to have file names set as early as possible. Units are
19567 -- loaded well before semantic processing starts.
19569 -- The only processing we defer to this point is the check for
19570 -- correct placement.
19572 when Pragma_Source_File_Name
=>
19574 Check_Valid_Configuration_Pragma
;
19576 ------------------------------
19577 -- Source_File_Name_Project --
19578 ------------------------------
19580 -- See Source_File_Name for syntax
19582 -- No processing here. Processing was completed during parsing, since
19583 -- we need to have file names set as early as possible. Units are
19584 -- loaded well before semantic processing starts.
19586 -- The only processing we defer to this point is the check for
19587 -- correct placement.
19589 when Pragma_Source_File_Name_Project
=>
19591 Check_Valid_Configuration_Pragma
;
19593 -- Check that a pragma Source_File_Name_Project is used only in a
19594 -- configuration pragmas file.
19596 -- Pragmas Source_File_Name_Project should only be generated by
19597 -- the Project Manager in configuration pragmas files.
19599 -- This is really an ugly test. It seems to depend on some
19600 -- accidental and undocumented property. At the very least it
19601 -- needs to be documented, but it would be better to have a
19602 -- clean way of testing if we are in a configuration file???
19604 if Present
(Parent
(N
)) then
19606 ("pragma% can only appear in a configuration pragmas file");
19609 ----------------------
19610 -- Source_Reference --
19611 ----------------------
19613 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19615 -- Nothing to do, all processing completed in Par.Prag, since we need
19616 -- the information for possible parser messages that are output.
19618 when Pragma_Source_Reference
=>
19625 -- pragma SPARK_Mode [(On | Off)];
19627 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19628 Body_Id
: Entity_Id
;
19631 Mode_Id
: SPARK_Mode_Type
;
19632 Spec_Id
: Entity_Id
;
19635 procedure Check_Pragma_Conformance
19636 (Context_Pragma
: Node_Id
;
19637 Entity_Pragma
: Node_Id
;
19638 Entity
: Entity_Id
);
19639 -- If Context_Pragma is not Empty, verify that the new pragma N
19640 -- is compatible with the pragma Context_Pragma that was inherited
19641 -- from the context:
19642 -- . if Context_Pragma is ON, then the new mode can be anything
19643 -- . if Context_Pragma is OFF, then the only allowed new mode is
19646 -- If Entity is not Empty, verify that the new pragma N is
19647 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19648 -- for Entity (which may be Empty):
19649 -- . if Entity_Pragma is ON, then the new mode can be anything
19650 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19652 -- . if Entity_Pragma is Empty, we always issue an error, as this
19653 -- corresponds to a case where a previous section of Entity
19654 -- had no SPARK_Mode set.
19656 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19657 -- Verify that pragma is applied to library-level entity E
19659 ------------------------------
19660 -- Check_Pragma_Conformance --
19661 ------------------------------
19663 procedure Check_Pragma_Conformance
19664 (Context_Pragma
: Node_Id
;
19665 Entity_Pragma
: Node_Id
;
19666 Entity
: Entity_Id
)
19669 if Present
(Context_Pragma
) then
19670 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19672 -- New mode less restrictive than the established mode
19674 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19675 and then Mode_Id
= On
19678 ("cannot change SPARK_Mode from Off to On", Arg1
);
19679 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19680 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg1
);
19685 if Present
(Entity
) then
19686 if Present
(Entity_Pragma
) then
19687 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19688 and then Mode_Id
= On
19690 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19691 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19693 ("\value Off was set for SPARK_Mode on&#",
19699 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19700 Error_Msg_Sloc
:= Sloc
(Entity
);
19702 ("\no value was set for SPARK_Mode on&#",
19707 end Check_Pragma_Conformance
;
19709 --------------------------------
19710 -- Check_Library_Level_Entity --
19711 --------------------------------
19713 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19714 MsgF
: String := "incorrect placement of pragma%";
19717 if not Is_Library_Level_Entity
(E
) then
19718 Error_Msg_Name_1
:= Pname
;
19720 Error_Msg_N
(MsgF
, N
);
19722 if Ekind_In
(E
, E_Generic_Package
,
19727 ("\& is not a library-level package", N
, E
);
19730 ("\& is not a library-level subprogram", N
, E
);
19735 end Check_Library_Level_Entity
;
19737 -- Start of processing for Do_SPARK_Mode
19741 Check_No_Identifiers
;
19742 Check_At_Most_N_Arguments
(1);
19744 -- Check the legality of the mode (no argument = ON)
19746 if Arg_Count
= 1 then
19747 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19748 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19753 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19754 Context
:= Parent
(N
);
19756 -- Packages and subprograms declared in a generic unit cannot be
19757 -- subject to the pragma.
19759 if Inside_A_Generic
then
19760 Error_Pragma
("incorrect placement of pragma% in a generic");
19762 -- The pragma appears in a configuration pragmas file
19764 elsif No
(Context
) then
19765 Check_Valid_Configuration_Pragma
;
19767 if Present
(SPARK_Mode_Pragma
) then
19768 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19769 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19773 SPARK_Mode_Pragma
:= N
;
19774 SPARK_Mode
:= Mode_Id
;
19776 -- When the pragma is placed before the declaration of a unit, it
19777 -- configures the whole unit.
19779 elsif Nkind
(Context
) = N_Compilation_Unit
then
19780 Check_Valid_Configuration_Pragma
;
19782 if Nkind
(Unit
(Context
)) in N_Generic_Declaration
19783 or else (Present
(Library_Unit
(Context
))
19784 and then Nkind
(Unit
(Library_Unit
(Context
))) in
19785 N_Generic_Declaration
)
19787 Error_Pragma
("incorrect placement of pragma% in a generic");
19790 SPARK_Mode_Pragma
:= N
;
19791 SPARK_Mode
:= Mode_Id
;
19793 -- The pragma applies to a [library unit] subprogram or package
19796 -- Verify the placement of the pragma with respect to package
19797 -- or subprogram declarations and detect duplicates.
19800 while Present
(Stmt
) loop
19802 -- Skip prior pragmas, but check for duplicates
19804 if Nkind
(Stmt
) = N_Pragma
then
19805 if Pragma_Name
(Stmt
) = Pname
then
19806 Error_Msg_Name_1
:= Pname
;
19807 Error_Msg_Sloc
:= Sloc
(Stmt
);
19808 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19812 -- Skip internally generated code
19814 elsif not Comes_From_Source
(Stmt
) then
19817 elsif Nkind
(Stmt
) in N_Generic_Declaration
then
19819 ("incorrect placement of pragma% on a generic");
19821 -- The pragma applies to a package declaration
19823 elsif Nkind
(Stmt
) = N_Package_Declaration
then
19824 Spec_Id
:= Defining_Entity
(Stmt
);
19825 Check_Library_Level_Entity
(Spec_Id
);
19826 Check_Pragma_Conformance
19827 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19828 Entity_Pragma
=> Empty
,
19831 Set_SPARK_Pragma
(Spec_Id
, N
);
19832 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19833 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19834 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19837 -- The pragma applies to a subprogram declaration
19839 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
19840 Spec_Id
:= Defining_Entity
(Stmt
);
19841 Check_Library_Level_Entity
(Spec_Id
);
19842 Check_Pragma_Conformance
19843 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19844 Entity_Pragma
=> Empty
,
19847 Set_SPARK_Pragma
(Spec_Id
, N
);
19848 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19851 -- The pragma does not apply to a legal construct, issue an
19852 -- error and stop the analysis.
19859 Stmt
:= Prev
(Stmt
);
19862 -- Handle all cases where the pragma is actually an aspect and
19863 -- applies to a library-level package spec, body or subprogram.
19865 -- function F ... with SPARK_Mode => ...;
19866 -- package P with SPARK_Mode => ...;
19867 -- package body P with SPARK_Mode => ... is
19869 -- The following circuitry simply prepares the proper context
19870 -- for the general pragma processing mechanism below.
19872 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19873 Context
:= Unit
(Parent
(Context
));
19875 if Nkind_In
(Context
, N_Package_Declaration
,
19876 N_Subprogram_Declaration
)
19878 Context
:= Specification
(Context
);
19882 -- The pragma is at the top level of a package spec
19885 -- pragma SPARK_Mode;
19892 -- pragma SPARK_Mode;
19894 if Nkind
(Context
) = N_Package_Specification
then
19895 Spec_Id
:= Defining_Entity
(Context
);
19897 -- Pragma applies to private part
19899 if List_Containing
(N
) = Private_Declarations
(Context
) then
19900 Check_Library_Level_Entity
(Spec_Id
);
19901 Check_Pragma_Conformance
19902 (Context_Pragma
=> Empty
,
19903 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19904 Entity
=> Spec_Id
);
19905 SPARK_Mode_Pragma
:= N
;
19906 SPARK_Mode
:= Mode_Id
;
19908 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19909 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19911 -- Pragma applies to public part
19914 Check_Library_Level_Entity
(Spec_Id
);
19915 Check_Pragma_Conformance
19916 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19917 Entity_Pragma
=> Empty
,
19919 SPARK_Mode_Pragma
:= N
;
19920 SPARK_Mode
:= Mode_Id
;
19922 Set_SPARK_Pragma
(Spec_Id
, N
);
19923 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19924 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19925 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19928 -- The pragma appears as an aspect on a subprogram.
19930 -- function F ... with SPARK_Mode => ...;
19932 elsif Nkind_In
(Context
, N_Function_Specification
,
19933 N_Procedure_Specification
)
19935 Spec_Id
:= Defining_Entity
(Context
);
19936 Check_Library_Level_Entity
(Spec_Id
);
19937 Check_Pragma_Conformance
19938 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19939 Entity_Pragma
=> Empty
,
19941 Set_SPARK_Pragma
(Spec_Id
, N
);
19942 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19944 -- Pragma is immediately within a package body
19946 -- package body P is
19947 -- pragma SPARK_Mode;
19949 elsif Nkind
(Context
) = N_Package_Body
then
19950 Spec_Id
:= Corresponding_Spec
(Context
);
19951 Body_Id
:= Defining_Entity
(Context
);
19952 Check_Library_Level_Entity
(Body_Id
);
19953 Check_Pragma_Conformance
19954 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19955 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19956 Entity
=> Spec_Id
);
19957 SPARK_Mode_Pragma
:= N
;
19958 SPARK_Mode
:= Mode_Id
;
19960 Set_SPARK_Pragma
(Body_Id
, N
);
19961 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19962 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19963 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19965 -- Pragma is immediately within a subprogram body
19967 -- function F ... is
19968 -- pragma SPARK_Mode;
19970 elsif Nkind
(Context
) = N_Subprogram_Body
then
19971 Spec_Id
:= Corresponding_Spec
(Context
);
19972 Context
:= Specification
(Context
);
19973 Body_Id
:= Defining_Entity
(Context
);
19974 Check_Library_Level_Entity
(Body_Id
);
19976 if Present
(Spec_Id
) then
19977 Check_Pragma_Conformance
19978 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19979 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19980 Entity
=> Spec_Id
);
19982 Check_Pragma_Conformance
19983 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19984 Entity_Pragma
=> Empty
,
19988 SPARK_Mode_Pragma
:= N
;
19989 SPARK_Mode
:= Mode_Id
;
19991 Set_SPARK_Pragma
(Body_Id
, N
);
19992 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19994 -- The pragma applies to the statements of a package body
19996 -- package body P is
19998 -- pragma SPARK_Mode;
20000 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
20001 and then Nkind
(Parent
(Context
)) = N_Package_Body
20003 Context
:= Parent
(Context
);
20004 Spec_Id
:= Corresponding_Spec
(Context
);
20005 Body_Id
:= Defining_Entity
(Context
);
20006 Check_Library_Level_Entity
(Body_Id
);
20007 Check_Pragma_Conformance
20008 (Context_Pragma
=> Empty
,
20009 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
20010 Entity
=> Body_Id
);
20011 SPARK_Mode_Pragma
:= N
;
20012 SPARK_Mode
:= Mode_Id
;
20014 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
20015 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
20017 -- The pragma does not apply to a legal construct, issue error
20025 --------------------------------
20026 -- Static_Elaboration_Desired --
20027 --------------------------------
20029 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20031 when Pragma_Static_Elaboration_Desired
=>
20033 Check_At_Most_N_Arguments
(1);
20035 if Is_Compilation_Unit
(Current_Scope
)
20036 and then Ekind
(Current_Scope
) = E_Package
20038 Set_Static_Elaboration_Desired
(Current_Scope
, True);
20040 Error_Pragma
("pragma% must apply to a library-level package");
20047 -- pragma Storage_Size (EXPRESSION);
20049 when Pragma_Storage_Size
=> Storage_Size
: declare
20050 P
: constant Node_Id
:= Parent
(N
);
20054 Check_No_Identifiers
;
20055 Check_Arg_Count
(1);
20057 -- The expression must be analyzed in the special manner described
20058 -- in "Handling of Default Expressions" in sem.ads.
20060 Arg
:= Get_Pragma_Arg
(Arg1
);
20061 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20063 if not Is_Static_Expression
(Arg
) then
20064 Check_Restriction
(Static_Storage_Size
, Arg
);
20067 if Nkind
(P
) /= N_Task_Definition
then
20072 if Has_Storage_Size_Pragma
(P
) then
20073 Error_Pragma
("duplicate pragma% not allowed");
20075 Set_Has_Storage_Size_Pragma
(P
, True);
20078 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20086 -- pragma Storage_Unit (NUMERIC_LITERAL);
20088 -- Only permitted argument is System'Storage_Unit value
20090 when Pragma_Storage_Unit
=>
20091 Check_No_Identifiers
;
20092 Check_Arg_Count
(1);
20093 Check_Arg_Is_Integer_Literal
(Arg1
);
20095 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20096 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20098 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20100 ("the only allowed argument for pragma% is ^", Arg1
);
20103 --------------------
20104 -- Stream_Convert --
20105 --------------------
20107 -- pragma Stream_Convert (
20108 -- [Entity =>] type_LOCAL_NAME,
20109 -- [Read =>] function_NAME,
20110 -- [Write =>] function NAME);
20112 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20114 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20115 -- Check that the given argument is the name of a local function
20116 -- of one argument that is not overloaded earlier in the current
20117 -- local scope. A check is also made that the argument is a
20118 -- function with one parameter.
20120 --------------------------------------
20121 -- Check_OK_Stream_Convert_Function --
20122 --------------------------------------
20124 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20128 Check_Arg_Is_Local_Name
(Arg
);
20129 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20131 if Has_Homonym
(Ent
) then
20133 ("argument for pragma% may not be overloaded", Arg
);
20136 if Ekind
(Ent
) /= E_Function
20137 or else No
(First_Formal
(Ent
))
20138 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20141 ("argument for pragma% must be function of one argument",
20144 end Check_OK_Stream_Convert_Function
;
20146 -- Start of processing for Stream_Convert
20150 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20151 Check_Arg_Count
(3);
20152 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20153 Check_Optional_Identifier
(Arg2
, Name_Read
);
20154 Check_Optional_Identifier
(Arg3
, Name_Write
);
20155 Check_Arg_Is_Local_Name
(Arg1
);
20156 Check_OK_Stream_Convert_Function
(Arg2
);
20157 Check_OK_Stream_Convert_Function
(Arg3
);
20160 Typ
: constant Entity_Id
:=
20161 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20162 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20163 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20166 Check_First_Subtype
(Arg1
);
20168 -- Check for too early or too late. Note that we don't enforce
20169 -- the rule about primitive operations in this case, since, as
20170 -- is the case for explicit stream attributes themselves, these
20171 -- restrictions are not appropriate. Note that the chaining of
20172 -- the pragma by Rep_Item_Too_Late is actually the critical
20173 -- processing done for this pragma.
20175 if Rep_Item_Too_Early
(Typ
, N
)
20177 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20182 -- Return if previous error
20184 if Etype
(Typ
) = Any_Type
20186 Etype
(Read
) = Any_Type
20188 Etype
(Write
) = Any_Type
20195 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20197 ("incorrect return type for function&", Arg2
);
20200 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20202 ("incorrect parameter type for function&", Arg3
);
20205 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20206 Underlying_Type
(Etype
(Write
))
20209 ("result type of & does not match Read parameter type",
20213 end Stream_Convert
;
20219 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20221 -- This is processed by the parser since some of the style checks
20222 -- take place during source scanning and parsing. This means that
20223 -- we don't need to issue error messages here.
20225 when Pragma_Style_Checks
=> Style_Checks
: declare
20226 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20232 Check_No_Identifiers
;
20234 -- Two argument form
20236 if Arg_Count
= 2 then
20237 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20244 E_Id
:= Get_Pragma_Arg
(Arg2
);
20247 if not Is_Entity_Name
(E_Id
) then
20249 ("second argument of pragma% must be entity name",
20253 E
:= Entity
(E_Id
);
20255 if not Ignore_Style_Checks_Pragmas
then
20260 Set_Suppress_Style_Checks
20261 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20262 exit when No
(Homonym
(E
));
20269 -- One argument form
20272 Check_Arg_Count
(1);
20274 if Nkind
(A
) = N_String_Literal
then
20278 Slen
: constant Natural := Natural (String_Length
(S
));
20279 Options
: String (1 .. Slen
);
20285 C
:= Get_String_Char
(S
, Int
(J
));
20286 exit when not In_Character_Range
(C
);
20287 Options
(J
) := Get_Character
(C
);
20289 -- If at end of string, set options. As per discussion
20290 -- above, no need to check for errors, since we issued
20291 -- them in the parser.
20294 if not Ignore_Style_Checks_Pragmas
then
20295 Set_Style_Check_Options
(Options
);
20305 elsif Nkind
(A
) = N_Identifier
then
20306 if Chars
(A
) = Name_All_Checks
then
20307 if not Ignore_Style_Checks_Pragmas
then
20309 Set_GNAT_Style_Check_Options
;
20311 Set_Default_Style_Check_Options
;
20315 elsif Chars
(A
) = Name_On
then
20316 if not Ignore_Style_Checks_Pragmas
then
20317 Style_Check
:= True;
20320 elsif Chars
(A
) = Name_Off
then
20321 if not Ignore_Style_Checks_Pragmas
then
20322 Style_Check
:= False;
20333 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20335 when Pragma_Subtitle
=>
20337 Check_Arg_Count
(1);
20338 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20339 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
20346 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20348 when Pragma_Suppress
=>
20349 Process_Suppress_Unsuppress
(True);
20355 -- pragma Suppress_All;
20357 -- The only check made here is that the pragma has no arguments.
20358 -- There are no placement rules, and the processing required (setting
20359 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20360 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20361 -- then creates and inserts a pragma Suppress (All_Checks).
20363 when Pragma_Suppress_All
=>
20365 Check_Arg_Count
(0);
20367 -------------------------
20368 -- Suppress_Debug_Info --
20369 -------------------------
20371 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20373 when Pragma_Suppress_Debug_Info
=>
20375 Check_Arg_Count
(1);
20376 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20377 Check_Arg_Is_Local_Name
(Arg1
);
20378 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20380 ----------------------------------
20381 -- Suppress_Exception_Locations --
20382 ----------------------------------
20384 -- pragma Suppress_Exception_Locations;
20386 when Pragma_Suppress_Exception_Locations
=>
20388 Check_Arg_Count
(0);
20389 Check_Valid_Configuration_Pragma
;
20390 Exception_Locations_Suppressed
:= True;
20392 -----------------------------
20393 -- Suppress_Initialization --
20394 -----------------------------
20396 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20398 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20404 Check_Arg_Count
(1);
20405 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20406 Check_Arg_Is_Local_Name
(Arg1
);
20408 E_Id
:= Get_Pragma_Arg
(Arg1
);
20410 if Etype
(E_Id
) = Any_Type
then
20414 E
:= Entity
(E_Id
);
20416 if not Is_Type
(E
) then
20417 Error_Pragma_Arg
("pragma% requires type or subtype", Arg1
);
20420 if Rep_Item_Too_Early
(E
, N
)
20422 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20427 -- For incomplete/private type, set flag on full view
20429 if Is_Incomplete_Or_Private_Type
(E
) then
20430 if No
(Full_View
(Base_Type
(E
))) then
20432 ("argument of pragma% cannot be an incomplete type", Arg1
);
20434 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20437 -- For first subtype, set flag on base type
20439 elsif Is_First_Subtype
(E
) then
20440 Set_Suppress_Initialization
(Base_Type
(E
));
20442 -- For other than first subtype, set flag on subtype itself
20445 Set_Suppress_Initialization
(E
);
20453 -- pragma System_Name (DIRECT_NAME);
20455 -- Syntax check: one argument, which must be the identifier GNAT or
20456 -- the identifier GCC, no other identifiers are acceptable.
20458 when Pragma_System_Name
=>
20460 Check_No_Identifiers
;
20461 Check_Arg_Count
(1);
20462 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20464 -----------------------------
20465 -- Task_Dispatching_Policy --
20466 -----------------------------
20468 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20470 when Pragma_Task_Dispatching_Policy
=> declare
20474 Check_Ada_83_Warning
;
20475 Check_Arg_Count
(1);
20476 Check_No_Identifiers
;
20477 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20478 Check_Valid_Configuration_Pragma
;
20479 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20480 DP
:= Fold_Upper
(Name_Buffer
(1));
20482 if Task_Dispatching_Policy
/= ' '
20483 and then Task_Dispatching_Policy
/= DP
20485 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20487 ("task dispatching policy incompatible with policy#");
20489 -- Set new policy, but always preserve System_Location since we
20490 -- like the error message with the run time name.
20493 Task_Dispatching_Policy
:= DP
;
20495 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20496 Task_Dispatching_Policy_Sloc
:= Loc
;
20505 -- pragma Task_Info (EXPRESSION);
20507 when Pragma_Task_Info
=> Task_Info
: declare
20508 P
: constant Node_Id
:= Parent
(N
);
20514 if Nkind
(P
) /= N_Task_Definition
then
20515 Error_Pragma
("pragma% must appear in task definition");
20518 Check_No_Identifiers
;
20519 Check_Arg_Count
(1);
20521 Analyze_And_Resolve
20522 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20524 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20528 Ent
:= Defining_Identifier
(Parent
(P
));
20530 -- Check duplicate pragma before we chain the pragma in the Rep
20531 -- Item chain of Ent.
20534 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20536 Error_Pragma
("duplicate pragma% not allowed");
20539 Record_Rep_Item
(Ent
, N
);
20546 -- pragma Task_Name (string_EXPRESSION);
20548 when Pragma_Task_Name
=> Task_Name
: declare
20549 P
: constant Node_Id
:= Parent
(N
);
20554 Check_No_Identifiers
;
20555 Check_Arg_Count
(1);
20557 Arg
:= Get_Pragma_Arg
(Arg1
);
20559 -- The expression is used in the call to Create_Task, and must be
20560 -- expanded there, not in the context of the current spec. It must
20561 -- however be analyzed to capture global references, in case it
20562 -- appears in a generic context.
20564 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20566 if Nkind
(P
) /= N_Task_Definition
then
20570 Ent
:= Defining_Identifier
(Parent
(P
));
20572 -- Check duplicate pragma before we chain the pragma in the Rep
20573 -- Item chain of Ent.
20576 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20578 Error_Pragma
("duplicate pragma% not allowed");
20581 Record_Rep_Item
(Ent
, N
);
20588 -- pragma Task_Storage (
20589 -- [Task_Type =>] LOCAL_NAME,
20590 -- [Top_Guard =>] static_integer_EXPRESSION);
20592 when Pragma_Task_Storage
=> Task_Storage
: declare
20593 Args
: Args_List
(1 .. 2);
20594 Names
: constant Name_List
(1 .. 2) := (
20598 Task_Type
: Node_Id
renames Args
(1);
20599 Top_Guard
: Node_Id
renames Args
(2);
20605 Gather_Associations
(Names
, Args
);
20607 if No
(Task_Type
) then
20609 ("missing task_type argument for pragma%");
20612 Check_Arg_Is_Local_Name
(Task_Type
);
20614 Ent
:= Entity
(Task_Type
);
20616 if not Is_Task_Type
(Ent
) then
20618 ("argument for pragma% must be task type", Task_Type
);
20621 if No
(Top_Guard
) then
20623 ("pragma% takes two arguments", Task_Type
);
20625 Check_Arg_Is_Static_Expression
(Top_Guard
, Any_Integer
);
20628 Check_First_Subtype
(Task_Type
);
20630 if Rep_Item_Too_Late
(Ent
, N
) then
20639 -- pragma Test_Case
20640 -- ([Name =>] Static_String_EXPRESSION
20641 -- ,[Mode =>] MODE_TYPE
20642 -- [, Requires => Boolean_EXPRESSION]
20643 -- [, Ensures => Boolean_EXPRESSION]);
20645 -- MODE_TYPE ::= Nominal | Robustness
20647 when Pragma_Test_Case
=>
20651 --------------------------
20652 -- Thread_Local_Storage --
20653 --------------------------
20655 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20657 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20663 Check_Arg_Count
(1);
20664 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20665 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20667 Id
:= Get_Pragma_Arg
(Arg1
);
20670 if not Is_Entity_Name
(Id
)
20671 or else Ekind
(Entity
(Id
)) /= E_Variable
20673 Error_Pragma_Arg
("local variable name required", Arg1
);
20678 if Rep_Item_Too_Early
(E
, N
)
20679 or else Rep_Item_Too_Late
(E
, N
)
20684 Set_Has_Pragma_Thread_Local_Storage
(E
);
20685 Set_Has_Gigi_Rep_Item
(E
);
20686 end Thread_Local_Storage
;
20692 -- pragma Time_Slice (static_duration_EXPRESSION);
20694 when Pragma_Time_Slice
=> Time_Slice
: declare
20700 Check_Arg_Count
(1);
20701 Check_No_Identifiers
;
20702 Check_In_Main_Program
;
20703 Check_Arg_Is_Static_Expression
(Arg1
, Standard_Duration
);
20705 if not Error_Posted
(Arg1
) then
20707 while Present
(Nod
) loop
20708 if Nkind
(Nod
) = N_Pragma
20709 and then Pragma_Name
(Nod
) = Name_Time_Slice
20711 Error_Msg_Name_1
:= Pname
;
20712 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20719 -- Process only if in main unit
20721 if Get_Source_Unit
(Loc
) = Main_Unit
then
20722 Opt
.Time_Slice_Set
:= True;
20723 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20725 if Val
<= Ureal_0
then
20726 Opt
.Time_Slice_Value
:= 0;
20728 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20729 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20732 Opt
.Time_Slice_Value
:=
20733 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20742 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20744 -- TITLING_OPTION ::=
20745 -- [Title =>] STRING_LITERAL
20746 -- | [Subtitle =>] STRING_LITERAL
20748 when Pragma_Title
=> Title
: declare
20749 Args
: Args_List
(1 .. 2);
20750 Names
: constant Name_List
(1 .. 2) := (
20756 Gather_Associations
(Names
, Args
);
20759 for J
in 1 .. 2 loop
20760 if Present
(Args
(J
)) then
20761 Check_Arg_Is_Static_Expression
(Args
(J
), Standard_String
);
20766 ----------------------------
20767 -- Type_Invariant[_Class] --
20768 ----------------------------
20770 -- pragma Type_Invariant[_Class]
20771 -- ([Entity =>] type_LOCAL_NAME,
20772 -- [Check =>] EXPRESSION);
20774 when Pragma_Type_Invariant |
20775 Pragma_Type_Invariant_Class
=>
20776 Type_Invariant
: declare
20777 I_Pragma
: Node_Id
;
20780 Check_Arg_Count
(2);
20782 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20783 -- setting Class_Present for the Type_Invariant_Class case.
20785 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20786 I_Pragma
:= New_Copy
(N
);
20787 Set_Pragma_Identifier
20788 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20789 Rewrite
(N
, I_Pragma
);
20790 Set_Analyzed
(N
, False);
20792 end Type_Invariant
;
20794 ---------------------
20795 -- Unchecked_Union --
20796 ---------------------
20798 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20800 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20801 Assoc
: constant Node_Id
:= Arg1
;
20802 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20812 Check_No_Identifiers
;
20813 Check_Arg_Count
(1);
20814 Check_Arg_Is_Local_Name
(Arg1
);
20816 Find_Type
(Type_Id
);
20818 Typ
:= Entity
(Type_Id
);
20821 or else Rep_Item_Too_Early
(Typ
, N
)
20825 Typ
:= Underlying_Type
(Typ
);
20828 if Rep_Item_Too_Late
(Typ
, N
) then
20832 Check_First_Subtype
(Arg1
);
20834 -- Note remaining cases are references to a type in the current
20835 -- declarative part. If we find an error, we post the error on
20836 -- the relevant type declaration at an appropriate point.
20838 if not Is_Record_Type
(Typ
) then
20839 Error_Msg_N
("unchecked union must be record type", Typ
);
20842 elsif Is_Tagged_Type
(Typ
) then
20843 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20846 elsif not Has_Discriminants
(Typ
) then
20848 ("unchecked union must have one discriminant", Typ
);
20851 -- Note: in previous versions of GNAT we used to check for limited
20852 -- types and give an error, but in fact the standard does allow
20853 -- Unchecked_Union on limited types, so this check was removed.
20855 -- Similarly, GNAT used to require that all discriminants have
20856 -- default values, but this is not mandated by the RM.
20858 -- Proceed with basic error checks completed
20861 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20862 Clist
:= Component_List
(Tdef
);
20864 -- Check presence of component list and variant part
20866 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20868 ("unchecked union must have variant part", Tdef
);
20872 -- Check components
20874 Comp
:= First
(Component_Items
(Clist
));
20875 while Present
(Comp
) loop
20876 Check_Component
(Comp
, Typ
);
20880 -- Check variant part
20882 Vpart
:= Variant_Part
(Clist
);
20884 Variant
:= First
(Variants
(Vpart
));
20885 while Present
(Variant
) loop
20886 Check_Variant
(Variant
, Typ
);
20891 Set_Is_Unchecked_Union
(Typ
);
20892 Set_Convention
(Typ
, Convention_C
);
20893 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20894 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20895 end Unchecked_Union
;
20897 ------------------------
20898 -- Unimplemented_Unit --
20899 ------------------------
20901 -- pragma Unimplemented_Unit;
20903 -- Note: this only gives an error if we are generating code, or if
20904 -- we are in a generic library unit (where the pragma appears in the
20905 -- body, not in the spec).
20907 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20908 Cunitent
: constant Entity_Id
:=
20909 Cunit_Entity
(Get_Source_Unit
(Loc
));
20910 Ent_Kind
: constant Entity_Kind
:=
20915 Check_Arg_Count
(0);
20917 if Operating_Mode
= Generate_Code
20918 or else Ent_Kind
= E_Generic_Function
20919 or else Ent_Kind
= E_Generic_Procedure
20920 or else Ent_Kind
= E_Generic_Package
20922 Get_Name_String
(Chars
(Cunitent
));
20923 Set_Casing
(Mixed_Case
);
20924 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20925 Write_Str
(" is not supported in this configuration");
20927 raise Unrecoverable_Error
;
20929 end Unimplemented_Unit
;
20931 ------------------------
20932 -- Universal_Aliasing --
20933 ------------------------
20935 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20937 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20942 Check_Arg_Count
(1);
20943 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20944 Check_Arg_Is_Local_Name
(Arg1
);
20945 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20947 if E_Id
= Any_Type
then
20949 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20950 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20953 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20954 Record_Rep_Item
(E_Id
, N
);
20955 end Universal_Alias
;
20957 --------------------
20958 -- Universal_Data --
20959 --------------------
20961 -- pragma Universal_Data [(library_unit_NAME)];
20963 when Pragma_Universal_Data
=>
20966 -- If this is a configuration pragma, then set the universal
20967 -- addressing option, otherwise confirm that the pragma satisfies
20968 -- the requirements of library unit pragma placement and leave it
20969 -- to the GNAAMP back end to detect the pragma (avoids transitive
20970 -- setting of the option due to withed units).
20972 if Is_Configuration_Pragma
then
20973 Universal_Addressing_On_AAMP
:= True;
20975 Check_Valid_Library_Unit_Pragma
;
20978 if not AAMP_On_Target
then
20979 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20986 -- pragma Unmodified (local_Name {, local_Name});
20988 when Pragma_Unmodified
=> Unmodified
: declare
20989 Arg_Node
: Node_Id
;
20990 Arg_Expr
: Node_Id
;
20991 Arg_Ent
: Entity_Id
;
20995 Check_At_Least_N_Arguments
(1);
20997 -- Loop through arguments
21000 while Present
(Arg_Node
) loop
21001 Check_No_Identifier
(Arg_Node
);
21003 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21004 -- in fact generate reference, so that the entity will have a
21005 -- reference, which will inhibit any warnings about it not
21006 -- being referenced, and also properly show up in the ali file
21007 -- as a reference. But this reference is recorded before the
21008 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21009 -- generated for this reference.
21011 Check_Arg_Is_Local_Name
(Arg_Node
);
21012 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21014 if Is_Entity_Name
(Arg_Expr
) then
21015 Arg_Ent
:= Entity
(Arg_Expr
);
21017 if not Is_Assignable
(Arg_Ent
) then
21019 ("pragma% can only be applied to a variable",
21022 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21034 -- pragma Unreferenced (local_Name {, local_Name});
21036 -- or when used in a context clause:
21038 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21040 when Pragma_Unreferenced
=> Unreferenced
: declare
21041 Arg_Node
: Node_Id
;
21042 Arg_Expr
: Node_Id
;
21043 Arg_Ent
: Entity_Id
;
21048 Check_At_Least_N_Arguments
(1);
21050 -- Check case of appearing within context clause
21052 if Is_In_Context_Clause
then
21054 -- The arguments must all be units mentioned in a with clause
21055 -- in the same context clause. Note we already checked (in
21056 -- Par.Prag) that the arguments are either identifiers or
21057 -- selected components.
21060 while Present
(Arg_Node
) loop
21061 Citem
:= First
(List_Containing
(N
));
21062 while Citem
/= N
loop
21063 if Nkind
(Citem
) = N_With_Clause
21065 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21067 Set_Has_Pragma_Unreferenced
21070 (Library_Unit
(Citem
))));
21072 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21081 ("argument of pragma% is not withed unit", Arg_Node
);
21087 -- Case of not in list of context items
21091 while Present
(Arg_Node
) loop
21092 Check_No_Identifier
(Arg_Node
);
21094 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21095 -- will in fact generate reference, so that the entity will
21096 -- have a reference, which will inhibit any warnings about
21097 -- it not being referenced, and also properly show up in the
21098 -- ali file as a reference. But this reference is recorded
21099 -- before the Has_Pragma_Unreferenced flag is set, so that
21100 -- no warning is generated for this reference.
21102 Check_Arg_Is_Local_Name
(Arg_Node
);
21103 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21105 if Is_Entity_Name
(Arg_Expr
) then
21106 Arg_Ent
:= Entity
(Arg_Expr
);
21108 -- If the entity is overloaded, the pragma applies to the
21109 -- most recent overloading, as documented. In this case,
21110 -- name resolution does not generate a reference, so it
21111 -- must be done here explicitly.
21113 if Is_Overloaded
(Arg_Expr
) then
21114 Generate_Reference
(Arg_Ent
, N
);
21117 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21125 --------------------------
21126 -- Unreferenced_Objects --
21127 --------------------------
21129 -- pragma Unreferenced_Objects (local_Name {, local_Name});
21131 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21132 Arg_Node
: Node_Id
;
21133 Arg_Expr
: Node_Id
;
21137 Check_At_Least_N_Arguments
(1);
21140 while Present
(Arg_Node
) loop
21141 Check_No_Identifier
(Arg_Node
);
21142 Check_Arg_Is_Local_Name
(Arg_Node
);
21143 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21145 if not Is_Entity_Name
(Arg_Expr
)
21146 or else not Is_Type
(Entity
(Arg_Expr
))
21149 ("argument for pragma% must be type or subtype", Arg_Node
);
21152 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21155 end Unreferenced_Objects
;
21157 ------------------------------
21158 -- Unreserve_All_Interrupts --
21159 ------------------------------
21161 -- pragma Unreserve_All_Interrupts;
21163 when Pragma_Unreserve_All_Interrupts
=>
21165 Check_Arg_Count
(0);
21167 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21168 Unreserve_All_Interrupts
:= True;
21175 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21177 when Pragma_Unsuppress
=>
21179 Process_Suppress_Unsuppress
(False);
21181 -------------------
21182 -- Use_VADS_Size --
21183 -------------------
21185 -- pragma Use_VADS_Size;
21187 when Pragma_Use_VADS_Size
=>
21189 Check_Arg_Count
(0);
21190 Check_Valid_Configuration_Pragma
;
21191 Use_VADS_Size
:= True;
21193 ---------------------
21194 -- Validity_Checks --
21195 ---------------------
21197 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21199 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21200 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21206 Check_Arg_Count
(1);
21207 Check_No_Identifiers
;
21209 -- Pragma always active unless in CodePeer or GNATprove modes,
21210 -- which use a fixed configuration of validity checks.
21212 if not (CodePeer_Mode
or GNATprove_Mode
) then
21213 if Nkind
(A
) = N_String_Literal
then
21217 Slen
: constant Natural := Natural (String_Length
(S
));
21218 Options
: String (1 .. Slen
);
21222 -- Couldn't we use a for loop here over Options'Range???
21226 C
:= Get_String_Char
(S
, Int
(J
));
21228 -- This is a weird test, it skips setting validity
21229 -- checks entirely if any element of S is out of
21230 -- range of Character, what is that about ???
21232 exit when not In_Character_Range
(C
);
21233 Options
(J
) := Get_Character
(C
);
21236 Set_Validity_Check_Options
(Options
);
21244 elsif Nkind
(A
) = N_Identifier
then
21245 if Chars
(A
) = Name_All_Checks
then
21246 Set_Validity_Check_Options
("a");
21247 elsif Chars
(A
) = Name_On
then
21248 Validity_Checks_On
:= True;
21249 elsif Chars
(A
) = Name_Off
then
21250 Validity_Checks_On
:= False;
21254 end Validity_Checks
;
21260 -- pragma Volatile (LOCAL_NAME);
21262 when Pragma_Volatile
=>
21263 Process_Atomic_Shared_Volatile
;
21265 -------------------------
21266 -- Volatile_Components --
21267 -------------------------
21269 -- pragma Volatile_Components (array_LOCAL_NAME);
21271 -- Volatile is handled by the same circuit as Atomic_Components
21273 ----------------------
21274 -- Warning_As_Error --
21275 ----------------------
21277 when Pragma_Warning_As_Error
=>
21279 Check_Arg_Count
(1);
21280 Check_No_Identifiers
;
21281 Check_Valid_Configuration_Pragma
;
21283 if not Is_Static_String_Expression
(Arg1
) then
21285 ("argument of pragma% must be static string expression",
21288 -- OK static string expression
21291 String_To_Name_Buffer
21292 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
21293 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21294 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21295 new String'(Name_Buffer (1 .. Name_Len));
21302 -- pragma Warnings (On | Off [,REASON]);
21303 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
21304 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
21305 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
21307 -- REASON ::= Reason => Static_String_Expression
21309 when Pragma_Warnings => Warnings : declare
21310 Reason : String_Id;
21314 Check_At_Least_N_Arguments (1);
21316 -- See if last argument is labeled Reason. If so, make sure we
21317 -- have a static string expression, and acquire the REASON string.
21318 -- Then remove the REASON argument by decreasing Num_Args by one;
21319 -- Remaining processing looks only at first Num_Args arguments).
21322 Last_Arg : constant Node_Id :=
21323 Last (Pragma_Argument_Associations (N));
21325 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21326 and then Chars (Last_Arg) = Name_Reason
21329 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21330 Reason := End_String;
21331 Arg_Count := Arg_Count - 1;
21333 -- Not allowed in compiler units (bootstrap issues)
21335 Check_Compiler_Unit (N);
21337 -- No REASON string, set null string as reason
21340 Reason := Null_String_Id;
21344 -- Now proceed with REASON taken care of and eliminated
21346 Check_No_Identifiers;
21348 -- If debug flag -gnatd.i is set, pragma is ignored
21350 if Debug_Flag_Dot_I then
21354 -- Process various forms of the pragma
21357 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21360 -- One argument case
21362 if Arg_Count = 1 then
21364 -- On/Off one argument case was processed by parser
21366 if Nkind (Argx) = N_Identifier
21367 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21371 -- One argument case must be ON/OFF or static string expr
21373 elsif not Is_Static_String_Expression (Arg1) then
21375 ("argument of pragma% must be On/Off or static string "
21376 & "expression", Arg1);
21378 -- One argument string expression case
21382 Lit : constant Node_Id := Expr_Value_S (Argx);
21383 Str : constant String_Id := Strval (Lit);
21384 Len : constant Nat := String_Length (Str);
21392 while J <= Len loop
21393 C := Get_String_Char (Str, J);
21394 OK := In_Character_Range (C);
21397 Chr := Get_Character (C);
21399 -- Dash case: only -Wxxx is accepted
21406 C := Get_String_Char (Str, J);
21407 Chr := Get_Character (C);
21408 exit when Chr = 'W
';
21413 elsif J < Len and then Chr = '.' then
21415 C := Get_String_Char (Str, J);
21416 Chr := Get_Character (C);
21418 if not Set_Dot_Warning_Switch (Chr) then
21420 ("invalid warning switch character "
21421 & '.' & Chr, Arg1);
21427 OK := Set_Warning_Switch (Chr);
21433 ("invalid warning switch character " & Chr,
21442 -- Two or more arguments (must be two)
21445 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21446 Check_At_Most_N_Arguments (2);
21454 E_Id := Get_Pragma_Arg (Arg2);
21457 -- In the expansion of an inlined body, a reference to
21458 -- the formal may be wrapped in a conversion if the
21459 -- actual is a conversion. Retrieve the real entity name.
21461 if (In_Instance_Body or In_Inlined_Body)
21462 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21464 E_Id := Expression (E_Id);
21467 -- Entity name case
21469 if Is_Entity_Name (E_Id) then
21470 E := Entity (E_Id);
21477 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21480 -- For OFF case, make entry in warnings off
21481 -- pragma table for later processing. But we do
21482 -- not do that within an instance, since these
21483 -- warnings are about what is needed in the
21484 -- template, not an instance of it.
21486 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21487 and then Warn_On_Warnings_Off
21488 and then not In_Instance
21490 Warnings_Off_Pragmas.Append ((N, E, Reason));
21493 if Is_Enumeration_Type (E) then
21497 Lit := First_Literal (E);
21498 while Present (Lit) loop
21499 Set_Warnings_Off (Lit);
21500 Next_Literal (Lit);
21505 exit when No (Homonym (E));
21510 -- Error if not entity or static string expression case
21512 elsif not Is_Static_String_Expression (Arg2) then
21514 ("second argument of pragma% must be entity name "
21515 & "or static string expression", Arg2);
21517 -- Static string expression case
21520 String_To_Name_Buffer
21521 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
21523 -- Note on configuration pragma case: If this is a
21524 -- configuration pragma, then for an OFF pragma, we
21525 -- just set Config True in the call, which is all
21526 -- that needs to be done. For the case of ON, this
21527 -- is normally an error, unless it is canceling the
21528 -- effect of a previous OFF pragma in the same file.
21529 -- In any other case, an error will be signalled (ON
21530 -- with no matching OFF).
21532 -- Note: We set Used if we are inside a generic to
21533 -- disable the test that the non-config case actually
21534 -- cancels a warning. That's because we can't be sure
21535 -- there isn't an instantiation in some other unit
21536 -- where a warning is suppressed.
21538 -- We could do a little better here by checking if the
21539 -- generic unit we are inside is public, but for now
21540 -- we don't bother with that refinement.
21542 if Chars (Argx) = Name_Off then
21543 Set_Specific_Warning_Off
21544 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21545 Config => Is_Configuration_Pragma,
21546 Used => Inside_A_Generic or else In_Instance);
21548 elsif Chars (Argx) = Name_On then
21549 Set_Specific_Warning_On
21550 (Loc, Name_Buffer (1 .. Name_Len), Err);
21554 ("??pragma Warnings On with no matching "
21555 & "Warnings Off", Loc);
21564 -------------------
21565 -- Weak_External --
21566 -------------------
21568 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21570 when Pragma_Weak_External => Weak_External : declare
21575 Check_Arg_Count (1);
21576 Check_Optional_Identifier (Arg1, Name_Entity);
21577 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21578 Ent := Entity (Get_Pragma_Arg (Arg1));
21580 if Rep_Item_Too_Early (Ent, N) then
21583 Ent := Underlying_Type (Ent);
21586 -- The only processing required is to link this item on to the
21587 -- list of rep items for the given entity. This is accomplished
21588 -- by the call to Rep_Item_Too_Late (when no error is detected
21589 -- and False is returned).
21591 if Rep_Item_Too_Late (Ent, N) then
21594 Set_Has_Gigi_Rep_Item (Ent);
21598 -----------------------------
21599 -- Wide_Character_Encoding --
21600 -----------------------------
21602 -- pragma Wide_Character_Encoding (IDENTIFIER);
21604 when Pragma_Wide_Character_Encoding =>
21607 -- Nothing to do, handled in parser. Note that we do not enforce
21608 -- configuration pragma placement, this pragma can appear at any
21609 -- place in the source, allowing mixed encodings within a single
21614 --------------------
21615 -- Unknown_Pragma --
21616 --------------------
21618 -- Should be impossible, since the case of an unknown pragma is
21619 -- separately processed before the case statement is entered.
21621 when Unknown_Pragma =>
21622 raise Program_Error;
21625 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21626 -- until AI is formally approved.
21628 -- Check_Order_Dependence;
21631 when Pragma_Exit => null;
21632 end Analyze_Pragma;
21634 ---------------------------------------------
21635 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21636 ---------------------------------------------
21638 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21640 Subp_Id : Entity_Id)
21642 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21643 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21646 Restore_Scope : Boolean := False;
21647 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21650 -- Ensure that the subprogram and its formals are visible when analyzing
21651 -- the expression of the pragma.
21653 if not In_Open_Scopes (Subp_Id) then
21654 Restore_Scope := True;
21655 Push_Scope (Subp_Id);
21656 Install_Formals (Subp_Id);
21659 -- Preanalyze the boolean expression, we treat this as a spec expression
21660 -- (i.e. similar to a default expression).
21662 Expr := Get_Pragma_Arg (Arg1);
21664 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21665 -- the original aspect expression, which is shared with the generated
21668 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21669 Expr := Expression (Corresponding_Aspect (Prag));
21672 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21674 -- For a class-wide condition, a reference to a controlling formal must
21675 -- be interpreted as having the class-wide type (or an access to such)
21676 -- so that the inherited condition can be properly applied to any
21677 -- overriding operation (see ARM12 6.6.1 (7)).
21679 if Class_Present (Prag) then
21680 Class_Wide_Condition : declare
21681 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21683 ACW : Entity_Id := Empty;
21684 -- Access to T'class, created if there is a controlling formal
21685 -- that is an access parameter.
21687 function Get_ACW return Entity_Id;
21688 -- If the expression has a reference to an controlling access
21689 -- parameter, create an access to T'class for the necessary
21690 -- conversions if one does not exist.
21692 function Process (N : Node_Id) return Traverse_Result;
21693 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21694 -- aspect for a primitive subprogram of a tagged type T, a name
21695 -- that denotes a formal parameter of type T is interpreted as
21696 -- having type T'Class. Similarly, a name that denotes a formal
21697 -- accessparameter of type access-to-T is interpreted as having
21698 -- type access-to-T'Class. This ensures the expression is well-
21699 -- defined for a primitive subprogram of a type descended from T.
21700 -- Note that this replacement is not done for selector names in
21701 -- parameter associations. These carry an entity for reference
21702 -- purposes, but semantically they are just identifiers.
21708 function Get_ACW return Entity_Id is
21709 Loc : constant Source_Ptr := Sloc (Prag);
21715 Make_Full_Type_Declaration (Loc,
21716 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21718 Make_Access_To_Object_Definition (Loc,
21719 Subtype_Indication =>
21720 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21721 All_Present => True));
21723 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21725 ACW := Defining_Identifier (Decl);
21726 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21736 function Process (N : Node_Id) return Traverse_Result is
21737 Loc : constant Source_Ptr := Sloc (N);
21741 if Is_Entity_Name (N)
21742 and then Present (Entity (N))
21743 and then Is_Formal (Entity (N))
21744 and then Nkind (Parent (N)) /= N_Type_Conversion
21746 (Nkind (Parent (N)) /= N_Parameter_Association
21747 or else N /= Selector_Name (Parent (N)))
21749 if Etype (Entity (N)) = T then
21750 Typ := Class_Wide_Type (T);
21752 elsif Is_Access_Type (Etype (Entity (N)))
21753 and then Designated_Type (Etype (Entity (N))) = T
21760 if Present (Typ) then
21762 Make_Type_Conversion (Loc,
21764 New_Occurrence_Of (Typ, Loc),
21765 Expression => New_Occurrence_Of (Entity (N), Loc)));
21766 Set_Etype (N, Typ);
21773 procedure Replace_Type is new Traverse_Proc (Process);
21775 -- Start of processing for Class_Wide_Condition
21778 if not Present (T) then
21780 -- Pre'Class/Post'Class aspect cases
21782 if From_Aspect_Specification (Prag) then
21783 if Nam = Name_uPre then
21784 Error_Msg_Name_1 := Name_Pre;
21786 Error_Msg_Name_1 := Name_Post;
21789 Error_Msg_Name_2 := Name_Class;
21792 ("aspect `%''%` can only be specified for a primitive "
21793 & "operation of a tagged type",
21794 Corresponding_Aspect (Prag));
21796 -- Pre_Class, Post_Class pragma cases
21799 if Nam = Name_uPre then
21800 Error_Msg_Name_1 := Name_Pre_Class;
21802 Error_Msg_Name_1 := Name_Post_Class;
21806 ("pragma% can only be specified for a primitive "
21807 & "operation of a tagged type",
21808 Corresponding_Aspect (Prag));
21812 Replace_Type (Get_Pragma_Arg (Arg1));
21813 end Class_Wide_Condition;
21816 -- Remove the subprogram from the scope stack now that the pre-analysis
21817 -- of the precondition/postcondition is done.
21819 if Restore_Scope then
21822 end Analyze_Pre_Post_Condition_In_Decl_Part;
21824 ------------------------------------------
21825 -- Analyze_Refined_Depends_In_Decl_Part --
21826 ------------------------------------------
21828 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21829 Dependencies : List_Id := No_List;
21831 -- The corresponding Depends pragma along with its clauses
21833 Refinements : List_Id := No_List;
21834 -- The clauses of pragma Refined_Depends
21836 Spec_Id : Entity_Id;
21837 -- The entity of the subprogram subject to pragma Refined_Depends
21839 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21840 -- Verify the legality of a single clause
21842 function Input_Match
21843 (Dep_Input : Node_Id;
21844 Ref_Inputs : List_Id;
21845 Post_Errors : Boolean) return Boolean;
21846 -- Determine whether input Dep_Input matches one of inputs found in list
21847 -- Ref_Inputs. If flag Post_Errors is set, the routine reports missed or
21848 -- extra input items.
21850 function Inputs_Match
21851 (Dep_Clause : Node_Id;
21852 Ref_Clause : Node_Id;
21853 Post_Errors : Boolean) return Boolean;
21854 -- Determine whether the inputs of Depends clause Dep_Clause match those
21855 -- of refinement clause Ref_Clause. If flag Post_Errors is set, then the
21856 -- routine reports missed or extra input items.
21858 function Is_Self_Referential (Item_Id : Entity_Id) return Boolean;
21859 -- Determine whether a formal parameter, variable or state denoted by
21860 -- Item_Id appears both as input and an output in a single clause of
21863 procedure Report_Extra_Clauses;
21864 -- Emit an error for each extra clause the appears in Refined_Depends
21866 -----------------------------
21867 -- Check_Dependency_Clause --
21868 -----------------------------
21870 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21871 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21872 Dep_Id : Entity_Id;
21873 Matching_Clause : Node_Id := Empty;
21874 Next_Ref_Clause : Node_Id;
21875 Ref_Clause : Node_Id;
21876 Ref_Id : Entity_Id;
21877 Ref_Output : Node_Id;
21879 Has_Constituent : Boolean := False;
21880 -- Flag set when the refinement output list contains at least one
21881 -- constituent of the state denoted by Dep_Id.
21883 Has_Null_State : Boolean := False;
21884 -- Flag set when the output of clause Dep_Clause is a state with a
21885 -- null refinement.
21887 Has_Refined_State : Boolean := False;
21888 -- Flag set when the output of clause Dep_Clause is a state with
21889 -- visible refinement.
21892 -- The analysis of pragma Depends should produce normalized clauses
21893 -- with exactly one output. This is important because output items
21894 -- are unique in the whole dependence relation and can be used as
21897 pragma Assert (No (Next (Dep_Output)));
21899 -- Inspect all clauses of Refined_Depends and attempt to match the
21900 -- output of Dep_Clause against an output from the refinement clauses
21903 Ref_Clause := First (Refinements);
21904 while Present (Ref_Clause) loop
21905 Matching_Clause := Empty;
21907 -- Store the next clause now because a match will trim the list of
21908 -- refinement clauses and this side effect should not be visible
21909 -- in pragma Refined_Depends.
21911 Next_Ref_Clause := Next (Ref_Clause);
21913 -- The analysis of pragma Refined_Depends should produce
21914 -- normalized clauses with exactly one output.
21916 Ref_Output := First (Choices (Ref_Clause));
21917 pragma Assert (No (Next (Ref_Output)));
21919 -- Two null output lists match if their inputs match
21921 if Nkind (Dep_Output) = N_Null
21922 and then Nkind (Ref_Output) = N_Null
21924 Matching_Clause := Ref_Clause;
21927 -- Two function 'Result attributes match
if their inputs match
.
21928 -- Note that there is no need to compare the two prefixes because
21929 -- the attributes cannot denote anything but the related function.
21931 elsif Is_Attribute_Result
(Dep_Output
)
21932 and then Is_Attribute_Result
(Ref_Output
)
21934 Matching_Clause
:= Ref_Clause
;
21937 -- The remaining cases are formal parameters, variables and states
21939 elsif Is_Entity_Name
(Dep_Output
) then
21941 -- Handle abstract views of states and variables generated for
21942 -- limited with clauses.
21944 Dep_Id
:= Available_View
(Entity_Of
(Dep_Output
));
21946 if Ekind
(Dep_Id
) = E_Abstract_State
then
21948 -- A state with a null refinement matches either a null
21949 -- output list or nothing at all (no clause):
21951 -- Refined_State => (State => null)
21955 -- Depends => (State => null)
21956 -- Refined_Depends => null -- OK
21958 -- Null output list
21960 -- Depends => (State => <input>)
21961 -- Refined_Depends => (null => <input>) -- OK
21963 if Has_Null_Refinement
(Dep_Id
) then
21964 Has_Null_State
:= True;
21966 -- When a state with null refinement matches a null
21967 -- output, compare their inputs.
21969 if Nkind
(Ref_Output
) = N_Null
then
21970 Matching_Clause
:= Ref_Clause
;
21975 -- The state has a non-null refinement in which case the
21976 -- match is based on constituents and inputs. A state with
21977 -- multiple output constituents may match multiple clauses:
21979 -- Refined_State => (State => (C1, C2))
21980 -- Depends => (State => <input>)
21981 -- Refined_Depends => ((C1, C2) => <input>)
21983 -- When normalized, the above becomes:
21985 -- Refined_Depends => (C1 => <input>,
21988 elsif Has_Non_Null_Refinement
(Dep_Id
) then
21989 Has_Refined_State
:= True;
21991 -- Account for the case where a state with a non-null
21992 -- refinement matches a null output list:
21994 -- Refined_State => (State_1 => (C1, C2),
21995 -- State_2 => (C3, C4))
21996 -- Depends => (State_1 => State_2)
21997 -- Refined_Depends => (null => C3)
21999 if Nkind
(Ref_Output
) = N_Null
22000 and then Inputs_Match
22001 (Dep_Clause
=> Dep_Clause
,
22002 Ref_Clause
=> Ref_Clause
,
22003 Post_Errors
=> False)
22005 Has_Constituent
:= True;
22007 -- Note that the search continues after the clause is
22008 -- removed from the pool of candidates because it may
22009 -- have been normalized into multiple simple clauses.
22011 Remove
(Ref_Clause
);
22013 -- Otherwise the output of the refinement clause must be
22014 -- a valid constituent of the state:
22016 -- Refined_State => (State => (C1, C2))
22017 -- Depends => (State => <input>)
22018 -- Refined_Depends => (C1 => <input>)
22020 elsif Is_Entity_Name
(Ref_Output
) then
22021 Ref_Id
:= Entity_Of
(Ref_Output
);
22023 if Ekind_In
(Ref_Id
, E_Abstract_State
, E_Variable
)
22024 and then Present
(Encapsulating_State
(Ref_Id
))
22025 and then Encapsulating_State
(Ref_Id
) = Dep_Id
22026 and then Inputs_Match
22027 (Dep_Clause
=> Dep_Clause
,
22028 Ref_Clause
=> Ref_Clause
,
22029 Post_Errors
=> False)
22031 Has_Constituent
:= True;
22033 -- Note that the search continues after the clause
22034 -- is removed from the pool of candidates because
22035 -- it may have been normalized into multiple simple
22038 Remove
(Ref_Clause
);
22042 -- The abstract view of a state matches is corresponding
22043 -- non-abstract view:
22045 -- Depends => (Lim_Pack.State => <input>)
22046 -- Refined_Depends => (State => <input>)
22048 elsif Is_Entity_Name
(Ref_Output
)
22049 and then Entity_Of
(Ref_Output
) = Dep_Id
22051 Matching_Clause
:= Ref_Clause
;
22055 -- Formal parameters and variables match if their inputs match
22057 elsif Is_Entity_Name
(Ref_Output
)
22058 and then Entity_Of
(Ref_Output
) = Dep_Id
22060 Matching_Clause
:= Ref_Clause
;
22065 Ref_Clause
:= Next_Ref_Clause
;
22068 -- Handle the case where pragma Depends contains one or more clauses
22069 -- that only mention states with null refinements. In that case the
22070 -- corresponding pragma Refined_Depends may have a null relation.
22072 -- Refined_State => (State => null)
22073 -- Depends => (State => null)
22074 -- Refined_Depends => null -- OK
22076 -- Another instance of the same scenario occurs when the list of
22077 -- refinements has been depleted while processing previous clauses.
22079 if Is_Entity_Name
(Dep_Output
)
22080 and then (No
(Refinements
) or else Is_Empty_List
(Refinements
))
22082 Dep_Id
:= Entity_Of
(Dep_Output
);
22084 if Ekind
(Dep_Id
) = E_Abstract_State
22085 and then Has_Null_Refinement
(Dep_Id
)
22087 Has_Null_State
:= True;
22091 -- The above search produced a match based on unique output. Ensure
22092 -- that the inputs match as well and if they do, remove the clause
22093 -- from the pool of candidates.
22095 if Present
(Matching_Clause
) then
22097 (Ref_Clause
=> Ref_Clause
,
22098 Dep_Clause
=> Matching_Clause
,
22099 Post_Errors
=> True)
22101 Remove
(Matching_Clause
);
22104 -- A state with a visible refinement was matched against one or
22105 -- more clauses containing appropriate constituents.
22107 elsif Has_Constituent
then
22110 -- A state with a null refinement did not warrant a clause
22112 elsif Has_Null_State
then
22115 -- The dependence relation of pragma Refined_Depends does not contain
22116 -- a matching clause, emit an error.
22120 ("dependence clause of subprogram & has no matching refinement "
22121 & "in body", Ref_Clause
, Spec_Id
);
22123 if Has_Refined_State
then
22125 ("\check the use of constituents in dependence refinement",
22129 end Check_Dependency_Clause
;
22135 function Input_Match
22136 (Dep_Input
: Node_Id
;
22137 Ref_Inputs
: List_Id
;
22138 Post_Errors
: Boolean) return Boolean
22140 procedure Match_Error
(Msg
: String; N
: Node_Id
);
22141 -- Emit a matching error if flag Post_Errors is set
22147 procedure Match_Error
(Msg
: String; N
: Node_Id
) is
22149 if Post_Errors
then
22150 Error_Msg_N
(Msg
, N
);
22157 Next_Ref_Input
: Node_Id
;
22158 Ref_Id
: Entity_Id
;
22159 Ref_Input
: Node_Id
;
22161 Has_Constituent
: Boolean := False;
22162 -- Flag set when the refinement input list contains at least one
22163 -- constituent of the state denoted by Dep_Id.
22165 Has_Null_State
: Boolean := False;
22166 -- Flag set when the dependency input is a state with a visible null
22169 Has_Refined_State
: Boolean := False;
22170 -- Flag set when the dependency input is a state with visible non-
22171 -- null refinement.
22173 -- Start of processing for Input_Match
22176 -- Match a null input with another null input
22178 if Nkind
(Dep_Input
) = N_Null
then
22179 Ref_Input
:= First
(Ref_Inputs
);
22181 -- Remove the matching null from the pool of candidates
22183 if Nkind
(Ref_Input
) = N_Null
then
22184 Remove
(Ref_Input
);
22189 ("null input cannot be matched in corresponding refinement "
22190 & "clause", Dep_Input
);
22193 -- Remaining cases are formal parameters, variables, and states
22196 -- Handle abstract views of states and variables generated for
22197 -- limited with clauses.
22199 Dep_Id
:= Available_View
(Entity_Of
(Dep_Input
));
22201 -- Inspect all inputs of the refinement clause and attempt to
22202 -- match against the inputs of the dependence clause.
22204 Ref_Input
:= First
(Ref_Inputs
);
22205 while Present
(Ref_Input
) loop
22207 -- Store the next input now because a match will remove it from
22210 Next_Ref_Input
:= Next
(Ref_Input
);
22212 if Ekind
(Dep_Id
) = E_Abstract_State
then
22214 -- A state with a null refinement matches either a null
22215 -- input list or nothing at all (no input):
22217 -- Refined_State => (State => null)
22221 -- Depends => (<output> => (State, Input))
22222 -- Refined_Depends => (<output> => Input) -- OK
22226 -- Depends => (<output> => State)
22227 -- Refined_Depends => (<output> => null) -- OK
22229 if Has_Null_Refinement
(Dep_Id
) then
22230 Has_Null_State
:= True;
22232 -- Remove the matching null from the pool of candidates
22234 if Nkind
(Ref_Input
) = N_Null
then
22235 Remove
(Ref_Input
);
22240 -- The state has a non-null refinement in which case remove
22241 -- all the matching constituents of the state:
22243 -- Refined_State => (State => (C1, C2))
22244 -- Depends => (<output> => State)
22245 -- Refined_Depends => (<output> => (C1, C2))
22247 elsif Has_Non_Null_Refinement
(Dep_Id
) then
22248 Has_Refined_State
:= True;
22250 -- A state with a visible non-null refinement may have a
22251 -- null input_list only when it is self referential.
22253 -- Refined_State => (State => (C1, C2))
22254 -- Depends => (State => State)
22255 -- Refined_Depends => (C2 => null) -- OK
22257 if Nkind
(Ref_Input
) = N_Null
22258 and then Is_Self_Referential
(Dep_Id
)
22260 -- Remove the null from the pool of candidates. Note
22261 -- that the search continues because the state may be
22262 -- represented by multiple constituents.
22264 Has_Constituent
:= True;
22265 Remove
(Ref_Input
);
22267 -- Ref_Input is an entity name
22269 elsif Is_Entity_Name
(Ref_Input
) then
22270 Ref_Id
:= Entity_Of
(Ref_Input
);
22272 -- The input of the refinement clause is a valid
22273 -- constituent of the state. Remove the input from the
22274 -- pool of candidates. Note that the search continues
22275 -- because the state may be represented by multiple
22278 if Ekind_In
(Ref_Id
, E_Abstract_State
,
22280 and then Present
(Encapsulating_State
(Ref_Id
))
22281 and then Encapsulating_State
(Ref_Id
) = Dep_Id
22283 Has_Constituent
:= True;
22284 Remove
(Ref_Input
);
22288 -- The abstract view of a state matches its corresponding
22289 -- non-abstract view:
22291 -- Depends => (<output> => Lim_Pack.State)
22292 -- Refined_Depends => (<output> => State)
22294 elsif Is_Entity_Name
(Ref_Input
)
22295 and then Entity_Of
(Ref_Input
) = Dep_Id
22297 Remove
(Ref_Input
);
22301 -- Formal parameters and variables are matched on entities. If
22302 -- this is the case, remove the input from the candidate list.
22304 elsif Is_Entity_Name
(Ref_Input
)
22305 and then Entity_Of
(Ref_Input
) = Dep_Id
22307 Remove
(Ref_Input
);
22311 Ref_Input
:= Next_Ref_Input
;
22314 -- When a state with a null refinement appears as the last input,
22315 -- it matches nothing:
22317 -- Refined_State => (State => null)
22318 -- Depends => (<output> => (Input, State))
22319 -- Refined_Depends => (<output> => Input) -- OK
22321 if Ekind
(Dep_Id
) = E_Abstract_State
22322 and then Has_Null_Refinement
(Dep_Id
)
22323 and then No
(Ref_Input
)
22325 Has_Null_State
:= True;
22329 -- A state with visible refinement was matched against one or more of
22330 -- its constituents.
22332 if Has_Constituent
then
22335 -- A state with a null refinement matched null or nothing
22337 elsif Has_Null_State
then
22340 -- The input of a dependence clause does not have a matching input in
22341 -- the refinement clause, emit an error.
22345 ("input cannot be matched in corresponding refinement clause",
22348 if Has_Refined_State
then
22350 ("\check the use of constituents in dependence refinement",
22362 function Inputs_Match
22363 (Dep_Clause
: Node_Id
;
22364 Ref_Clause
: Node_Id
;
22365 Post_Errors
: Boolean) return Boolean
22367 Ref_Inputs
: List_Id
;
22368 -- The input list of the refinement clause
22370 procedure Report_Extra_Inputs
;
22371 -- Emit errors for all extra inputs that appear in Ref_Inputs
22373 -------------------------
22374 -- Report_Extra_Inputs --
22375 -------------------------
22377 procedure Report_Extra_Inputs
is
22381 if Present
(Ref_Inputs
) and then Post_Errors
then
22382 Input
:= First
(Ref_Inputs
);
22383 while Present
(Input
) loop
22385 ("unmatched or extra input in refinement clause", Input
);
22390 end Report_Extra_Inputs
;
22394 Dep_Inputs
: constant Node_Id
:= Expression
(Dep_Clause
);
22395 Inputs
: constant Node_Id
:= Expression
(Ref_Clause
);
22396 Dep_Input
: Node_Id
;
22399 -- Start of processing for Inputs_Match
22402 -- Construct a list of all refinement inputs. Note that the input
22403 -- list is copied because the algorithm modifies its contents and
22404 -- this should not be visible in Refined_Depends. The same applies
22405 -- for a solitary input.
22407 if Nkind
(Inputs
) = N_Aggregate
then
22408 Ref_Inputs
:= New_Copy_List
(Expressions
(Inputs
));
22410 Ref_Inputs
:= New_List
(New_Copy
(Inputs
));
22413 -- Depending on whether the original dependency clause mentions
22414 -- states with visible refinement, the corresponding refinement
22415 -- clause may differ greatly in structure and contents:
22417 -- State with null refinement
22419 -- Refined_State => (State => null)
22420 -- Depends => (<output> => State)
22421 -- Refined_Depends => (<output> => null)
22423 -- Depends => (<output> => (State, Input))
22424 -- Refined_Depends => (<output> => Input)
22426 -- Depends => (<output> => (Input_1, State, Input_2))
22427 -- Refined_Depends => (<output> => (Input_1, Input_2))
22429 -- State with non-null refinement
22431 -- Refined_State => (State_1 => (C1, C2))
22432 -- Depends => (<output> => State)
22433 -- Refined_Depends => (<output> => C1)
22435 -- Refined_Depends => (<output> => (C1, C2))
22437 if Nkind
(Dep_Inputs
) = N_Aggregate
then
22438 Dep_Input
:= First
(Expressions
(Dep_Inputs
));
22439 while Present
(Dep_Input
) loop
22441 (Dep_Input
=> Dep_Input
,
22442 Ref_Inputs
=> Ref_Inputs
,
22443 Post_Errors
=> Post_Errors
)
22458 (Dep_Input
=> Dep_Inputs
,
22459 Ref_Inputs
=> Ref_Inputs
,
22460 Post_Errors
=> Post_Errors
);
22463 -- List all inputs that appear as extras
22465 Report_Extra_Inputs
;
22470 -------------------------
22471 -- Is_Self_Referential --
22472 -------------------------
22474 function Is_Self_Referential
(Item_Id
: Entity_Id
) return Boolean is
22475 function Denotes_Item
(N
: Node_Id
) return Boolean;
22476 -- Determine whether an arbitrary node N denotes item Item_Id
22482 function Denotes_Item
(N
: Node_Id
) return Boolean is
22486 and then Present
(Entity
(N
))
22487 and then Entity
(N
) = Item_Id
;
22492 Clauses
: constant Node_Id
:=
22494 (First
(Pragma_Argument_Associations
(Depends
)));
22499 -- Start of processing for Is_Self_Referential
22502 Clause
:= First
(Component_Associations
(Clauses
));
22503 while Present
(Clause
) loop
22505 -- Due to normalization, a dependence clause has exactly one
22506 -- output even if the original clause had multiple outputs.
22508 Output
:= First
(Choices
(Clause
));
22510 -- Detect the following scenario:
22512 -- Item_Id => [(...,] Item_Id [, ...)]
22514 if Denotes_Item
(Output
) then
22515 Input
:= Expression
(Clause
);
22517 -- Multiple inputs appear as an aggregate
22519 if Nkind
(Input
) = N_Aggregate
then
22520 Input
:= First
(Expressions
(Input
));
22522 if Denotes_Item
(Input
) then
22530 elsif Denotes_Item
(Input
) then
22539 end Is_Self_Referential
;
22541 --------------------------
22542 -- Report_Extra_Clauses --
22543 --------------------------
22545 procedure Report_Extra_Clauses
is
22549 if Present
(Refinements
) then
22550 Clause
:= First
(Refinements
);
22551 while Present
(Clause
) loop
22553 -- Do not complain about a null input refinement, since a null
22554 -- input legitimately matches anything.
22556 if Nkind
(Clause
) /= N_Component_Association
22557 or else Nkind
(Expression
(Clause
)) /= N_Null
22560 ("unmatched or extra clause in dependence refinement",
22567 end Report_Extra_Clauses
;
22571 Body_Decl
: constant Node_Id
:= Parent
(N
);
22572 Errors
: constant Nat
:= Serious_Errors_Detected
;
22573 Refs
: constant Node_Id
:=
22574 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22578 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22581 -- Verify the syntax of pragma Refined_Depends when SPARK checks are
22582 -- suppressed. Semantic analysis is disabled in this mode.
22584 if SPARK_Mode
= Off
then
22585 Check_Dependence_List_Syntax
(Refs
);
22589 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22590 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22592 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22593 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22595 if No
(Depends
) then
22597 ("useless refinement, declaration of subprogram & lacks aspect or "
22598 & "pragma Depends", N
, Spec_Id
);
22602 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
22604 -- A null dependency relation renders the refinement useless because it
22605 -- cannot possibly mention abstract states with visible refinement. Note
22606 -- that the inverse is not true as states may be refined to null
22607 -- (SPARK RM 7.2.5(2)).
22609 if Nkind
(Deps
) = N_Null
then
22611 ("useless refinement, subprogram & does not depend on abstract "
22612 & "state with visible refinement",
22617 -- Multiple dependency clauses appear as component associations of an
22620 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22621 Dependencies
:= Component_Associations
(Deps
);
22623 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22624 -- This ensures that the categorization of all refined dependency items
22625 -- is consistent with their role.
22627 Analyze_Depends_In_Decl_Part
(N
);
22629 if Serious_Errors_Detected
= Errors
then
22630 if Nkind
(Refs
) = N_Null
then
22631 Refinements
:= No_List
;
22633 -- Multiple dependency clauses appear as component associations of an
22634 -- aggregate. Note that the clauses are copied because the algorithm
22635 -- modifies them and this should not be visible in Refined_Depends.
22637 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22638 Refinements
:= New_Copy_List
(Component_Associations
(Refs
));
22641 -- Inspect all the clauses of pragma Depends looking for a matching
22642 -- clause in pragma Refined_Depends. The approach is to use the
22643 -- sole output of a clause as a key. Output items are unique in a
22644 -- dependence relation. Clause normalization also ensured that all
22645 -- clauses have exactly one output. Depending on what the key is, one
22646 -- or more refinement clauses may satisfy the dependency clause. Each
22647 -- time a dependency clause is matched, its related refinement clause
22648 -- is consumed. In the end, two things may happen:
22650 -- 1) A clause of pragma Depends was not matched in which case
22651 -- Check_Dependency_Clause reports the error.
22653 -- 2) Refined_Depends has an extra clause in which case the error
22654 -- is reported by Report_Extra_Clauses.
22656 Clause
:= First
(Dependencies
);
22657 while Present
(Clause
) loop
22658 Check_Dependency_Clause
(Clause
);
22663 if Serious_Errors_Detected
= Errors
then
22664 Report_Extra_Clauses
;
22666 end Analyze_Refined_Depends_In_Decl_Part
;
22668 -----------------------------------------
22669 -- Analyze_Refined_Global_In_Decl_Part --
22670 -----------------------------------------
22672 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22674 -- The corresponding Global pragma
22676 Has_In_State
: Boolean := False;
22677 Has_In_Out_State
: Boolean := False;
22678 Has_Out_State
: Boolean := False;
22679 Has_Proof_In_State
: Boolean := False;
22680 -- These flags are set when the corresponding Global pragma has a state
22681 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22684 Has_Null_State
: Boolean := False;
22685 -- This flag is set when the corresponding Global pragma has at least
22686 -- one state with a null refinement.
22688 In_Constits
: Elist_Id
:= No_Elist
;
22689 In_Out_Constits
: Elist_Id
:= No_Elist
;
22690 Out_Constits
: Elist_Id
:= No_Elist
;
22691 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22692 -- These lists contain the entities of all Input, In_Out, Output and
22693 -- Proof_In constituents that appear in Refined_Global and participate
22694 -- in state refinement.
22696 In_Items
: Elist_Id
:= No_Elist
;
22697 In_Out_Items
: Elist_Id
:= No_Elist
;
22698 Out_Items
: Elist_Id
:= No_Elist
;
22699 Proof_In_Items
: Elist_Id
:= No_Elist
;
22700 -- These list contain the entities of all Input, In_Out, Output and
22701 -- Proof_In items defined in the corresponding Global pragma.
22703 procedure Check_In_Out_States
;
22704 -- Determine whether the corresponding Global pragma mentions In_Out
22705 -- states with visible refinement and if so, ensure that one of the
22706 -- following completions apply to the constituents of the state:
22707 -- 1) there is at least one constituent of mode In_Out
22708 -- 2) there is at least one Input and one Output constituent
22709 -- 3) not all constituents are present and one of them is of mode
22711 -- This routine may remove elements from In_Constits, In_Out_Constits,
22712 -- Out_Constits and Proof_In_Constits.
22714 procedure Check_Input_States
;
22715 -- Determine whether the corresponding Global pragma mentions Input
22716 -- states with visible refinement and if so, ensure that at least one of
22717 -- its constituents appears as an Input item in Refined_Global.
22718 -- This routine may remove elements from In_Constits, In_Out_Constits,
22719 -- Out_Constits and Proof_In_Constits.
22721 procedure Check_Output_States
;
22722 -- Determine whether the corresponding Global pragma mentions Output
22723 -- states with visible refinement and if so, ensure that all of its
22724 -- constituents appear as Output items in Refined_Global.
22725 -- This routine may remove elements from In_Constits, In_Out_Constits,
22726 -- Out_Constits and Proof_In_Constits.
22728 procedure Check_Proof_In_States
;
22729 -- Determine whether the corresponding Global pragma mentions Proof_In
22730 -- states with visible refinement and if so, ensure that at least one of
22731 -- its constituents appears as a Proof_In item in Refined_Global.
22732 -- This routine may remove elements from In_Constits, In_Out_Constits,
22733 -- Out_Constits and Proof_In_Constits.
22735 procedure Check_Refined_Global_List
22737 Global_Mode
: Name_Id
:= Name_Input
);
22738 -- Verify the legality of a single global list declaration. Global_Mode
22739 -- denotes the current mode in effect.
22741 function Present_Then_Remove
22743 Item
: Entity_Id
) return Boolean;
22744 -- Search List for a particular entity Item. If Item has been found,
22745 -- remove it from List. This routine is used to strip lists In_Constits,
22746 -- In_Out_Constits and Out_Constits of valid constituents.
22748 procedure Report_Extra_Constituents
;
22749 -- Emit an error for each constituent found in lists In_Constits,
22750 -- In_Out_Constits and Out_Constits.
22752 -------------------------
22753 -- Check_In_Out_States --
22754 -------------------------
22756 procedure Check_In_Out_States
is
22757 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22758 -- Determine whether one of the following coverage scenarios is in
22760 -- 1) there is at least one constituent of mode In_Out
22761 -- 2) there is at least one Input and one Output constituent
22762 -- 3) not all constituents are present and one of them is of mode
22764 -- If this is not the case, emit an error.
22766 -----------------------------
22767 -- Check_Constituent_Usage --
22768 -----------------------------
22770 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22771 Constit_Elmt
: Elmt_Id
;
22772 Constit_Id
: Entity_Id
;
22773 Has_Missing
: Boolean := False;
22774 In_Out_Seen
: Boolean := False;
22775 In_Seen
: Boolean := False;
22776 Out_Seen
: Boolean := False;
22779 -- Process all the constituents of the state and note their modes
22780 -- within the global refinement.
22782 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22783 while Present
(Constit_Elmt
) loop
22784 Constit_Id
:= Node
(Constit_Elmt
);
22786 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22789 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22790 In_Out_Seen
:= True;
22792 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22795 -- A Proof_In constituent cannot participate in the completion
22796 -- of an Output state (SPARK RM 7.2.4(5)).
22798 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22799 Error_Msg_Name_1
:= Chars
(State_Id
);
22801 ("constituent & of state % must have mode Input, In_Out "
22802 & "or Output in global refinement",
22806 Has_Missing
:= True;
22809 Next_Elmt
(Constit_Elmt
);
22812 -- A single In_Out constituent is a valid completion
22814 if In_Out_Seen
then
22817 -- A pair of one Input and one Output constituent is a valid
22820 elsif In_Seen
and then Out_Seen
then
22823 -- A single Output constituent is a valid completion only when
22824 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22826 elsif Has_Missing
and then Out_Seen
then
22831 ("global refinement of state & redefines the mode of its "
22832 & "constituents", N
, State_Id
);
22834 end Check_Constituent_Usage
;
22838 Item_Elmt
: Elmt_Id
;
22839 Item_Id
: Entity_Id
;
22841 -- Start of processing for Check_In_Out_States
22844 -- Inspect the In_Out items of the corresponding Global pragma
22845 -- looking for a state with a visible refinement.
22847 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22848 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22849 while Present
(Item_Elmt
) loop
22850 Item_Id
:= Node
(Item_Elmt
);
22852 -- Ensure that one of the three coverage variants is satisfied
22854 if Ekind
(Item_Id
) = E_Abstract_State
22855 and then Has_Non_Null_Refinement
(Item_Id
)
22857 Check_Constituent_Usage
(Item_Id
);
22860 Next_Elmt
(Item_Elmt
);
22863 end Check_In_Out_States
;
22865 ------------------------
22866 -- Check_Input_States --
22867 ------------------------
22869 procedure Check_Input_States
is
22870 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22871 -- Determine whether at least one constituent of state State_Id with
22872 -- visible refinement is used and has mode Input. Ensure that the
22873 -- remaining constituents do not have In_Out, Output or Proof_In
22876 -----------------------------
22877 -- Check_Constituent_Usage --
22878 -----------------------------
22880 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22881 Constit_Elmt
: Elmt_Id
;
22882 Constit_Id
: Entity_Id
;
22883 In_Seen
: Boolean := False;
22886 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22887 while Present
(Constit_Elmt
) loop
22888 Constit_Id
:= Node
(Constit_Elmt
);
22890 -- At least one of the constituents appears as an Input
22892 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22895 -- The constituent appears in the global refinement, but has
22896 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22898 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22899 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22900 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22902 Error_Msg_Name_1
:= Chars
(State_Id
);
22904 ("constituent & of state % must have mode Input in global "
22905 & "refinement", N
, Constit_Id
);
22908 Next_Elmt
(Constit_Elmt
);
22911 -- Not one of the constituents appeared as Input
22913 if not In_Seen
then
22915 ("global refinement of state & must include at least one "
22916 & "constituent of mode Input", N
, State_Id
);
22918 end Check_Constituent_Usage
;
22922 Item_Elmt
: Elmt_Id
;
22923 Item_Id
: Entity_Id
;
22925 -- Start of processing for Check_Input_States
22928 -- Inspect the Input items of the corresponding Global pragma
22929 -- looking for a state with a visible refinement.
22931 if Has_In_State
and then Present
(In_Items
) then
22932 Item_Elmt
:= First_Elmt
(In_Items
);
22933 while Present
(Item_Elmt
) loop
22934 Item_Id
:= Node
(Item_Elmt
);
22936 -- Ensure that at least one of the constituents is utilized and
22937 -- is of mode Input.
22939 if Ekind
(Item_Id
) = E_Abstract_State
22940 and then Has_Non_Null_Refinement
(Item_Id
)
22942 Check_Constituent_Usage
(Item_Id
);
22945 Next_Elmt
(Item_Elmt
);
22948 end Check_Input_States
;
22950 -------------------------
22951 -- Check_Output_States --
22952 -------------------------
22954 procedure Check_Output_States
is
22955 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22956 -- Determine whether all constituents of state State_Id with visible
22957 -- refinement are used and have mode Output. Emit an error if this is
22960 -----------------------------
22961 -- Check_Constituent_Usage --
22962 -----------------------------
22964 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22965 Constit_Elmt
: Elmt_Id
;
22966 Constit_Id
: Entity_Id
;
22967 Posted
: Boolean := False;
22970 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22971 while Present
(Constit_Elmt
) loop
22972 Constit_Id
:= Node
(Constit_Elmt
);
22974 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22977 -- The constituent appears in the global refinement, but has
22978 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22980 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22981 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22982 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22984 Error_Msg_Name_1
:= Chars
(State_Id
);
22986 ("constituent & of state % must have mode Output in "
22987 & "global refinement", N
, Constit_Id
);
22989 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22995 ("output state & must be replaced by all its "
22996 & "constituents in global refinement", N
, State_Id
);
23000 ("\constituent & is missing in output list",
23004 Next_Elmt
(Constit_Elmt
);
23006 end Check_Constituent_Usage
;
23010 Item_Elmt
: Elmt_Id
;
23011 Item_Id
: Entity_Id
;
23013 -- Start of processing for Check_Output_States
23016 -- Inspect the Output items of the corresponding Global pragma
23017 -- looking for a state with a visible refinement.
23019 if Has_Out_State
and then Present
(Out_Items
) then
23020 Item_Elmt
:= First_Elmt
(Out_Items
);
23021 while Present
(Item_Elmt
) loop
23022 Item_Id
:= Node
(Item_Elmt
);
23024 -- Ensure that all of the constituents are utilized and they
23025 -- have mode Output.
23027 if Ekind
(Item_Id
) = E_Abstract_State
23028 and then Has_Non_Null_Refinement
(Item_Id
)
23030 Check_Constituent_Usage
(Item_Id
);
23033 Next_Elmt
(Item_Elmt
);
23036 end Check_Output_States
;
23038 ---------------------------
23039 -- Check_Proof_In_States --
23040 ---------------------------
23042 procedure Check_Proof_In_States
is
23043 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23044 -- Determine whether at least one constituent of state State_Id with
23045 -- visible refinement is used and has mode Proof_In. Ensure that the
23046 -- remaining constituents do not have Input, In_Out or Output modes.
23048 -----------------------------
23049 -- Check_Constituent_Usage --
23050 -----------------------------
23052 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23053 Constit_Elmt
: Elmt_Id
;
23054 Constit_Id
: Entity_Id
;
23055 Proof_In_Seen
: Boolean := False;
23058 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23059 while Present
(Constit_Elmt
) loop
23060 Constit_Id
:= Node
(Constit_Elmt
);
23062 -- At least one of the constituents appears as Proof_In
23064 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23065 Proof_In_Seen
:= True;
23067 -- The constituent appears in the global refinement, but has
23068 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23070 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23071 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23072 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23074 Error_Msg_Name_1
:= Chars
(State_Id
);
23076 ("constituent & of state % must have mode Proof_In in "
23077 & "global refinement", N
, Constit_Id
);
23080 Next_Elmt
(Constit_Elmt
);
23083 -- Not one of the constituents appeared as Proof_In
23085 if not Proof_In_Seen
then
23087 ("global refinement of state & must include at least one "
23088 & "constituent of mode Proof_In", N
, State_Id
);
23090 end Check_Constituent_Usage
;
23094 Item_Elmt
: Elmt_Id
;
23095 Item_Id
: Entity_Id
;
23097 -- Start of processing for Check_Proof_In_States
23100 -- Inspect the Proof_In items of the corresponding Global pragma
23101 -- looking for a state with a visible refinement.
23103 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23104 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23105 while Present
(Item_Elmt
) loop
23106 Item_Id
:= Node
(Item_Elmt
);
23108 -- Ensure that at least one of the constituents is utilized and
23109 -- is of mode Proof_In
23111 if Ekind
(Item_Id
) = E_Abstract_State
23112 and then Has_Non_Null_Refinement
(Item_Id
)
23114 Check_Constituent_Usage
(Item_Id
);
23117 Next_Elmt
(Item_Elmt
);
23120 end Check_Proof_In_States
;
23122 -------------------------------
23123 -- Check_Refined_Global_List --
23124 -------------------------------
23126 procedure Check_Refined_Global_List
23128 Global_Mode
: Name_Id
:= Name_Input
)
23130 procedure Check_Refined_Global_Item
23132 Global_Mode
: Name_Id
);
23133 -- Verify the legality of a single global item declaration. Parameter
23134 -- Global_Mode denotes the current mode in effect.
23136 -------------------------------
23137 -- Check_Refined_Global_Item --
23138 -------------------------------
23140 procedure Check_Refined_Global_Item
23142 Global_Mode
: Name_Id
)
23144 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23146 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23147 -- Issue a common error message for all mode mismatches. Expect
23148 -- denotes the expected mode.
23150 -----------------------------
23151 -- Inconsistent_Mode_Error --
23152 -----------------------------
23154 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23157 ("global item & has inconsistent modes", Item
, Item_Id
);
23159 Error_Msg_Name_1
:= Global_Mode
;
23160 Error_Msg_Name_2
:= Expect
;
23161 Error_Msg_N
("\expected mode %, found mode %", Item
);
23162 end Inconsistent_Mode_Error
;
23164 -- Start of processing for Check_Refined_Global_Item
23167 -- When the state or variable acts as a constituent of another
23168 -- state with a visible refinement, collect it for the state
23169 -- completeness checks performed later on.
23171 if Present
(Encapsulating_State
(Item_Id
))
23172 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23174 if Global_Mode
= Name_Input
then
23175 Add_Item
(Item_Id
, In_Constits
);
23177 elsif Global_Mode
= Name_In_Out
then
23178 Add_Item
(Item_Id
, In_Out_Constits
);
23180 elsif Global_Mode
= Name_Output
then
23181 Add_Item
(Item_Id
, Out_Constits
);
23183 elsif Global_Mode
= Name_Proof_In
then
23184 Add_Item
(Item_Id
, Proof_In_Constits
);
23187 -- When not a constituent, ensure that both occurrences of the
23188 -- item in pragmas Global and Refined_Global match.
23190 elsif Contains
(In_Items
, Item_Id
) then
23191 if Global_Mode
/= Name_Input
then
23192 Inconsistent_Mode_Error
(Name_Input
);
23195 elsif Contains
(In_Out_Items
, Item_Id
) then
23196 if Global_Mode
/= Name_In_Out
then
23197 Inconsistent_Mode_Error
(Name_In_Out
);
23200 elsif Contains
(Out_Items
, Item_Id
) then
23201 if Global_Mode
/= Name_Output
then
23202 Inconsistent_Mode_Error
(Name_Output
);
23205 elsif Contains
(Proof_In_Items
, Item_Id
) then
23208 -- The item does not appear in the corresponding Global pragma,
23209 -- it must be an extra (SPARK RM 7.2.4(3)).
23212 Error_Msg_NE
("extra global item &", Item
, Item_Id
);
23214 end Check_Refined_Global_Item
;
23220 -- Start of processing for Check_Refined_Global_List
23223 if Nkind
(List
) = N_Null
then
23226 -- Single global item declaration
23228 elsif Nkind_In
(List
, N_Expanded_Name
,
23230 N_Selected_Component
)
23232 Check_Refined_Global_Item
(List
, Global_Mode
);
23234 -- Simple global list or moded global list declaration
23236 elsif Nkind
(List
) = N_Aggregate
then
23238 -- The declaration of a simple global list appear as a collection
23241 if Present
(Expressions
(List
)) then
23242 Item
:= First
(Expressions
(List
));
23243 while Present
(Item
) loop
23244 Check_Refined_Global_Item
(Item
, Global_Mode
);
23249 -- The declaration of a moded global list appears as a collection
23250 -- of component associations where individual choices denote
23253 elsif Present
(Component_Associations
(List
)) then
23254 Item
:= First
(Component_Associations
(List
));
23255 while Present
(Item
) loop
23256 Check_Refined_Global_List
23257 (List
=> Expression
(Item
),
23258 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23266 raise Program_Error
;
23272 raise Program_Error
;
23274 end Check_Refined_Global_List
;
23276 -------------------------
23277 -- Present_Then_Remove --
23278 -------------------------
23280 function Present_Then_Remove
23282 Item
: Entity_Id
) return Boolean
23287 if Present
(List
) then
23288 Elmt
:= First_Elmt
(List
);
23289 while Present
(Elmt
) loop
23290 if Node
(Elmt
) = Item
then
23291 Remove_Elmt
(List
, Elmt
);
23300 end Present_Then_Remove
;
23302 -------------------------------
23303 -- Report_Extra_Constituents --
23304 -------------------------------
23306 procedure Report_Extra_Constituents
is
23307 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23308 -- Emit an error for every element of List
23310 ---------------------------------------
23311 -- Report_Extra_Constituents_In_List --
23312 ---------------------------------------
23314 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23315 Constit_Elmt
: Elmt_Id
;
23318 if Present
(List
) then
23319 Constit_Elmt
:= First_Elmt
(List
);
23320 while Present
(Constit_Elmt
) loop
23321 Error_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23322 Next_Elmt
(Constit_Elmt
);
23325 end Report_Extra_Constituents_In_List
;
23327 -- Start of processing for Report_Extra_Constituents
23330 Report_Extra_Constituents_In_List
(In_Constits
);
23331 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23332 Report_Extra_Constituents_In_List
(Out_Constits
);
23333 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23334 end Report_Extra_Constituents
;
23338 Body_Decl
: constant Node_Id
:= Parent
(N
);
23339 Errors
: constant Nat
:= Serious_Errors_Detected
;
23340 Items
: constant Node_Id
:=
23341 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23342 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
23344 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23347 -- Verify the syntax of pragma Refined_Global when SPARK checks are
23348 -- suppressed. Semantic analysis is disabled in this mode.
23350 if SPARK_Mode
= Off
then
23351 Check_Global_List_Syntax
(Items
);
23355 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23357 -- The subprogram declaration lacks pragma Global. This renders
23358 -- Refined_Global useless as there is nothing to refine.
23360 if No
(Global
) then
23362 ("useless refinement, declaration of subprogram & lacks aspect or "
23363 & "pragma Global", N
, Spec_Id
);
23367 -- Extract all relevant items from the corresponding Global pragma
23369 Collect_Global_Items
23371 In_Items
=> In_Items
,
23372 In_Out_Items
=> In_Out_Items
,
23373 Out_Items
=> Out_Items
,
23374 Proof_In_Items
=> Proof_In_Items
,
23375 Has_In_State
=> Has_In_State
,
23376 Has_In_Out_State
=> Has_In_Out_State
,
23377 Has_Out_State
=> Has_Out_State
,
23378 Has_Proof_In_State
=> Has_Proof_In_State
,
23379 Has_Null_State
=> Has_Null_State
);
23381 -- Corresponding Global pragma must mention at least one state witha
23382 -- visible refinement at the point Refined_Global is processed. States
23383 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23385 if not Has_In_State
23386 and then not Has_In_Out_State
23387 and then not Has_Out_State
23388 and then not Has_Proof_In_State
23389 and then not Has_Null_State
23392 ("useless refinement, subprogram & does not depend on abstract "
23393 & "state with visible refinement", N
, Spec_Id
);
23397 -- The global refinement of inputs and outputs cannot be null when the
23398 -- corresponding Global pragma contains at least one item except in the
23399 -- case where we have states with null refinements.
23401 if Nkind
(Items
) = N_Null
23403 (Present
(In_Items
)
23404 or else Present
(In_Out_Items
)
23405 or else Present
(Out_Items
)
23406 or else Present
(Proof_In_Items
))
23407 and then not Has_Null_State
23410 ("refinement cannot be null, subprogram & has global items",
23415 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23416 -- This ensures that the categorization of all refined global items is
23417 -- consistent with their role.
23419 Analyze_Global_In_Decl_Part
(N
);
23421 -- Perform all refinement checks with respect to completeness and mode
23424 if Serious_Errors_Detected
= Errors
then
23425 Check_Refined_Global_List
(Items
);
23428 -- For Input states with visible refinement, at least one constituent
23429 -- must be used as an Input in the global refinement.
23431 if Serious_Errors_Detected
= Errors
then
23432 Check_Input_States
;
23435 -- Verify all possible completion variants for In_Out states with
23436 -- visible refinement.
23438 if Serious_Errors_Detected
= Errors
then
23439 Check_In_Out_States
;
23442 -- For Output states with visible refinement, all constituents must be
23443 -- used as Outputs in the global refinement.
23445 if Serious_Errors_Detected
= Errors
then
23446 Check_Output_States
;
23449 -- For Proof_In states with visible refinement, at least one constituent
23450 -- must be used as Proof_In in the global refinement.
23452 if Serious_Errors_Detected
= Errors
then
23453 Check_Proof_In_States
;
23456 -- Emit errors for all constituents that belong to other states with
23457 -- visible refinement that do not appear in Global.
23459 if Serious_Errors_Detected
= Errors
then
23460 Report_Extra_Constituents
;
23462 end Analyze_Refined_Global_In_Decl_Part
;
23464 ----------------------------------------
23465 -- Analyze_Refined_State_In_Decl_Part --
23466 ----------------------------------------
23468 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23469 Available_States
: Elist_Id
:= No_Elist
;
23470 -- A list of all abstract states defined in the package declaration that
23471 -- are available for refinement. The list is used to report unrefined
23474 Body_Id
: Entity_Id
;
23475 -- The body entity of the package subject to pragma Refined_State
23477 Body_States
: Elist_Id
:= No_Elist
;
23478 -- A list of all hidden states that appear in the body of the related
23479 -- package. The list is used to report unused hidden states.
23481 Constituents_Seen
: Elist_Id
:= No_Elist
;
23482 -- A list that contains all constituents processed so far. The list is
23483 -- used to detect multiple uses of the same constituent.
23485 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23486 -- A list that contains all refined states processed so far. The list is
23487 -- used to detect duplicate refinements.
23489 Spec_Id
: Entity_Id
;
23490 -- The spec entity of the package subject to pragma Refined_State
23492 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23493 -- Perform full analysis of a single refinement clause
23495 procedure Check_Refinement_List_Syntax
(List
: Node_Id
);
23496 -- Verify the syntax of refinement clause list List
23498 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23499 -- Gather the entities of all abstract states and variables declared in
23500 -- the body state space of package Pack_Id.
23502 procedure Report_Unrefined_States
(States
: Elist_Id
);
23503 -- Emit errors for all unrefined abstract states found in list States
23505 procedure Report_Unused_States
(States
: Elist_Id
);
23506 -- Emit errors for all unused states found in list States
23508 -------------------------------
23509 -- Analyze_Refinement_Clause --
23510 -------------------------------
23512 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23513 AR_Constit
: Entity_Id
:= Empty
;
23514 AW_Constit
: Entity_Id
:= Empty
;
23515 ER_Constit
: Entity_Id
:= Empty
;
23516 EW_Constit
: Entity_Id
:= Empty
;
23517 -- The entities of external constituents that contain one of the
23518 -- following enabled properties: Async_Readers, Async_Writers,
23519 -- Effective_Reads and Effective_Writes.
23521 External_Constit_Seen
: Boolean := False;
23522 -- Flag used to mark when at least one external constituent is part
23523 -- of the state refinement.
23525 Non_Null_Seen
: Boolean := False;
23526 Null_Seen
: Boolean := False;
23527 -- Flags used to detect multiple uses of null in a single clause or a
23528 -- mixture of null and non-null constituents.
23530 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23531 -- A list of all candidate constituents subject to indicator Part_Of
23532 -- where the encapsulating state is the current state.
23535 State_Id
: Entity_Id
;
23536 -- The current state being refined
23538 procedure Analyze_Constituent
(Constit
: Node_Id
);
23539 -- Perform full analysis of a single constituent
23541 procedure Check_External_Property
23542 (Prop_Nam
: Name_Id
;
23544 Constit
: Entity_Id
);
23545 -- Determine whether a property denoted by name Prop_Nam is present
23546 -- in both the refined state and constituent Constit. Flag Enabled
23547 -- should be set when the property applies to the refined state. If
23548 -- this is not the case, emit an error message.
23550 procedure Check_Matching_State
;
23551 -- Determine whether the state being refined appears in list
23552 -- Available_States. Emit an error when attempting to re-refine the
23553 -- state or when the state is not defined in the package declaration,
23554 -- otherwise remove the state from Available_States.
23556 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23557 -- Emit errors for all unused Part_Of constituents in list Constits
23559 -------------------------
23560 -- Analyze_Constituent --
23561 -------------------------
23563 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23564 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23565 -- Determine whether constituent Constit denoted by its entity
23566 -- Constit_Id appears in Hidden_States. Emit an error when the
23567 -- constituent is not a valid hidden state of the related package
23568 -- or when it is used more than once. Otherwise remove the
23569 -- constituent from Hidden_States.
23571 --------------------------------
23572 -- Check_Matching_Constituent --
23573 --------------------------------
23575 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23576 procedure Collect_Constituent
;
23577 -- Add constituent Constit_Id to the refinements of State_Id
23579 -------------------------
23580 -- Collect_Constituent --
23581 -------------------------
23583 procedure Collect_Constituent
is
23585 -- Add the constituent to the list of processed items to aid
23586 -- with the detection of duplicates.
23588 Add_Item
(Constit_Id
, Constituents_Seen
);
23590 -- Collect the constituent in the list of refinement items
23591 -- and establish a relation between the refined state and
23594 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23595 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23597 -- The state has at least one legal constituent, mark the
23598 -- start of the refinement region. The region ends when the
23599 -- body declarations end (see routine Analyze_Declarations).
23601 Set_Has_Visible_Refinement
(State_Id
);
23603 -- When the constituent is external, save its relevant
23604 -- property for further checks.
23606 if Async_Readers_Enabled
(Constit_Id
) then
23607 AR_Constit
:= Constit_Id
;
23608 External_Constit_Seen
:= True;
23611 if Async_Writers_Enabled
(Constit_Id
) then
23612 AW_Constit
:= Constit_Id
;
23613 External_Constit_Seen
:= True;
23616 if Effective_Reads_Enabled
(Constit_Id
) then
23617 ER_Constit
:= Constit_Id
;
23618 External_Constit_Seen
:= True;
23621 if Effective_Writes_Enabled
(Constit_Id
) then
23622 EW_Constit
:= Constit_Id
;
23623 External_Constit_Seen
:= True;
23625 end Collect_Constituent
;
23629 State_Elmt
: Elmt_Id
;
23631 -- Start of processing for Check_Matching_Constituent
23634 -- Detect a duplicate use of a constituent
23636 if Contains
(Constituents_Seen
, Constit_Id
) then
23638 ("duplicate use of constituent &", Constit
, Constit_Id
);
23642 -- The constituent is subject to a Part_Of indicator
23644 if Present
(Encapsulating_State
(Constit_Id
)) then
23645 if Encapsulating_State
(Constit_Id
) = State_Id
then
23646 Remove
(Part_Of_Constits
, Constit_Id
);
23647 Collect_Constituent
;
23649 -- The constituent is part of another state and is used
23650 -- incorrectly in the refinement of the current state.
23653 Error_Msg_Name_1
:= Chars
(State_Id
);
23655 ("& cannot act as constituent of state %",
23656 Constit
, Constit_Id
);
23658 ("\Part_Of indicator specifies & as encapsulating "
23659 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23662 -- The only other source of legal constituents is the body
23663 -- state space of the related package.
23666 if Present
(Body_States
) then
23667 State_Elmt
:= First_Elmt
(Body_States
);
23668 while Present
(State_Elmt
) loop
23670 -- Consume a valid constituent to signal that it has
23671 -- been encountered.
23673 if Node
(State_Elmt
) = Constit_Id
then
23674 Remove_Elmt
(Body_States
, State_Elmt
);
23675 Collect_Constituent
;
23679 Next_Elmt
(State_Elmt
);
23683 -- If we get here, then the constituent is not a hidden
23684 -- state of the related package and may not be used in a
23685 -- refinement (SPARK RM 7.2.2(9)).
23687 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23689 ("cannot use & in refinement, constituent is not a hidden "
23690 & "state of package %", Constit
, Constit_Id
);
23692 end Check_Matching_Constituent
;
23696 Constit_Id
: Entity_Id
;
23698 -- Start of processing for Analyze_Constituent
23701 -- Detect multiple uses of null in a single refinement clause or a
23702 -- mixture of null and non-null constituents.
23704 if Nkind
(Constit
) = N_Null
then
23707 ("multiple null constituents not allowed", Constit
);
23709 elsif Non_Null_Seen
then
23711 ("cannot mix null and non-null constituents", Constit
);
23716 -- Collect the constituent in the list of refinement items
23718 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23720 -- The state has at least one legal constituent, mark the
23721 -- start of the refinement region. The region ends when the
23722 -- body declarations end (see Analyze_Declarations).
23724 Set_Has_Visible_Refinement
(State_Id
);
23727 -- Non-null constituents
23730 Non_Null_Seen
:= True;
23734 ("cannot mix null and non-null constituents", Constit
);
23738 Resolve_State
(Constit
);
23740 -- Ensure that the constituent denotes a valid state or a
23743 if Is_Entity_Name
(Constit
) then
23744 Constit_Id
:= Entity_Of
(Constit
);
23746 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
23747 Check_Matching_Constituent
(Constit_Id
);
23751 ("constituent & must denote a variable or state (SPARK "
23752 & "RM 7.2.2(5))", Constit
, Constit_Id
);
23755 -- The constituent is illegal
23758 Error_Msg_N
("malformed constituent", Constit
);
23761 end Analyze_Constituent
;
23763 -----------------------------
23764 -- Check_External_Property --
23765 -----------------------------
23767 procedure Check_External_Property
23768 (Prop_Nam
: Name_Id
;
23770 Constit
: Entity_Id
)
23773 Error_Msg_Name_1
:= Prop_Nam
;
23775 -- The property is enabled in the related Abstract_State pragma
23776 -- that defines the state (SPARK RM 7.2.8(3)).
23779 if No
(Constit
) then
23781 ("external state & requires at least one constituent with "
23782 & "property %", State
, State_Id
);
23785 -- The property is missing in the declaration of the state, but
23786 -- a constituent is introducing it in the state refinement
23787 -- (SPARK RM 7.2.8(3)).
23789 elsif Present
(Constit
) then
23790 Error_Msg_Name_2
:= Chars
(Constit
);
23792 ("external state & lacks property % set by constituent %",
23795 end Check_External_Property
;
23797 --------------------------
23798 -- Check_Matching_State --
23799 --------------------------
23801 procedure Check_Matching_State
is
23802 State_Elmt
: Elmt_Id
;
23805 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23807 if Contains
(Refined_States_Seen
, State_Id
) then
23809 ("duplicate refinement of state &", State
, State_Id
);
23813 -- Inspect the abstract states defined in the package declaration
23814 -- looking for a match.
23816 State_Elmt
:= First_Elmt
(Available_States
);
23817 while Present
(State_Elmt
) loop
23819 -- A valid abstract state is being refined in the body. Add
23820 -- the state to the list of processed refined states to aid
23821 -- with the detection of duplicate refinements. Remove the
23822 -- state from Available_States to signal that it has already
23825 if Node
(State_Elmt
) = State_Id
then
23826 Add_Item
(State_Id
, Refined_States_Seen
);
23827 Remove_Elmt
(Available_States
, State_Elmt
);
23831 Next_Elmt
(State_Elmt
);
23834 -- If we get here, we are refining a state that is not defined in
23835 -- the package declaration.
23837 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23839 ("cannot refine state, & is not defined in package %",
23841 end Check_Matching_State
;
23843 --------------------------------
23844 -- Report_Unused_Constituents --
23845 --------------------------------
23847 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
23848 Constit_Elmt
: Elmt_Id
;
23849 Constit_Id
: Entity_Id
;
23850 Posted
: Boolean := False;
23853 if Present
(Constits
) then
23854 Constit_Elmt
:= First_Elmt
(Constits
);
23855 while Present
(Constit_Elmt
) loop
23856 Constit_Id
:= Node
(Constit_Elmt
);
23858 -- Generate an error message of the form:
23860 -- state ... has unused Part_Of constituents
23861 -- abstract state ... defined at ...
23862 -- variable ... defined at ...
23867 ("state & has unused Part_Of constituents",
23871 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
23873 if Ekind
(Constit_Id
) = E_Abstract_State
then
23875 ("\abstract state & defined #", State
, Constit_Id
);
23878 ("\variable & defined #", State
, Constit_Id
);
23881 Next_Elmt
(Constit_Elmt
);
23884 end Report_Unused_Constituents
;
23886 -- Local declarations
23888 Body_Ref
: Node_Id
;
23889 Body_Ref_Elmt
: Elmt_Id
;
23891 Extra_State
: Node_Id
;
23893 -- Start of processing for Analyze_Refinement_Clause
23896 -- A refinement clause appears as a component association where the
23897 -- sole choice is the state and the expressions are the constituents.
23899 if Nkind
(Clause
) /= N_Component_Association
then
23900 Error_Msg_N
("malformed state refinement clause", Clause
);
23904 -- Analyze the state name of a refinement clause
23906 State
:= First
(Choices
(Clause
));
23909 Resolve_State
(State
);
23911 -- Ensure that the state name denotes a valid abstract state that is
23912 -- defined in the spec of the related package.
23914 if Is_Entity_Name
(State
) then
23915 State_Id
:= Entity_Of
(State
);
23917 -- Catch any attempts to re-refine a state or refine a state that
23918 -- is not defined in the package declaration.
23920 if Ekind
(State_Id
) = E_Abstract_State
then
23921 Check_Matching_State
;
23924 ("& must denote an abstract state", State
, State_Id
);
23928 -- References to a state with visible refinement are illegal.
23929 -- When nested packages are involved, detecting such references is
23930 -- tricky because pragma Refined_State is analyzed later than the
23931 -- offending pragma Depends or Global. References that occur in
23932 -- such nested context are stored in a list. Emit errors for all
23933 -- references found in Body_References (SPARK RM 6.1.4(8)).
23935 if Present
(Body_References
(State_Id
)) then
23936 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
23937 while Present
(Body_Ref_Elmt
) loop
23938 Body_Ref
:= Node
(Body_Ref_Elmt
);
23940 Error_Msg_N
("reference to & not allowed", Body_Ref
);
23941 Error_Msg_Sloc
:= Sloc
(State
);
23942 Error_Msg_N
("\refinement of & is visible#", Body_Ref
);
23944 Next_Elmt
(Body_Ref_Elmt
);
23948 -- The state name is illegal
23951 Error_Msg_N
("malformed state name in refinement clause", State
);
23955 -- A refinement clause may only refine one state at a time
23957 Extra_State
:= Next
(State
);
23959 if Present
(Extra_State
) then
23961 ("refinement clause cannot cover multiple states", Extra_State
);
23964 -- Replicate the Part_Of constituents of the refined state because
23965 -- the algorithm will consume items.
23967 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
23969 -- Analyze all constituents of the refinement. Multiple constituents
23970 -- appear as an aggregate.
23972 Constit
:= Expression
(Clause
);
23974 if Nkind
(Constit
) = N_Aggregate
then
23975 if Present
(Component_Associations
(Constit
)) then
23977 ("constituents of refinement clause must appear in "
23978 & "positional form", Constit
);
23980 else pragma Assert
(Present
(Expressions
(Constit
)));
23981 Constit
:= First
(Expressions
(Constit
));
23982 while Present
(Constit
) loop
23983 Analyze_Constituent
(Constit
);
23989 -- Various forms of a single constituent. Note that these may include
23990 -- malformed constituents.
23993 Analyze_Constituent
(Constit
);
23996 -- A refined external state is subject to special rules with respect
23997 -- to its properties and constituents.
23999 if Is_External_State
(State_Id
) then
24001 -- The set of properties that all external constituents yield must
24002 -- match that of the refined state. There are two cases to detect:
24003 -- the refined state lacks a property or has an extra property.
24005 if External_Constit_Seen
then
24006 Check_External_Property
24007 (Prop_Nam
=> Name_Async_Readers
,
24008 Enabled
=> Async_Readers_Enabled
(State_Id
),
24009 Constit
=> AR_Constit
);
24011 Check_External_Property
24012 (Prop_Nam
=> Name_Async_Writers
,
24013 Enabled
=> Async_Writers_Enabled
(State_Id
),
24014 Constit
=> AW_Constit
);
24016 Check_External_Property
24017 (Prop_Nam
=> Name_Effective_Reads
,
24018 Enabled
=> Effective_Reads_Enabled
(State_Id
),
24019 Constit
=> ER_Constit
);
24021 Check_External_Property
24022 (Prop_Nam
=> Name_Effective_Writes
,
24023 Enabled
=> Effective_Writes_Enabled
(State_Id
),
24024 Constit
=> EW_Constit
);
24026 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24028 elsif Null_Seen
then
24031 -- The external state has constituents, but none of them are
24032 -- external (SPARK RM 7.2.8(2)).
24036 ("external state & requires at least one external "
24037 & "constituent or null refinement", State
, State_Id
);
24040 -- When a refined state is not external, it should not have external
24041 -- constituents (SPARK RM 7.2.8(1)).
24043 elsif External_Constit_Seen
then
24045 ("non-external state & cannot contain external constituents in "
24046 & "refinement", State
, State_Id
);
24049 -- Ensure that all Part_Of candidate constituents have been mentioned
24050 -- in the refinement clause.
24052 Report_Unused_Constituents
(Part_Of_Constits
);
24053 end Analyze_Refinement_Clause
;
24055 ----------------------------------
24056 -- Check_Refinement_List_Syntax --
24057 ----------------------------------
24059 procedure Check_Refinement_List_Syntax
(List
: Node_Id
) is
24060 procedure Check_Clause_Syntax
(Clause
: Node_Id
);
24061 -- Verify the syntax of state refinement clause Clause
24063 -------------------------
24064 -- Check_Clause_Syntax --
24065 -------------------------
24067 procedure Check_Clause_Syntax
(Clause
: Node_Id
) is
24068 Constits
: constant Node_Id
:= Expression
(Clause
);
24072 -- State to be refined
24074 Check_Item_Syntax
(First
(Choices
(Clause
)));
24076 -- Multiple constituents
24078 if Nkind
(Constits
) = N_Aggregate
24079 and then Present
(Expressions
(Constits
))
24081 Constit
:= First
(Expressions
(Constits
));
24082 while Present
(Constit
) loop
24083 Check_Item_Syntax
(Constit
);
24087 -- Single constituent
24090 Check_Item_Syntax
(Constits
);
24092 end Check_Clause_Syntax
;
24098 -- Start of processing for Check_Refinement_List_Syntax
24101 -- Multiple state refinement clauses
24103 if Nkind
(List
) = N_Aggregate
24104 and then Present
(Component_Associations
(List
))
24106 Clause
:= First
(Component_Associations
(List
));
24107 while Present
(Clause
) loop
24108 Check_Clause_Syntax
(Clause
);
24112 -- Single state refinement clause
24115 Check_Clause_Syntax
(List
);
24117 end Check_Refinement_List_Syntax
;
24119 -------------------------
24120 -- Collect_Body_States --
24121 -------------------------
24123 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24124 Result
: Elist_Id
:= No_Elist
;
24125 -- A list containing all body states of Pack_Id
24127 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24128 -- Gather the entities of all abstract states and variables declared
24129 -- in the visible state space of package Pack_Id.
24131 ----------------------------
24132 -- Collect_Visible_States --
24133 ----------------------------
24135 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24136 Item_Id
: Entity_Id
;
24139 -- Traverse the entity chain of the package and inspect all
24142 Item_Id
:= First_Entity
(Pack_Id
);
24143 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24145 -- Do not consider internally generated items as those cannot
24146 -- be named and participate in refinement.
24148 if not Comes_From_Source
(Item_Id
) then
24151 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24152 Add_Item
(Item_Id
, Result
);
24154 -- Recursively gather the visible states of a nested package
24156 elsif Ekind
(Item_Id
) = E_Package
then
24157 Collect_Visible_States
(Item_Id
);
24160 Next_Entity
(Item_Id
);
24162 end Collect_Visible_States
;
24166 Pack_Body
: constant Node_Id
:=
24167 Declaration_Node
(Body_Entity
(Pack_Id
));
24169 Item_Id
: Entity_Id
;
24171 -- Start of processing for Collect_Body_States
24174 -- Inspect the declarations of the body looking for source variables,
24175 -- packages and package instantiations.
24177 Decl
:= First
(Declarations
(Pack_Body
));
24178 while Present
(Decl
) loop
24179 if Nkind
(Decl
) = N_Object_Declaration
then
24180 Item_Id
:= Defining_Entity
(Decl
);
24182 -- Capture source variables only as internally generated
24183 -- temporaries cannot be named and participate in refinement.
24185 if Ekind
(Item_Id
) = E_Variable
24186 and then Comes_From_Source
(Item_Id
)
24188 Add_Item
(Item_Id
, Result
);
24191 elsif Nkind
(Decl
) = N_Package_Declaration
then
24192 Item_Id
:= Defining_Entity
(Decl
);
24194 -- Capture the visible abstract states and variables of a
24195 -- source package [instantiation].
24197 if Comes_From_Source
(Item_Id
) then
24198 Collect_Visible_States
(Item_Id
);
24206 end Collect_Body_States
;
24208 -----------------------------
24209 -- Report_Unrefined_States --
24210 -----------------------------
24212 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24213 State_Elmt
: Elmt_Id
;
24216 if Present
(States
) then
24217 State_Elmt
:= First_Elmt
(States
);
24218 while Present
(State_Elmt
) loop
24220 ("abstract state & must be refined", Node
(State_Elmt
));
24222 Next_Elmt
(State_Elmt
);
24225 end Report_Unrefined_States
;
24227 --------------------------
24228 -- Report_Unused_States --
24229 --------------------------
24231 procedure Report_Unused_States
(States
: Elist_Id
) is
24232 Posted
: Boolean := False;
24233 State_Elmt
: Elmt_Id
;
24234 State_Id
: Entity_Id
;
24237 if Present
(States
) then
24238 State_Elmt
:= First_Elmt
(States
);
24239 while Present
(State_Elmt
) loop
24240 State_Id
:= Node
(State_Elmt
);
24242 -- Generate an error message of the form:
24244 -- body of package ... has unused hidden states
24245 -- abstract state ... defined at ...
24246 -- variable ... defined at ...
24251 ("body of package & has unused hidden states", Body_Id
);
24254 Error_Msg_Sloc
:= Sloc
(State_Id
);
24256 if Ekind
(State_Id
) = E_Abstract_State
then
24258 ("\abstract state & defined #", Body_Id
, State_Id
);
24261 ("\variable & defined #", Body_Id
, State_Id
);
24264 Next_Elmt
(State_Elmt
);
24267 end Report_Unused_States
;
24269 -- Local declarations
24271 Body_Decl
: constant Node_Id
:= Parent
(N
);
24272 Clauses
: constant Node_Id
:=
24273 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
24276 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24281 -- Verify the syntax of pragma Refined_State when SPARK checks are
24282 -- suppressed. Semantic analysis is disabled in this mode.
24284 if SPARK_Mode
= Off
then
24285 Check_Refinement_List_Syntax
(Clauses
);
24289 Body_Id
:= Defining_Entity
(Body_Decl
);
24290 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
24292 -- Replicate the abstract states declared by the package because the
24293 -- matching algorithm will consume states.
24295 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24297 -- Gather all abstract states and variables declared in the visible
24298 -- state space of the package body. These items must be utilized as
24299 -- constituents in a state refinement.
24301 Body_States
:= Collect_Body_States
(Spec_Id
);
24303 -- Multiple non-null state refinements appear as an aggregate
24305 if Nkind
(Clauses
) = N_Aggregate
then
24306 if Present
(Expressions
(Clauses
)) then
24308 ("state refinements must appear as component associations",
24311 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24312 Clause
:= First
(Component_Associations
(Clauses
));
24313 while Present
(Clause
) loop
24314 Analyze_Refinement_Clause
(Clause
);
24320 -- Various forms of a single state refinement. Note that these may
24321 -- include malformed refinements.
24324 Analyze_Refinement_Clause
(Clauses
);
24327 -- List all abstract states that were left unrefined
24329 Report_Unrefined_States
(Available_States
);
24331 -- Ensure that all abstract states and variables declared in the body
24332 -- state space of the related package are utilized as constituents.
24334 Report_Unused_States
(Body_States
);
24335 end Analyze_Refined_State_In_Decl_Part
;
24337 ------------------------------------
24338 -- Analyze_Test_Case_In_Decl_Part --
24339 ------------------------------------
24341 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
24343 -- Install formals and push subprogram spec onto scope stack so that we
24344 -- can see the formals from the pragma.
24347 Install_Formals
(S
);
24349 -- Preanalyze the boolean expressions, we treat these as spec
24350 -- expressions (i.e. similar to a default expression).
24352 if Pragma_Name
(N
) = Name_Test_Case
then
24353 Preanalyze_CTC_Args
24355 Get_Requires_From_CTC_Pragma
(N
),
24356 Get_Ensures_From_CTC_Pragma
(N
));
24359 -- Remove the subprogram from the scope stack now that the pre-analysis
24360 -- of the expressions in the contract case or test case is done.
24363 end Analyze_Test_Case_In_Decl_Part
;
24369 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24374 if Present
(List
) then
24375 Elmt
:= First_Elmt
(List
);
24376 while Present
(Elmt
) loop
24377 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24380 Id
:= Entity_Of
(Node
(Elmt
));
24383 if Id
= Item_Id
then
24394 -----------------------------
24395 -- Check_Applicable_Policy --
24396 -----------------------------
24398 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24402 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
24405 -- No effect if not valid assertion kind name
24407 if not Is_Valid_Assertion_Kind
(Ename
) then
24411 -- Loop through entries in check policy list
24413 PP
:= Opt
.Check_Policy_List
;
24414 while Present
(PP
) loop
24416 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24417 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24421 or else Pnm
= Name_Assertion
24422 or else (Pnm
= Name_Statement_Assertions
24423 and then Nam_In
(Ename
, Name_Assert
,
24424 Name_Assert_And_Cut
,
24426 Name_Loop_Invariant
,
24427 Name_Loop_Variant
))
24429 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24432 when Name_Off | Name_Ignore
=>
24433 Set_Is_Ignored
(N
, True);
24434 Set_Is_Checked
(N
, False);
24436 when Name_On | Name_Check
=>
24437 Set_Is_Checked
(N
, True);
24438 Set_Is_Ignored
(N
, False);
24440 when Name_Disable
=>
24441 Set_Is_Ignored
(N
, True);
24442 Set_Is_Checked
(N
, False);
24443 Set_Is_Disabled
(N
, True);
24445 -- That should be exhaustive, the null here is a defence
24446 -- against a malformed tree from previous errors.
24455 PP
:= Next_Pragma
(PP
);
24459 -- If there are no specific entries that matched, then we let the
24460 -- setting of assertions govern. Note that this provides the needed
24461 -- compatibility with the RM for the cases of assertion, invariant,
24462 -- precondition, predicate, and postcondition.
24464 if Assertions_Enabled
then
24465 Set_Is_Checked
(N
, True);
24466 Set_Is_Ignored
(N
, False);
24468 Set_Is_Checked
(N
, False);
24469 Set_Is_Ignored
(N
, True);
24471 end Check_Applicable_Policy
;
24473 ----------------------------------
24474 -- Check_Dependence_List_Syntax --
24475 ----------------------------------
24477 procedure Check_Dependence_List_Syntax
(List
: Node_Id
) is
24478 procedure Check_Clause_Syntax
(Clause
: Node_Id
);
24479 -- Verify the syntax of a dependency clause Clause
24481 -------------------------
24482 -- Check_Clause_Syntax --
24483 -------------------------
24485 procedure Check_Clause_Syntax
(Clause
: Node_Id
) is
24493 Output
:= First
(Choices
(Clause
));
24494 while Present
(Output
) loop
24495 Check_Item_Syntax
(Output
);
24499 Inputs
:= Expression
(Clause
);
24501 -- A self-dependency appears as operator "+"
24503 if Nkind
(Inputs
) = N_Op_Plus
then
24504 Inputs
:= Right_Opnd
(Inputs
);
24509 if Nkind
(Inputs
) = N_Aggregate
then
24510 if Present
(Expressions
(Inputs
)) then
24511 Input
:= First
(Expressions
(Inputs
));
24512 while Present
(Input
) loop
24513 Check_Item_Syntax
(Input
);
24518 Error_Msg_N
("malformed input dependency list", Inputs
);
24521 -- Single input item
24524 Check_Item_Syntax
(Inputs
);
24526 end Check_Clause_Syntax
;
24532 -- Start of processing for Check_Dependence_List_Syntax
24535 -- Null dependency relation
24537 if Nkind
(List
) = N_Null
then
24540 -- Verify the syntax of a single or multiple dependency clauses
24542 elsif Nkind
(List
) = N_Aggregate
24543 and then Present
(Component_Associations
(List
))
24545 Clause
:= First
(Component_Associations
(List
));
24546 while Present
(Clause
) loop
24547 if Has_Extra_Parentheses
(Clause
) then
24550 Check_Clause_Syntax
(Clause
);
24557 Error_Msg_N
("malformed dependency relation", List
);
24559 end Check_Dependence_List_Syntax
;
24561 -------------------------------
24562 -- Check_External_Properties --
24563 -------------------------------
24565 procedure Check_External_Properties
24573 -- All properties enabled
24575 if AR
and AW
and ER
and EW
then
24578 -- Async_Readers + Effective_Writes
24579 -- Async_Readers + Async_Writers + Effective_Writes
24581 elsif AR
and EW
and not ER
then
24584 -- Async_Writers + Effective_Reads
24585 -- Async_Readers + Async_Writers + Effective_Reads
24587 elsif AW
and ER
and not EW
then
24590 -- Async_Readers + Async_Writers
24592 elsif AR
and AW
and not ER
and not EW
then
24597 elsif AR
and not AW
and not ER
and not EW
then
24602 elsif AW
and not AR
and not ER
and not EW
then
24607 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24610 end Check_External_Properties
;
24612 ------------------------------
24613 -- Check_Global_List_Syntax --
24614 ------------------------------
24616 procedure Check_Global_List_Syntax
(List
: Node_Id
) is
24621 -- Null global list
24623 if Nkind
(List
) = N_Null
then
24626 -- Single global item
24628 elsif Nkind_In
(List
, N_Expanded_Name
,
24630 N_Selected_Component
)
24634 elsif Nkind
(List
) = N_Aggregate
then
24636 -- Items in a simple global list
24638 if Present
(Expressions
(List
)) then
24639 Item
:= First
(Expressions
(List
));
24640 while Present
(Item
) loop
24641 Check_Item_Syntax
(Item
);
24645 -- Items in a moded global list
24647 elsif Present
(Component_Associations
(List
)) then
24648 Assoc
:= First
(Component_Associations
(List
));
24649 while Present
(Assoc
) loop
24650 Check_Item_Syntax
(First
(Choices
(Assoc
)));
24651 Check_Global_List_Syntax
(Expression
(Assoc
));
24657 -- Anything else is an error
24660 Error_Msg_N
("malformed global list", List
);
24662 end Check_Global_List_Syntax
;
24664 -----------------------
24665 -- Check_Item_Syntax --
24666 -----------------------
24668 procedure Check_Item_Syntax
(Item
: Node_Id
) is
24670 -- Null can appear in various annotation lists to denote a missing or
24671 -- optional relation.
24673 if Nkind
(Item
) = N_Null
then
24676 -- Formal parameter, state or variable nodes
24678 elsif Nkind_In
(Item
, N_Expanded_Name
,
24680 N_Selected_Component
)
24684 -- Attribute 'Result can appear in annotations to denote the outcome of
24685 -- a function call.
24687 elsif Is_Attribute_Result
(Item
) then
24690 -- Any other node cannot possibly denote a legal SPARK item
24693 Error_Msg_N
("malformed item", Item
);
24695 end Check_Item_Syntax
;
24701 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24705 -- Loop through entries in check policy list
24707 PP
:= Opt
.Check_Policy_List
;
24708 while Present
(PP
) loop
24710 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24711 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24715 or else (Pnm
= Name_Assertion
24716 and then Is_Valid_Assertion_Kind
(Nam
))
24717 or else (Pnm
= Name_Statement_Assertions
24718 and then Nam_In
(Nam
, Name_Assert
,
24719 Name_Assert_And_Cut
,
24721 Name_Loop_Invariant
,
24722 Name_Loop_Variant
))
24724 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24725 when Name_On | Name_Check
=>
24727 when Name_Off | Name_Ignore
=>
24728 return Name_Ignore
;
24729 when Name_Disable
=>
24730 return Name_Disable
;
24732 raise Program_Error
;
24736 PP
:= Next_Pragma
(PP
);
24741 -- If there are no specific entries that matched, then we let the
24742 -- setting of assertions govern. Note that this provides the needed
24743 -- compatibility with the RM for the cases of assertion, invariant,
24744 -- precondition, predicate, and postcondition.
24746 if Assertions_Enabled
then
24749 return Name_Ignore
;
24753 ---------------------------
24754 -- Check_Missing_Part_Of --
24755 ---------------------------
24757 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24758 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24759 -- Determine whether a package denoted by Pack_Id declares at least one
24762 -----------------------
24763 -- Has_Visible_State --
24764 -----------------------
24766 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24767 Item_Id
: Entity_Id
;
24770 -- Traverse the entity chain of the package trying to find at least
24771 -- one visible abstract state, variable or a package [instantiation]
24772 -- that declares a visible state.
24774 Item_Id
:= First_Entity
(Pack_Id
);
24775 while Present
(Item_Id
)
24776 and then not In_Private_Part
(Item_Id
)
24778 -- Do not consider internally generated items
24780 if not Comes_From_Source
(Item_Id
) then
24783 -- A visible state has been found
24785 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24788 -- Recursively peek into nested packages and instantiations
24790 elsif Ekind
(Item_Id
) = E_Package
24791 and then Has_Visible_State
(Item_Id
)
24796 Next_Entity
(Item_Id
);
24800 end Has_Visible_State
;
24804 Pack_Id
: Entity_Id
;
24805 Placement
: State_Space_Kind
;
24807 -- Start of processing for Check_Missing_Part_Of
24810 -- Do not consider internally generated entities as these can never
24811 -- have a Part_Of indicator.
24813 if not Comes_From_Source
(Item_Id
) then
24816 -- Perform these checks only when SPARK_Mode is enabled as they will
24817 -- interfere with standard Ada rules and produce false positives.
24819 elsif SPARK_Mode
/= On
then
24823 -- Find where the abstract state, variable or package instantiation
24824 -- lives with respect to the state space.
24826 Find_Placement_In_State_Space
24827 (Item_Id
=> Item_Id
,
24828 Placement
=> Placement
,
24829 Pack_Id
=> Pack_Id
);
24831 -- Items that appear in a non-package construct (subprogram, block, etc)
24832 -- do not require a Part_Of indicator because they can never act as a
24835 if Placement
= Not_In_Package
then
24838 -- An item declared in the body state space of a package always act as a
24839 -- constituent and does not need explicit Part_Of indicator.
24841 elsif Placement
= Body_State_Space
then
24844 -- In general an item declared in the visible state space of a package
24845 -- does not require a Part_Of indicator. The only exception is when the
24846 -- related package is a private child unit in which case Part_Of must
24847 -- denote a state in the parent unit or in one of its descendants.
24849 elsif Placement
= Visible_State_Space
then
24850 if Is_Child_Unit
(Pack_Id
)
24851 and then Is_Private_Descendant
(Pack_Id
)
24853 -- A package instantiation does not need a Part_Of indicator when
24854 -- the related generic template has no visible state.
24856 if Ekind
(Item_Id
) = E_Package
24857 and then Is_Generic_Instance
(Item_Id
)
24858 and then not Has_Visible_State
(Item_Id
)
24862 -- All other cases require Part_Of
24866 ("indicator Part_Of is required in this context "
24867 & "(SPARK RM 7.2.6(3))", Item_Id
);
24868 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24870 ("\& is declared in the visible part of private child "
24871 & "unit %", Item_Id
);
24875 -- When the item appears in the private state space of a packge, it must
24876 -- be a part of some state declared by the said package.
24878 else pragma Assert
(Placement
= Private_State_Space
);
24880 -- The related package does not declare a state, the item cannot act
24881 -- as a Part_Of constituent.
24883 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24886 -- A package instantiation does not need a Part_Of indicator when the
24887 -- related generic template has no visible state.
24889 elsif Ekind
(Pack_Id
) = E_Package
24890 and then Is_Generic_Instance
(Pack_Id
)
24891 and then not Has_Visible_State
(Pack_Id
)
24895 -- All other cases require Part_Of
24899 ("indicator Part_Of is required in this context "
24900 & "(SPARK RM 7.2.6(2))", Item_Id
);
24901 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24903 ("\& is declared in the private part of package %", Item_Id
);
24906 end Check_Missing_Part_Of
;
24908 ---------------------------------
24909 -- Check_SPARK_Aspect_For_ASIS --
24910 ---------------------------------
24912 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
24916 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
24917 Expr
:= Expression
(Corresponding_Aspect
(N
));
24918 if Nkind
(Expr
) /= N_Aggregate
then
24919 Preanalyze_And_Resolve
(Expr
);
24923 Comps
: constant List_Id
:= Component_Associations
(Expr
);
24924 Exprs
: constant List_Id
:= Expressions
(Expr
);
24929 E
:= First
(Exprs
);
24930 while Present
(E
) loop
24935 C
:= First
(Comps
);
24936 while Present
(C
) loop
24937 Analyze
(Expression
(C
));
24943 end Check_SPARK_Aspect_For_ASIS
;
24945 -------------------------------------
24946 -- Check_State_And_Constituent_Use --
24947 -------------------------------------
24949 procedure Check_State_And_Constituent_Use
24950 (States
: Elist_Id
;
24951 Constits
: Elist_Id
;
24954 function Find_Encapsulating_State
24955 (Constit_Id
: Entity_Id
) return Entity_Id
;
24956 -- Given the entity of a constituent, try to find a corresponding
24957 -- encapsulating state that appears in the same context. The routine
24958 -- returns Empty is no such state is found.
24960 ------------------------------
24961 -- Find_Encapsulating_State --
24962 ------------------------------
24964 function Find_Encapsulating_State
24965 (Constit_Id
: Entity_Id
) return Entity_Id
24967 State_Id
: Entity_Id
;
24970 -- Since a constituent may be part of a larger constituent set, climb
24971 -- the encapsulated state chain looking for a state that appears in
24972 -- the same context.
24974 State_Id
:= Encapsulating_State
(Constit_Id
);
24975 while Present
(State_Id
) loop
24976 if Contains
(States
, State_Id
) then
24980 State_Id
:= Encapsulating_State
(State_Id
);
24984 end Find_Encapsulating_State
;
24988 Constit_Elmt
: Elmt_Id
;
24989 Constit_Id
: Entity_Id
;
24990 State_Id
: Entity_Id
;
24992 -- Start of processing for Check_State_And_Constituent_Use
24995 -- Nothing to do if there are no states or constituents
24997 if No
(States
) or else No
(Constits
) then
25001 -- Inspect the list of constituents and try to determine whether its
25002 -- encapsulating state is in list States.
25004 Constit_Elmt
:= First_Elmt
(Constits
);
25005 while Present
(Constit_Elmt
) loop
25006 Constit_Id
:= Node
(Constit_Elmt
);
25008 -- Determine whether the constituent is part of an encapsulating
25009 -- state that appears in the same context and if this is the case,
25010 -- emit an error (SPARK RM 7.2.6(7)).
25012 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
25014 if Present
(State_Id
) then
25015 Error_Msg_Name_1
:= Chars
(Constit_Id
);
25017 ("cannot mention state & and its constituent % in the same "
25018 & "context", Context
, State_Id
);
25022 Next_Elmt
(Constit_Elmt
);
25024 end Check_State_And_Constituent_Use
;
25026 --------------------------
25027 -- Collect_Global_Items --
25028 --------------------------
25030 procedure Collect_Global_Items
25032 In_Items
: in out Elist_Id
;
25033 In_Out_Items
: in out Elist_Id
;
25034 Out_Items
: in out Elist_Id
;
25035 Proof_In_Items
: in out Elist_Id
;
25036 Has_In_State
: out Boolean;
25037 Has_In_Out_State
: out Boolean;
25038 Has_Out_State
: out Boolean;
25039 Has_Proof_In_State
: out Boolean;
25040 Has_Null_State
: out Boolean)
25042 procedure Process_Global_List
25044 Mode
: Name_Id
:= Name_Input
);
25045 -- Collect all items housed in a global list. Formal Mode denotes the
25046 -- current mode in effect.
25048 -------------------------
25049 -- Process_Global_List --
25050 -------------------------
25052 procedure Process_Global_List
25054 Mode
: Name_Id
:= Name_Input
)
25056 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25057 -- Add a single item to the appropriate list. Formal Mode denotes the
25058 -- current mode in effect.
25060 -------------------------
25061 -- Process_Global_Item --
25062 -------------------------
25064 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25065 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
25066 -- The above handles abstract views of variables and states built
25067 -- for limited with clauses.
25070 -- Signal that the global list contains at least one abstract
25071 -- state with a visible refinement. Note that the refinement may
25072 -- be null in which case there are no constituents.
25074 if Ekind
(Item_Id
) = E_Abstract_State
then
25075 if Has_Null_Refinement
(Item_Id
) then
25076 Has_Null_State
:= True;
25078 elsif Has_Non_Null_Refinement
(Item_Id
) then
25079 if Mode
= Name_Input
then
25080 Has_In_State
:= True;
25081 elsif Mode
= Name_In_Out
then
25082 Has_In_Out_State
:= True;
25083 elsif Mode
= Name_Output
then
25084 Has_Out_State
:= True;
25085 elsif Mode
= Name_Proof_In
then
25086 Has_Proof_In_State
:= True;
25091 -- Add the item to the proper list
25093 if Mode
= Name_Input
then
25094 Add_Item
(Item_Id
, In_Items
);
25095 elsif Mode
= Name_In_Out
then
25096 Add_Item
(Item_Id
, In_Out_Items
);
25097 elsif Mode
= Name_Output
then
25098 Add_Item
(Item_Id
, Out_Items
);
25099 elsif Mode
= Name_Proof_In
then
25100 Add_Item
(Item_Id
, Proof_In_Items
);
25102 end Process_Global_Item
;
25108 -- Start of processing for Process_Global_List
25111 if Nkind
(List
) = N_Null
then
25114 -- Single global item declaration
25116 elsif Nkind_In
(List
, N_Expanded_Name
,
25118 N_Selected_Component
)
25120 Process_Global_Item
(List
, Mode
);
25122 -- Single global list or moded global list declaration
25124 elsif Nkind
(List
) = N_Aggregate
then
25126 -- The declaration of a simple global list appear as a collection
25129 if Present
(Expressions
(List
)) then
25130 Item
:= First
(Expressions
(List
));
25131 while Present
(Item
) loop
25132 Process_Global_Item
(Item
, Mode
);
25137 -- The declaration of a moded global list appears as a collection
25138 -- of component associations where individual choices denote mode.
25140 elsif Present
(Component_Associations
(List
)) then
25141 Item
:= First
(Component_Associations
(List
));
25142 while Present
(Item
) loop
25143 Process_Global_List
25144 (List
=> Expression
(Item
),
25145 Mode
=> Chars
(First
(Choices
(Item
))));
25153 raise Program_Error
;
25159 raise Program_Error
;
25161 end Process_Global_List
;
25165 Items
: constant Node_Id
:=
25166 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
)));
25168 -- Start of processing for Collect_Global_Items
25171 -- Assume that no states have been encountered
25173 Has_In_State
:= False;
25174 Has_In_Out_State
:= False;
25175 Has_Out_State
:= False;
25176 Has_Proof_In_State
:= False;
25177 Has_Null_State
:= False;
25179 Process_Global_List
(Items
);
25180 end Collect_Global_Items
;
25182 ---------------------------------------
25183 -- Collect_Subprogram_Inputs_Outputs --
25184 ---------------------------------------
25186 procedure Collect_Subprogram_Inputs_Outputs
25187 (Subp_Id
: Entity_Id
;
25188 Subp_Inputs
: in out Elist_Id
;
25189 Subp_Outputs
: in out Elist_Id
;
25190 Global_Seen
: out Boolean)
25192 procedure Collect_Global_List
25194 Mode
: Name_Id
:= Name_Input
);
25195 -- Collect all relevant items from a global list
25197 -------------------------
25198 -- Collect_Global_List --
25199 -------------------------
25201 procedure Collect_Global_List
25203 Mode
: Name_Id
:= Name_Input
)
25205 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25206 -- Add an item to the proper subprogram input or output collection
25208 -------------------------
25209 -- Collect_Global_Item --
25210 -------------------------
25212 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25214 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
25215 Add_Item
(Item
, Subp_Inputs
);
25218 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
25219 Add_Item
(Item
, Subp_Outputs
);
25221 end Collect_Global_Item
;
25228 -- Start of processing for Collect_Global_List
25231 if Nkind
(List
) = N_Null
then
25234 -- Single global item declaration
25236 elsif Nkind_In
(List
, N_Expanded_Name
,
25238 N_Selected_Component
)
25240 Collect_Global_Item
(List
, Mode
);
25242 -- Simple global list or moded global list declaration
25244 elsif Nkind
(List
) = N_Aggregate
then
25245 if Present
(Expressions
(List
)) then
25246 Item
:= First
(Expressions
(List
));
25247 while Present
(Item
) loop
25248 Collect_Global_Item
(Item
, Mode
);
25253 Assoc
:= First
(Component_Associations
(List
));
25254 while Present
(Assoc
) loop
25255 Collect_Global_List
25256 (List
=> Expression
(Assoc
),
25257 Mode
=> Chars
(First
(Choices
(Assoc
))));
25265 raise Program_Error
;
25267 end Collect_Global_List
;
25271 Formal
: Entity_Id
;
25274 Spec_Id
: Entity_Id
;
25276 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25279 Global_Seen
:= False;
25281 -- Find the entity of the corresponding spec when processing a body
25283 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25284 Spec_Id
:= Corresponding_Spec
(Parent
(Parent
(Subp_Id
)));
25286 Spec_Id
:= Subp_Id
;
25289 -- Process all formal parameters
25291 Formal
:= First_Formal
(Spec_Id
);
25292 while Present
(Formal
) loop
25293 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
25294 Add_Item
(Formal
, Subp_Inputs
);
25297 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
25298 Add_Item
(Formal
, Subp_Outputs
);
25300 -- Out parameters can act as inputs when the related type is
25301 -- tagged, unconstrained array, unconstrained record or record
25302 -- with unconstrained components.
25304 if Ekind
(Formal
) = E_Out_Parameter
25305 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25307 Add_Item
(Formal
, Subp_Inputs
);
25311 Next_Formal
(Formal
);
25314 -- When processing a subprogram body, look for pragma Refined_Global as
25315 -- it provides finer granularity of inputs and outputs.
25317 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25318 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25320 -- Subprogram declaration case, look for pragma Global
25323 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25326 if Present
(Global
) then
25327 Global_Seen
:= True;
25328 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
25330 -- The pragma may not have been analyzed because of the arbitrary
25331 -- declaration order of aspects. Make sure that it is analyzed for
25332 -- the purposes of item extraction.
25334 if not Analyzed
(List
) then
25335 if Pragma_Name
(Global
) = Name_Refined_Global
then
25336 Analyze_Refined_Global_In_Decl_Part
(Global
);
25338 Analyze_Global_In_Decl_Part
(Global
);
25342 -- Nothing to be done for a null global list
25344 if Nkind
(List
) /= N_Null
then
25345 Collect_Global_List
(List
);
25348 end Collect_Subprogram_Inputs_Outputs
;
25350 ---------------------------------
25351 -- Delay_Config_Pragma_Analyze --
25352 ---------------------------------
25354 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25356 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25357 Name_Priority_Specific_Dispatching
);
25358 end Delay_Config_Pragma_Analyze
;
25360 -------------------------------------
25361 -- Find_Related_Subprogram_Or_Body --
25362 -------------------------------------
25364 function Find_Related_Subprogram_Or_Body
25366 Do_Checks
: Boolean := False) return Node_Id
25368 Context
: constant Node_Id
:= Parent
(Prag
);
25369 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25372 Look_For_Body
: constant Boolean :=
25373 Nam_In
(Nam
, Name_Refined_Depends
,
25374 Name_Refined_Global
,
25375 Name_Refined_Post
);
25376 -- Refinement pragmas must be associated with a subprogram body [stub]
25379 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
25381 -- If the pragma is a byproduct of aspect expansion, return the related
25382 -- context of the original aspect.
25384 if Present
(Corresponding_Aspect
(Prag
)) then
25385 return Parent
(Corresponding_Aspect
(Prag
));
25388 -- Otherwise the pragma is a source construct, most likely part of a
25389 -- declarative list. Skip preceding declarations while looking for a
25390 -- proper subprogram declaration.
25392 pragma Assert
(Is_List_Member
(Prag
));
25394 Stmt
:= Prev
(Prag
);
25395 while Present
(Stmt
) loop
25397 -- Skip prior pragmas, but check for duplicates
25399 if Nkind
(Stmt
) = N_Pragma
then
25400 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
25401 Error_Msg_Name_1
:= Nam
;
25402 Error_Msg_Sloc
:= Sloc
(Stmt
);
25403 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25406 -- Emit an error when a refinement pragma appears on an expression
25407 -- function without a completion.
25410 and then Look_For_Body
25411 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25412 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25413 and then not Has_Completion
(Defining_Entity
(Stmt
))
25415 Error_Msg_Name_1
:= Nam
;
25417 ("pragma % cannot apply to a stand alone expression function",
25422 -- The refinement pragma applies to a subprogram body stub
25424 elsif Look_For_Body
25425 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25429 -- Skip internally generated code
25431 elsif not Comes_From_Source
(Stmt
) then
25434 -- Return the current construct which is either a subprogram body,
25435 -- a subprogram declaration or is illegal.
25444 -- If we fall through, then the pragma was either the first declaration
25445 -- or it was preceded by other pragmas and no source constructs.
25447 -- The pragma is associated with a library-level subprogram
25449 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25450 return Unit
(Parent
(Context
));
25452 -- The pragma appears inside the declarative part of a subprogram body
25454 elsif Nkind
(Context
) = N_Subprogram_Body
then
25457 -- No candidate subprogram [body] found
25462 end Find_Related_Subprogram_Or_Body
;
25464 -------------------------
25465 -- Get_Base_Subprogram --
25466 -------------------------
25468 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25469 Result
: Entity_Id
;
25472 -- Follow subprogram renaming chain
25476 if Is_Subprogram
(Result
)
25478 Nkind
(Parent
(Declaration_Node
(Result
))) =
25479 N_Subprogram_Renaming_Declaration
25480 and then Present
(Alias
(Result
))
25482 Result
:= Alias
(Result
);
25486 end Get_Base_Subprogram
;
25488 -----------------------
25489 -- Get_SPARK_Mode_Type --
25490 -----------------------
25492 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25494 if N
= Name_On
then
25496 elsif N
= Name_Off
then
25499 -- Any other argument is erroneous
25502 raise Program_Error
;
25504 end Get_SPARK_Mode_Type
;
25506 --------------------------------
25507 -- Get_SPARK_Mode_From_Pragma --
25508 --------------------------------
25510 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25515 pragma Assert
(Nkind
(N
) = N_Pragma
);
25516 Args
:= Pragma_Argument_Associations
(N
);
25518 -- Extract the mode from the argument list
25520 if Present
(Args
) then
25521 Mode
:= First
(Pragma_Argument_Associations
(N
));
25522 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25524 -- If SPARK_Mode pragma has no argument, default is ON
25529 end Get_SPARK_Mode_From_Pragma
;
25531 ---------------------------
25532 -- Has_Extra_Parentheses --
25533 ---------------------------
25535 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25539 -- The aggregate should not have an expression list because a clause
25540 -- is always interpreted as a component association. The only way an
25541 -- expression list can sneak in is by adding extra parentheses around
25542 -- the individual clauses:
25544 -- Depends (Output => Input) -- proper form
25545 -- Depends ((Output => Input)) -- extra parentheses
25547 -- Since the extra parentheses are not allowed by the syntax of the
25548 -- pragma, flag them now to avoid emitting misleading errors down the
25551 if Nkind
(Clause
) = N_Aggregate
25552 and then Present
(Expressions
(Clause
))
25554 Expr
:= First
(Expressions
(Clause
));
25555 while Present
(Expr
) loop
25557 -- A dependency clause surrounded by extra parentheses appears
25558 -- as an aggregate of component associations with an optional
25559 -- Paren_Count set.
25561 if Nkind
(Expr
) = N_Aggregate
25562 and then Present
(Component_Associations
(Expr
))
25565 ("dependency clause contains extra parentheses", Expr
);
25567 -- Otherwise the expression is a malformed construct
25570 Error_Msg_N
("malformed dependency clause", Expr
);
25580 end Has_Extra_Parentheses
;
25586 procedure Initialize
is
25591 -----------------------------
25592 -- Is_Config_Static_String --
25593 -----------------------------
25595 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25597 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25598 -- This is an internal recursive function that is just like the outer
25599 -- function except that it adds the string to the name buffer rather
25600 -- than placing the string in the name buffer.
25602 ------------------------------
25603 -- Add_Config_Static_String --
25604 ------------------------------
25606 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25613 if Nkind
(N
) = N_Op_Concat
then
25614 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25615 N
:= Right_Opnd
(N
);
25621 if Nkind
(N
) /= N_String_Literal
then
25622 Error_Msg_N
("string literal expected for pragma argument", N
);
25626 for J
in 1 .. String_Length
(Strval
(N
)) loop
25627 C
:= Get_String_Char
(Strval
(N
), J
);
25629 if not In_Character_Range
(C
) then
25631 ("string literal contains invalid wide character",
25632 Sloc
(N
) + 1 + Source_Ptr
(J
));
25636 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25641 end Add_Config_Static_String
;
25643 -- Start of processing for Is_Config_Static_String
25648 return Add_Config_Static_String
(Arg
);
25649 end Is_Config_Static_String
;
25651 -------------------------------
25652 -- Is_Elaboration_SPARK_Mode --
25653 -------------------------------
25655 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
25658 (Nkind
(N
) = N_Pragma
25659 and then Pragma_Name
(N
) = Name_SPARK_Mode
25660 and then Is_List_Member
(N
));
25662 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25663 -- appears in the statement part of the body.
25666 Present
(Parent
(N
))
25667 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
25668 and then List_Containing
(N
) = Statements
(Parent
(N
))
25669 and then Present
(Parent
(Parent
(N
)))
25670 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
25671 end Is_Elaboration_SPARK_Mode
;
25673 -----------------------------------------
25674 -- Is_Non_Significant_Pragma_Reference --
25675 -----------------------------------------
25677 -- This function makes use of the following static table which indicates
25678 -- whether appearance of some name in a given pragma is to be considered
25679 -- as a reference for the purposes of warnings about unreferenced objects.
25681 -- -1 indicates that references in any argument position are significant
25682 -- 0 indicates that appearance in any argument is not significant
25683 -- +n indicates that appearance as argument n is significant, but all
25684 -- other arguments are not significant
25685 -- 99 special processing required (e.g. for pragma Check)
25687 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
25688 (Pragma_AST_Entry
=> -1,
25689 Pragma_Abort_Defer
=> -1,
25690 Pragma_Abstract_State
=> -1,
25691 Pragma_Ada_83
=> -1,
25692 Pragma_Ada_95
=> -1,
25693 Pragma_Ada_05
=> -1,
25694 Pragma_Ada_2005
=> -1,
25695 Pragma_Ada_12
=> -1,
25696 Pragma_Ada_2012
=> -1,
25697 Pragma_All_Calls_Remote
=> -1,
25698 Pragma_Allow_Integer_Address
=> 0,
25699 Pragma_Annotate
=> -1,
25700 Pragma_Assert
=> -1,
25701 Pragma_Assert_And_Cut
=> -1,
25702 Pragma_Assertion_Policy
=> 0,
25703 Pragma_Assume
=> -1,
25704 Pragma_Assume_No_Invalid_Values
=> 0,
25705 Pragma_Async_Readers
=> 0,
25706 Pragma_Async_Writers
=> 0,
25707 Pragma_Asynchronous
=> -1,
25708 Pragma_Atomic
=> 0,
25709 Pragma_Atomic_Components
=> 0,
25710 Pragma_Attach_Handler
=> -1,
25711 Pragma_Attribute_Definition
=> +3,
25712 Pragma_Check
=> 99,
25713 Pragma_Check_Float_Overflow
=> 0,
25714 Pragma_Check_Name
=> 0,
25715 Pragma_Check_Policy
=> 0,
25716 Pragma_CIL_Constructor
=> -1,
25717 Pragma_CPP_Class
=> 0,
25718 Pragma_CPP_Constructor
=> 0,
25719 Pragma_CPP_Virtual
=> 0,
25720 Pragma_CPP_Vtable
=> 0,
25722 Pragma_C_Pass_By_Copy
=> 0,
25723 Pragma_Comment
=> 0,
25724 Pragma_Common_Object
=> -1,
25725 Pragma_Compile_Time_Error
=> -1,
25726 Pragma_Compile_Time_Warning
=> -1,
25727 Pragma_Compiler_Unit
=> 0,
25728 Pragma_Compiler_Unit_Warning
=> 0,
25729 Pragma_Complete_Representation
=> 0,
25730 Pragma_Complex_Representation
=> 0,
25731 Pragma_Component_Alignment
=> -1,
25732 Pragma_Contract_Cases
=> -1,
25733 Pragma_Controlled
=> 0,
25734 Pragma_Convention
=> 0,
25735 Pragma_Convention_Identifier
=> 0,
25736 Pragma_Debug
=> -1,
25737 Pragma_Debug_Policy
=> 0,
25738 Pragma_Detect_Blocking
=> -1,
25739 Pragma_Default_Storage_Pool
=> -1,
25740 Pragma_Depends
=> -1,
25741 Pragma_Disable_Atomic_Synchronization
=> -1,
25742 Pragma_Discard_Names
=> 0,
25743 Pragma_Dispatching_Domain
=> -1,
25744 Pragma_Effective_Reads
=> 0,
25745 Pragma_Effective_Writes
=> 0,
25746 Pragma_Elaborate
=> -1,
25747 Pragma_Elaborate_All
=> -1,
25748 Pragma_Elaborate_Body
=> -1,
25749 Pragma_Elaboration_Checks
=> -1,
25750 Pragma_Eliminate
=> -1,
25751 Pragma_Enable_Atomic_Synchronization
=> -1,
25752 Pragma_Export
=> -1,
25753 Pragma_Export_Exception
=> -1,
25754 Pragma_Export_Function
=> -1,
25755 Pragma_Export_Object
=> -1,
25756 Pragma_Export_Procedure
=> -1,
25757 Pragma_Export_Value
=> -1,
25758 Pragma_Export_Valued_Procedure
=> -1,
25759 Pragma_Extend_System
=> -1,
25760 Pragma_Extensions_Allowed
=> -1,
25761 Pragma_External
=> -1,
25762 Pragma_Favor_Top_Level
=> -1,
25763 Pragma_External_Name_Casing
=> -1,
25764 Pragma_Fast_Math
=> -1,
25765 Pragma_Finalize_Storage_Only
=> 0,
25766 Pragma_Float_Representation
=> 0,
25767 Pragma_Global
=> -1,
25768 Pragma_Ident
=> -1,
25769 Pragma_Implementation_Defined
=> -1,
25770 Pragma_Implemented
=> -1,
25771 Pragma_Implicit_Packing
=> 0,
25772 Pragma_Import
=> +2,
25773 Pragma_Import_Exception
=> 0,
25774 Pragma_Import_Function
=> 0,
25775 Pragma_Import_Object
=> 0,
25776 Pragma_Import_Procedure
=> 0,
25777 Pragma_Import_Valued_Procedure
=> 0,
25778 Pragma_Independent
=> 0,
25779 Pragma_Independent_Components
=> 0,
25780 Pragma_Initial_Condition
=> -1,
25781 Pragma_Initialize_Scalars
=> -1,
25782 Pragma_Initializes
=> -1,
25783 Pragma_Inline
=> 0,
25784 Pragma_Inline_Always
=> 0,
25785 Pragma_Inline_Generic
=> 0,
25786 Pragma_Inspection_Point
=> -1,
25787 Pragma_Interface
=> +2,
25788 Pragma_Interface_Name
=> +2,
25789 Pragma_Interrupt_Handler
=> -1,
25790 Pragma_Interrupt_Priority
=> -1,
25791 Pragma_Interrupt_State
=> -1,
25792 Pragma_Invariant
=> -1,
25793 Pragma_Java_Constructor
=> -1,
25794 Pragma_Java_Interface
=> -1,
25795 Pragma_Keep_Names
=> 0,
25796 Pragma_License
=> -1,
25797 Pragma_Link_With
=> -1,
25798 Pragma_Linker_Alias
=> -1,
25799 Pragma_Linker_Constructor
=> -1,
25800 Pragma_Linker_Destructor
=> -1,
25801 Pragma_Linker_Options
=> -1,
25802 Pragma_Linker_Section
=> -1,
25804 Pragma_Lock_Free
=> -1,
25805 Pragma_Locking_Policy
=> -1,
25806 Pragma_Long_Float
=> -1,
25807 Pragma_Loop_Invariant
=> -1,
25808 Pragma_Loop_Optimize
=> -1,
25809 Pragma_Loop_Variant
=> -1,
25810 Pragma_Machine_Attribute
=> -1,
25812 Pragma_Main_Storage
=> -1,
25813 Pragma_Memory_Size
=> -1,
25814 Pragma_No_Return
=> 0,
25815 Pragma_No_Body
=> 0,
25816 Pragma_No_Inline
=> 0,
25817 Pragma_No_Run_Time
=> -1,
25818 Pragma_No_Strict_Aliasing
=> -1,
25819 Pragma_Normalize_Scalars
=> -1,
25820 Pragma_Obsolescent
=> 0,
25821 Pragma_Optimize
=> -1,
25822 Pragma_Optimize_Alignment
=> -1,
25823 Pragma_Overflow_Mode
=> 0,
25824 Pragma_Overriding_Renamings
=> 0,
25825 Pragma_Ordered
=> 0,
25828 Pragma_Part_Of
=> -1,
25829 Pragma_Partition_Elaboration_Policy
=> -1,
25830 Pragma_Passive
=> -1,
25831 Pragma_Persistent_BSS
=> 0,
25832 Pragma_Polling
=> -1,
25834 Pragma_Postcondition
=> -1,
25835 Pragma_Post_Class
=> -1,
25837 Pragma_Precondition
=> -1,
25838 Pragma_Predicate
=> -1,
25839 Pragma_Preelaborable_Initialization
=> -1,
25840 Pragma_Preelaborate
=> -1,
25841 Pragma_Preelaborate_05
=> -1,
25842 Pragma_Pre_Class
=> -1,
25843 Pragma_Priority
=> -1,
25844 Pragma_Priority_Specific_Dispatching
=> -1,
25845 Pragma_Profile
=> 0,
25846 Pragma_Profile_Warnings
=> 0,
25847 Pragma_Propagate_Exceptions
=> -1,
25848 Pragma_Provide_Shift_Operators
=> -1,
25849 Pragma_Psect_Object
=> -1,
25851 Pragma_Pure_05
=> -1,
25852 Pragma_Pure_12
=> -1,
25853 Pragma_Pure_Function
=> -1,
25854 Pragma_Queuing_Policy
=> -1,
25855 Pragma_Rational
=> -1,
25856 Pragma_Ravenscar
=> -1,
25857 Pragma_Refined_Depends
=> -1,
25858 Pragma_Refined_Global
=> -1,
25859 Pragma_Refined_Post
=> -1,
25860 Pragma_Refined_State
=> -1,
25861 Pragma_Relative_Deadline
=> -1,
25862 Pragma_Remote_Access_Type
=> -1,
25863 Pragma_Remote_Call_Interface
=> -1,
25864 Pragma_Remote_Types
=> -1,
25865 Pragma_Restricted_Run_Time
=> -1,
25866 Pragma_Restriction_Warnings
=> -1,
25867 Pragma_Restrictions
=> -1,
25868 Pragma_Reviewable
=> -1,
25869 Pragma_Short_Circuit_And_Or
=> -1,
25870 Pragma_Share_Generic
=> -1,
25871 Pragma_Shared
=> -1,
25872 Pragma_Shared_Passive
=> -1,
25873 Pragma_Short_Descriptors
=> 0,
25874 Pragma_Simple_Storage_Pool_Type
=> 0,
25875 Pragma_Source_File_Name
=> -1,
25876 Pragma_Source_File_Name_Project
=> -1,
25877 Pragma_Source_Reference
=> -1,
25878 Pragma_SPARK_Mode
=> 0,
25879 Pragma_Storage_Size
=> -1,
25880 Pragma_Storage_Unit
=> -1,
25881 Pragma_Static_Elaboration_Desired
=> -1,
25882 Pragma_Stream_Convert
=> -1,
25883 Pragma_Style_Checks
=> -1,
25884 Pragma_Subtitle
=> -1,
25885 Pragma_Suppress
=> 0,
25886 Pragma_Suppress_Exception_Locations
=> 0,
25887 Pragma_Suppress_All
=> -1,
25888 Pragma_Suppress_Debug_Info
=> 0,
25889 Pragma_Suppress_Initialization
=> 0,
25890 Pragma_System_Name
=> -1,
25891 Pragma_Task_Dispatching_Policy
=> -1,
25892 Pragma_Task_Info
=> -1,
25893 Pragma_Task_Name
=> -1,
25894 Pragma_Task_Storage
=> 0,
25895 Pragma_Test_Case
=> -1,
25896 Pragma_Thread_Local_Storage
=> 0,
25897 Pragma_Time_Slice
=> -1,
25898 Pragma_Title
=> -1,
25899 Pragma_Type_Invariant
=> -1,
25900 Pragma_Type_Invariant_Class
=> -1,
25901 Pragma_Unchecked_Union
=> 0,
25902 Pragma_Unimplemented_Unit
=> -1,
25903 Pragma_Universal_Aliasing
=> -1,
25904 Pragma_Universal_Data
=> -1,
25905 Pragma_Unmodified
=> -1,
25906 Pragma_Unreferenced
=> -1,
25907 Pragma_Unreferenced_Objects
=> -1,
25908 Pragma_Unreserve_All_Interrupts
=> -1,
25909 Pragma_Unsuppress
=> 0,
25910 Pragma_Use_VADS_Size
=> -1,
25911 Pragma_Validity_Checks
=> -1,
25912 Pragma_Volatile
=> 0,
25913 Pragma_Volatile_Components
=> 0,
25914 Pragma_Warning_As_Error
=> -1,
25915 Pragma_Warnings
=> -1,
25916 Pragma_Weak_External
=> -1,
25917 Pragma_Wide_Character_Encoding
=> 0,
25918 Unknown_Pragma
=> 0);
25920 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25929 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25933 Id
:= Get_Pragma_Id
(Parent
(P
));
25934 C
:= Sig_Flags
(Id
);
25946 -- For pragma Check, the first argument is not significant,
25947 -- the second and the third (if present) arguments are
25950 when Pragma_Check
=>
25952 P
= First
(Pragma_Argument_Associations
(Parent
(P
)));
25955 raise Program_Error
;
25959 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25960 for J
in 1 .. C
- 1 loop
25968 return A
= P
; -- is this wrong way round ???
25971 end Is_Non_Significant_Pragma_Reference
;
25973 ------------------------------
25974 -- Is_Pragma_String_Literal --
25975 ------------------------------
25977 -- This function returns true if the corresponding pragma argument is a
25978 -- static string expression. These are the only cases in which string
25979 -- literals can appear as pragma arguments. We also allow a string literal
25980 -- as the first argument to pragma Assert (although it will of course
25981 -- always generate a type error).
25983 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
25984 Pragn
: constant Node_Id
:= Parent
(Par
);
25985 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
25986 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
25992 N
:= First
(Assoc
);
25999 if Pname
= Name_Assert
then
26002 elsif Pname
= Name_Export
then
26005 elsif Pname
= Name_Ident
then
26008 elsif Pname
= Name_Import
then
26011 elsif Pname
= Name_Interface_Name
then
26014 elsif Pname
= Name_Linker_Alias
then
26017 elsif Pname
= Name_Linker_Section
then
26020 elsif Pname
= Name_Machine_Attribute
then
26023 elsif Pname
= Name_Source_File_Name
then
26026 elsif Pname
= Name_Source_Reference
then
26029 elsif Pname
= Name_Title
then
26032 elsif Pname
= Name_Subtitle
then
26038 end Is_Pragma_String_Literal
;
26040 ---------------------------
26041 -- Is_Private_SPARK_Mode --
26042 ---------------------------
26044 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
26047 (Nkind
(N
) = N_Pragma
26048 and then Pragma_Name
(N
) = Name_SPARK_Mode
26049 and then Is_List_Member
(N
));
26051 -- For pragma SPARK_Mode to be private, it has to appear in the private
26052 -- declarations of a package.
26055 Present
(Parent
(N
))
26056 and then Nkind
(Parent
(N
)) = N_Package_Specification
26057 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
26058 end Is_Private_SPARK_Mode
;
26060 -------------------------------------
26061 -- Is_Unconstrained_Or_Tagged_Item --
26062 -------------------------------------
26064 function Is_Unconstrained_Or_Tagged_Item
26065 (Item
: Entity_Id
) return Boolean
26067 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
26068 -- Determine whether record type Typ has at least one unconstrained
26071 ---------------------------------
26072 -- Has_Unconstrained_Component --
26073 ---------------------------------
26075 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
26079 Comp
:= First_Component
(Typ
);
26080 while Present
(Comp
) loop
26081 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
26085 Next_Component
(Comp
);
26089 end Has_Unconstrained_Component
;
26093 Typ
: constant Entity_Id
:= Etype
(Item
);
26095 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26098 if Is_Tagged_Type
(Typ
) then
26101 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
26104 elsif Is_Record_Type
(Typ
) then
26105 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
26108 return Has_Unconstrained_Component
(Typ
);
26114 end Is_Unconstrained_Or_Tagged_Item
;
26116 -----------------------------
26117 -- Is_Valid_Assertion_Kind --
26118 -----------------------------
26120 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
26127 Name_Static_Predicate |
26128 Name_Dynamic_Predicate |
26133 Name_Type_Invariant |
26134 Name_uType_Invariant |
26138 Name_Assert_And_Cut |
26140 Name_Contract_Cases |
26142 Name_Initial_Condition |
26145 Name_Loop_Invariant |
26146 Name_Loop_Variant |
26147 Name_Postcondition |
26148 Name_Precondition |
26150 Name_Refined_Post |
26151 Name_Statement_Assertions
=> return True;
26153 when others => return False;
26155 end Is_Valid_Assertion_Kind
;
26157 -----------------------------------------
26158 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
26159 -----------------------------------------
26161 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
26162 Aspects
: constant List_Id
:= New_List
;
26163 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
26164 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
26166 Original_Aspects
: List_Id
;
26167 -- To capture global references, a copy of the created aspects must be
26168 -- inserted in the original tree.
26171 Prag_Arg_Ass
: Node_Id
;
26172 Prag_Id
: Pragma_Id
;
26175 -- Check for any PPC pragmas that appear within Decl
26177 Prag
:= Next
(Decl
);
26178 while Nkind
(Prag
) = N_Pragma
loop
26179 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
26182 when Pragma_Postcondition | Pragma_Precondition
=>
26183 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
26185 -- Make an aspect from any PPC pragma
26187 Append_To
(Aspects
,
26188 Make_Aspect_Specification
(Loc
,
26190 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
26192 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
26194 -- Generate the analysis information in the pragma expression
26195 -- and then set the pragma node analyzed to avoid any further
26198 Analyze
(Expression
(Prag_Arg_Ass
));
26199 Set_Analyzed
(Prag
, True);
26201 when others => null;
26207 -- Set all new aspects into the generic declaration node
26209 if Is_Non_Empty_List
(Aspects
) then
26211 -- Create the list of aspects to be inserted in the original tree
26213 Original_Aspects
:= Copy_Separate_List
(Aspects
);
26215 -- Check if Decl already has aspects
26217 -- Attach the new lists of aspects to both the generic copy and the
26220 if Has_Aspects
(Decl
) then
26221 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
26222 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
26225 Set_Parent
(Aspects
, Decl
);
26226 Set_Aspect_Specifications
(Decl
, Aspects
);
26227 Set_Parent
(Original_Aspects
, Or_Decl
);
26228 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
26231 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
26233 -------------------------
26234 -- Preanalyze_CTC_Args --
26235 -------------------------
26237 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
26239 -- Preanalyze the boolean expressions, we treat these as spec
26240 -- expressions (i.e. similar to a default expression).
26242 if Present
(Arg_Req
) then
26243 Preanalyze_Assert_Expression
26244 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
26246 -- In ASIS mode, for a pragma generated from a source aspect, also
26247 -- analyze the original aspect expression.
26249 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26250 Preanalyze_Assert_Expression
26251 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
26255 if Present
(Arg_Ens
) then
26256 Preanalyze_Assert_Expression
26257 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
26259 -- In ASIS mode, for a pragma generated from a source aspect, also
26260 -- analyze the original aspect expression.
26262 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26263 Preanalyze_Assert_Expression
26264 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
26267 end Preanalyze_CTC_Args
;
26269 --------------------------------------
26270 -- Process_Compilation_Unit_Pragmas --
26271 --------------------------------------
26273 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26275 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26276 -- strange because it comes at the end of the unit. Rational has the
26277 -- same name for a pragma, but treats it as a program unit pragma, In
26278 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26279 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26280 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26281 -- the context clause to ensure the correct processing.
26283 if Has_Pragma_Suppress_All
(N
) then
26284 Prepend_To
(Context_Items
(N
),
26285 Make_Pragma
(Sloc
(N
),
26286 Chars
=> Name_Suppress
,
26287 Pragma_Argument_Associations
=> New_List
(
26288 Make_Pragma_Argument_Association
(Sloc
(N
),
26289 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26292 -- Nothing else to do at the current time
26294 end Process_Compilation_Unit_Pragmas
;
26296 ------------------------------------
26297 -- Record_Possible_Body_Reference --
26298 ------------------------------------
26300 procedure Record_Possible_Body_Reference
26301 (State_Id
: Entity_Id
;
26305 Spec_Id
: Entity_Id
;
26308 -- Ensure that we are dealing with a reference to a state
26310 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26312 -- Climb the tree starting from the reference looking for a package body
26313 -- whose spec declares the referenced state. This criteria automatically
26314 -- excludes references in package specs which are legal. Note that it is
26315 -- not wise to emit an error now as the package body may lack pragma
26316 -- Refined_State or the referenced state may not be mentioned in the
26317 -- refinement. This approach avoids the generation of misleading errors.
26320 while Present
(Context
) loop
26321 if Nkind
(Context
) = N_Package_Body
then
26322 Spec_Id
:= Corresponding_Spec
(Context
);
26324 if Present
(Abstract_States
(Spec_Id
))
26325 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26327 if No
(Body_References
(State_Id
)) then
26328 Set_Body_References
(State_Id
, New_Elmt_List
);
26331 Append_Elmt
(Ref
, Body_References
(State_Id
));
26336 Context
:= Parent
(Context
);
26338 end Record_Possible_Body_Reference
;
26340 ------------------------------
26341 -- Relocate_Pragmas_To_Body --
26342 ------------------------------
26344 procedure Relocate_Pragmas_To_Body
26345 (Subp_Body
: Node_Id
;
26346 Target_Body
: Node_Id
:= Empty
)
26348 procedure Relocate_Pragma
(Prag
: Node_Id
);
26349 -- Remove a single pragma from its current list and add it to the
26350 -- declarations of the proper body (either Subp_Body or Target_Body).
26352 ---------------------
26353 -- Relocate_Pragma --
26354 ---------------------
26356 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26361 -- When subprogram stubs or expression functions are involves, the
26362 -- destination declaration list belongs to the proper body.
26364 if Present
(Target_Body
) then
26365 Target
:= Target_Body
;
26367 Target
:= Subp_Body
;
26370 Decls
:= Declarations
(Target
);
26374 Set_Declarations
(Target
, Decls
);
26377 -- Unhook the pragma from its current list
26380 Prepend
(Prag
, Decls
);
26381 end Relocate_Pragma
;
26385 Body_Id
: constant Entity_Id
:=
26386 Defining_Unit_Name
(Specification
(Subp_Body
));
26387 Next_Stmt
: Node_Id
;
26390 -- Start of processing for Relocate_Pragmas_To_Body
26393 -- Do not process a body that comes from a separate unit as no construct
26394 -- can possibly follow it.
26396 if not Is_List_Member
(Subp_Body
) then
26399 -- Do not relocate pragmas that follow a stub if the stub does not have
26402 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26403 and then No
(Target_Body
)
26407 -- Do not process internally generated routine _Postconditions
26409 elsif Ekind
(Body_Id
) = E_Procedure
26410 and then Chars
(Body_Id
) = Name_uPostconditions
26415 -- Look at what is following the body. We are interested in certain kind
26416 -- of pragmas (either from source or byproducts of expansion) that can
26417 -- apply to a body [stub].
26419 Stmt
:= Next
(Subp_Body
);
26420 while Present
(Stmt
) loop
26422 -- Preserve the following statement for iteration purposes due to a
26423 -- possible relocation of a pragma.
26425 Next_Stmt
:= Next
(Stmt
);
26427 -- Move a candidate pragma following the body to the declarations of
26430 if Nkind
(Stmt
) = N_Pragma
26431 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26433 Relocate_Pragma
(Stmt
);
26435 -- Skip internally generated code
26437 elsif not Comes_From_Source
(Stmt
) then
26440 -- No candidate pragmas are available for relocation
26448 end Relocate_Pragmas_To_Body
;
26450 -------------------
26451 -- Resolve_State --
26452 -------------------
26454 procedure Resolve_State
(N
: Node_Id
) is
26459 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26460 Func
:= Entity
(N
);
26462 -- Handle overloading of state names by functions. Traverse the
26463 -- homonym chain looking for an abstract state.
26465 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26466 State
:= Homonym
(Func
);
26467 while Present
(State
) loop
26469 -- Resolve the overloading by setting the proper entity of the
26470 -- reference to that of the state.
26472 if Ekind
(State
) = E_Abstract_State
then
26473 Set_Etype
(N
, Standard_Void_Type
);
26474 Set_Entity
(N
, State
);
26475 Set_Associated_Node
(N
, State
);
26479 State
:= Homonym
(State
);
26482 -- A function can never act as a state. If the homonym chain does
26483 -- not contain a corresponding state, then something went wrong in
26484 -- the overloading mechanism.
26486 raise Program_Error
;
26491 ----------------------------
26492 -- Rewrite_Assertion_Kind --
26493 ----------------------------
26495 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26499 if Nkind
(N
) = N_Attribute_Reference
26500 and then Attribute_Name
(N
) = Name_Class
26501 and then Nkind
(Prefix
(N
)) = N_Identifier
26503 case Chars
(Prefix
(N
)) is
26508 when Name_Type_Invariant
=>
26509 Nam
:= Name_uType_Invariant
;
26510 when Name_Invariant
=>
26511 Nam
:= Name_uInvariant
;
26516 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26518 end Rewrite_Assertion_Kind
;
26529 --------------------------------
26530 -- Set_Encoded_Interface_Name --
26531 --------------------------------
26533 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26534 Str
: constant String_Id
:= Strval
(S
);
26535 Len
: constant Int
:= String_Length
(Str
);
26540 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26543 -- Stores encoded value of character code CC. The encoding we use an
26544 -- underscore followed by four lower case hex digits.
26550 procedure Encode
is
26552 Store_String_Char
(Get_Char_Code
('_'));
26554 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26556 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26558 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26560 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26563 -- Start of processing for Set_Encoded_Interface_Name
26566 -- If first character is asterisk, this is a link name, and we leave it
26567 -- completely unmodified. We also ignore null strings (the latter case
26568 -- happens only in error cases) and no encoding should occur for Java or
26569 -- AAMP interface names.
26572 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26573 or else VM_Target
/= No_VM
26574 or else AAMP_On_Target
26576 Set_Interface_Name
(E
, S
);
26581 CC
:= Get_String_Char
(Str
, J
);
26583 exit when not In_Character_Range
(CC
);
26585 C
:= Get_Character
(CC
);
26587 exit when C
/= '_' and then C
/= '$'
26588 and then C
not in '0' .. '9'
26589 and then C
not in 'a' .. 'z'
26590 and then C
not in 'A' .. 'Z';
26593 Set_Interface_Name
(E
, S
);
26601 -- Here we need to encode. The encoding we use as follows:
26602 -- three underscores + four hex digits (lower case)
26606 for J
in 1 .. String_Length
(Str
) loop
26607 CC
:= Get_String_Char
(Str
, J
);
26609 if not In_Character_Range
(CC
) then
26612 C
:= Get_Character
(CC
);
26614 if C
= '_' or else C
= '$'
26615 or else C
in '0' .. '9'
26616 or else C
in 'a' .. 'z'
26617 or else C
in 'A' .. 'Z'
26619 Store_String_Char
(CC
);
26626 Set_Interface_Name
(E
,
26627 Make_String_Literal
(Sloc
(S
),
26628 Strval
=> End_String
));
26630 end Set_Encoded_Interface_Name
;
26632 -------------------
26633 -- Set_Unit_Name --
26634 -------------------
26636 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26641 if Nkind
(N
) = N_Identifier
26642 and then Nkind
(With_Item
) = N_Identifier
26644 Set_Entity
(N
, Entity
(With_Item
));
26646 elsif Nkind
(N
) = N_Selected_Component
then
26647 Change_Selected_Component_To_Expanded_Name
(N
);
26648 Set_Entity
(N
, Entity
(With_Item
));
26649 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26651 Pref
:= Prefix
(N
);
26652 Scop
:= Scope
(Entity
(N
));
26653 while Nkind
(Pref
) = N_Selected_Component
loop
26654 Change_Selected_Component_To_Expanded_Name
(Pref
);
26655 Set_Entity
(Selector_Name
(Pref
), Scop
);
26656 Set_Entity
(Pref
, Scop
);
26657 Pref
:= Prefix
(Pref
);
26658 Scop
:= Scope
(Scop
);
26661 Set_Entity
(Pref
, Scop
);