1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Csets
; use Csets
;
37 with Debug
; use Debug
;
38 with Einfo
; use Einfo
;
39 with Elists
; use Elists
;
40 with Errout
; use Errout
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
45 with Lib
.Writ
; use Lib
.Writ
;
46 with Lib
.Xref
; use Lib
.Xref
;
47 with Namet
.Sp
; use Namet
.Sp
;
48 with Nlists
; use Nlists
;
49 with Nmake
; use Nmake
;
50 with Output
; use Output
;
51 with Par_SCO
; use Par_SCO
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch6
; use Sem_Ch6
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Ch12
; use Sem_Ch12
;
61 with Sem_Ch13
; use Sem_Ch13
;
62 with Sem_Disp
; use Sem_Disp
;
63 with Sem_Dist
; use Sem_Dist
;
64 with Sem_Elim
; use Sem_Elim
;
65 with Sem_Eval
; use Sem_Eval
;
66 with Sem_Intr
; use Sem_Intr
;
67 with Sem_Mech
; use Sem_Mech
;
68 with Sem_Res
; use Sem_Res
;
69 with Sem_Type
; use Sem_Type
;
70 with Sem_Util
; use Sem_Util
;
71 with Sem_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 function Check_Kind
(Nam
: Name_Id
) return Name_Id
;
188 -- This function is used in connection with pragmas Assert, Check,
189 -- and assertion aspects and pragmas, to determine if Check pragmas
190 -- (or corresponding assertion aspects or pragmas) are currently active
191 -- as determined by the presence of -gnata on the command line (which
192 -- sets the default), and the appearance of pragmas Check_Policy and
193 -- Assertion_Policy as configuration pragmas either in a configuration
194 -- pragma file, or at the start of the current unit, or locally given
195 -- Check_Policy and Assertion_Policy pragmas that are currently active.
197 -- The value returned is one of the names Check, Ignore, Disable (On
198 -- returns Check, and Off returns Ignore).
200 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
201 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
202 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
203 -- _Post, _Invariant, or _Type_Invariant, which are special names used
204 -- in identifiers to represent these attribute references.
206 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
);
207 -- In ASIS mode we need to analyze the original expression in the aspect
208 -- specification. For Initializes, Global, and related SPARK aspects, the
209 -- expression has a sui-generis syntax which may be a list, an expression,
212 procedure Check_State_And_Constituent_Use
216 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
217 -- Global and Initializes. Determine whether a state from list States and a
218 -- corresponding constituent from list Constits (if any) appear in the same
219 -- context denoted by Context. If this is the case, emit an error.
221 procedure Collect_Global_Items
223 In_Items
: in out Elist_Id
;
224 In_Out_Items
: in out Elist_Id
;
225 Out_Items
: in out Elist_Id
;
226 Proof_In_Items
: in out Elist_Id
;
227 Has_In_State
: out Boolean;
228 Has_In_Out_State
: out Boolean;
229 Has_Out_State
: out Boolean;
230 Has_Proof_In_State
: out Boolean;
231 Has_Null_State
: out Boolean);
232 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
233 -- Prag denotes pragma [Refined_]Global. Gather all input, in out, output
234 -- and Proof_In items of Prag in lists In_Items, In_Out_Items, Out_Items
235 -- and Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
236 -- and Has_Proof_In_State are set when there is at least one abstract state
237 -- with visible refinement available in the corresponding mode. Flag
238 -- Has_Null_State is set when at least state has a null refinement.
240 procedure Collect_Subprogram_Inputs_Outputs
241 (Subp_Id
: Entity_Id
;
242 Subp_Inputs
: in out Elist_Id
;
243 Subp_Outputs
: in out Elist_Id
;
244 Global_Seen
: out Boolean);
245 -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends
246 -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id
247 -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram
248 -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen
249 -- is set when the related subprogram has pragma [Refined_]Global.
251 function Find_Related_Subprogram_Or_Body
253 Do_Checks
: Boolean := False) return Node_Id
;
254 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
255 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
256 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
257 -- Do_Checks is set, the routine reports duplicate pragmas and detects
258 -- improper use of refinement pragmas in stand alone expression functions.
259 -- The returned value depends on the related pragma as follows:
260 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
261 -- N_Subprogram_Declaration node or if the pragma applies to a stand
262 -- alone body, the N_Subprogram_Body node or Empty if illegal.
263 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
264 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
267 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
268 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
269 -- original one, following the renaming chain) is returned. Otherwise the
270 -- entity is returned unchanged. Should be in Einfo???
272 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
273 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
274 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
277 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
278 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
279 -- Determine whether dependency clause Clause is surrounded by extra
280 -- parentheses. If this is the case, issue an error message.
282 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
283 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
284 -- pragma Depends. Determine whether the type of dependency item Item is
285 -- tagged, unconstrained array, unconstrained record or a record with at
286 -- least one unconstrained component.
288 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
);
289 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
290 -- of a Test_Case pragma if present (possibly Empty). We treat these as
291 -- spec expressions (i.e. similar to a default expression).
293 procedure Record_Possible_Body_Reference
294 (State_Id
: Entity_Id
;
296 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
297 -- Global. Given an abstract state denoted by State_Id and a reference Ref
298 -- to it, determine whether the reference appears in a package body that
299 -- will eventually refine the state. If this is the case, record the
300 -- reference for future checks (see Analyze_Refined_State_In_Decls).
302 procedure Resolve_State
(N
: Node_Id
);
303 -- Handle the overloading of state names by functions. When N denotes a
304 -- function, this routine finds the corresponding state and sets the entity
305 -- of N to that of the state.
307 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
308 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
309 -- then it is rewritten as an identifier with the corresponding special
310 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
311 -- Check, Check_Policy.
313 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
314 -- Place semantic information on the argument of an Elaborate/Elaborate_All
315 -- pragma. Entity name for unit and its parents is taken from item in
316 -- previous with_clause that mentions the unit.
319 -- This is a dummy function called by the processing for pragma Reviewable.
320 -- It is there for assisting front end debugging. By placing a Reviewable
321 -- pragma in the source program, a breakpoint on rv catches this place in
322 -- the source, allowing convenient stepping to the point of interest.
328 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
331 To_List
:= New_Elmt_List
;
334 Append_Elmt
(Item
, To_List
);
337 -------------------------------
338 -- Adjust_External_Name_Case --
339 -------------------------------
341 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
345 -- Adjust case of literal if required
347 if Opt
.External_Name_Exp_Casing
= As_Is
then
351 -- Copy existing string
357 for J
in 1 .. String_Length
(Strval
(N
)) loop
358 CC
:= Get_String_Char
(Strval
(N
), J
);
360 if Opt
.External_Name_Exp_Casing
= Uppercase
361 and then CC
>= Get_Char_Code
('a')
362 and then CC
<= Get_Char_Code
('z')
364 Store_String_Char
(CC
- 32);
366 elsif Opt
.External_Name_Exp_Casing
= Lowercase
367 and then CC
>= Get_Char_Code
('A')
368 and then CC
<= Get_Char_Code
('Z')
370 Store_String_Char
(CC
+ 32);
373 Store_String_Char
(CC
);
378 Make_String_Literal
(Sloc
(N
),
379 Strval
=> End_String
);
381 end Adjust_External_Name_Case
;
383 -----------------------------------------
384 -- Analyze_Contract_Cases_In_Decl_Part --
385 -----------------------------------------
387 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
388 Others_Seen
: Boolean := False;
390 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
391 -- Verify the legality of a single contract case
393 ---------------------------
394 -- Analyze_Contract_Case --
395 ---------------------------
397 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
398 Case_Guard
: Node_Id
;
400 Extra_Guard
: Node_Id
;
403 if Nkind
(CCase
) = N_Component_Association
then
404 Case_Guard
:= First
(Choices
(CCase
));
405 Conseq
:= Expression
(CCase
);
407 -- Each contract case must have exactly one case guard
409 Extra_Guard
:= Next
(Case_Guard
);
411 if Present
(Extra_Guard
) then
413 ("contract case must have exactly one case guard",
417 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
419 if Nkind
(Case_Guard
) = N_Others_Choice
then
422 ("only one others choice allowed in contract cases",
428 elsif Others_Seen
then
430 ("others must be the last choice in contract cases", N
);
433 -- Preanalyze the case guard and consequence
435 if Nkind
(Case_Guard
) /= N_Others_Choice
then
436 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
439 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
441 -- The contract case is malformed
444 Error_Msg_N
("wrong syntax in contract case", CCase
);
446 end Analyze_Contract_Case
;
455 Restore_Scope
: Boolean := False;
456 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
458 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
463 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
464 Subp_Id
:= Defining_Entity
(Subp_Decl
);
465 All_Cases
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
467 -- Single and multiple contract cases must appear in aggregate form. If
468 -- this is not the case, then either the parser of the analysis of the
469 -- pragma failed to produce an aggregate.
471 pragma Assert
(Nkind
(All_Cases
) = N_Aggregate
);
473 if No
(Component_Associations
(All_Cases
)) then
474 Error_Msg_N
("wrong syntax for constract cases", N
);
476 -- Individual contract cases appear as component associations
479 -- Ensure that the formal parameters are visible when analyzing all
480 -- clauses. This falls out of the general rule of aspects pertaining
481 -- to subprogram declarations. Skip the installation for subprogram
482 -- bodies because the formals are already visible.
484 if not In_Open_Scopes
(Subp_Id
) then
485 Restore_Scope
:= True;
486 Push_Scope
(Subp_Id
);
487 Install_Formals
(Subp_Id
);
490 CCase
:= First
(Component_Associations
(All_Cases
));
491 while Present
(CCase
) loop
492 Analyze_Contract_Case
(CCase
);
496 if Restore_Scope
then
500 end Analyze_Contract_Cases_In_Decl_Part
;
502 ----------------------------------
503 -- Analyze_Depends_In_Decl_Part --
504 ----------------------------------
506 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
507 Loc
: constant Source_Ptr
:= Sloc
(N
);
509 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
510 -- A list containing the entities of all the inputs processed so far.
511 -- The list is populated with unique entities because the same input
512 -- may appear in multiple input lists.
514 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
515 -- A list containing the entities of all the outputs processed so far.
516 -- The list is populated with unique entities because output items are
517 -- unique in a dependence relation.
519 Constits_Seen
: Elist_Id
:= No_Elist
;
520 -- A list containing the entities of all constituents processed so far.
521 -- It aids in detecting illegal usage of a state and a corresponding
522 -- constituent in pragma [Refinde_]Depends.
524 Global_Seen
: Boolean := False;
525 -- A flag set when pragma Global has been processed
527 Null_Output_Seen
: Boolean := False;
528 -- A flag used to track the legality of a null output
530 Result_Seen
: Boolean := False;
531 -- A flag set when Subp_Id'Result is processed
534 -- The entity of the subprogram subject to pragma [Refined_]Depends
536 States_Seen
: Elist_Id
:= No_Elist
;
537 -- A list containing the entities of all states processed so far. It
538 -- helps in detecting illegal usage of a state and a corresponding
539 -- constituent in pragma [Refined_]Depends.
542 -- The entity of the subprogram [body or stub] subject to pragma
543 -- [Refined_]Depends.
545 Subp_Inputs
: Elist_Id
:= No_Elist
;
546 Subp_Outputs
: Elist_Id
:= No_Elist
;
547 -- Two lists containing the full set of inputs and output of the related
548 -- subprograms. Note that these lists contain both nodes and entities.
550 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
551 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
552 -- to the name buffer. The individual kinds are as follows:
553 -- E_Abstract_State - "state"
554 -- E_In_Parameter - "parameter"
555 -- E_In_Out_Parameter - "parameter"
556 -- E_Out_Parameter - "parameter"
557 -- E_Variable - "global"
559 procedure Analyze_Dependency_Clause
562 -- Verify the legality of a single dependency clause. Flag Is_Last
563 -- denotes whether Clause is the last clause in the relation.
565 procedure Check_Function_Return
;
566 -- Verify that Funtion'Result appears as one of the outputs
567 -- (SPARK RM 6.1.5(10)).
574 -- Ensure that an item fulfils its designated input and/or output role
575 -- as specified by pragma Global (if any) or the enclosing context. If
576 -- this is not the case, emit an error. Item and Item_Id denote the
577 -- attributes of an item. Flag Is_Input should be set when item comes
578 -- from an input list. Flag Self_Ref should be set when the item is an
579 -- output and the dependency clause has operator "+".
581 procedure Check_Usage
582 (Subp_Items
: Elist_Id
;
583 Used_Items
: Elist_Id
;
585 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
586 -- error if this is not the case.
588 procedure Normalize_Clause
(Clause
: Node_Id
);
589 -- Remove a self-dependency "+" from the input list of a clause. Split
590 -- a clause with multiple outputs into multiple clauses with a single
593 -----------------------------
594 -- Add_Item_To_Name_Buffer --
595 -----------------------------
597 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
599 if Ekind
(Item_Id
) = E_Abstract_State
then
600 Add_Str_To_Name_Buffer
("state");
602 elsif Is_Formal
(Item_Id
) then
603 Add_Str_To_Name_Buffer
("parameter");
605 elsif Ekind
(Item_Id
) = E_Variable
then
606 Add_Str_To_Name_Buffer
("global");
608 -- The routine should not be called with non-SPARK items
613 end Add_Item_To_Name_Buffer
;
615 -------------------------------
616 -- Analyze_Dependency_Clause --
617 -------------------------------
619 procedure Analyze_Dependency_Clause
623 procedure Analyze_Input_List
(Inputs
: Node_Id
);
624 -- Verify the legality of a single input list
626 procedure Analyze_Input_Output
631 Seen
: in out Elist_Id
;
632 Null_Seen
: in out Boolean;
633 Non_Null_Seen
: in out Boolean);
634 -- Verify the legality of a single input or output item. Flag
635 -- Is_Input should be set whenever Item is an input, False when it
636 -- denotes an output. Flag Self_Ref should be set when the item is an
637 -- output and the dependency clause has a "+". Flag Top_Level should
638 -- be set whenever Item appears immediately within an input or output
639 -- list. Seen is a collection of all abstract states, variables and
640 -- formals processed so far. Flag Null_Seen denotes whether a null
641 -- input or output has been encountered. Flag Non_Null_Seen denotes
642 -- whether a non-null input or output has been encountered.
644 ------------------------
645 -- Analyze_Input_List --
646 ------------------------
648 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
649 Inputs_Seen
: Elist_Id
:= No_Elist
;
650 -- A list containing the entities of all inputs that appear in the
651 -- current input list.
653 Non_Null_Input_Seen
: Boolean := False;
654 Null_Input_Seen
: Boolean := False;
655 -- Flags used to check the legality of an input list
660 -- Multiple inputs appear as an aggregate
662 if Nkind
(Inputs
) = N_Aggregate
then
663 if Present
(Component_Associations
(Inputs
)) then
665 ("nested dependency relations not allowed", Inputs
);
667 elsif Present
(Expressions
(Inputs
)) then
668 Input
:= First
(Expressions
(Inputs
));
669 while Present
(Input
) loop
676 Null_Seen
=> Null_Input_Seen
,
677 Non_Null_Seen
=> Non_Null_Input_Seen
);
682 -- Syntax error, always report
685 Error_Msg_N
("malformed input dependency list", Inputs
);
688 -- Process a solitary input
697 Null_Seen
=> Null_Input_Seen
,
698 Non_Null_Seen
=> Non_Null_Input_Seen
);
701 -- Detect an illegal dependency clause of the form
705 if Null_Output_Seen
and then Null_Input_Seen
then
707 ("null dependency clause cannot have a null input list",
710 end Analyze_Input_List
;
712 --------------------------
713 -- Analyze_Input_Output --
714 --------------------------
716 procedure Analyze_Input_Output
721 Seen
: in out Elist_Id
;
722 Null_Seen
: in out Boolean;
723 Non_Null_Seen
: in out Boolean)
725 Is_Output
: constant Boolean := not Is_Input
;
730 -- Multiple input or output items appear as an aggregate
732 if Nkind
(Item
) = N_Aggregate
then
733 if not Top_Level
then
734 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
736 elsif Present
(Component_Associations
(Item
)) then
738 ("nested dependency relations not allowed", Item
);
740 -- Recursively analyze the grouped items
742 elsif Present
(Expressions
(Item
)) then
743 Grouped
:= First
(Expressions
(Item
));
744 while Present
(Grouped
) loop
747 Is_Input
=> Is_Input
,
748 Self_Ref
=> Self_Ref
,
751 Null_Seen
=> Null_Seen
,
752 Non_Null_Seen
=> Non_Null_Seen
);
757 -- Syntax error, always report
760 Error_Msg_N
("malformed dependency list", Item
);
763 -- Process Function'Result in the context of a dependency clause
765 elsif Is_Attribute_Result
(Item
) then
766 Non_Null_Seen
:= True;
768 -- It is sufficent to analyze the prefix of 'Result in order to
769 -- establish legality of the attribute.
771 Analyze
(Prefix
(Item
));
773 -- The prefix of 'Result must denote the function for which
774 -- pragma Depends applies (SPARK RM 6.1.5(11)).
776 if not Is_Entity_Name
(Prefix
(Item
))
777 or else Ekind
(Spec_Id
) /= E_Function
778 or else Entity
(Prefix
(Item
)) /= Spec_Id
780 Error_Msg_Name_1
:= Name_Result
;
782 ("prefix of attribute % must denote the enclosing "
785 -- Function'Result is allowed to appear on the output side of a
786 -- dependency clause (SPARK RM 6.1.5(6)).
789 SPARK_Msg_N
("function result cannot act as input", Item
);
793 ("cannot mix null and non-null dependency items", Item
);
799 -- Detect multiple uses of null in a single dependency list or
800 -- throughout the whole relation. Verify the placement of a null
801 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
803 elsif Nkind
(Item
) = N_Null
then
806 ("multiple null dependency relations not allowed", Item
);
808 elsif Non_Null_Seen
then
810 ("cannot mix null and non-null dependency items", Item
);
818 ("null output list must be the last clause in a "
819 & "dependency relation", Item
);
821 -- Catch a useless dependence of the form:
826 ("useless dependence, null depends on itself", Item
);
834 Non_Null_Seen
:= True;
837 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
841 Resolve_State
(Item
);
843 -- Find the entity of the item. If this is a renaming, climb
844 -- the renaming chain to reach the root object. Renamings of
845 -- non-entire objects do not yield an entity (Empty).
847 Item_Id
:= Entity_Of
(Item
);
849 if Present
(Item_Id
) then
850 if Ekind_In
(Item_Id
, E_Abstract_State
,
856 -- Ensure that the item fulfils its role as input and/or
857 -- output as specified by pragma Global or the enclosing
860 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
862 -- Detect multiple uses of the same state, variable or
863 -- formal parameter. If this is not the case, add the
864 -- item to the list of processed relations.
866 if Contains
(Seen
, Item_Id
) then
868 ("duplicate use of item &", Item
, Item_Id
);
870 Add_Item
(Item_Id
, Seen
);
873 -- Detect illegal use of an input related to a null
874 -- output. Such input items cannot appear in other
875 -- input lists (SPARK RM 6.1.5(13)).
878 and then Null_Output_Seen
879 and then Contains
(All_Inputs_Seen
, Item_Id
)
882 ("input of a null output list cannot appear in "
883 & "multiple input lists", Item
);
886 -- Add an input or a self-referential output to the list
887 -- of all processed inputs.
889 if Is_Input
or else Self_Ref
then
890 Add_Item
(Item_Id
, All_Inputs_Seen
);
893 -- State related checks (SPARK RM 6.1.5(3))
895 if Ekind
(Item_Id
) = E_Abstract_State
then
896 if Has_Visible_Refinement
(Item_Id
) then
898 ("cannot mention state & in global refinement",
901 ("\use its constituents instead", Item
);
904 -- If the reference to the abstract state appears in
905 -- an enclosing package body that will eventually
906 -- refine the state, record the reference for future
910 Record_Possible_Body_Reference
911 (State_Id
=> Item_Id
,
916 -- When the item renames an entire object, replace the
917 -- item with a reference to the object.
919 if Present
(Renamed_Object
(Entity
(Item
))) then
921 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
925 -- Add the entity of the current item to the list of
928 if Ekind
(Item_Id
) = E_Abstract_State
then
929 Add_Item
(Item_Id
, States_Seen
);
932 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
933 and then Present
(Encapsulating_State
(Item_Id
))
935 Add_Item
(Item_Id
, Constits_Seen
);
938 -- All other input/output items are illegal
939 -- (SPARK RM 6.1.5(1)).
943 ("item must denote parameter, variable, or state",
947 -- All other input/output items are illegal
948 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
952 ("item must denote parameter, variable, or state", Item
);
955 end Analyze_Input_Output
;
963 Non_Null_Output_Seen
: Boolean := False;
964 -- Flag used to check the legality of an output list
966 -- Start of processing for Analyze_Dependency_Clause
969 Inputs
:= Expression
(Clause
);
972 -- An input list with a self-dependency appears as operator "+" where
973 -- the actuals inputs are the right operand.
975 if Nkind
(Inputs
) = N_Op_Plus
then
976 Inputs
:= Right_Opnd
(Inputs
);
980 -- Process the output_list of a dependency_clause
982 Output
:= First
(Choices
(Clause
));
983 while Present
(Output
) loop
987 Self_Ref
=> Self_Ref
,
989 Seen
=> All_Outputs_Seen
,
990 Null_Seen
=> Null_Output_Seen
,
991 Non_Null_Seen
=> Non_Null_Output_Seen
);
996 -- Process the input_list of a dependency_clause
998 Analyze_Input_List
(Inputs
);
999 end Analyze_Dependency_Clause
;
1001 ---------------------------
1002 -- Check_Function_Return --
1003 ---------------------------
1005 procedure Check_Function_Return
is
1007 if Ekind
(Spec_Id
) = E_Function
and then not Result_Seen
then
1009 ("result of & must appear in exactly one output list",
1012 end Check_Function_Return
;
1018 procedure Check_Role
1020 Item_Id
: Entity_Id
;
1025 (Item_Is_Input
: out Boolean;
1026 Item_Is_Output
: out Boolean);
1027 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1028 -- Item_Is_Output are set depending on the role.
1030 procedure Role_Error
1031 (Item_Is_Input
: Boolean;
1032 Item_Is_Output
: Boolean);
1033 -- Emit an error message concerning the incorrect use of Item in
1034 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1035 -- denote whether the item is an input and/or an output.
1042 (Item_Is_Input
: out Boolean;
1043 Item_Is_Output
: out Boolean)
1046 Item_Is_Input
:= False;
1047 Item_Is_Output
:= False;
1049 -- Abstract state cases
1051 if Ekind
(Item_Id
) = E_Abstract_State
then
1053 -- When pragma Global is present, the mode of the state may be
1054 -- further constrained by setting a more restrictive mode.
1057 if Appears_In
(Subp_Inputs
, Item_Id
) then
1058 Item_Is_Input
:= True;
1061 if Appears_In
(Subp_Outputs
, Item_Id
) then
1062 Item_Is_Output
:= True;
1065 -- Otherwise the state has a default IN OUT mode
1068 Item_Is_Input
:= True;
1069 Item_Is_Output
:= True;
1074 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1075 Item_Is_Input
:= True;
1077 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1078 Item_Is_Input
:= True;
1079 Item_Is_Output
:= True;
1081 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1082 if Scope
(Item_Id
) = Spec_Id
then
1084 -- An OUT parameter of the related subprogram has mode IN
1085 -- if its type is unconstrained or tagged because array
1086 -- bounds, discriminants or tags can be read.
1088 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1089 Item_Is_Input
:= True;
1092 Item_Is_Output
:= True;
1094 -- An OUT parameter of an enclosing subprogram behaves as a
1095 -- read-write variable in which case the mode is IN OUT.
1098 Item_Is_Input
:= True;
1099 Item_Is_Output
:= True;
1104 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1106 -- When pragma Global is present, the mode of the variable may
1107 -- be further constrained by setting a more restrictive mode.
1111 -- A variable has mode IN when its type is unconstrained or
1112 -- tagged because array bounds, discriminants or tags can be
1115 if Appears_In
(Subp_Inputs
, Item_Id
)
1116 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1118 Item_Is_Input
:= True;
1121 if Appears_In
(Subp_Outputs
, Item_Id
) then
1122 Item_Is_Output
:= True;
1125 -- Otherwise the variable has a default IN OUT mode
1128 Item_Is_Input
:= True;
1129 Item_Is_Output
:= True;
1138 procedure Role_Error
1139 (Item_Is_Input
: Boolean;
1140 Item_Is_Output
: Boolean)
1142 Error_Msg
: Name_Id
;
1147 -- When the item is not part of the input and the output set of
1148 -- the related subprogram, then it appears as extra in pragma
1149 -- [Refined_]Depends.
1151 if not Item_Is_Input
and then not Item_Is_Output
then
1152 Add_Item_To_Name_Buffer
(Item_Id
);
1153 Add_Str_To_Name_Buffer
1154 (" & cannot appear in dependence relation");
1156 Error_Msg
:= Name_Find
;
1157 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1159 Error_Msg_Name_1
:= Chars
(Subp_Id
);
1161 ("\& is not part of the input or output set of subprogram %",
1164 -- The mode of the item and its role in pragma [Refined_]Depends
1165 -- are in conflict. Construct a detailed message explaining the
1166 -- illegality (SPARK RM 6.1.5(5-6)).
1169 if Item_Is_Input
then
1170 Add_Str_To_Name_Buffer
("read-only");
1172 Add_Str_To_Name_Buffer
("write-only");
1175 Add_Char_To_Name_Buffer
(' ');
1176 Add_Item_To_Name_Buffer
(Item_Id
);
1177 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1179 if Item_Is_Input
then
1180 Add_Str_To_Name_Buffer
("output");
1182 Add_Str_To_Name_Buffer
("input");
1185 Add_Str_To_Name_Buffer
(" in dependence relation");
1186 Error_Msg
:= Name_Find
;
1187 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1193 Item_Is_Input
: Boolean;
1194 Item_Is_Output
: Boolean;
1196 -- Start of processing for Check_Role
1199 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1204 if not Item_Is_Input
then
1205 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1208 -- Self-referential item
1211 if not Item_Is_Input
or else not Item_Is_Output
then
1212 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1217 elsif not Item_Is_Output
then
1218 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1226 procedure Check_Usage
1227 (Subp_Items
: Elist_Id
;
1228 Used_Items
: Elist_Id
;
1231 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
1232 -- Emit an error concerning the illegal usage of an item
1238 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
1239 Error_Msg
: Name_Id
;
1246 -- Unconstrained and tagged items are not part of the explicit
1247 -- input set of the related subprogram, they do not have to be
1248 -- present in a dependence relation and should not be flagged
1249 -- (SPARK RM 6.1.5(8)).
1251 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1254 Add_Item_To_Name_Buffer
(Item_Id
);
1255 Add_Str_To_Name_Buffer
1256 (" & must appear in at least one input dependence list");
1258 Error_Msg
:= Name_Find
;
1259 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1262 -- Output case (SPARK RM 6.1.5(10))
1267 Add_Item_To_Name_Buffer
(Item_Id
);
1268 Add_Str_To_Name_Buffer
1269 (" & must appear in exactly one output dependence list");
1271 Error_Msg
:= Name_Find
;
1272 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1280 Item_Id
: Entity_Id
;
1282 -- Start of processing for Check_Usage
1285 if No
(Subp_Items
) then
1289 -- Each input or output of the subprogram must appear in a dependency
1292 Elmt
:= First_Elmt
(Subp_Items
);
1293 while Present
(Elmt
) loop
1294 Item
:= Node
(Elmt
);
1296 if Nkind
(Item
) = N_Defining_Identifier
then
1299 Item_Id
:= Entity_Of
(Item
);
1302 -- The item does not appear in a dependency
1304 if Present
(Item_Id
)
1305 and then not Contains
(Used_Items
, Item_Id
)
1307 if Is_Formal
(Item_Id
) then
1308 Usage_Error
(Item
, Item_Id
);
1310 -- States and global variables are not used properly only when
1311 -- the subprogram is subject to pragma Global.
1313 elsif Global_Seen
then
1314 Usage_Error
(Item
, Item_Id
);
1322 ----------------------
1323 -- Normalize_Clause --
1324 ----------------------
1326 procedure Normalize_Clause
(Clause
: Node_Id
) is
1327 procedure Create_Or_Modify_Clause
1333 Multiple
: Boolean);
1334 -- Create a brand new clause to represent the self-reference or
1335 -- modify the input and/or output lists of an existing clause. Output
1336 -- denotes a self-referencial output. Outputs is the output list of a
1337 -- clause. Inputs is the input list of a clause. After denotes the
1338 -- clause after which the new clause is to be inserted. Flag In_Place
1339 -- should be set when normalizing the last output of an output list.
1340 -- Flag Multiple should be set when Output comes from a list with
1343 procedure Split_Multiple_Outputs
;
1344 -- If Clause contains more than one output, split the clause into
1345 -- multiple clauses with a single output. All new clauses are added
1348 -----------------------------
1349 -- Create_Or_Modify_Clause --
1350 -----------------------------
1352 procedure Create_Or_Modify_Clause
1360 procedure Propagate_Output
1363 -- Handle the various cases of output propagation to the input
1364 -- list. Output denotes a self-referencial output item. Inputs is
1365 -- the input list of a clause.
1367 ----------------------
1368 -- Propagate_Output --
1369 ----------------------
1371 procedure Propagate_Output
1375 function In_Input_List
1377 Inputs
: List_Id
) return Boolean;
1378 -- Determine whether a particulat item appears in the input
1379 -- list of a clause.
1385 function In_Input_List
1387 Inputs
: List_Id
) return Boolean
1392 Elmt
:= First
(Inputs
);
1393 while Present
(Elmt
) loop
1394 if Entity_Of
(Elmt
) = Item
then
1406 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1409 -- Start of processing for Propagate_Output
1412 -- The clause is of the form:
1414 -- (Output =>+ null)
1416 -- Remove the null input and replace it with a copy of the
1419 -- (Output => Output)
1421 if Nkind
(Inputs
) = N_Null
then
1422 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1424 -- The clause is of the form:
1426 -- (Output =>+ (Input1, ..., InputN))
1428 -- Determine whether the output is not already mentioned in the
1429 -- input list and if not, add it to the list of inputs:
1431 -- (Output => (Output, Input1, ..., InputN))
1433 elsif Nkind
(Inputs
) = N_Aggregate
then
1434 Grouped
:= Expressions
(Inputs
);
1436 if not In_Input_List
1440 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1443 -- The clause is of the form:
1445 -- (Output =>+ Input)
1447 -- If the input does not mention the output, group the two
1450 -- (Output => (Output, Input))
1452 elsif Entity_Of
(Inputs
) /= Output_Id
then
1454 Make_Aggregate
(Loc
,
1455 Expressions
=> New_List
(
1456 New_Copy_Tree
(Output
),
1457 New_Copy_Tree
(Inputs
))));
1459 end Propagate_Output
;
1463 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1464 New_Clause
: Node_Id
;
1466 -- Start of processing for Create_Or_Modify_Clause
1469 -- A null output depending on itself does not require any
1472 if Nkind
(Output
) = N_Null
then
1475 -- A function result cannot depend on itself because it cannot
1476 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1478 elsif Is_Attribute_Result
(Output
) then
1479 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1483 -- When performing the transformation in place, simply add the
1484 -- output to the list of inputs (if not already there). This case
1485 -- arises when dealing with the last output of an output list -
1486 -- we perform the normalization in place to avoid generating a
1490 Propagate_Output
(Output
, Inputs
);
1492 -- A list with multiple outputs is slowly trimmed until only
1493 -- one element remains. When this happens, replace the
1494 -- aggregate with the element itself.
1498 Rewrite
(Outputs
, Output
);
1504 -- Unchain the output from its output list as it will appear in
1505 -- a new clause. Note that we cannot simply rewrite the output
1506 -- as null because this will violate the semantics of pragma
1511 -- Generate a new clause of the form:
1512 -- (Output => Inputs)
1515 Make_Component_Association
(Loc
,
1516 Choices
=> New_List
(Output
),
1517 Expression
=> New_Copy_Tree
(Inputs
));
1519 -- The new clause contains replicated content that has already
1520 -- been analyzed. There is not need to reanalyze it or
1521 -- renormalize it again.
1523 Set_Analyzed
(New_Clause
);
1526 (Output
=> First
(Choices
(New_Clause
)),
1527 Inputs
=> Expression
(New_Clause
));
1529 Insert_After
(After
, New_Clause
);
1531 end Create_Or_Modify_Clause
;
1533 ----------------------------
1534 -- Split_Multiple_Outputs --
1535 ----------------------------
1537 procedure Split_Multiple_Outputs
is
1538 Inputs
: constant Node_Id
:= Expression
(Clause
);
1539 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1540 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1541 Last_Output
: Node_Id
;
1542 Next_Output
: Node_Id
;
1546 -- Start of processing for Split_Multiple_Outputs
1549 -- Multiple outputs appear as an aggregate. Nothing to do when
1550 -- the clause has exactly one output.
1552 if Nkind
(Outputs
) = N_Aggregate
then
1553 Last_Output
:= Last
(Expressions
(Outputs
));
1555 -- Create a clause for each output. Note that each time a new
1556 -- clause is created, the original output list slowly shrinks
1557 -- until there is one item left.
1559 Output
:= First
(Expressions
(Outputs
));
1560 while Present
(Output
) loop
1561 Next_Output
:= Next
(Output
);
1563 -- Unhook the output from the original output list as it
1564 -- will be relocated to a new clause.
1568 -- Special processing for the last output. At this point
1569 -- the original aggregate has been stripped down to one
1570 -- element. Replace the aggregate by the element itself.
1572 if Output
= Last_Output
then
1573 Rewrite
(Outputs
, Output
);
1576 -- Generate a clause of the form:
1577 -- (Output => Inputs)
1580 Make_Component_Association
(Loc
,
1581 Choices
=> New_List
(Output
),
1582 Expression
=> New_Copy_Tree
(Inputs
));
1584 -- The new clause contains replicated content that has
1585 -- already been analyzed. There is not need to reanalyze
1588 Set_Analyzed
(Split
);
1589 Insert_After
(Clause
, Split
);
1592 Output
:= Next_Output
;
1595 end Split_Multiple_Outputs
;
1599 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1601 Last_Output
: Node_Id
;
1602 Next_Output
: Node_Id
;
1605 -- Start of processing for Normalize_Clause
1608 -- A self-dependency appears as operator "+". Remove the "+" from the
1609 -- tree by moving the real inputs to their proper place.
1611 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1612 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1613 Inputs
:= Expression
(Clause
);
1615 -- Multiple outputs appear as an aggregate
1617 if Nkind
(Outputs
) = N_Aggregate
then
1618 Last_Output
:= Last
(Expressions
(Outputs
));
1620 Output
:= First
(Expressions
(Outputs
));
1621 while Present
(Output
) loop
1623 -- Normalization may remove an output from its list,
1624 -- preserve the subsequent output now.
1626 Next_Output
:= Next
(Output
);
1628 Create_Or_Modify_Clause
1633 In_Place
=> Output
= Last_Output
,
1636 Output
:= Next_Output
;
1642 Create_Or_Modify_Clause
1652 -- Split a clause with multiple outputs into multiple clauses with a
1655 Split_Multiple_Outputs
;
1656 end Normalize_Clause
;
1660 Deps
: constant Node_Id
:=
1662 (First
(Pragma_Argument_Associations
(N
)));
1665 Last_Clause
: Node_Id
;
1666 Subp_Decl
: Node_Id
;
1668 Restore_Scope
: Boolean := False;
1669 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1671 -- Start of processing for Analyze_Depends_In_Decl_Part
1676 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
1677 Subp_Id
:= Defining_Entity
(Subp_Decl
);
1679 -- The logic in this routine is used to analyze both pragma Depends and
1680 -- pragma Refined_Depends since they have the same syntax and base
1681 -- semantics. Find the entity of the corresponding spec when analyzing
1684 if Nkind
(Subp_Decl
) = N_Subprogram_Body
1685 and then Present
(Corresponding_Spec
(Subp_Decl
))
1687 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
1689 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
1690 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
1692 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
1698 -- Empty dependency list
1700 if Nkind
(Deps
) = N_Null
then
1702 -- Gather all states, variables and formal parameters that the
1703 -- subprogram may depend on. These items are obtained from the
1704 -- parameter profile or pragma [Refined_]Global (if available).
1706 Collect_Subprogram_Inputs_Outputs
1707 (Subp_Id
=> Subp_Id
,
1708 Subp_Inputs
=> Subp_Inputs
,
1709 Subp_Outputs
=> Subp_Outputs
,
1710 Global_Seen
=> Global_Seen
);
1712 -- Verify that every input or output of the subprogram appear in a
1715 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1716 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1717 Check_Function_Return
;
1719 -- Dependency clauses appear as component associations of an aggregate
1721 elsif Nkind
(Deps
) = N_Aggregate
then
1723 -- Do not attempt to perform analysis of a syntactically illegal
1724 -- clause as this will lead to misleading errors.
1726 if Has_Extra_Parentheses
(Deps
) then
1730 if Present
(Component_Associations
(Deps
)) then
1731 Last_Clause
:= Last
(Component_Associations
(Deps
));
1733 -- Gather all states, variables and formal parameters that the
1734 -- subprogram may depend on. These items are obtained from the
1735 -- parameter profile or pragma [Refined_]Global (if available).
1737 Collect_Subprogram_Inputs_Outputs
1738 (Subp_Id
=> Subp_Id
,
1739 Subp_Inputs
=> Subp_Inputs
,
1740 Subp_Outputs
=> Subp_Outputs
,
1741 Global_Seen
=> Global_Seen
);
1743 -- Ensure that the formal parameters are visible when analyzing
1744 -- all clauses. This falls out of the general rule of aspects
1745 -- pertaining to subprogram declarations. Skip the installation
1746 -- for subprogram bodies because the formals are already visible.
1748 if not In_Open_Scopes
(Spec_Id
) then
1749 Restore_Scope
:= True;
1750 Push_Scope
(Spec_Id
);
1751 Install_Formals
(Spec_Id
);
1754 Clause
:= First
(Component_Associations
(Deps
));
1755 while Present
(Clause
) loop
1756 Errors
:= Serious_Errors_Detected
;
1758 -- Normalization may create extra clauses that contain
1759 -- replicated input and output names. There is no need to
1762 if not Analyzed
(Clause
) then
1763 Set_Analyzed
(Clause
);
1765 Analyze_Dependency_Clause
1767 Is_Last
=> Clause
= Last_Clause
);
1770 -- Do not normalize a clause if errors were detected (count
1771 -- of Serious_Errors has increased) because the inputs and/or
1772 -- outputs may denote illegal items. Normalization is disabled
1773 -- in ASIS mode as it alters the tree by introducing new nodes
1774 -- similar to expansion.
1776 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1777 Normalize_Clause
(Clause
);
1783 if Restore_Scope
then
1787 -- Verify that every input or output of the subprogram appear in a
1790 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1791 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1792 Check_Function_Return
;
1794 -- The dependency list is malformed. This is a syntax error, always
1798 Error_Msg_N
("malformed dependency relation", Deps
);
1802 -- The top level dependency relation is malformed. This is a syntax
1803 -- error, always report.
1806 Error_Msg_N
("malformed dependency relation", Deps
);
1810 -- Ensure that a state and a corresponding constituent do not appear
1811 -- together in pragma [Refined_]Depends.
1813 Check_State_And_Constituent_Use
1814 (States
=> States_Seen
,
1815 Constits
=> Constits_Seen
,
1817 end Analyze_Depends_In_Decl_Part
;
1819 --------------------------------------------
1820 -- Analyze_External_Property_In_Decl_Part --
1821 --------------------------------------------
1823 procedure Analyze_External_Property_In_Decl_Part
1825 Expr_Val
: out Boolean)
1827 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1828 Obj
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
1829 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Next
(Arg1
));
1832 Error_Msg_Name_1
:= Pragma_Name
(N
);
1834 -- The Async / Effective pragmas must apply to a volatile object other
1835 -- than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1837 if Is_SPARK_Volatile_Object
(Obj
) then
1838 if Is_Entity_Name
(Obj
)
1839 and then Present
(Entity
(Obj
))
1840 and then Is_Formal
(Entity
(Obj
))
1842 SPARK_Msg_N
("external property % cannot apply to parameter", N
);
1846 ("external property % must apply to a volatile object", N
);
1849 -- Ensure that the expression (if present) is static Boolean. A missing
1850 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1854 if Present
(Expr
) then
1855 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
1857 if Is_Static_Expression
(Expr
) then
1858 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1860 Error_Msg_Name_1
:= Pragma_Name
(N
);
1861 SPARK_Msg_N
("expression of % must be static", Expr
);
1864 end Analyze_External_Property_In_Decl_Part
;
1866 ---------------------------------
1867 -- Analyze_Global_In_Decl_Part --
1868 ---------------------------------
1870 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1871 Constits_Seen
: Elist_Id
:= No_Elist
;
1872 -- A list containing the entities of all constituents processed so far.
1873 -- It aids in detecting illegal usage of a state and a corresponding
1874 -- constituent in pragma [Refinde_]Global.
1876 Seen
: Elist_Id
:= No_Elist
;
1877 -- A list containing the entities of all the items processed so far. It
1878 -- plays a role in detecting distinct entities.
1880 Spec_Id
: Entity_Id
;
1881 -- The entity of the subprogram subject to pragma [Refined_]Global
1883 States_Seen
: Elist_Id
:= No_Elist
;
1884 -- A list containing the entities of all states processed so far. It
1885 -- helps in detecting illegal usage of a state and a corresponding
1886 -- constituent in pragma [Refined_]Global.
1888 Subp_Id
: Entity_Id
;
1889 -- The entity of the subprogram [body or stub] subject to pragma
1890 -- [Refined_]Global.
1892 In_Out_Seen
: Boolean := False;
1893 Input_Seen
: Boolean := False;
1894 Output_Seen
: Boolean := False;
1895 Proof_Seen
: Boolean := False;
1896 -- Flags used to verify the consistency of modes
1898 procedure Analyze_Global_List
1900 Global_Mode
: Name_Id
:= Name_Input
);
1901 -- Verify the legality of a single global list declaration. Global_Mode
1902 -- denotes the current mode in effect.
1904 -------------------------
1905 -- Analyze_Global_List --
1906 -------------------------
1908 procedure Analyze_Global_List
1910 Global_Mode
: Name_Id
:= Name_Input
)
1912 procedure Analyze_Global_Item
1914 Global_Mode
: Name_Id
);
1915 -- Verify the legality of a single global item declaration.
1916 -- Global_Mode denotes the current mode in effect.
1918 procedure Check_Duplicate_Mode
1920 Status
: in out Boolean);
1921 -- Flag Status denotes whether a particular mode has been seen while
1922 -- processing a global list. This routine verifies that Mode is not a
1923 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1925 procedure Check_Mode_Restriction_In_Enclosing_Context
1927 Item_Id
: Entity_Id
);
1928 -- Verify that an item of mode In_Out or Output does not appear as an
1929 -- input in the Global aspect of an enclosing subprogram. If this is
1930 -- the case, emit an error. Item and Item_Id are respectively the
1931 -- item and its entity.
1933 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1934 -- Mode denotes either In_Out or Output. Depending on the kind of the
1935 -- related subprogram, emit an error if those two modes apply to a
1936 -- function (SPARK RM 6.1.4(10)).
1938 -------------------------
1939 -- Analyze_Global_Item --
1940 -------------------------
1942 procedure Analyze_Global_Item
1944 Global_Mode
: Name_Id
)
1946 Item_Id
: Entity_Id
;
1949 -- Detect one of the following cases
1951 -- with Global => (null, Name)
1952 -- with Global => (Name_1, null, Name_2)
1953 -- with Global => (Name, null)
1955 if Nkind
(Item
) = N_Null
then
1956 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
1961 Resolve_State
(Item
);
1963 -- Find the entity of the item. If this is a renaming, climb the
1964 -- renaming chain to reach the root object. Renamings of non-
1965 -- entire objects do not yield an entity (Empty).
1967 Item_Id
:= Entity_Of
(Item
);
1969 if Present
(Item_Id
) then
1971 -- A global item may denote a formal parameter of an enclosing
1972 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1973 -- provide a better error diagnostic.
1975 if Is_Formal
(Item_Id
) then
1976 if Scope
(Item_Id
) = Spec_Id
then
1978 ("global item cannot reference parameter of subprogram",
1983 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1984 -- Do this check first to provide a better error diagnostic.
1986 elsif Ekind
(Item_Id
) = E_Constant
then
1987 SPARK_Msg_N
("global item cannot denote a constant", Item
);
1989 -- The only legal references are those to abstract states and
1990 -- variables (SPARK RM 6.1.4(4)).
1992 elsif not Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
1994 ("global item must denote variable or state", Item
);
1998 -- State related checks
2000 if Ekind
(Item_Id
) = E_Abstract_State
then
2002 -- An abstract state with visible refinement cannot appear
2003 -- in pragma [Refined_]Global as its place must be taken by
2004 -- some of its constituents (SPARK RM 6.1.4(8)).
2006 if Has_Visible_Refinement
(Item_Id
) then
2008 ("cannot mention state & in global refinement",
2010 SPARK_Msg_N
("\use its constituents instead", Item
);
2013 -- If the reference to the abstract state appears in an
2014 -- enclosing package body that will eventually refine the
2015 -- state, record the reference for future checks.
2018 Record_Possible_Body_Reference
2019 (State_Id
=> Item_Id
,
2023 -- Variable related checks. These are only relevant when
2024 -- SPARK_Mode is on as they are not standard Ada legality
2027 elsif SPARK_Mode
= On
and then Is_SPARK_Volatile
(Item_Id
) then
2029 -- A volatile object cannot appear as a global item of a
2030 -- function (SPARK RM 7.1.3(9)).
2032 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2034 ("volatile object & cannot act as global item of a "
2035 & "function", Item
, Item_Id
);
2038 -- A volatile object with property Effective_Reads set to
2039 -- True must have mode Output or In_Out.
2041 elsif Effective_Reads_Enabled
(Item_Id
)
2042 and then Global_Mode
= Name_Input
2045 ("volatile object & with property Effective_Reads must "
2046 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
2052 -- When the item renames an entire object, replace the item
2053 -- with a reference to the object.
2055 if Present
(Renamed_Object
(Entity
(Item
))) then
2056 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2060 -- Some form of illegal construct masquerading as a name
2061 -- (SPARK RM 6.1.4(4)).
2064 Error_Msg_N
("global item must denote variable or state", Item
);
2068 -- Verify that an output does not appear as an input in an
2069 -- enclosing subprogram.
2071 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2072 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2075 -- The same entity might be referenced through various way.
2076 -- Check the entity of the item rather than the item itself
2077 -- (SPARK RM 6.1.4(11)).
2079 if Contains
(Seen
, Item_Id
) then
2080 SPARK_Msg_N
("duplicate global item", Item
);
2082 -- Add the entity of the current item to the list of processed
2086 Add_Item
(Item_Id
, Seen
);
2088 if Ekind
(Item_Id
) = E_Abstract_State
then
2089 Add_Item
(Item_Id
, States_Seen
);
2092 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
2093 and then Present
(Encapsulating_State
(Item_Id
))
2095 Add_Item
(Item_Id
, Constits_Seen
);
2098 end Analyze_Global_Item
;
2100 --------------------------
2101 -- Check_Duplicate_Mode --
2102 --------------------------
2104 procedure Check_Duplicate_Mode
2106 Status
: in out Boolean)
2110 SPARK_Msg_N
("duplicate global mode", Mode
);
2114 end Check_Duplicate_Mode
;
2116 -------------------------------------------------
2117 -- Check_Mode_Restriction_In_Enclosing_Context --
2118 -------------------------------------------------
2120 procedure Check_Mode_Restriction_In_Enclosing_Context
2122 Item_Id
: Entity_Id
)
2124 Context
: Entity_Id
;
2126 Inputs
: Elist_Id
:= No_Elist
;
2127 Outputs
: Elist_Id
:= No_Elist
;
2130 -- Traverse the scope stack looking for enclosing subprograms
2131 -- subject to pragma [Refined_]Global.
2133 Context
:= Scope
(Subp_Id
);
2134 while Present
(Context
) and then Context
/= Standard_Standard
loop
2135 if Is_Subprogram
(Context
)
2137 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2139 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2141 Collect_Subprogram_Inputs_Outputs
2142 (Subp_Id
=> Context
,
2143 Subp_Inputs
=> Inputs
,
2144 Subp_Outputs
=> Outputs
,
2145 Global_Seen
=> Dummy
);
2147 -- The item is classified as In_Out or Output but appears as
2148 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2150 if Appears_In
(Inputs
, Item_Id
)
2151 and then not Appears_In
(Outputs
, Item_Id
)
2154 ("global item & cannot have mode In_Out or Output",
2157 ("\item already appears as input of subprogram &",
2160 -- Stop the traversal once an error has been detected
2166 Context
:= Scope
(Context
);
2168 end Check_Mode_Restriction_In_Enclosing_Context
;
2170 ----------------------------------------
2171 -- Check_Mode_Restriction_In_Function --
2172 ----------------------------------------
2174 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2176 if Ekind
(Spec_Id
) = E_Function
then
2178 ("global mode & is not applicable to functions", Mode
);
2180 end Check_Mode_Restriction_In_Function
;
2188 -- Start of processing for Analyze_Global_List
2191 if Nkind
(List
) = N_Null
then
2192 Set_Analyzed
(List
);
2194 -- Single global item declaration
2196 elsif Nkind_In
(List
, N_Expanded_Name
,
2198 N_Selected_Component
)
2200 Analyze_Global_Item
(List
, Global_Mode
);
2202 -- Simple global list or moded global list declaration
2204 elsif Nkind
(List
) = N_Aggregate
then
2205 Set_Analyzed
(List
);
2207 -- The declaration of a simple global list appear as a collection
2210 if Present
(Expressions
(List
)) then
2211 if Present
(Component_Associations
(List
)) then
2213 ("cannot mix moded and non-moded global lists", List
);
2216 Item
:= First
(Expressions
(List
));
2217 while Present
(Item
) loop
2218 Analyze_Global_Item
(Item
, Global_Mode
);
2223 -- The declaration of a moded global list appears as a collection
2224 -- of component associations where individual choices denote
2227 elsif Present
(Component_Associations
(List
)) then
2228 if Present
(Expressions
(List
)) then
2230 ("cannot mix moded and non-moded global lists", List
);
2233 Assoc
:= First
(Component_Associations
(List
));
2234 while Present
(Assoc
) loop
2235 Mode
:= First
(Choices
(Assoc
));
2237 if Nkind
(Mode
) = N_Identifier
then
2238 if Chars
(Mode
) = Name_In_Out
then
2239 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2240 Check_Mode_Restriction_In_Function
(Mode
);
2242 elsif Chars
(Mode
) = Name_Input
then
2243 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2245 elsif Chars
(Mode
) = Name_Output
then
2246 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2247 Check_Mode_Restriction_In_Function
(Mode
);
2249 elsif Chars
(Mode
) = Name_Proof_In
then
2250 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2253 SPARK_Msg_N
("invalid mode selector", Mode
);
2257 SPARK_Msg_N
("invalid mode selector", Mode
);
2260 -- Items in a moded list appear as a collection of
2261 -- expressions. Reuse the existing machinery to analyze
2265 (List
=> Expression
(Assoc
),
2266 Global_Mode
=> Chars
(Mode
));
2274 raise Program_Error
;
2277 -- Any other attempt to declare a global item is illegal. This is a
2278 -- syntax error, always report.
2281 Error_Msg_N
("malformed global list", List
);
2283 end Analyze_Global_List
;
2287 Items
: constant Node_Id
:=
2288 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2289 Subp_Decl
: Node_Id
;
2291 Restore_Scope
: Boolean := False;
2292 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2294 -- Start of processing for Analyze_Global_In_Decl_List
2298 Check_SPARK_Aspect_For_ASIS
(N
);
2300 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
2301 Subp_Id
:= Defining_Entity
(Subp_Decl
);
2303 -- The logic in this routine is used to analyze both pragma Global and
2304 -- pragma Refined_Global since they have the same syntax and base
2305 -- semantics. Find the entity of the corresponding spec when analyzing
2308 if Nkind
(Subp_Decl
) = N_Subprogram_Body
2309 and then Present
(Corresponding_Spec
(Subp_Decl
))
2311 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
2313 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
2314 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
2316 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
2322 -- There is nothing to be done for a null global list
2324 if Nkind
(Items
) = N_Null
then
2325 Set_Analyzed
(Items
);
2327 -- Analyze the various forms of global lists and items. Note that some
2328 -- of these may be malformed in which case the analysis emits error
2332 -- Ensure that the formal parameters are visible when processing an
2333 -- item. This falls out of the general rule of aspects pertaining to
2334 -- subprogram declarations.
2336 if not In_Open_Scopes
(Spec_Id
) then
2337 Restore_Scope
:= True;
2338 Push_Scope
(Spec_Id
);
2339 Install_Formals
(Spec_Id
);
2342 Analyze_Global_List
(Items
);
2344 if Restore_Scope
then
2349 -- Ensure that a state and a corresponding constituent do not appear
2350 -- together in pragma [Refined_]Global.
2352 Check_State_And_Constituent_Use
2353 (States
=> States_Seen
,
2354 Constits
=> Constits_Seen
,
2356 end Analyze_Global_In_Decl_Part
;
2358 --------------------------------------------
2359 -- Analyze_Initial_Condition_In_Decl_Part --
2360 --------------------------------------------
2362 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2363 Expr
: constant Node_Id
:=
2364 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2369 -- The expression is preanalyzed because it has not been moved to its
2370 -- final place yet. A direct analysis may generate side effects and this
2371 -- is not desired at this point.
2373 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
2374 end Analyze_Initial_Condition_In_Decl_Part
;
2376 --------------------------------------
2377 -- Analyze_Initializes_In_Decl_Part --
2378 --------------------------------------
2380 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2381 Pack_Spec
: constant Node_Id
:= Parent
(N
);
2382 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Parent
(Pack_Spec
));
2384 Constits_Seen
: Elist_Id
:= No_Elist
;
2385 -- A list containing the entities of all constituents processed so far.
2386 -- It aids in detecting illegal usage of a state and a corresponding
2387 -- constituent in pragma Initializes.
2389 Items_Seen
: Elist_Id
:= No_Elist
;
2390 -- A list of all initialization items processed so far. This list is
2391 -- used to detect duplicate items.
2393 Non_Null_Seen
: Boolean := False;
2394 Null_Seen
: Boolean := False;
2395 -- Flags used to check the legality of a null initialization list
2397 States_And_Vars
: Elist_Id
:= No_Elist
;
2398 -- A list of all abstract states and variables declared in the visible
2399 -- declarations of the related package. This list is used to detect the
2400 -- legality of initialization items.
2402 States_Seen
: Elist_Id
:= No_Elist
;
2403 -- A list containing the entities of all states processed so far. It
2404 -- helps in detecting illegal usage of a state and a corresponding
2405 -- constituent in pragma Initializes.
2407 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2408 -- Verify the legality of a single initialization item
2410 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2411 -- Verify the legality of a single initialization item followed by a
2412 -- list of input items.
2414 procedure Collect_States_And_Variables
;
2415 -- Inspect the visible declarations of the related package and gather
2416 -- the entities of all abstract states and variables in States_And_Vars.
2418 ---------------------------------
2419 -- Analyze_Initialization_Item --
2420 ---------------------------------
2422 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2423 Item_Id
: Entity_Id
;
2426 -- Null initialization list
2428 if Nkind
(Item
) = N_Null
then
2430 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2432 elsif Non_Null_Seen
then
2434 ("cannot mix null and non-null initialization items", Item
);
2439 -- Initialization item
2442 Non_Null_Seen
:= True;
2446 ("cannot mix null and non-null initialization items", Item
);
2450 Resolve_State
(Item
);
2452 if Is_Entity_Name
(Item
) then
2453 Item_Id
:= Entity_Of
(Item
);
2455 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
2457 -- The state or variable must be declared in the visible
2458 -- declarations of the package (SPARK RM 7.1.5(7)).
2460 if not Contains
(States_And_Vars
, Item_Id
) then
2461 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2463 ("initialization item & must appear in the visible "
2464 & "declarations of package %", Item
, Item_Id
);
2466 -- Detect a duplicate use of the same initialization item
2467 -- (SPARK RM 7.1.5(5)).
2469 elsif Contains
(Items_Seen
, Item_Id
) then
2470 SPARK_Msg_N
("duplicate initialization item", Item
);
2472 -- The item is legal, add it to the list of processed states
2476 Add_Item
(Item_Id
, Items_Seen
);
2478 if Ekind
(Item_Id
) = E_Abstract_State
then
2479 Add_Item
(Item_Id
, States_Seen
);
2482 if Present
(Encapsulating_State
(Item_Id
)) then
2483 Add_Item
(Item_Id
, Constits_Seen
);
2487 -- The item references something that is not a state or a
2488 -- variable (SPARK RM 7.1.5(3)).
2492 ("initialization item must denote variable or state",
2496 -- Some form of illegal construct masquerading as a name
2497 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2501 ("initialization item must denote variable or state", Item
);
2504 end Analyze_Initialization_Item
;
2506 ---------------------------------------------
2507 -- Analyze_Initialization_Item_With_Inputs --
2508 ---------------------------------------------
2510 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2511 Inputs_Seen
: Elist_Id
:= No_Elist
;
2512 -- A list of all inputs processed so far. This list is used to detect
2513 -- duplicate uses of an input.
2515 Non_Null_Seen
: Boolean := False;
2516 Null_Seen
: Boolean := False;
2517 -- Flags used to check the legality of an input list
2519 procedure Analyze_Input_Item
(Input
: Node_Id
);
2520 -- Verify the legality of a single input item
2522 ------------------------
2523 -- Analyze_Input_Item --
2524 ------------------------
2526 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2527 Input_Id
: Entity_Id
;
2532 if Nkind
(Input
) = N_Null
then
2535 ("multiple null initializations not allowed", Item
);
2537 elsif Non_Null_Seen
then
2539 ("cannot mix null and non-null initialization item", Item
);
2547 Non_Null_Seen
:= True;
2551 ("cannot mix null and non-null initialization item", Item
);
2555 Resolve_State
(Input
);
2557 if Is_Entity_Name
(Input
) then
2558 Input_Id
:= Entity_Of
(Input
);
2560 if Ekind_In
(Input_Id
, E_Abstract_State
,
2566 -- The input cannot denote states or variables declared
2567 -- within the related package.
2569 if Within_Scope
(Input_Id
, Current_Scope
) then
2570 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2572 ("input item & cannot denote a visible variable or "
2573 & "state of package % (SPARK RM 7.1.5(4))",
2576 -- Detect a duplicate use of the same input item
2577 -- (SPARK RM 7.1.5(5)).
2579 elsif Contains
(Inputs_Seen
, Input_Id
) then
2580 SPARK_Msg_N
("duplicate input item", Input
);
2582 -- Input is legal, add it to the list of processed inputs
2585 Add_Item
(Input_Id
, Inputs_Seen
);
2587 if Ekind
(Input_Id
) = E_Abstract_State
then
2588 Add_Item
(Input_Id
, States_Seen
);
2591 if Ekind_In
(Input_Id
, E_Abstract_State
, E_Variable
)
2592 and then Present
(Encapsulating_State
(Input_Id
))
2594 Add_Item
(Input_Id
, Constits_Seen
);
2598 -- The input references something that is not a state or a
2599 -- variable (SPARK RM 7.1.5(3)).
2603 ("input item must denote variable or state", Input
);
2606 -- Some form of illegal construct masquerading as a name
2607 -- (SPARK RM 7.1.5(3)).
2611 ("input item must denote variable or state", Input
);
2614 end Analyze_Input_Item
;
2618 Inputs
: constant Node_Id
:= Expression
(Item
);
2622 Name_Seen
: Boolean := False;
2623 -- A flag used to detect multiple item names
2625 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2628 -- Inspect the name of an item with inputs
2630 Elmt
:= First
(Choices
(Item
));
2631 while Present
(Elmt
) loop
2633 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2636 Analyze_Initialization_Item
(Elmt
);
2642 -- Multiple input items appear as an aggregate
2644 if Nkind
(Inputs
) = N_Aggregate
then
2645 if Present
(Expressions
(Inputs
)) then
2646 Input
:= First
(Expressions
(Inputs
));
2647 while Present
(Input
) loop
2648 Analyze_Input_Item
(Input
);
2653 if Present
(Component_Associations
(Inputs
)) then
2655 ("inputs must appear in named association form", Inputs
);
2658 -- Single input item
2661 Analyze_Input_Item
(Inputs
);
2663 end Analyze_Initialization_Item_With_Inputs
;
2665 ----------------------------------
2666 -- Collect_States_And_Variables --
2667 ----------------------------------
2669 procedure Collect_States_And_Variables
is
2673 -- Collect the abstract states defined in the package (if any)
2675 if Present
(Abstract_States
(Pack_Id
)) then
2676 States_And_Vars
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2679 -- Collect all variables the appear in the visible declarations of
2680 -- the related package.
2682 if Present
(Visible_Declarations
(Pack_Spec
)) then
2683 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2684 while Present
(Decl
) loop
2685 if Nkind
(Decl
) = N_Object_Declaration
2686 and then Ekind
(Defining_Entity
(Decl
)) = E_Variable
2687 and then Comes_From_Source
(Decl
)
2689 Add_Item
(Defining_Entity
(Decl
), States_And_Vars
);
2695 end Collect_States_And_Variables
;
2699 Inits
: constant Node_Id
:=
2700 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2703 -- Start of processing for Analyze_Initializes_In_Decl_Part
2708 Check_SPARK_Aspect_For_ASIS
(N
);
2710 -- Nothing to do when the initialization list is empty
2712 if Nkind
(Inits
) = N_Null
then
2716 -- Single and multiple initialization clauses appear as an aggregate. If
2717 -- this is not the case, then either the parser or the analysis of the
2718 -- pragma failed to produce an aggregate.
2720 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2722 -- Initialize the various lists used during analysis
2724 Collect_States_And_Variables
;
2726 if Present
(Expressions
(Inits
)) then
2727 Init
:= First
(Expressions
(Inits
));
2728 while Present
(Init
) loop
2729 Analyze_Initialization_Item
(Init
);
2734 if Present
(Component_Associations
(Inits
)) then
2735 Init
:= First
(Component_Associations
(Inits
));
2736 while Present
(Init
) loop
2737 Analyze_Initialization_Item_With_Inputs
(Init
);
2742 -- Ensure that a state and a corresponding constituent do not appear
2743 -- together in pragma Initializes.
2745 Check_State_And_Constituent_Use
2746 (States
=> States_Seen
,
2747 Constits
=> Constits_Seen
,
2749 end Analyze_Initializes_In_Decl_Part
;
2751 --------------------
2752 -- Analyze_Pragma --
2753 --------------------
2755 procedure Analyze_Pragma
(N
: Node_Id
) is
2756 Loc
: constant Source_Ptr
:= Sloc
(N
);
2757 Prag_Id
: Pragma_Id
;
2760 -- Name of the source pragma, or name of the corresponding aspect for
2761 -- pragmas which originate in a source aspect. In the latter case, the
2762 -- name may be different from the pragma name.
2764 Pragma_Exit
: exception;
2765 -- This exception is used to exit pragma processing completely. It
2766 -- is used when an error is detected, and no further processing is
2767 -- required. It is also used if an earlier error has left the tree in
2768 -- a state where the pragma should not be processed.
2771 -- Number of pragma argument associations
2777 -- First four pragma arguments (pragma argument association nodes, or
2778 -- Empty if the corresponding argument does not exist).
2780 type Name_List
is array (Natural range <>) of Name_Id
;
2781 type Args_List
is array (Natural range <>) of Node_Id
;
2782 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2784 -----------------------
2785 -- Local Subprograms --
2786 -----------------------
2788 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
2789 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2790 -- get the given string argument, and place it in Name_Buffer, adding
2791 -- leading and trailing asterisks if they are not already present. The
2792 -- caller has already checked that Arg is a static string expression.
2794 procedure Ada_2005_Pragma
;
2795 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2796 -- Ada 95 mode, these are implementation defined pragmas, so should be
2797 -- caught by the No_Implementation_Pragmas restriction.
2799 procedure Ada_2012_Pragma
;
2800 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2801 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2802 -- should be caught by the No_Implementation_Pragmas restriction.
2804 procedure Analyze_Part_Of
2805 (Item_Id
: Entity_Id
;
2808 Legal
: out Boolean);
2809 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2810 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2811 -- an abstract state, variable or package instantiation. State is the
2812 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2813 -- set when the indicator is legal.
2815 procedure Analyze_Refined_Pragma
2816 (Spec_Id
: out Entity_Id
;
2817 Body_Id
: out Entity_Id
;
2818 Legal
: out Boolean);
2819 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2820 -- Refined_Global and Refined_Post. Check the placement and related
2821 -- context of the pragma. Spec_Id is the entity of the related
2822 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2823 -- Legal is set when the pragma is properly placed.
2825 procedure Check_Ada_83_Warning
;
2826 -- Issues a warning message for the current pragma if operating in Ada
2827 -- 83 mode (used for language pragmas that are not a standard part of
2828 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2831 procedure Check_Arg_Count
(Required
: Nat
);
2832 -- Check argument count for pragma is equal to given parameter. If not,
2833 -- then issue an error message and raise Pragma_Exit.
2835 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2836 -- Arg which can either be a pragma argument association, in which case
2837 -- the check is applied to the expression of the association or an
2838 -- expression directly.
2840 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
2841 -- Check that an argument has the right form for an EXTERNAL_NAME
2842 -- parameter of an extended import/export pragma. The rule is that the
2843 -- name must be an identifier or string literal (in Ada 83 mode) or a
2844 -- static string expression (in Ada 95 mode).
2846 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
2847 -- Check the specified argument Arg to make sure that it is an
2848 -- identifier. If not give error and raise Pragma_Exit.
2850 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
2851 -- Check the specified argument Arg to make sure that it is an integer
2852 -- literal. If not give error and raise Pragma_Exit.
2854 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
2855 -- Check the specified argument Arg to make sure that it has the proper
2856 -- syntactic form for a local name and meets the semantic requirements
2857 -- for a local name. The local name is analyzed as part of the
2858 -- processing for this call. In addition, the local name is required
2859 -- to represent an entity at the library level.
2861 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
2862 -- Check the specified argument Arg to make sure that it has the proper
2863 -- syntactic form for a local name and meets the semantic requirements
2864 -- for a local name. The local name is analyzed as part of the
2865 -- processing for this call.
2867 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
2868 -- Check the specified argument Arg to make sure that it is a valid
2869 -- locking policy name. If not give error and raise Pragma_Exit.
2871 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
2872 -- Check the specified argument Arg to make sure that it is a valid
2873 -- elaboration policy name. If not give error and raise Pragma_Exit.
2875 procedure Check_Arg_Is_One_Of
2878 procedure Check_Arg_Is_One_Of
2880 N1
, N2
, N3
: Name_Id
);
2881 procedure Check_Arg_Is_One_Of
2883 N1
, N2
, N3
, N4
: Name_Id
);
2884 procedure Check_Arg_Is_One_Of
2886 N1
, N2
, N3
, N4
, N5
: Name_Id
);
2887 -- Check the specified argument Arg to make sure that it is an
2888 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2889 -- present). If not then give error and raise Pragma_Exit.
2891 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
2892 -- Check the specified argument Arg to make sure that it is a valid
2893 -- queuing policy name. If not give error and raise Pragma_Exit.
2895 procedure Check_Arg_Is_Static_Expression
2897 Typ
: Entity_Id
:= Empty
);
2898 -- Check the specified argument Arg to make sure that it is a static
2899 -- expression of the given type (i.e. it will be analyzed and resolved
2900 -- using this type, which can be any valid argument to Resolve, e.g.
2901 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2902 -- Typ is left Empty, then any static expression is allowed.
2904 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
2905 -- Check the specified argument Arg to make sure that it is a valid task
2906 -- dispatching policy name. If not give error and raise Pragma_Exit.
2908 procedure Check_Arg_Order
(Names
: Name_List
);
2909 -- Checks for an instance of two arguments with identifiers for the
2910 -- current pragma which are not in the sequence indicated by Names,
2911 -- and if so, generates a fatal message about bad order of arguments.
2913 procedure Check_At_Least_N_Arguments
(N
: Nat
);
2914 -- Check there are at least N arguments present
2916 procedure Check_At_Most_N_Arguments
(N
: Nat
);
2917 -- Check there are no more than N arguments present
2919 procedure Check_Component
2922 In_Variant_Part
: Boolean := False);
2923 -- Examine an Unchecked_Union component for correct use of per-object
2924 -- constrained subtypes, and for restrictions on finalizable components.
2925 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2926 -- should be set when Comp comes from a record variant.
2928 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
);
2929 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2930 -- Initial_Condition and Initializes. Determine whether pragma First
2931 -- appears before pragma Second. If this is not the case, emit an error.
2933 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
2934 -- Check if a rep item of the same name as the current pragma is already
2935 -- chained as a rep pragma to the given entity. If so give a message
2936 -- about the duplicate, and then raise Pragma_Exit so does not return.
2937 -- Note that if E is a type, then this routine avoids flagging a pragma
2938 -- which applies to a parent type from which E is derived.
2940 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
2941 -- Nam is an N_String_Literal node containing the external name set by
2942 -- an Import or Export pragma (or extended Import or Export pragma).
2943 -- This procedure checks for possible duplications if this is the export
2944 -- case, and if found, issues an appropriate error message.
2946 procedure Check_Expr_Is_Static_Expression
2948 Typ
: Entity_Id
:= Empty
);
2949 -- Check the specified expression Expr to make sure that it is a static
2950 -- expression of the given type (i.e. it will be analyzed and resolved
2951 -- using this type, which can be any valid argument to Resolve, e.g.
2952 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2953 -- Typ is left Empty, then any static expression is allowed.
2955 procedure Check_First_Subtype
(Arg
: Node_Id
);
2956 -- Checks that Arg, whose expression is an entity name, references a
2959 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2960 -- Checks that the given argument has an identifier, and if so, requires
2961 -- it to match the given identifier name. If there is no identifier, or
2962 -- a non-matching identifier, then an error message is given and
2963 -- Pragma_Exit is raised.
2965 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
2966 -- Checks that the given argument has an identifier, and if so, requires
2967 -- it to match one of the given identifier names. If there is no
2968 -- identifier, or a non-matching identifier, then an error message is
2969 -- given and Pragma_Exit is raised.
2971 procedure Check_In_Main_Program
;
2972 -- Common checks for pragmas that appear within a main program
2973 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2975 procedure Check_Interrupt_Or_Attach_Handler
;
2976 -- Common processing for first argument of pragma Interrupt_Handler or
2977 -- pragma Attach_Handler.
2979 procedure Check_Loop_Pragma_Placement
;
2980 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2981 -- appear immediately within a construct restricted to loops, and that
2982 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2984 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
2985 -- Check that pragma appears in a declarative part, or in a package
2986 -- specification, i.e. that it does not occur in a statement sequence
2989 procedure Check_No_Identifier
(Arg
: Node_Id
);
2990 -- Checks that the given argument does not have an identifier. If
2991 -- an identifier is present, then an error message is issued, and
2992 -- Pragma_Exit is raised.
2994 procedure Check_No_Identifiers
;
2995 -- Checks that none of the arguments to the pragma has an identifier.
2996 -- If any argument has an identifier, then an error message is issued,
2997 -- and Pragma_Exit is raised.
2999 procedure Check_No_Link_Name
;
3000 -- Checks that no link name is specified
3002 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3003 -- Checks if the given argument has an identifier, and if so, requires
3004 -- it to match the given identifier name. If there is a non-matching
3005 -- identifier, then an error message is given and Pragma_Exit is raised.
3007 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3008 -- Checks if the given argument has an identifier, and if so, requires
3009 -- it to match the given identifier name. If there is a non-matching
3010 -- identifier, then an error message is given and Pragma_Exit is raised.
3011 -- In this version of the procedure, the identifier name is given as
3012 -- a string with lower case letters.
3014 procedure Check_Pre_Post
;
3015 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
3016 -- pragmas. These are processed by transformation to equivalent
3017 -- Precondition and Postcondition pragmas, but Pre and Post need an
3018 -- additional check that they are not used in a subprogram body when
3019 -- there is a separate spec present.
3021 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
3022 -- Called to process a precondition or postcondition pragma. There are
3025 -- The pragma appears after a subprogram spec
3027 -- If the corresponding check is not enabled, the pragma is analyzed
3028 -- but otherwise ignored and control returns with In_Body set False.
3030 -- If the check is enabled, then the first step is to analyze the
3031 -- pragma, but this is skipped if the subprogram spec appears within
3032 -- a package specification (because this is the case where we delay
3033 -- analysis till the end of the spec). Then (whether or not it was
3034 -- analyzed), the pragma is chained to the subprogram in question
3035 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
3036 -- to the caller with In_Body set False.
3038 -- The pragma appears at the start of subprogram body declarations
3040 -- In this case an immediate return to the caller is made with
3041 -- In_Body set True, and the pragma is NOT analyzed.
3043 -- In all other cases, an error message for bad placement is given
3045 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3046 -- Constr is a constraint from an N_Subtype_Indication node from a
3047 -- component constraint in an Unchecked_Union type. This routine checks
3048 -- that the constraint is static as required by the restrictions for
3051 procedure Check_Test_Case
;
3052 -- Called to process a test-case pragma. It starts with checking pragma
3053 -- arguments, and the rest of the treatment is similar to the one for
3054 -- pre- and postcondition in Check_Precondition_Postcondition, except
3055 -- the placement rules for the test-case pragma are stricter. These
3056 -- pragmas may only occur after a subprogram spec declared directly
3057 -- in a package spec unit. In this case, the pragma is chained to the
3058 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
3059 -- and analysis of the pragma is delayed till the end of the spec. In
3060 -- all other cases, an error message for bad placement is given.
3062 procedure Check_Valid_Configuration_Pragma
;
3063 -- Legality checks for placement of a configuration pragma
3065 procedure Check_Valid_Library_Unit_Pragma
;
3066 -- Legality checks for library unit pragmas. A special case arises for
3067 -- pragmas in generic instances that come from copies of the original
3068 -- library unit pragmas in the generic templates. In the case of other
3069 -- than library level instantiations these can appear in contexts which
3070 -- would normally be invalid (they only apply to the original template
3071 -- and to library level instantiations), and they are simply ignored,
3072 -- which is implemented by rewriting them as null statements.
3074 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3075 -- Check an Unchecked_Union variant for lack of nested variants and
3076 -- presence of at least one component. UU_Typ is the related Unchecked_
3079 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3080 -- Subsidiary routine to the processing of pragmas Abstract_State,
3081 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3082 -- Refined_Global and Refined_State. Transform argument Arg into an
3083 -- aggregate if not one already. N_Null is never transformed.
3085 procedure Error_Pragma
(Msg
: String);
3086 pragma No_Return
(Error_Pragma
);
3087 -- Outputs error message for current pragma. The message contains a %
3088 -- that will be replaced with the pragma name, and the flag is placed
3089 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3090 -- calls Fix_Error (see spec of that procedure for details).
3092 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3093 pragma No_Return
(Error_Pragma_Arg
);
3094 -- Outputs error message for current pragma. The message may contain
3095 -- a % that will be replaced with the pragma name. The parameter Arg
3096 -- may either be a pragma argument association, in which case the flag
3097 -- is placed on the expression of this association, or an expression,
3098 -- in which case the flag is placed directly on the expression. The
3099 -- message is placed using Error_Msg_N, so the message may also contain
3100 -- an & insertion character which will reference the given Arg value.
3101 -- After placing the message, Pragma_Exit is raised. Note: this routine
3102 -- calls Fix_Error (see spec of that procedure for details).
3104 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3105 pragma No_Return
(Error_Pragma_Arg
);
3106 -- Similar to above form of Error_Pragma_Arg except that two messages
3107 -- are provided, the second is a continuation comment starting with \.
3109 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3110 pragma No_Return
(Error_Pragma_Arg_Ident
);
3111 -- Outputs error message for current pragma. The message may contain a %
3112 -- that will be replaced with the pragma name. The parameter Arg must be
3113 -- a pragma argument association with a non-empty identifier (i.e. its
3114 -- Chars field must be set), and the error message is placed on the
3115 -- identifier. The message is placed using Error_Msg_N so the message
3116 -- may also contain an & insertion character which will reference
3117 -- the identifier. After placing the message, Pragma_Exit is raised.
3118 -- Note: this routine calls Fix_Error (see spec of that procedure for
3121 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3122 pragma No_Return
(Error_Pragma_Ref
);
3123 -- Outputs error message for current pragma. The message may contain
3124 -- a % that will be replaced with the pragma name. The parameter Ref
3125 -- must be an entity whose name can be referenced by & and sloc by #.
3126 -- After placing the message, Pragma_Exit is raised. Note: this routine
3127 -- calls Fix_Error (see spec of that procedure for details).
3129 function Find_Lib_Unit_Name
return Entity_Id
;
3130 -- Used for a library unit pragma to find the entity to which the
3131 -- library unit pragma applies, returns the entity found.
3133 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3134 -- If the pragma is a compilation unit pragma, the id must denote the
3135 -- compilation unit in the same compilation, and the pragma must appear
3136 -- in the list of preceding or trailing pragmas. If it is a program
3137 -- unit pragma that is not a compilation unit pragma, then the
3138 -- identifier must be visible.
3140 function Find_Unique_Parameterless_Procedure
3142 Arg
: Node_Id
) return Entity_Id
;
3143 -- Used for a procedure pragma to find the unique parameterless
3144 -- procedure identified by Name, returns it if it exists, otherwise
3145 -- errors out and uses Arg as the pragma argument for the message.
3147 function Fix_Error
(Msg
: String) return String;
3148 -- This is called prior to issuing an error message. Msg is the normal
3149 -- error message issued in the pragma case. This routine checks for the
3150 -- case of a pragma coming from an aspect in the source, and returns a
3151 -- message suitable for the aspect case as follows:
3153 -- Each substring "pragma" is replaced by "aspect"
3155 -- If "argument of" is at the start of the error message text, it is
3156 -- replaced by "entity for".
3158 -- If "argument" is at the start of the error message text, it is
3159 -- replaced by "entity".
3161 -- So for example, "argument of pragma X must be discrete type"
3162 -- returns "entity for aspect X must be a discrete type".
3164 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3165 -- be different from the pragma name). If the current pragma results
3166 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3167 -- original pragma name.
3169 procedure Gather_Associations
3171 Args
: out Args_List
);
3172 -- This procedure is used to gather the arguments for a pragma that
3173 -- permits arbitrary ordering of parameters using the normal rules
3174 -- for named and positional parameters. The Names argument is a list
3175 -- of Name_Id values that corresponds to the allowed pragma argument
3176 -- association identifiers in order. The result returned in Args is
3177 -- a list of corresponding expressions that are the pragma arguments.
3178 -- Note that this is a list of expressions, not of pragma argument
3179 -- associations (Gather_Associations has completely checked all the
3180 -- optional identifiers when it returns). An entry in Args is Empty
3181 -- on return if the corresponding argument is not present.
3183 procedure GNAT_Pragma
;
3184 -- Called for all GNAT defined pragmas to check the relevant restriction
3185 -- (No_Implementation_Pragmas).
3187 function Is_Before_First_Decl
3188 (Pragma_Node
: Node_Id
;
3189 Decls
: List_Id
) return Boolean;
3190 -- Return True if Pragma_Node is before the first declarative item in
3191 -- Decls where Decls is the list of declarative items.
3193 function Is_Configuration_Pragma
return Boolean;
3194 -- Determines if the placement of the current pragma is appropriate
3195 -- for a configuration pragma.
3197 function Is_In_Context_Clause
return Boolean;
3198 -- Returns True if pragma appears within the context clause of a unit,
3199 -- and False for any other placement (does not generate any messages).
3201 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3202 -- Analyzes the argument, and determines if it is a static string
3203 -- expression, returns True if so, False if non-static or not String.
3205 procedure Pragma_Misplaced
;
3206 pragma No_Return
(Pragma_Misplaced
);
3207 -- Issue fatal error message for misplaced pragma
3209 procedure Process_Atomic_Shared_Volatile
;
3210 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3211 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3212 -- in effect to pragma Atomic.
3214 procedure Process_Compile_Time_Warning_Or_Error
;
3215 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3217 procedure Process_Convention
3218 (C
: out Convention_Id
;
3219 Ent
: out Entity_Id
);
3220 -- Common processing for Convention, Interface, Import and Export.
3221 -- Checks first two arguments of pragma, and sets the appropriate
3222 -- convention value in the specified entity or entities. On return
3223 -- C is the convention, Ent is the referenced entity.
3225 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3226 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3227 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3229 procedure Process_Extended_Import_Export_Exception_Pragma
3230 (Arg_Internal
: Node_Id
;
3231 Arg_External
: Node_Id
;
3233 Arg_Code
: Node_Id
);
3234 -- Common processing for the pragmas Import/Export_Exception. The three
3235 -- arguments correspond to the three named parameters of the pragma. An
3236 -- argument is empty if the corresponding parameter is not present in
3239 procedure Process_Extended_Import_Export_Object_Pragma
3240 (Arg_Internal
: Node_Id
;
3241 Arg_External
: Node_Id
;
3242 Arg_Size
: Node_Id
);
3243 -- Common processing for the pragmas Import/Export_Object. The three
3244 -- arguments correspond to the three named parameters of the pragmas. An
3245 -- argument is empty if the corresponding parameter is not present in
3248 procedure Process_Extended_Import_Export_Internal_Arg
3249 (Arg_Internal
: Node_Id
:= Empty
);
3250 -- Common processing for all extended Import and Export pragmas. The
3251 -- argument is the pragma parameter for the Internal argument. If
3252 -- Arg_Internal is empty or inappropriate, an error message is posted.
3253 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3254 -- set to identify the referenced entity.
3256 procedure Process_Extended_Import_Export_Subprogram_Pragma
3257 (Arg_Internal
: Node_Id
;
3258 Arg_External
: Node_Id
;
3259 Arg_Parameter_Types
: Node_Id
;
3260 Arg_Result_Type
: Node_Id
:= Empty
;
3261 Arg_Mechanism
: Node_Id
;
3262 Arg_Result_Mechanism
: Node_Id
:= Empty
;
3263 Arg_First_Optional_Parameter
: Node_Id
:= Empty
);
3264 -- Common processing for all extended Import and Export pragmas applying
3265 -- to subprograms. The caller omits any arguments that do not apply to
3266 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3267 -- only in the Import_Function and Export_Function cases). The argument
3268 -- names correspond to the allowed pragma association identifiers.
3270 procedure Process_Generic_List
;
3271 -- Common processing for Share_Generic and Inline_Generic
3273 procedure Process_Import_Or_Interface
;
3274 -- Common processing for Import of Interface
3276 procedure Process_Import_Predefined_Type
;
3277 -- Processing for completing a type with pragma Import. This is used
3278 -- to declare types that match predefined C types, especially for cases
3279 -- without corresponding Ada predefined type.
3281 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3282 -- Inline status of a subprogram, indicated as follows:
3283 -- Suppressed: inlining is suppressed for the subprogram
3284 -- Disabled: no inlining is requested for the subprogram
3285 -- Enabled: inlining is requested/required for the subprogram
3287 procedure Process_Inline
(Status
: Inline_Status
);
3288 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3289 -- indicates the inline status specified by the pragma.
3291 procedure Process_Interface_Name
3292 (Subprogram_Def
: Entity_Id
;
3294 Link_Arg
: Node_Id
);
3295 -- Given the last two arguments of pragma Import, pragma Export, or
3296 -- pragma Interface_Name, performs validity checks and sets the
3297 -- Interface_Name field of the given subprogram entity to the
3298 -- appropriate external or link name, depending on the arguments given.
3299 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3300 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3301 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3302 -- nor Link_Arg is present, the interface name is set to the default
3303 -- from the subprogram name.
3305 procedure Process_Interrupt_Or_Attach_Handler
;
3306 -- Common processing for Interrupt and Attach_Handler pragmas
3308 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3309 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3310 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3311 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3312 -- is not set in the Restrictions case.
3314 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3315 -- Common processing for Suppress and Unsuppress. The boolean parameter
3316 -- Suppress_Case is True for the Suppress case, and False for the
3319 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3320 -- This procedure sets the Is_Exported flag for the given entity,
3321 -- checking that the entity was not previously imported. Arg is
3322 -- the argument that specified the entity. A check is also made
3323 -- for exporting inappropriate entities.
3325 procedure Set_Extended_Import_Export_External_Name
3326 (Internal_Ent
: Entity_Id
;
3327 Arg_External
: Node_Id
);
3328 -- Common processing for all extended import export pragmas. The first
3329 -- argument, Internal_Ent, is the internal entity, which has already
3330 -- been checked for validity by the caller. Arg_External is from the
3331 -- Import or Export pragma, and may be null if no External parameter
3332 -- was present. If Arg_External is present and is a non-null string
3333 -- (a null string is treated as the default), then the Interface_Name
3334 -- field of Internal_Ent is set appropriately.
3336 procedure Set_Imported
(E
: Entity_Id
);
3337 -- This procedure sets the Is_Imported flag for the given entity,
3338 -- checking that it is not previously exported or imported.
3340 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3341 -- Mech is a parameter passing mechanism (see Import_Function syntax
3342 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3343 -- has the right form, and if not issues an error message. If the
3344 -- argument has the right form then the Mechanism field of Ent is
3345 -- set appropriately.
3347 procedure Set_Rational_Profile
;
3348 -- Activate the set of configuration pragmas and permissions that make
3349 -- up the Rational profile.
3351 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3352 -- Activate the set of configuration pragmas and restrictions that make
3353 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3354 -- is used for error messages on any constructs violating the profile.
3356 ----------------------------------
3357 -- Acquire_Warning_Match_String --
3358 ----------------------------------
3360 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3362 String_To_Name_Buffer
3363 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3365 -- Add asterisk at start if not already there
3367 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3368 Name_Buffer
(2 .. Name_Len
+ 1) :=
3369 Name_Buffer
(1 .. Name_Len
);
3370 Name_Buffer
(1) := '*';
3371 Name_Len
:= Name_Len
+ 1;
3374 -- Add asterisk at end if not already there
3376 if Name_Buffer
(Name_Len
) /= '*' then
3377 Name_Len
:= Name_Len
+ 1;
3378 Name_Buffer
(Name_Len
) := '*';
3380 end Acquire_Warning_Match_String
;
3382 ---------------------
3383 -- Ada_2005_Pragma --
3384 ---------------------
3386 procedure Ada_2005_Pragma
is
3388 if Ada_Version
<= Ada_95
then
3389 Check_Restriction
(No_Implementation_Pragmas
, N
);
3391 end Ada_2005_Pragma
;
3393 ---------------------
3394 -- Ada_2012_Pragma --
3395 ---------------------
3397 procedure Ada_2012_Pragma
is
3399 if Ada_Version
<= Ada_2005
then
3400 Check_Restriction
(No_Implementation_Pragmas
, N
);
3402 end Ada_2012_Pragma
;
3404 ---------------------
3405 -- Analyze_Part_Of --
3406 ---------------------
3408 procedure Analyze_Part_Of
3409 (Item_Id
: Entity_Id
;
3412 Legal
: out Boolean)
3414 Pack_Id
: Entity_Id
;
3415 Placement
: State_Space_Kind
;
3416 Parent_Unit
: Entity_Id
;
3417 State_Id
: Entity_Id
;
3420 -- Assume that the pragma/option is illegal
3424 if Nkind_In
(State
, N_Expanded_Name
,
3426 N_Selected_Component
)
3429 Resolve_State
(State
);
3431 if Is_Entity_Name
(State
)
3432 and then Ekind
(Entity
(State
)) = E_Abstract_State
3434 State_Id
:= Entity
(State
);
3438 ("indicator Part_Of must denote an abstract state", State
);
3442 -- This is a syntax error, always report
3446 ("indicator Part_Of must denote an abstract state", State
);
3450 -- Determine where the state, variable or the package instantiation
3451 -- lives with respect to the enclosing packages or package bodies (if
3452 -- any). This placement dictates the legality of the encapsulating
3455 Find_Placement_In_State_Space
3456 (Item_Id
=> Item_Id
,
3457 Placement
=> Placement
,
3458 Pack_Id
=> Pack_Id
);
3460 -- The item appears in a non-package construct with a declarative
3461 -- part (subprogram, block, etc). As such, the item is not allowed
3462 -- to be a part of an encapsulating state because the item is not
3465 if Placement
= Not_In_Package
then
3467 ("indicator Part_Of cannot appear in this context "
3468 & "(SPARK RM 7.2.6(5))", Indic
);
3469 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3471 ("\& is not part of the hidden state of package %",
3474 -- The item appears in the visible state space of some package. In
3475 -- general this scenario does not warrant Part_Of except when the
3476 -- package is a private child unit and the encapsulating state is
3477 -- declared in a parent unit or a public descendant of that parent
3480 elsif Placement
= Visible_State_Space
then
3481 if Is_Child_Unit
(Pack_Id
)
3482 and then Is_Private_Descendant
(Pack_Id
)
3484 -- A variable or state abstraction which is part of the
3485 -- visible state of a private child unit (or a public
3486 -- descendant thereof) shall have its Part_Of indicator
3487 -- specified; the Part_Of indicator shall denote a state
3488 -- abstraction declared by either the parent unit of the
3489 -- private unit or by a public descendant of that parent unit.
3491 -- Find nearest nearest private ancestor (which can be the
3492 -- current unit itself).
3494 Parent_Unit
:= Pack_Id
;
3495 while Present
(Parent_Unit
) loop
3496 exit when Private_Present
3497 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3498 Parent_Unit
:= Scope
(Parent_Unit
);
3501 Parent_Unit
:= Scope
(Parent_Unit
);
3503 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3505 ("indicator Part_Of must denote an abstract state of& "
3506 & "or public descendant (SPARK RM 7.2.6(3))",
3507 Indic
, Parent_Unit
);
3509 elsif Scope
(State_Id
) = Parent_Unit
3510 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3512 not Is_Private_Descendant
(Scope
(State_Id
)))
3518 ("indicator Part_Of must denote an abstract state of& "
3519 & "or public descendant (SPARK RM 7.2.6(3))",
3520 Indic
, Parent_Unit
);
3523 -- Indicator Part_Of is not needed when the related package is not
3524 -- a private child unit or a public descendant thereof.
3528 ("indicator Part_Of cannot appear in this context "
3529 & "(SPARK RM 7.2.6(5))", Indic
);
3530 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3532 ("\& is declared in the visible part of package %",
3536 -- When the item appears in the private state space of a package, the
3537 -- encapsulating state must be declared in the same package.
3539 elsif Placement
= Private_State_Space
then
3540 if Scope
(State_Id
) /= Pack_Id
then
3542 ("indicator Part_Of must designate an abstract state of "
3543 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3544 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3546 ("\& is declared in the private part of package %",
3550 -- Items declared in the body state space of a package do not need
3551 -- Part_Of indicators as the refinement has already been seen.
3555 ("indicator Part_Of cannot appear in this context "
3556 & "(SPARK RM 7.2.6(5))", Indic
);
3558 if Scope
(State_Id
) = Pack_Id
then
3559 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3561 ("\& is declared in the body of package %", Indic
, Item_Id
);
3566 end Analyze_Part_Of
;
3568 ----------------------------
3569 -- Analyze_Refined_Pragma --
3570 ----------------------------
3572 procedure Analyze_Refined_Pragma
3573 (Spec_Id
: out Entity_Id
;
3574 Body_Id
: out Entity_Id
;
3575 Legal
: out Boolean)
3577 Body_Decl
: Node_Id
;
3578 Spec_Decl
: Node_Id
;
3581 -- Assume that the pragma is illegal
3588 Check_Arg_Count
(1);
3589 Check_No_Identifiers
;
3591 if Nam_In
(Pname
, Name_Refined_Depends
,
3592 Name_Refined_Global
,
3595 Ensure_Aggregate_Form
(Arg1
);
3598 -- Verify the placement of the pragma and check for duplicates. The
3599 -- pragma must apply to a subprogram body [stub].
3601 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3603 -- Extract the entities of the spec and body
3605 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3606 Body_Id
:= Defining_Entity
(Body_Decl
);
3607 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3609 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3610 Body_Id
:= Defining_Entity
(Body_Decl
);
3611 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3618 -- The pragma must apply to the second declaration of a subprogram.
3619 -- In other words, the body [stub] cannot acts as a spec.
3621 if No
(Spec_Id
) then
3622 Error_Pragma
("pragma % cannot apply to a stand alone body");
3625 -- Catch the case where the subprogram body is a subunit and acts as
3626 -- the third declaration of the subprogram.
3628 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3629 Error_Pragma
("pragma % cannot apply to a subunit");
3633 -- The pragma can only apply to the body [stub] of a subprogram
3634 -- declared in the visible part of a package. Retrieve the context of
3635 -- the subprogram declaration.
3637 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3639 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3641 ("pragma % must apply to the body of a subprogram declared in a "
3642 & "package specification");
3646 -- If we get here, then the pragma is legal
3649 end Analyze_Refined_Pragma
;
3651 --------------------------
3652 -- Check_Ada_83_Warning --
3653 --------------------------
3655 procedure Check_Ada_83_Warning
is
3657 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3658 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3660 end Check_Ada_83_Warning
;
3662 ---------------------
3663 -- Check_Arg_Count --
3664 ---------------------
3666 procedure Check_Arg_Count
(Required
: Nat
) is
3668 if Arg_Count
/= Required
then
3669 Error_Pragma
("wrong number of arguments for pragma%");
3671 end Check_Arg_Count
;
3673 --------------------------------
3674 -- Check_Arg_Is_External_Name --
3675 --------------------------------
3677 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3678 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3681 if Nkind
(Argx
) = N_Identifier
then
3685 Analyze_And_Resolve
(Argx
, Standard_String
);
3687 if Is_OK_Static_Expression
(Argx
) then
3690 elsif Etype
(Argx
) = Any_Type
then
3693 -- An interesting special case, if we have a string literal and
3694 -- we are in Ada 83 mode, then we allow it even though it will
3695 -- not be flagged as static. This allows expected Ada 83 mode
3696 -- use of external names which are string literals, even though
3697 -- technically these are not static in Ada 83.
3699 elsif Ada_Version
= Ada_83
3700 and then Nkind
(Argx
) = N_String_Literal
3704 -- Static expression that raises Constraint_Error. This has
3705 -- already been flagged, so just exit from pragma processing.
3707 elsif Is_Static_Expression
(Argx
) then
3710 -- Here we have a real error (non-static expression)
3713 Error_Msg_Name_1
:= Pname
;
3716 Msg
: constant String :=
3717 "argument for pragma% must be a identifier or "
3718 & "static string expression!";
3720 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3725 end Check_Arg_Is_External_Name
;
3727 -----------------------------
3728 -- Check_Arg_Is_Identifier --
3729 -----------------------------
3731 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3732 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3734 if Nkind
(Argx
) /= N_Identifier
then
3736 ("argument for pragma% must be identifier", Argx
);
3738 end Check_Arg_Is_Identifier
;
3740 ----------------------------------
3741 -- Check_Arg_Is_Integer_Literal --
3742 ----------------------------------
3744 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3745 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3747 if Nkind
(Argx
) /= N_Integer_Literal
then
3749 ("argument for pragma% must be integer literal", Argx
);
3751 end Check_Arg_Is_Integer_Literal
;
3753 -------------------------------------------
3754 -- Check_Arg_Is_Library_Level_Local_Name --
3755 -------------------------------------------
3759 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3760 -- | library_unit_NAME
3762 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3764 Check_Arg_Is_Local_Name
(Arg
);
3766 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3767 and then Comes_From_Source
(N
)
3770 ("argument for pragma% must be library level entity", Arg
);
3772 end Check_Arg_Is_Library_Level_Local_Name
;
3774 -----------------------------
3775 -- Check_Arg_Is_Local_Name --
3776 -----------------------------
3780 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3781 -- | library_unit_NAME
3783 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3784 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3789 if Nkind
(Argx
) not in N_Direct_Name
3790 and then (Nkind
(Argx
) /= N_Attribute_Reference
3791 or else Present
(Expressions
(Argx
))
3792 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3793 and then (not Is_Entity_Name
(Argx
)
3794 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3796 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3799 -- No further check required if not an entity name
3801 if not Is_Entity_Name
(Argx
) then
3807 Ent
: constant Entity_Id
:= Entity
(Argx
);
3808 Scop
: constant Entity_Id
:= Scope
(Ent
);
3811 -- Case of a pragma applied to a compilation unit: pragma must
3812 -- occur immediately after the program unit in the compilation.
3814 if Is_Compilation_Unit
(Ent
) then
3816 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3819 -- Case of pragma placed immediately after spec
3821 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3824 -- Case of pragma placed immediately after body
3826 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3827 and then Present
(Corresponding_Body
(Decl
))
3831 (Parent
(Unit_Declaration_Node
3832 (Corresponding_Body
(Decl
))));
3834 -- All other cases are illegal
3841 -- Special restricted placement rule from 10.2.1(11.8/2)
3843 elsif Is_Generic_Formal
(Ent
)
3844 and then Prag_Id
= Pragma_Preelaborable_Initialization
3846 OK
:= List_Containing
(N
) =
3847 Generic_Formal_Declarations
3848 (Unit_Declaration_Node
(Scop
));
3850 -- If this is an aspect applied to a subprogram body, the
3851 -- pragma is inserted in its declarative part.
3853 elsif From_Aspect_Specification
(N
)
3855 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3856 and then Ent
= Current_Scope
3860 -- If the aspect is a predicate (possibly others ???) and the
3861 -- context is a record type, this is a discriminant expression
3862 -- within a type declaration, that freezes the predicated
3865 elsif From_Aspect_Specification
(N
)
3866 and then Prag_Id
= Pragma_Predicate
3867 and then Ekind
(Current_Scope
) = E_Record_Type
3868 and then Scop
= Scope
(Current_Scope
)
3872 -- Default case, just check that the pragma occurs in the scope
3873 -- of the entity denoted by the name.
3876 OK
:= Current_Scope
= Scop
;
3881 ("pragma% argument must be in same declarative part", Arg
);
3885 end Check_Arg_Is_Local_Name
;
3887 ---------------------------------
3888 -- Check_Arg_Is_Locking_Policy --
3889 ---------------------------------
3891 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3892 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3895 Check_Arg_Is_Identifier
(Argx
);
3897 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3898 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3900 end Check_Arg_Is_Locking_Policy
;
3902 -----------------------------------------------
3903 -- Check_Arg_Is_Partition_Elaboration_Policy --
3904 -----------------------------------------------
3906 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3907 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3910 Check_Arg_Is_Identifier
(Argx
);
3912 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3914 ("& is not a valid partition elaboration policy name", Argx
);
3916 end Check_Arg_Is_Partition_Elaboration_Policy
;
3918 -------------------------
3919 -- Check_Arg_Is_One_Of --
3920 -------------------------
3922 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3923 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3926 Check_Arg_Is_Identifier
(Argx
);
3928 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3929 Error_Msg_Name_2
:= N1
;
3930 Error_Msg_Name_3
:= N2
;
3931 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3933 end Check_Arg_Is_One_Of
;
3935 procedure Check_Arg_Is_One_Of
3937 N1
, N2
, N3
: Name_Id
)
3939 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3942 Check_Arg_Is_Identifier
(Argx
);
3944 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3945 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3947 end Check_Arg_Is_One_Of
;
3949 procedure Check_Arg_Is_One_Of
3951 N1
, N2
, N3
, N4
: Name_Id
)
3953 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3956 Check_Arg_Is_Identifier
(Argx
);
3958 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3959 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3961 end Check_Arg_Is_One_Of
;
3963 procedure Check_Arg_Is_One_Of
3965 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3967 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3970 Check_Arg_Is_Identifier
(Argx
);
3972 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3973 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3975 end Check_Arg_Is_One_Of
;
3977 ---------------------------------
3978 -- Check_Arg_Is_Queuing_Policy --
3979 ---------------------------------
3981 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3982 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3985 Check_Arg_Is_Identifier
(Argx
);
3987 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3988 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3990 end Check_Arg_Is_Queuing_Policy
;
3992 ------------------------------------
3993 -- Check_Arg_Is_Static_Expression --
3994 ------------------------------------
3996 procedure Check_Arg_Is_Static_Expression
3998 Typ
: Entity_Id
:= Empty
)
4001 Check_Expr_Is_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
4002 end Check_Arg_Is_Static_Expression
;
4004 ------------------------------------------
4005 -- Check_Arg_Is_Task_Dispatching_Policy --
4006 ------------------------------------------
4008 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4009 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4012 Check_Arg_Is_Identifier
(Argx
);
4014 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4016 ("& is not an allowed task dispatching policy name", Argx
);
4018 end Check_Arg_Is_Task_Dispatching_Policy
;
4020 ---------------------
4021 -- Check_Arg_Order --
4022 ---------------------
4024 procedure Check_Arg_Order
(Names
: Name_List
) is
4027 Highest_So_Far
: Natural := 0;
4028 -- Highest index in Names seen do far
4032 for J
in 1 .. Arg_Count
loop
4033 if Chars
(Arg
) /= No_Name
then
4034 for K
in Names
'Range loop
4035 if Chars
(Arg
) = Names
(K
) then
4036 if K
< Highest_So_Far
then
4037 Error_Msg_Name_1
:= Pname
;
4039 ("parameters out of order for pragma%", Arg
);
4040 Error_Msg_Name_1
:= Names
(K
);
4041 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4042 Error_Msg_N
("\% must appear before %", Arg
);
4046 Highest_So_Far
:= K
;
4054 end Check_Arg_Order
;
4056 --------------------------------
4057 -- Check_At_Least_N_Arguments --
4058 --------------------------------
4060 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4062 if Arg_Count
< N
then
4063 Error_Pragma
("too few arguments for pragma%");
4065 end Check_At_Least_N_Arguments
;
4067 -------------------------------
4068 -- Check_At_Most_N_Arguments --
4069 -------------------------------
4071 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4074 if Arg_Count
> N
then
4076 for J
in 1 .. N
loop
4078 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4081 end Check_At_Most_N_Arguments
;
4083 ---------------------
4084 -- Check_Component --
4085 ---------------------
4087 procedure Check_Component
4090 In_Variant_Part
: Boolean := False)
4092 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4093 Sindic
: constant Node_Id
:=
4094 Subtype_Indication
(Component_Definition
(Comp
));
4095 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4098 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4099 -- object constraint, then the component type shall be an Unchecked_
4102 if Nkind
(Sindic
) = N_Subtype_Indication
4103 and then Has_Per_Object_Constraint
(Comp_Id
)
4104 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4107 ("component subtype subject to per-object constraint "
4108 & "must be an Unchecked_Union", Comp
);
4110 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4111 -- the body of a generic unit, or within the body of any of its
4112 -- descendant library units, no part of the type of a component
4113 -- declared in a variant_part of the unchecked union type shall be of
4114 -- a formal private type or formal private extension declared within
4115 -- the formal part of the generic unit.
4117 elsif Ada_Version
>= Ada_2012
4118 and then In_Generic_Body
(UU_Typ
)
4119 and then In_Variant_Part
4120 and then Is_Private_Type
(Typ
)
4121 and then Is_Generic_Type
(Typ
)
4124 ("component of unchecked union cannot be of generic type", Comp
);
4126 elsif Needs_Finalization
(Typ
) then
4128 ("component of unchecked union cannot be controlled", Comp
);
4130 elsif Has_Task
(Typ
) then
4132 ("component of unchecked union cannot have tasks", Comp
);
4134 end Check_Component
;
4136 -----------------------------
4137 -- Check_Declaration_Order --
4138 -----------------------------
4140 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4141 procedure Check_Aspect_Specification_Order
;
4142 -- Inspect the aspect specifications of the context to determine the
4145 --------------------------------------
4146 -- Check_Aspect_Specification_Order --
4147 --------------------------------------
4149 procedure Check_Aspect_Specification_Order
is
4150 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4151 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4155 -- Both aspects must be part of the same aspect specification list
4158 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4160 -- Try to reach Second starting from First in a left to right
4161 -- traversal of the aspect specifications.
4163 Asp
:= Next
(Asp_First
);
4164 while Present
(Asp
) loop
4166 -- The order is ok, First is followed by Second
4168 if Asp
= Asp_Second
then
4175 -- If we get here, then the aspects are out of order
4177 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4178 end Check_Aspect_Specification_Order
;
4184 -- Start of processing for Check_Declaration_Order
4187 -- Cannot check the order if one of the pragmas is missing
4189 if No
(First
) or else No
(Second
) then
4193 -- Set up the error names in case the order is incorrect
4195 Error_Msg_Name_1
:= Pragma_Name
(First
);
4196 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4198 if From_Aspect_Specification
(First
) then
4200 -- Both pragmas are actually aspects, check their declaration
4201 -- order in the associated aspect specification list. Otherwise
4202 -- First is an aspect and Second a source pragma.
4204 if From_Aspect_Specification
(Second
) then
4205 Check_Aspect_Specification_Order
;
4208 -- Abstract_States is a source pragma
4211 if From_Aspect_Specification
(Second
) then
4212 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4214 -- Both pragmas are source constructs. Try to reach First from
4215 -- Second by traversing the declarations backwards.
4218 Stmt
:= Prev
(Second
);
4219 while Present
(Stmt
) loop
4221 -- The order is ok, First is followed by Second
4223 if Stmt
= First
then
4230 -- If we get here, then the pragmas are out of order
4232 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4235 end Check_Declaration_Order
;
4237 ----------------------------
4238 -- Check_Duplicate_Pragma --
4239 ----------------------------
4241 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4242 Id
: Entity_Id
:= E
;
4246 -- Nothing to do if this pragma comes from an aspect specification,
4247 -- since we could not be duplicating a pragma, and we dealt with the
4248 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4250 if From_Aspect_Specification
(N
) then
4254 -- Otherwise current pragma may duplicate previous pragma or a
4255 -- previously given aspect specification or attribute definition
4256 -- clause for the same pragma.
4258 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4262 -- If the entity is a type, then we have to make sure that the
4263 -- ostensible duplicate is not for a parent type from which this
4267 if Nkind
(P
) = N_Pragma
then
4269 Args
: constant List_Id
:=
4270 Pragma_Argument_Associations
(P
);
4273 and then Is_Entity_Name
(Expression
(First
(Args
)))
4274 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4275 and then Entity
(Expression
(First
(Args
))) /= E
4281 elsif Nkind
(P
) = N_Aspect_Specification
4282 and then Is_Type
(Entity
(P
))
4283 and then Entity
(P
) /= E
4289 -- Here we have a definite duplicate
4291 Error_Msg_Name_1
:= Pragma_Name
(N
);
4292 Error_Msg_Sloc
:= Sloc
(P
);
4294 -- For a single protected or a single task object, the error is
4295 -- issued on the original entity.
4297 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4298 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4301 if Nkind
(P
) = N_Aspect_Specification
4302 or else From_Aspect_Specification
(P
)
4304 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4306 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4311 end Check_Duplicate_Pragma
;
4313 ----------------------------------
4314 -- Check_Duplicated_Export_Name --
4315 ----------------------------------
4317 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4318 String_Val
: constant String_Id
:= Strval
(Nam
);
4321 -- We are only interested in the export case, and in the case of
4322 -- generics, it is the instance, not the template, that is the
4323 -- problem (the template will generate a warning in any case).
4325 if not Inside_A_Generic
4326 and then (Prag_Id
= Pragma_Export
4328 Prag_Id
= Pragma_Export_Procedure
4330 Prag_Id
= Pragma_Export_Valued_Procedure
4332 Prag_Id
= Pragma_Export_Function
)
4334 for J
in Externals
.First
.. Externals
.Last
loop
4335 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4336 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4337 Error_Msg_N
("external name duplicates name given#", Nam
);
4342 Externals
.Append
(Nam
);
4344 end Check_Duplicated_Export_Name
;
4346 -------------------------------------
4347 -- Check_Expr_Is_Static_Expression --
4348 -------------------------------------
4350 procedure Check_Expr_Is_Static_Expression
4352 Typ
: Entity_Id
:= Empty
)
4355 if Present
(Typ
) then
4356 Analyze_And_Resolve
(Expr
, Typ
);
4358 Analyze_And_Resolve
(Expr
);
4361 if Is_OK_Static_Expression
(Expr
) then
4364 elsif Etype
(Expr
) = Any_Type
then
4367 -- An interesting special case, if we have a string literal and we
4368 -- are in Ada 83 mode, then we allow it even though it will not be
4369 -- flagged as static. This allows the use of Ada 95 pragmas like
4370 -- Import in Ada 83 mode. They will of course be flagged with
4371 -- warnings as usual, but will not cause errors.
4373 elsif Ada_Version
= Ada_83
4374 and then Nkind
(Expr
) = N_String_Literal
4378 -- Static expression that raises Constraint_Error. This has already
4379 -- been flagged, so just exit from pragma processing.
4381 elsif Is_Static_Expression
(Expr
) then
4384 -- Finally, we have a real error
4387 Error_Msg_Name_1
:= Pname
;
4388 Flag_Non_Static_Expr
4389 (Fix_Error
("argument for pragma% must be a static expression!"),
4393 end Check_Expr_Is_Static_Expression
;
4395 -------------------------
4396 -- Check_First_Subtype --
4397 -------------------------
4399 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4400 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4401 Ent
: constant Entity_Id
:= Entity
(Argx
);
4404 if Is_First_Subtype
(Ent
) then
4407 elsif Is_Type
(Ent
) then
4409 ("pragma% cannot apply to subtype", Argx
);
4411 elsif Is_Object
(Ent
) then
4413 ("pragma% cannot apply to object, requires a type", Argx
);
4417 ("pragma% cannot apply to&, requires a type", Argx
);
4419 end Check_First_Subtype
;
4421 ----------------------
4422 -- Check_Identifier --
4423 ----------------------
4425 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4428 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4430 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4431 Error_Msg_Name_1
:= Pname
;
4432 Error_Msg_Name_2
:= Id
;
4433 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4437 end Check_Identifier
;
4439 --------------------------------
4440 -- Check_Identifier_Is_One_Of --
4441 --------------------------------
4443 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4446 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4448 if Chars
(Arg
) = No_Name
then
4449 Error_Msg_Name_1
:= Pname
;
4450 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4453 elsif Chars
(Arg
) /= N1
4454 and then Chars
(Arg
) /= N2
4456 Error_Msg_Name_1
:= Pname
;
4457 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4461 end Check_Identifier_Is_One_Of
;
4463 ---------------------------
4464 -- Check_In_Main_Program --
4465 ---------------------------
4467 procedure Check_In_Main_Program
is
4468 P
: constant Node_Id
:= Parent
(N
);
4471 -- Must be at in subprogram body
4473 if Nkind
(P
) /= N_Subprogram_Body
then
4474 Error_Pragma
("% pragma allowed only in subprogram");
4476 -- Otherwise warn if obviously not main program
4478 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4479 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4481 Error_Msg_Name_1
:= Pname
;
4483 ("??pragma% is only effective in main program", N
);
4485 end Check_In_Main_Program
;
4487 ---------------------------------------
4488 -- Check_Interrupt_Or_Attach_Handler --
4489 ---------------------------------------
4491 procedure Check_Interrupt_Or_Attach_Handler
is
4492 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4493 Handler_Proc
, Proc_Scope
: Entity_Id
;
4498 if Prag_Id
= Pragma_Interrupt_Handler
then
4499 Check_Restriction
(No_Dynamic_Attachment
, N
);
4502 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4503 Proc_Scope
:= Scope
(Handler_Proc
);
4505 -- On AAMP only, a pragma Interrupt_Handler is supported for
4506 -- nonprotected parameterless procedures.
4508 if not AAMP_On_Target
4509 or else Prag_Id
= Pragma_Attach_Handler
4511 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4513 ("argument of pragma% must be protected procedure", Arg1
);
4516 -- For pragma case (as opposed to access case), check placement.
4517 -- We don't need to do that for aspects, because we have the
4518 -- check that they aspect applies an appropriate procedure.
4520 if not From_Aspect_Specification
(N
)
4521 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4523 Error_Pragma
("pragma% must be in protected definition");
4527 if not Is_Library_Level_Entity
(Proc_Scope
)
4528 or else (AAMP_On_Target
4529 and then not Is_Library_Level_Entity
(Handler_Proc
))
4532 ("argument for pragma% must be library level entity", Arg1
);
4535 -- AI05-0033: A pragma cannot appear within a generic body, because
4536 -- instance can be in a nested scope. The check that protected type
4537 -- is itself a library-level declaration is done elsewhere.
4539 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4540 -- handle code prior to AI-0033. Analysis tools typically are not
4541 -- interested in this pragma in any case, so no need to worry too
4542 -- much about its placement.
4544 if Inside_A_Generic
then
4545 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4546 and then In_Package_Body
(Scope
(Current_Scope
))
4547 and then not Relaxed_RM_Semantics
4549 Error_Pragma
("pragma% cannot be used inside a generic");
4552 end Check_Interrupt_Or_Attach_Handler
;
4554 ---------------------------------
4555 -- Check_Loop_Pragma_Placement --
4556 ---------------------------------
4558 procedure Check_Loop_Pragma_Placement
is
4559 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4560 -- Verify whether the current pragma is properly grouped with other
4561 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4562 -- related loop where the pragma appears.
4564 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4565 -- Determine whether an arbitrary statement Stmt denotes pragma
4566 -- Loop_Invariant or Loop_Variant.
4568 procedure Placement_Error
(Constr
: Node_Id
);
4569 pragma No_Return
(Placement_Error
);
4570 -- Node Constr denotes the last loop restricted construct before we
4571 -- encountered an illegal relation between enclosing constructs. Emit
4572 -- an error depending on what Constr was.
4574 --------------------------------
4575 -- Check_Loop_Pragma_Grouping --
4576 --------------------------------
4578 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4579 Stop_Search
: exception;
4580 -- This exception is used to terminate the recursive descent of
4581 -- routine Check_Grouping.
4583 procedure Check_Grouping
(L
: List_Id
);
4584 -- Find the first group of pragmas in list L and if successful,
4585 -- ensure that the current pragma is part of that group. The
4586 -- routine raises Stop_Search once such a check is performed to
4587 -- halt the recursive descent.
4589 procedure Grouping_Error
(Prag
: Node_Id
);
4590 pragma No_Return
(Grouping_Error
);
4591 -- Emit an error concerning the current pragma indicating that it
4592 -- should be placed after pragma Prag.
4594 --------------------
4595 -- Check_Grouping --
4596 --------------------
4598 procedure Check_Grouping
(L
: List_Id
) is
4604 -- Inspect the list of declarations or statements looking for
4605 -- the first grouping of pragmas:
4608 -- pragma Loop_Invariant ...;
4609 -- pragma Loop_Variant ...;
4611 -- pragma Loop_Variant ...; -- current pragma
4613 -- If the current pragma is not in the grouping, then it must
4614 -- either appear in a different declarative or statement list
4615 -- or the construct at (1) is separating the pragma from the
4619 while Present
(Stmt
) loop
4621 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4622 -- inside a loop or a block housed inside a loop. Inspect
4623 -- the declarations and statements of the block as they may
4624 -- contain the first grouping.
4626 if Nkind
(Stmt
) = N_Block_Statement
then
4627 HSS
:= Handled_Statement_Sequence
(Stmt
);
4629 Check_Grouping
(Declarations
(Stmt
));
4631 if Present
(HSS
) then
4632 Check_Grouping
(Statements
(HSS
));
4635 -- First pragma of the first topmost grouping has been found
4637 elsif Is_Loop_Pragma
(Stmt
) then
4639 -- The group and the current pragma are not in the same
4640 -- declarative or statement list.
4642 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4643 Grouping_Error
(Stmt
);
4645 -- Try to reach the current pragma from the first pragma
4646 -- of the grouping while skipping other members:
4648 -- pragma Loop_Invariant ...; -- first pragma
4649 -- pragma Loop_Variant ...; -- member
4651 -- pragma Loop_Variant ...; -- current pragma
4654 while Present
(Stmt
) loop
4656 -- The current pragma is either the first pragma
4657 -- of the group or is a member of the group. Stop
4658 -- the search as the placement is legal.
4663 -- Skip group members, but keep track of the last
4664 -- pragma in the group.
4666 elsif Is_Loop_Pragma
(Stmt
) then
4669 -- A non-pragma is separating the group from the
4670 -- current pragma, the placement is illegal.
4673 Grouping_Error
(Prag
);
4679 -- If the traversal did not reach the current pragma,
4680 -- then the list must be malformed.
4682 raise Program_Error
;
4690 --------------------
4691 -- Grouping_Error --
4692 --------------------
4694 procedure Grouping_Error
(Prag
: Node_Id
) is
4696 Error_Msg_Sloc
:= Sloc
(Prag
);
4697 Error_Pragma
("pragma% must appear next to pragma#");
4700 -- Start of processing for Check_Loop_Pragma_Grouping
4703 -- Inspect the statements of the loop or nested blocks housed
4704 -- within to determine whether the current pragma is part of the
4705 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4707 Check_Grouping
(Statements
(Loop_Stmt
));
4710 when Stop_Search
=> null;
4711 end Check_Loop_Pragma_Grouping
;
4713 --------------------
4714 -- Is_Loop_Pragma --
4715 --------------------
4717 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4719 -- Inspect the original node as Loop_Invariant and Loop_Variant
4720 -- pragmas are rewritten to null when assertions are disabled.
4722 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4724 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4725 Name_Loop_Invariant
,
4732 ---------------------
4733 -- Placement_Error --
4734 ---------------------
4736 procedure Placement_Error
(Constr
: Node_Id
) is
4737 LA
: constant String := " with Loop_Entry";
4740 if Prag_Id
= Pragma_Assert
then
4741 Error_Msg_String
(1 .. LA
'Length) := LA
;
4742 Error_Msg_Strlen
:= LA
'Length;
4744 Error_Msg_Strlen
:= 0;
4747 if Nkind
(Constr
) = N_Pragma
then
4749 ("pragma %~ must appear immediately within the statements "
4753 ("block containing pragma %~ must appear immediately within "
4754 & "the statements of a loop", Constr
);
4756 end Placement_Error
;
4758 -- Local declarations
4763 -- Start of processing for Check_Loop_Pragma_Placement
4766 -- Check that pragma appears immediately within a loop statement,
4767 -- ignoring intervening block statements.
4771 while Present
(Stmt
) loop
4773 -- The pragma or previous block must appear immediately within the
4774 -- current block's declarative or statement part.
4776 if Nkind
(Stmt
) = N_Block_Statement
then
4777 if (No
(Declarations
(Stmt
))
4778 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4780 List_Containing
(Prev
) /=
4781 Statements
(Handled_Statement_Sequence
(Stmt
))
4783 Placement_Error
(Prev
);
4786 -- Keep inspecting the parents because we are now within a
4787 -- chain of nested blocks.
4791 Stmt
:= Parent
(Stmt
);
4794 -- The pragma or previous block must appear immediately within the
4795 -- statements of the loop.
4797 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4798 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4799 Placement_Error
(Prev
);
4802 -- Stop the traversal because we reached the innermost loop
4803 -- regardless of whether we encountered an error or not.
4807 -- Ignore a handled statement sequence. Note that this node may
4808 -- be related to a subprogram body in which case we will emit an
4809 -- error on the next iteration of the search.
4811 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4812 Stmt
:= Parent
(Stmt
);
4814 -- Any other statement breaks the chain from the pragma to the
4818 Placement_Error
(Prev
);
4823 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4824 -- grouped together with other such pragmas.
4826 if Is_Loop_Pragma
(N
) then
4828 -- The previous check should have located the related loop
4830 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4831 Check_Loop_Pragma_Grouping
(Stmt
);
4833 end Check_Loop_Pragma_Placement
;
4835 -------------------------------------------
4836 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4837 -------------------------------------------
4839 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4848 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4851 elsif Nkind_In
(P
, N_Package_Specification
,
4856 -- Note: the following tests seem a little peculiar, because
4857 -- they test for bodies, but if we were in the statement part
4858 -- of the body, we would already have hit the handled statement
4859 -- sequence, so the only way we get here is by being in the
4860 -- declarative part of the body.
4862 elsif Nkind_In
(P
, N_Subprogram_Body
,
4873 Error_Pragma
("pragma% is not in declarative part or package spec");
4874 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4876 -------------------------
4877 -- Check_No_Identifier --
4878 -------------------------
4880 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4882 if Nkind
(Arg
) = N_Pragma_Argument_Association
4883 and then Chars
(Arg
) /= No_Name
4885 Error_Pragma_Arg_Ident
4886 ("pragma% does not permit identifier& here", Arg
);
4888 end Check_No_Identifier
;
4890 --------------------------
4891 -- Check_No_Identifiers --
4892 --------------------------
4894 procedure Check_No_Identifiers
is
4898 for J
in 1 .. Arg_Count
loop
4899 Check_No_Identifier
(Arg_Node
);
4902 end Check_No_Identifiers
;
4904 ------------------------
4905 -- Check_No_Link_Name --
4906 ------------------------
4908 procedure Check_No_Link_Name
is
4910 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4914 if Present
(Arg4
) then
4916 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4918 end Check_No_Link_Name
;
4920 -------------------------------
4921 -- Check_Optional_Identifier --
4922 -------------------------------
4924 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4927 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4928 and then Chars
(Arg
) /= No_Name
4930 if Chars
(Arg
) /= Id
then
4931 Error_Msg_Name_1
:= Pname
;
4932 Error_Msg_Name_2
:= Id
;
4933 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4937 end Check_Optional_Identifier
;
4939 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4941 Name_Buffer
(1 .. Id
'Length) := Id
;
4942 Name_Len
:= Id
'Length;
4943 Check_Optional_Identifier
(Arg
, Name_Find
);
4944 end Check_Optional_Identifier
;
4946 --------------------
4947 -- Check_Pre_Post --
4948 --------------------
4950 procedure Check_Pre_Post
is
4955 if not Is_List_Member
(N
) then
4959 -- If we are within an inlined body, the legality of the pragma
4960 -- has been checked already.
4962 if In_Inlined_Body
then
4966 -- Search prior declarations
4969 while Present
(Prev
(P
)) loop
4972 -- If the previous node is a generic subprogram, do not go to to
4973 -- the original node, which is the unanalyzed tree: we need to
4974 -- attach the pre/postconditions to the analyzed version at this
4975 -- point. They get propagated to the original tree when analyzing
4976 -- the corresponding body.
4978 if Nkind
(P
) not in N_Generic_Declaration
then
4979 PO
:= Original_Node
(P
);
4984 -- Skip past prior pragma
4986 if Nkind
(PO
) = N_Pragma
then
4989 -- Skip stuff not coming from source
4991 elsif not Comes_From_Source
(PO
) then
4993 -- The condition may apply to a subprogram instantiation
4995 if Nkind
(PO
) = N_Subprogram_Declaration
4996 and then Present
(Generic_Parent
(Specification
(PO
)))
5000 elsif Nkind
(PO
) = N_Subprogram_Declaration
5001 and then In_Instance
5005 -- For all other cases of non source code, do nothing
5011 -- Only remaining possibility is subprogram declaration
5018 -- If we fall through loop, pragma is at start of list, so see if it
5019 -- is at the start of declarations of a subprogram body.
5023 if Nkind
(PO
) = N_Subprogram_Body
5024 and then List_Containing
(N
) = Declarations
(PO
)
5026 -- This is only allowed if there is no separate specification
5028 if Present
(Corresponding_Spec
(PO
)) then
5030 ("pragma% must apply to subprogram specification");
5037 --------------------------------------
5038 -- Check_Precondition_Postcondition --
5039 --------------------------------------
5041 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
5045 procedure Chain_PPC
(PO
: Node_Id
);
5046 -- If PO is an entry or a [generic] subprogram declaration node, then
5047 -- the precondition/postcondition applies to this subprogram and the
5048 -- processing for the pragma is completed. Otherwise the pragma is
5055 procedure Chain_PPC
(PO
: Node_Id
) is
5059 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5060 if not From_Aspect_Specification
(N
) then
5062 ("pragma% cannot be applied to abstract subprogram");
5064 elsif Class_Present
(N
) then
5069 ("aspect % requires ''Class for abstract subprogram");
5072 -- AI05-0230: The same restriction applies to null procedures. For
5073 -- compatibility with earlier uses of the Ada pragma, apply this
5074 -- rule only to aspect specifications.
5076 -- The above discrepency needs documentation. Robert is dubious
5077 -- about whether it is a good idea ???
5079 elsif Nkind
(PO
) = N_Subprogram_Declaration
5080 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
5081 and then Null_Present
(Specification
(PO
))
5082 and then From_Aspect_Specification
(N
)
5083 and then not Class_Present
(N
)
5086 ("aspect % requires ''Class for null procedure");
5088 -- Pre/postconditions are legal on a subprogram body if it is not
5089 -- a completion of a declaration. They are also legal on a stub
5090 -- with no previous declarations (this is checked when processing
5091 -- the corresponding aspects).
5093 elsif Nkind
(PO
) = N_Subprogram_Body
5094 and then Acts_As_Spec
(PO
)
5098 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
5101 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5102 N_Expression_Function
,
5103 N_Generic_Subprogram_Declaration
,
5104 N_Entry_Declaration
)
5109 -- Here if we have [generic] subprogram or entry declaration
5111 if Nkind
(PO
) = N_Entry_Declaration
then
5112 S
:= Defining_Entity
(PO
);
5114 S
:= Defining_Unit_Name
(Specification
(PO
));
5116 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5117 S
:= Defining_Identifier
(S
);
5121 -- Note: we do not analyze the pragma at this point. Instead we
5122 -- delay this analysis until the end of the declarative part in
5123 -- which the pragma appears. This implements the required delay
5124 -- in this analysis, allowing forward references. The analysis
5125 -- happens at the end of Analyze_Declarations.
5127 -- Chain spec PPC pragma to list for subprogram
5129 Add_Contract_Item
(N
, S
);
5131 -- Return indicating spec case
5137 -- Start of processing for Check_Precondition_Postcondition
5140 if not Is_List_Member
(N
) then
5144 -- Preanalyze message argument if present. Visibility in this
5145 -- argument is established at the point of pragma occurrence.
5147 if Arg_Count
= 2 then
5148 Check_Optional_Identifier
(Arg2
, Name_Message
);
5149 Preanalyze_Spec_Expression
5150 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5153 -- For a pragma PPC in the extended main source unit, record enabled
5156 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5157 Set_SCO_Pragma_Enabled
(Loc
);
5160 -- If we are within an inlined body, the legality of the pragma
5161 -- has been checked already.
5163 if In_Inlined_Body
then
5168 -- Search prior declarations
5171 while Present
(Prev
(P
)) loop
5174 -- If the previous node is a generic subprogram, do not go to to
5175 -- the original node, which is the unanalyzed tree: we need to
5176 -- attach the pre/postconditions to the analyzed version at this
5177 -- point. They get propagated to the original tree when analyzing
5178 -- the corresponding body.
5180 if Nkind
(P
) not in N_Generic_Declaration
then
5181 PO
:= Original_Node
(P
);
5186 -- Skip past prior pragma
5188 if Nkind
(PO
) = N_Pragma
then
5191 -- Skip stuff not coming from source
5193 elsif not Comes_From_Source
(PO
) then
5195 -- The condition may apply to a subprogram instantiation
5197 if Nkind
(PO
) = N_Subprogram_Declaration
5198 and then Present
(Generic_Parent
(Specification
(PO
)))
5203 elsif Nkind
(PO
) = N_Subprogram_Declaration
5204 and then In_Instance
5209 -- For all other cases of non source code, do nothing
5215 -- Only remaining possibility is subprogram declaration
5223 -- If we fall through loop, pragma is at start of list, so see if it
5224 -- is at the start of declarations of a subprogram body.
5228 if Nkind
(PO
) = N_Subprogram_Body
5229 and then List_Containing
(N
) = Declarations
(PO
)
5231 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5233 -- Analyze pragma expression for correctness and for ASIS use
5235 Preanalyze_Assert_Expression
5236 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5238 -- In ASIS mode, for a pragma generated from a source aspect,
5239 -- also analyze the original aspect expression.
5241 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5242 Preanalyze_Assert_Expression
5243 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5247 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5248 -- The copy is needed because the pragma is expanded into other
5249 -- constructs which are not acceptable in the N_Contract node.
5251 if Acts_As_Spec
(PO
)
5252 and then GNATprove_Mode
5255 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5258 -- Preanalyze the pragma
5260 Preanalyze_Assert_Expression
5262 (First
(Pragma_Argument_Associations
(Prag
))),
5265 -- Preanalyze the corresponding aspect (if any)
5267 if Present
(Corresponding_Aspect
(Prag
)) then
5268 Preanalyze_Assert_Expression
5269 (Expression
(Corresponding_Aspect
(Prag
)),
5273 -- Chain the copy on the contract of the body
5276 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5283 -- See if it is in the pragmas after a library level subprogram
5285 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5287 -- In GNATprove mode, analyze pragma expression for correctness,
5288 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5289 -- no later point at which the aspect will be analyzed.
5291 if GNATprove_Mode
or ASIS_Mode
then
5292 Analyze_Pre_Post_Condition_In_Decl_Part
5293 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5296 Chain_PPC
(Unit
(Parent
(PO
)));
5300 -- If we fall through, pragma was misplaced
5303 end Check_Precondition_Postcondition
;
5305 -----------------------------
5306 -- Check_Static_Constraint --
5307 -----------------------------
5309 -- Note: for convenience in writing this procedure, in addition to
5310 -- the officially (i.e. by spec) allowed argument which is always a
5311 -- constraint, it also allows ranges and discriminant associations.
5312 -- Above is not clear ???
5314 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5316 procedure Require_Static
(E
: Node_Id
);
5317 -- Require given expression to be static expression
5319 --------------------
5320 -- Require_Static --
5321 --------------------
5323 procedure Require_Static
(E
: Node_Id
) is
5325 if not Is_OK_Static_Expression
(E
) then
5326 Flag_Non_Static_Expr
5327 ("non-static constraint not allowed in Unchecked_Union!", E
);
5332 -- Start of processing for Check_Static_Constraint
5335 case Nkind
(Constr
) is
5336 when N_Discriminant_Association
=>
5337 Require_Static
(Expression
(Constr
));
5340 Require_Static
(Low_Bound
(Constr
));
5341 Require_Static
(High_Bound
(Constr
));
5343 when N_Attribute_Reference
=>
5344 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5345 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5347 when N_Range_Constraint
=>
5348 Check_Static_Constraint
(Range_Expression
(Constr
));
5350 when N_Index_Or_Discriminant_Constraint
=>
5354 IDC
:= First
(Constraints
(Constr
));
5355 while Present
(IDC
) loop
5356 Check_Static_Constraint
(IDC
);
5364 end Check_Static_Constraint
;
5366 ---------------------
5367 -- Check_Test_Case --
5368 ---------------------
5370 procedure Check_Test_Case
is
5374 procedure Chain_CTC
(PO
: Node_Id
);
5375 -- If PO is a [generic] subprogram declaration node, then the
5376 -- test-case applies to this subprogram and the processing for
5377 -- the pragma is completed. Otherwise the pragma is misplaced.
5383 procedure Chain_CTC
(PO
: Node_Id
) is
5387 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5389 ("pragma% cannot be applied to abstract subprogram");
5391 elsif Nkind
(PO
) = N_Entry_Declaration
then
5392 Error_Pragma
("pragma% cannot be applied to entry");
5394 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5395 N_Generic_Subprogram_Declaration
)
5400 -- Here if we have [generic] subprogram declaration
5402 S
:= Defining_Unit_Name
(Specification
(PO
));
5404 -- Note: we do not analyze the pragma at this point. Instead we
5405 -- delay this analysis until the end of the declarative part in
5406 -- which the pragma appears. This implements the required delay
5407 -- in this analysis, allowing forward references. The analysis
5408 -- happens at the end of Analyze_Declarations.
5410 -- There should not be another test-case with the same name
5411 -- associated to this subprogram.
5414 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5418 CTC
:= Contract_Test_Cases
(Contract
(S
));
5419 while Present
(CTC
) loop
5421 -- Omit pragma Contract_Cases because it does not introduce
5422 -- a unique case name and it does not follow the syntax of
5425 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5429 (Name
, Get_Name_From_CTC_Pragma
(CTC
))
5431 Error_Msg_Sloc
:= Sloc
(CTC
);
5432 Error_Pragma
("name for pragma% is already used#");
5435 CTC
:= Next_Pragma
(CTC
);
5439 -- Chain spec CTC pragma to list for subprogram
5441 Add_Contract_Item
(N
, S
);
5444 -- Start of processing for Check_Test_Case
5447 -- First check pragma arguments
5449 Check_At_Least_N_Arguments
(2);
5450 Check_At_Most_N_Arguments
(4);
5452 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5454 Check_Optional_Identifier
(Arg1
, Name_Name
);
5455 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
5457 -- In ASIS mode, for a pragma generated from a source aspect, also
5458 -- analyze the original aspect expression.
5460 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5461 Check_Expr_Is_Static_Expression
5462 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5465 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5466 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5468 if Arg_Count
= 4 then
5469 Check_Identifier
(Arg3
, Name_Requires
);
5470 Check_Identifier
(Arg4
, Name_Ensures
);
5472 elsif Arg_Count
= 3 then
5473 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5476 -- Check pragma placement
5478 if not Is_List_Member
(N
) then
5482 -- Test-case should only appear in package spec unit
5484 if Get_Source_Unit
(N
) = No_Unit
5485 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Get_Source_Unit
(N
))),
5486 N_Package_Declaration
,
5487 N_Generic_Package_Declaration
)
5492 -- Search prior declarations
5495 while Present
(Prev
(P
)) loop
5498 -- If the previous node is a generic subprogram, do not go to to
5499 -- the original node, which is the unanalyzed tree: we need to
5500 -- attach the test-case to the analyzed version at this point.
5501 -- They get propagated to the original tree when analyzing the
5502 -- corresponding body.
5504 if Nkind
(P
) not in N_Generic_Declaration
then
5505 PO
:= Original_Node
(P
);
5510 -- Skip past prior pragma
5512 if Nkind
(PO
) = N_Pragma
then
5515 -- Skip stuff not coming from source
5517 elsif not Comes_From_Source
(PO
) then
5520 -- Only remaining possibility is subprogram declaration. First
5521 -- check that it is declared directly in a package declaration.
5522 -- This may be either the package declaration for the current unit
5523 -- being defined or a local package declaration.
5525 elsif not Present
(Parent
(Parent
(PO
)))
5526 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5527 or else not Nkind_In
(Parent
(Parent
(PO
)),
5528 N_Package_Declaration
,
5529 N_Generic_Package_Declaration
)
5539 -- If we fall through, pragma was misplaced
5542 end Check_Test_Case
;
5544 --------------------------------------
5545 -- Check_Valid_Configuration_Pragma --
5546 --------------------------------------
5548 -- A configuration pragma must appear in the context clause of a
5549 -- compilation unit, and only other pragmas may precede it. Note that
5550 -- the test also allows use in a configuration pragma file.
5552 procedure Check_Valid_Configuration_Pragma
is
5554 if not Is_Configuration_Pragma
then
5555 Error_Pragma
("incorrect placement for configuration pragma%");
5557 end Check_Valid_Configuration_Pragma
;
5559 -------------------------------------
5560 -- Check_Valid_Library_Unit_Pragma --
5561 -------------------------------------
5563 procedure Check_Valid_Library_Unit_Pragma
is
5565 Parent_Node
: Node_Id
;
5566 Unit_Name
: Entity_Id
;
5567 Unit_Kind
: Node_Kind
;
5568 Unit_Node
: Node_Id
;
5569 Sindex
: Source_File_Index
;
5572 if not Is_List_Member
(N
) then
5576 Plist
:= List_Containing
(N
);
5577 Parent_Node
:= Parent
(Plist
);
5579 if Parent_Node
= Empty
then
5582 -- Case of pragma appearing after a compilation unit. In this case
5583 -- it must have an argument with the corresponding name and must
5584 -- be part of the following pragmas of its parent.
5586 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5587 if Plist
/= Pragmas_After
(Parent_Node
) then
5590 elsif Arg_Count
= 0 then
5592 ("argument required if outside compilation unit");
5595 Check_No_Identifiers
;
5596 Check_Arg_Count
(1);
5597 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5598 Unit_Kind
:= Nkind
(Unit_Node
);
5600 Analyze
(Get_Pragma_Arg
(Arg1
));
5602 if Unit_Kind
= N_Generic_Subprogram_Declaration
5603 or else Unit_Kind
= N_Subprogram_Declaration
5605 Unit_Name
:= Defining_Entity
(Unit_Node
);
5607 elsif Unit_Kind
in N_Generic_Instantiation
then
5608 Unit_Name
:= Defining_Entity
(Unit_Node
);
5611 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5614 if Chars
(Unit_Name
) /=
5615 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5618 ("pragma% argument is not current unit name", Arg1
);
5621 if Ekind
(Unit_Name
) = E_Package
5622 and then Present
(Renamed_Entity
(Unit_Name
))
5624 Error_Pragma
("pragma% not allowed for renamed package");
5628 -- Pragma appears other than after a compilation unit
5631 -- Here we check for the generic instantiation case and also
5632 -- for the case of processing a generic formal package. We
5633 -- detect these cases by noting that the Sloc on the node
5634 -- does not belong to the current compilation unit.
5636 Sindex
:= Source_Index
(Current_Sem_Unit
);
5638 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5639 Rewrite
(N
, Make_Null_Statement
(Loc
));
5642 -- If before first declaration, the pragma applies to the
5643 -- enclosing unit, and the name if present must be this name.
5645 elsif Is_Before_First_Decl
(N
, Plist
) then
5646 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5647 Unit_Kind
:= Nkind
(Unit_Node
);
5649 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5652 elsif Unit_Kind
= N_Subprogram_Body
5653 and then not Acts_As_Spec
(Unit_Node
)
5657 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5660 elsif Nkind
(Parent_Node
) = N_Package_Specification
5661 and then Plist
= Private_Declarations
(Parent_Node
)
5665 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5666 or else Nkind
(Parent_Node
) =
5667 N_Generic_Subprogram_Declaration
)
5668 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5672 elsif Arg_Count
> 0 then
5673 Analyze
(Get_Pragma_Arg
(Arg1
));
5675 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5677 ("name in pragma% must be enclosing unit", Arg1
);
5680 -- It is legal to have no argument in this context
5686 -- Error if not before first declaration. This is because a
5687 -- library unit pragma argument must be the name of a library
5688 -- unit (RM 10.1.5(7)), but the only names permitted in this
5689 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5690 -- generic subprogram declarations or generic instantiations.
5694 ("pragma% misplaced, must be before first declaration");
5698 end Check_Valid_Library_Unit_Pragma
;
5704 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5705 Clist
: constant Node_Id
:= Component_List
(Variant
);
5709 Comp
:= First
(Component_Items
(Clist
));
5710 while Present
(Comp
) loop
5711 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5716 ---------------------------
5717 -- Ensure_Aggregate_Form --
5718 ---------------------------
5720 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5721 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5722 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5723 Nam
: constant Name_Id
:= Chars
(Arg
);
5724 Comps
: List_Id
:= No_List
;
5725 Exprs
: List_Id
:= No_List
;
5728 -- The argument is already in aggregate form, but the presence of a
5729 -- name causes this to be interpreted as a named association which in
5730 -- turn must be converted into an aggregate.
5732 -- pragma Global (In_Out => (A, B, C))
5736 -- pragma Global ((In_Out => (A, B, C)))
5738 -- aggregate aggregate
5740 if Nkind
(Expr
) = N_Aggregate
then
5741 if Nam
= No_Name
then
5745 -- Do not transform a null argument into an aggregate as N_Null has
5746 -- special meaning in formal verification pragmas.
5748 elsif Nkind
(Expr
) = N_Null
then
5752 -- Positional argument is transformed into an aggregate with an
5753 -- Expressions list.
5755 if Nam
= No_Name
then
5756 Exprs
:= New_List
(Relocate_Node
(Expr
));
5758 -- An associative argument is transformed into an aggregate with
5759 -- Component_Associations.
5763 Make_Component_Association
(Loc
,
5764 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5765 Expression
=> Relocate_Node
(Expr
)));
5769 -- Remove the pragma argument name as this information has been
5770 -- captured in the aggregate.
5772 Set_Chars
(Arg
, No_Name
);
5774 Set_Expression
(Arg
,
5775 Make_Aggregate
(Loc
,
5776 Component_Associations
=> Comps
,
5777 Expressions
=> Exprs
));
5778 end Ensure_Aggregate_Form
;
5784 procedure Error_Pragma
(Msg
: String) is
5786 Error_Msg_Name_1
:= Pname
;
5787 Error_Msg_N
(Fix_Error
(Msg
), N
);
5791 ----------------------
5792 -- Error_Pragma_Arg --
5793 ----------------------
5795 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5797 Error_Msg_Name_1
:= Pname
;
5798 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5800 end Error_Pragma_Arg
;
5802 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5804 Error_Msg_Name_1
:= Pname
;
5805 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5806 Error_Pragma_Arg
(Msg2
, Arg
);
5807 end Error_Pragma_Arg
;
5809 ----------------------------
5810 -- Error_Pragma_Arg_Ident --
5811 ----------------------------
5813 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5815 Error_Msg_Name_1
:= Pname
;
5816 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5818 end Error_Pragma_Arg_Ident
;
5820 ----------------------
5821 -- Error_Pragma_Ref --
5822 ----------------------
5824 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5826 Error_Msg_Name_1
:= Pname
;
5827 Error_Msg_Sloc
:= Sloc
(Ref
);
5828 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5830 end Error_Pragma_Ref
;
5832 ------------------------
5833 -- Find_Lib_Unit_Name --
5834 ------------------------
5836 function Find_Lib_Unit_Name
return Entity_Id
is
5838 -- Return inner compilation unit entity, for case of nested
5839 -- categorization pragmas. This happens in generic unit.
5841 if Nkind
(Parent
(N
)) = N_Package_Specification
5842 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5844 return Defining_Entity
(Parent
(N
));
5846 return Current_Scope
;
5848 end Find_Lib_Unit_Name
;
5850 ----------------------------
5851 -- Find_Program_Unit_Name --
5852 ----------------------------
5854 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5855 Unit_Name
: Entity_Id
;
5856 Unit_Kind
: Node_Kind
;
5857 P
: constant Node_Id
:= Parent
(N
);
5860 if Nkind
(P
) = N_Compilation_Unit
then
5861 Unit_Kind
:= Nkind
(Unit
(P
));
5863 if Unit_Kind
= N_Subprogram_Declaration
5864 or else Unit_Kind
= N_Package_Declaration
5865 or else Unit_Kind
in N_Generic_Declaration
5867 Unit_Name
:= Defining_Entity
(Unit
(P
));
5869 if Chars
(Id
) = Chars
(Unit_Name
) then
5870 Set_Entity
(Id
, Unit_Name
);
5871 Set_Etype
(Id
, Etype
(Unit_Name
));
5873 Set_Etype
(Id
, Any_Type
);
5875 ("cannot find program unit referenced by pragma%");
5879 Set_Etype
(Id
, Any_Type
);
5880 Error_Pragma
("pragma% inapplicable to this unit");
5886 end Find_Program_Unit_Name
;
5888 -----------------------------------------
5889 -- Find_Unique_Parameterless_Procedure --
5890 -----------------------------------------
5892 function Find_Unique_Parameterless_Procedure
5894 Arg
: Node_Id
) return Entity_Id
5896 Proc
: Entity_Id
:= Empty
;
5899 -- The body of this procedure needs some comments ???
5901 if not Is_Entity_Name
(Name
) then
5903 ("argument of pragma% must be entity name", Arg
);
5905 elsif not Is_Overloaded
(Name
) then
5906 Proc
:= Entity
(Name
);
5908 if Ekind
(Proc
) /= E_Procedure
5909 or else Present
(First_Formal
(Proc
))
5912 ("argument of pragma% must be parameterless procedure", Arg
);
5917 Found
: Boolean := False;
5919 Index
: Interp_Index
;
5922 Get_First_Interp
(Name
, Index
, It
);
5923 while Present
(It
.Nam
) loop
5926 if Ekind
(Proc
) = E_Procedure
5927 and then No
(First_Formal
(Proc
))
5931 Set_Entity
(Name
, Proc
);
5932 Set_Is_Overloaded
(Name
, False);
5935 ("ambiguous handler name for pragma% ", Arg
);
5939 Get_Next_Interp
(Index
, It
);
5944 ("argument of pragma% must be parameterless procedure",
5947 Proc
:= Entity
(Name
);
5953 end Find_Unique_Parameterless_Procedure
;
5959 function Fix_Error
(Msg
: String) return String is
5960 Res
: String (Msg
'Range) := Msg
;
5961 Res_Last
: Natural := Msg
'Last;
5965 -- If we have a rewriting of another pragma, go to that pragma
5967 if Is_Rewrite_Substitution
(N
)
5968 and then Nkind
(Original_Node
(N
)) = N_Pragma
5970 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5973 -- Case where pragma comes from an aspect specification
5975 if From_Aspect_Specification
(N
) then
5977 -- Change appearence of "pragma" in message to "aspect"
5980 while J
<= Res_Last
- 5 loop
5981 if Res
(J
.. J
+ 5) = "pragma" then
5982 Res
(J
.. J
+ 5) := "aspect";
5990 -- Change "argument of" at start of message to "entity for"
5993 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5995 Res
(Res
'First .. Res
'First + 9) := "entity for";
5996 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5997 Res
(Res
'First + 11 .. Res_Last
);
5998 Res_Last
:= Res_Last
- 1;
6001 -- Change "argument" at start of message to "entity"
6004 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6006 Res
(Res
'First .. Res
'First + 5) := "entity";
6007 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6008 Res
(Res
'First + 8 .. Res_Last
);
6009 Res_Last
:= Res_Last
- 2;
6012 -- Get name from corresponding aspect
6014 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
6017 -- Return possibly modified message
6019 return Res
(Res
'First .. Res_Last
);
6022 -------------------------
6023 -- Gather_Associations --
6024 -------------------------
6026 procedure Gather_Associations
6028 Args
: out Args_List
)
6033 -- Initialize all parameters to Empty
6035 for J
in Args
'Range loop
6039 -- That's all we have to do if there are no argument associations
6041 if No
(Pragma_Argument_Associations
(N
)) then
6045 -- Otherwise first deal with any positional parameters present
6047 Arg
:= First
(Pragma_Argument_Associations
(N
));
6048 for Index
in Args
'Range loop
6049 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6050 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6054 -- Positional parameters all processed, if any left, then we
6055 -- have too many positional parameters.
6057 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6059 ("too many positional associations for pragma%", Arg
);
6062 -- Process named parameters if any are present
6064 while Present
(Arg
) loop
6065 if Chars
(Arg
) = No_Name
then
6067 ("positional association cannot follow named association",
6071 for Index
in Names
'Range loop
6072 if Names
(Index
) = Chars
(Arg
) then
6073 if Present
(Args
(Index
)) then
6075 ("duplicate argument association for pragma%", Arg
);
6077 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6082 if Index
= Names
'Last then
6083 Error_Msg_Name_1
:= Pname
;
6084 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6086 -- Check for possible misspelling
6088 for Index1
in Names
'Range loop
6089 if Is_Bad_Spelling_Of
6090 (Chars
(Arg
), Names
(Index1
))
6092 Error_Msg_Name_1
:= Names
(Index1
);
6093 Error_Msg_N
-- CODEFIX
6094 ("\possible misspelling of%", Arg
);
6106 end Gather_Associations
;
6112 procedure GNAT_Pragma
is
6114 -- We need to check the No_Implementation_Pragmas restriction for
6115 -- the case of a pragma from source. Note that the case of aspects
6116 -- generating corresponding pragmas marks these pragmas as not being
6117 -- from source, so this test also catches that case.
6119 if Comes_From_Source
(N
) then
6120 Check_Restriction
(No_Implementation_Pragmas
, N
);
6124 --------------------------
6125 -- Is_Before_First_Decl --
6126 --------------------------
6128 function Is_Before_First_Decl
6129 (Pragma_Node
: Node_Id
;
6130 Decls
: List_Id
) return Boolean
6132 Item
: Node_Id
:= First
(Decls
);
6135 -- Only other pragmas can come before this pragma
6138 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6141 elsif Item
= Pragma_Node
then
6147 end Is_Before_First_Decl
;
6149 -----------------------------
6150 -- Is_Configuration_Pragma --
6151 -----------------------------
6153 -- A configuration pragma must appear in the context clause of a
6154 -- compilation unit, and only other pragmas may precede it. Note that
6155 -- the test below also permits use in a configuration pragma file.
6157 function Is_Configuration_Pragma
return Boolean is
6158 Lis
: constant List_Id
:= List_Containing
(N
);
6159 Par
: constant Node_Id
:= Parent
(N
);
6163 -- If no parent, then we are in the configuration pragma file,
6164 -- so the placement is definitely appropriate.
6169 -- Otherwise we must be in the context clause of a compilation unit
6170 -- and the only thing allowed before us in the context list is more
6171 -- configuration pragmas.
6173 elsif Nkind
(Par
) = N_Compilation_Unit
6174 and then Context_Items
(Par
) = Lis
6181 elsif Nkind
(Prg
) /= N_Pragma
then
6191 end Is_Configuration_Pragma
;
6193 --------------------------
6194 -- Is_In_Context_Clause --
6195 --------------------------
6197 function Is_In_Context_Clause
return Boolean is
6199 Parent_Node
: Node_Id
;
6202 if not Is_List_Member
(N
) then
6206 Plist
:= List_Containing
(N
);
6207 Parent_Node
:= Parent
(Plist
);
6209 if Parent_Node
= Empty
6210 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6211 or else Context_Items
(Parent_Node
) /= Plist
6218 end Is_In_Context_Clause
;
6220 ---------------------------------
6221 -- Is_Static_String_Expression --
6222 ---------------------------------
6224 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6225 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6228 Analyze_And_Resolve
(Argx
);
6229 return Is_OK_Static_Expression
(Argx
)
6230 and then Nkind
(Argx
) = N_String_Literal
;
6231 end Is_Static_String_Expression
;
6233 ----------------------
6234 -- Pragma_Misplaced --
6235 ----------------------
6237 procedure Pragma_Misplaced
is
6239 Error_Pragma
("incorrect placement of pragma%");
6240 end Pragma_Misplaced
;
6242 ------------------------------------
6243 -- Process_Atomic_Shared_Volatile --
6244 ------------------------------------
6246 procedure Process_Atomic_Shared_Volatile
is
6253 procedure Set_Atomic
(E
: Entity_Id
);
6254 -- Set given type as atomic, and if no explicit alignment was given,
6255 -- set alignment to unknown, since back end knows what the alignment
6256 -- requirements are for atomic arrays. Note: this step is necessary
6257 -- for derived types.
6263 procedure Set_Atomic
(E
: Entity_Id
) is
6267 if not Has_Alignment_Clause
(E
) then
6268 Set_Alignment
(E
, Uint_0
);
6272 -- Start of processing for Process_Atomic_Shared_Volatile
6275 Check_Ada_83_Warning
;
6276 Check_No_Identifiers
;
6277 Check_Arg_Count
(1);
6278 Check_Arg_Is_Local_Name
(Arg1
);
6279 E_Id
:= Get_Pragma_Arg
(Arg1
);
6281 if Etype
(E_Id
) = Any_Type
then
6286 D
:= Declaration_Node
(E
);
6289 -- Check duplicate before we chain ourselves
6291 Check_Duplicate_Pragma
(E
);
6293 -- Now check appropriateness of the entity
6296 if Rep_Item_Too_Early
(E
, N
)
6298 Rep_Item_Too_Late
(E
, N
)
6302 Check_First_Subtype
(Arg1
);
6305 if Prag_Id
/= Pragma_Volatile
then
6307 Set_Atomic
(Underlying_Type
(E
));
6308 Set_Atomic
(Base_Type
(E
));
6311 -- Attribute belongs on the base type. If the view of the type is
6312 -- currently private, it also belongs on the underlying type.
6314 Set_Is_Volatile
(Base_Type
(E
));
6315 Set_Is_Volatile
(Underlying_Type
(E
));
6317 Set_Treat_As_Volatile
(E
);
6318 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6320 -- The following check is only relevant when SPARK_Mode is on as
6321 -- this is not a standard Ada legality rule. Volatile types are
6322 -- not allowed (SPARK RM C.6(1)).
6324 if SPARK_Mode
= On
and then Prag_Id
= Pragma_Volatile
then
6325 Error_Msg_N
("volatile type not allowed", E
);
6328 elsif K
= N_Object_Declaration
6329 or else (K
= N_Component_Declaration
6330 and then Original_Record_Component
(E
) = E
)
6332 if Rep_Item_Too_Late
(E
, N
) then
6336 if Prag_Id
/= Pragma_Volatile
then
6339 -- If the object declaration has an explicit initialization, a
6340 -- temporary may have to be created to hold the expression, to
6341 -- ensure that access to the object remain atomic.
6343 if Nkind
(Parent
(E
)) = N_Object_Declaration
6344 and then Present
(Expression
(Parent
(E
)))
6346 Set_Has_Delayed_Freeze
(E
);
6349 -- An interesting improvement here. If an object of composite
6350 -- type X is declared atomic, and the type X isn't, that's a
6351 -- pity, since it may not have appropriate alignment etc. We
6352 -- can rescue this in the special case where the object and
6353 -- type are in the same unit by just setting the type as
6354 -- atomic, so that the back end will process it as atomic.
6356 -- Note: we used to do this for elementary types as well,
6357 -- but that turns out to be a bad idea and can have unwanted
6358 -- effects, most notably if the type is elementary, the object
6359 -- a simple component within a record, and both are in a spec:
6360 -- every object of this type in the entire program will be
6361 -- treated as atomic, thus incurring a potentially costly
6362 -- synchronization operation for every access.
6364 -- Of course it would be best if the back end could just adjust
6365 -- the alignment etc for the specific object, but that's not
6366 -- something we are capable of doing at this point.
6368 Utyp
:= Underlying_Type
(Etype
(E
));
6371 and then Is_Composite_Type
(Utyp
)
6372 and then Sloc
(E
) > No_Location
6373 and then Sloc
(Utyp
) > No_Location
6375 Get_Source_File_Index
(Sloc
(E
)) =
6376 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6378 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6382 Set_Is_Volatile
(E
);
6383 Set_Treat_As_Volatile
(E
);
6386 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6389 -- The following check is only relevant when SPARK_Mode is on as
6390 -- this is not a standard Ada legality rule. Pragma Volatile can
6391 -- only apply to a full type declaration or an object declaration
6392 -- (SPARK RM C.6(1)).
6395 and then Prag_Id
= Pragma_Volatile
6396 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6397 N_Object_Declaration
)
6400 ("argument of pragma % must denote a full type or object "
6401 & "declaration", Arg1
);
6403 end Process_Atomic_Shared_Volatile
;
6405 -------------------------------------------
6406 -- Process_Compile_Time_Warning_Or_Error --
6407 -------------------------------------------
6409 procedure Process_Compile_Time_Warning_Or_Error
is
6410 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6413 Check_Arg_Count
(2);
6414 Check_No_Identifiers
;
6415 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
6416 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6418 if Compile_Time_Known_Value
(Arg1x
) then
6419 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6421 Str
: constant String_Id
:=
6422 Strval
(Get_Pragma_Arg
(Arg2
));
6423 Len
: constant Int
:= String_Length
(Str
);
6428 Cent
: constant Entity_Id
:=
6429 Cunit_Entity
(Current_Sem_Unit
);
6431 Force
: constant Boolean :=
6432 Prag_Id
= Pragma_Compile_Time_Warning
6434 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6435 and then (Ekind
(Cent
) /= E_Package
6436 or else not In_Private_Part
(Cent
));
6437 -- Set True if this is the warning case, and we are in the
6438 -- visible part of a package spec, or in a subprogram spec,
6439 -- in which case we want to force the client to see the
6440 -- warning, even though it is not in the main unit.
6443 -- Loop through segments of message separated by line feeds.
6444 -- We output these segments as separate messages with
6445 -- continuation marks for all but the first.
6450 Error_Msg_Strlen
:= 0;
6452 -- Loop to copy characters from argument to error message
6456 exit when Ptr
> Len
;
6457 CC
:= Get_String_Char
(Str
, Ptr
);
6460 -- Ignore wide chars ??? else store character
6462 if In_Character_Range
(CC
) then
6463 C
:= Get_Character
(CC
);
6464 exit when C
= ASCII
.LF
;
6465 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6466 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6470 -- Here with one line ready to go
6472 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6474 -- If this is a warning in a spec, then we want clients
6475 -- to see the warning, so mark the message with the
6476 -- special sequence !! to force the warning. In the case
6477 -- of a package spec, we do not force this if we are in
6478 -- the private part of the spec.
6481 if Cont
= False then
6482 Error_Msg_N
("<<~!!", Arg1
);
6485 Error_Msg_N
("\<<~!!", Arg1
);
6488 -- Error, rather than warning, or in a body, so we do not
6489 -- need to force visibility for client (error will be
6490 -- output in any case, and this is the situation in which
6491 -- we do not want a client to get a warning, since the
6492 -- warning is in the body or the spec private part).
6495 if Cont
= False then
6496 Error_Msg_N
("<<~", Arg1
);
6499 Error_Msg_N
("\<<~", Arg1
);
6503 exit when Ptr
> Len
;
6508 end Process_Compile_Time_Warning_Or_Error
;
6510 ------------------------
6511 -- Process_Convention --
6512 ------------------------
6514 procedure Process_Convention
6515 (C
: out Convention_Id
;
6516 Ent
: out Entity_Id
)
6522 Comp_Unit
: Unit_Number_Type
;
6524 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6525 -- Called if we have more than one Export/Import/Convention pragma.
6526 -- This is generally illegal, but we have a special case of allowing
6527 -- Import and Interface to coexist if they specify the convention in
6528 -- a consistent manner. We are allowed to do this, since Interface is
6529 -- an implementation defined pragma, and we choose to do it since we
6530 -- know Rational allows this combination. S is the entity id of the
6531 -- subprogram in question. This procedure also sets the special flag
6532 -- Import_Interface_Present in both pragmas in the case where we do
6533 -- have matching Import and Interface pragmas.
6535 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6536 -- Set convention in entity E, and also flag that the entity has a
6537 -- convention pragma. If entity is for a private or incomplete type,
6538 -- also set convention and flag on underlying type. This procedure
6539 -- also deals with the special case of C_Pass_By_Copy convention,
6540 -- and error checks for inappropriate convention specification.
6542 -------------------------------
6543 -- Diagnose_Multiple_Pragmas --
6544 -------------------------------
6546 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6547 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6551 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6552 -- Decl is a pragma node. This function returns True if this
6553 -- pragma has a first argument that is an identifier with a
6554 -- Chars field corresponding to the Convention_Id C.
6556 function Same_Name
(Decl
: Node_Id
) return Boolean;
6557 -- Decl is a pragma node. This function returns True if this
6558 -- pragma has a second argument that is an identifier with a
6559 -- Chars field that matches the Chars of the current subprogram.
6561 ---------------------
6562 -- Same_Convention --
6563 ---------------------
6565 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6566 Arg1
: constant Node_Id
:=
6567 First
(Pragma_Argument_Associations
(Decl
));
6570 if Present
(Arg1
) then
6572 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6574 if Nkind
(Arg
) = N_Identifier
6575 and then Is_Convention_Name
(Chars
(Arg
))
6576 and then Get_Convention_Id
(Chars
(Arg
)) = C
6584 end Same_Convention
;
6590 function Same_Name
(Decl
: Node_Id
) return Boolean is
6591 Arg1
: constant Node_Id
:=
6592 First
(Pragma_Argument_Associations
(Decl
));
6600 Arg2
:= Next
(Arg1
);
6607 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6609 if Nkind
(Arg
) = N_Identifier
6610 and then Chars
(Arg
) = Chars
(S
)
6619 -- Start of processing for Diagnose_Multiple_Pragmas
6624 -- Definitely give message if we have Convention/Export here
6626 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6629 -- If we have an Import or Export, scan back from pragma to
6630 -- find any previous pragma applying to the same procedure.
6631 -- The scan will be terminated by the start of the list, or
6632 -- hitting the subprogram declaration. This won't allow one
6633 -- pragma to appear in the public part and one in the private
6634 -- part, but that seems very unlikely in practice.
6638 while Present
(Decl
) and then Decl
/= Pdec
loop
6640 -- Look for pragma with same name as us
6642 if Nkind
(Decl
) = N_Pragma
6643 and then Same_Name
(Decl
)
6645 -- Give error if same as our pragma or Export/Convention
6647 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6653 -- Case of Import/Interface or the other way round
6655 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6658 -- Here we know that we have Import and Interface. It
6659 -- doesn't matter which way round they are. See if
6660 -- they specify the same convention. If so, all OK,
6661 -- and set special flags to stop other messages
6663 if Same_Convention
(Decl
) then
6664 Set_Import_Interface_Present
(N
);
6665 Set_Import_Interface_Present
(Decl
);
6668 -- If different conventions, special message
6671 Error_Msg_Sloc
:= Sloc
(Decl
);
6673 ("convention differs from that given#", Arg1
);
6683 -- Give message if needed if we fall through those tests
6684 -- except on Relaxed_RM_Semantics where we let go: either this
6685 -- is a case accepted/ignored by other Ada compilers (e.g.
6686 -- a mix of Convention and Import), or another error will be
6687 -- generated later (e.g. using both Import and Export).
6689 if Err
and not Relaxed_RM_Semantics
then
6691 ("at most one Convention/Export/Import pragma is allowed",
6694 end Diagnose_Multiple_Pragmas
;
6696 --------------------------------
6697 -- Set_Convention_From_Pragma --
6698 --------------------------------
6700 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6702 -- Ghost convention is allowed only for functions
6704 if Ekind
(E
) /= E_Function
and then C
= Convention_Ghost
then
6706 ("& may not have Ghost convention", E
);
6708 ("\only functions are permitted to have Ghost convention",
6713 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6714 -- for an overridden dispatching operation. Technically this is
6715 -- an amendment and should only be done in Ada 2005 mode. However,
6716 -- this is clearly a mistake, since the problem that is addressed
6717 -- by this AI is that there is a clear gap in the RM.
6719 if Is_Dispatching_Operation
(E
)
6720 and then Present
(Overridden_Operation
(E
))
6721 and then C
/= Convention
(Overridden_Operation
(E
))
6723 -- An attempt to override a function with a ghost function
6724 -- appears as a mismatch in conventions.
6726 if C
= Convention_Ghost
then
6727 Error_Msg_N
("ghost function & cannot be overriding", E
);
6730 ("cannot change convention for overridden dispatching "
6731 & "operation", Arg1
);
6735 -- Special checks for Convention_Stdcall
6737 if C
= Convention_Stdcall
then
6739 -- A dispatching call is not allowed. A dispatching subprogram
6740 -- cannot be used to interface to the Win32 API, so in fact
6741 -- this check does not impose any effective restriction.
6743 if Is_Dispatching_Operation
(E
) then
6744 Error_Msg_Sloc
:= Sloc
(E
);
6746 -- Note: make this unconditional so that if there is more
6747 -- than one call to which the pragma applies, we get a
6748 -- message for each call. Also don't use Error_Pragma,
6749 -- so that we get multiple messages.
6752 ("dispatching subprogram# cannot use Stdcall convention!",
6755 -- Subprogram is allowed, but not a generic subprogram
6757 elsif not Is_Subprogram
(E
)
6758 and then not Is_Generic_Subprogram
(E
)
6762 and then Ekind
(E
) /= E_Variable
6764 -- An access to subprogram is also allowed
6768 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6770 -- Allow internal call to set convention of subprogram type
6772 and then not (Ekind
(E
) = E_Subprogram_Type
)
6775 ("second argument of pragma% must be subprogram (type)",
6780 -- Set the convention
6782 Set_Convention
(E
, C
);
6783 Set_Has_Convention_Pragma
(E
);
6785 -- For the case of a record base type, also set the convention of
6786 -- any anonymous access types declared in the record which do not
6787 -- currently have a specified convention.
6789 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6794 Comp
:= First_Component
(E
);
6795 while Present
(Comp
) loop
6796 if Present
(Etype
(Comp
))
6797 and then Ekind_In
(Etype
(Comp
),
6798 E_Anonymous_Access_Type
,
6799 E_Anonymous_Access_Subprogram_Type
)
6800 and then not Has_Convention_Pragma
(Comp
)
6802 Set_Convention
(Comp
, C
);
6805 Next_Component
(Comp
);
6810 -- Deal with incomplete/private type case, where underlying type
6811 -- is available, so set convention of that underlying type.
6813 if Is_Incomplete_Or_Private_Type
(E
)
6814 and then Present
(Underlying_Type
(E
))
6816 Set_Convention
(Underlying_Type
(E
), C
);
6817 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6820 -- A class-wide type should inherit the convention of the specific
6821 -- root type (although this isn't specified clearly by the RM).
6823 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6824 Set_Convention
(Class_Wide_Type
(E
), C
);
6827 -- If the entity is a record type, then check for special case of
6828 -- C_Pass_By_Copy, which is treated the same as C except that the
6829 -- special record flag is set. This convention is only permitted
6830 -- on record types (see AI95-00131).
6832 if Cname
= Name_C_Pass_By_Copy
then
6833 if Is_Record_Type
(E
) then
6834 Set_C_Pass_By_Copy
(Base_Type
(E
));
6835 elsif Is_Incomplete_Or_Private_Type
(E
)
6836 and then Is_Record_Type
(Underlying_Type
(E
))
6838 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6841 ("C_Pass_By_Copy convention allowed only for record type",
6846 -- If the entity is a derived boolean type, check for the special
6847 -- case of convention C, C++, or Fortran, where we consider any
6848 -- nonzero value to represent true.
6850 if Is_Discrete_Type
(E
)
6851 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6857 C
= Convention_Fortran
)
6859 Set_Nonzero_Is_True
(Base_Type
(E
));
6861 end Set_Convention_From_Pragma
;
6863 -- Start of processing for Process_Convention
6866 Check_At_Least_N_Arguments
(2);
6867 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6868 Check_Arg_Is_Identifier
(Arg1
);
6869 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6871 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6872 -- tested again below to set the critical flag).
6874 if Cname
= Name_C_Pass_By_Copy
then
6877 -- Otherwise we must have something in the standard convention list
6879 elsif Is_Convention_Name
(Cname
) then
6880 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6882 -- In DEC VMS, it seems that there is an undocumented feature that
6883 -- any unrecognized convention is treated as the default, which for
6884 -- us is convention C. It does not seem so terrible to do this
6885 -- unconditionally, silently in the VMS case, and with a warning
6886 -- in the non-VMS case.
6889 if Warn_On_Export_Import
and not OpenVMS_On_Target
then
6891 ("??unrecognized convention name, C assumed",
6892 Get_Pragma_Arg
(Arg1
));
6898 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6899 Check_Arg_Is_Local_Name
(Arg2
);
6901 Id
:= Get_Pragma_Arg
(Arg2
);
6904 if not Is_Entity_Name
(Id
) then
6905 Error_Pragma_Arg
("entity name required", Arg2
);
6910 -- Set entity to return
6914 -- Ada_Pass_By_Copy special checking
6916 if C
= Convention_Ada_Pass_By_Copy
then
6917 if not Is_First_Subtype
(E
) then
6919 ("convention `Ada_Pass_By_Copy` only allowed for types",
6923 if Is_By_Reference_Type
(E
) then
6925 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6930 -- Ada_Pass_By_Reference special checking
6932 if C
= Convention_Ada_Pass_By_Reference
then
6933 if not Is_First_Subtype
(E
) then
6935 ("convention `Ada_Pass_By_Reference` only allowed for types",
6939 if Is_By_Copy_Type
(E
) then
6941 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6946 -- Ghost special checking
6948 if Is_Ghost_Subprogram
(E
)
6949 and then Present
(Overridden_Operation
(E
))
6951 Error_Msg_N
("ghost function & cannot be overriding", E
);
6954 -- Go to renamed subprogram if present, since convention applies to
6955 -- the actual renamed entity, not to the renaming entity. If the
6956 -- subprogram is inherited, go to parent subprogram.
6958 if Is_Subprogram
(E
)
6959 and then Present
(Alias
(E
))
6961 if Nkind
(Parent
(Declaration_Node
(E
))) =
6962 N_Subprogram_Renaming_Declaration
6964 if Scope
(E
) /= Scope
(Alias
(E
)) then
6966 ("cannot apply pragma% to non-local entity&#", E
);
6971 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6972 N_Private_Extension_Declaration
)
6973 and then Scope
(E
) = Scope
(Alias
(E
))
6977 -- Return the parent subprogram the entity was inherited from
6983 -- Check that we are not applying this to a specless body
6984 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
6987 if Is_Subprogram
(E
)
6988 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6989 and then not Relaxed_RM_Semantics
6992 ("pragma% requires separate spec and must come before body");
6995 -- Check that we are not applying this to a named constant
6997 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6998 Error_Msg_Name_1
:= Pname
;
7000 ("cannot apply pragma% to named constant!",
7001 Get_Pragma_Arg
(Arg2
));
7003 ("\supply appropriate type for&!", Arg2
);
7006 if Ekind
(E
) = E_Enumeration_Literal
then
7007 Error_Pragma
("enumeration literal not allowed for pragma%");
7010 -- Check for rep item appearing too early or too late
7012 if Etype
(E
) = Any_Type
7013 or else Rep_Item_Too_Early
(E
, N
)
7017 elsif Present
(Underlying_Type
(E
)) then
7018 E
:= Underlying_Type
(E
);
7021 if Rep_Item_Too_Late
(E
, N
) then
7025 if Has_Convention_Pragma
(E
) then
7026 Diagnose_Multiple_Pragmas
(E
);
7028 elsif Convention
(E
) = Convention_Protected
7029 or else Ekind
(Scope
(E
)) = E_Protected_Type
7032 ("a protected operation cannot be given a different convention",
7036 -- For Intrinsic, a subprogram is required
7038 if C
= Convention_Intrinsic
7039 and then not Is_Subprogram
(E
)
7040 and then not Is_Generic_Subprogram
(E
)
7043 ("second argument of pragma% must be a subprogram", Arg2
);
7046 -- Deal with non-subprogram cases
7048 if not Is_Subprogram
(E
)
7049 and then not Is_Generic_Subprogram
(E
)
7051 Set_Convention_From_Pragma
(E
);
7054 Check_First_Subtype
(Arg2
);
7055 Set_Convention_From_Pragma
(Base_Type
(E
));
7057 -- For access subprograms, we must set the convention on the
7058 -- internally generated directly designated type as well.
7060 if Ekind
(E
) = E_Access_Subprogram_Type
then
7061 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7065 -- For the subprogram case, set proper convention for all homonyms
7066 -- in same scope and the same declarative part, i.e. the same
7067 -- compilation unit.
7070 Comp_Unit
:= Get_Source_Unit
(E
);
7071 Set_Convention_From_Pragma
(E
);
7073 -- Treat a pragma Import as an implicit body, and pragma import
7074 -- as implicit reference (for navigation in GPS).
7076 if Prag_Id
= Pragma_Import
then
7077 Generate_Reference
(E
, Id
, 'b');
7079 -- For exported entities we restrict the generation of references
7080 -- to entities exported to foreign languages since entities
7081 -- exported to Ada do not provide further information to GPS and
7082 -- add undesired references to the output of the gnatxref tool.
7084 elsif Prag_Id
= Pragma_Export
7085 and then Convention
(E
) /= Convention_Ada
7087 Generate_Reference
(E
, Id
, 'i');
7090 -- If the pragma comes from from an aspect, it only applies to the
7091 -- given entity, not its homonyms.
7093 if From_Aspect_Specification
(N
) then
7097 -- Otherwise Loop through the homonyms of the pragma argument's
7098 -- entity, an apply convention to those in the current scope.
7104 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7106 -- Ignore entry for which convention is already set
7108 if Has_Convention_Pragma
(E1
) then
7112 -- Do not set the pragma on inherited operations or on formal
7115 if Comes_From_Source
(E1
)
7116 and then Comp_Unit
= Get_Source_Unit
(E1
)
7117 and then not Is_Formal_Subprogram
(E1
)
7118 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7119 N_Full_Type_Declaration
7121 if Present
(Alias
(E1
))
7122 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7125 ("cannot apply pragma% to non-local entity& declared#",
7129 Set_Convention_From_Pragma
(E1
);
7131 if Prag_Id
= Pragma_Import
then
7132 Generate_Reference
(E1
, Id
, 'b');
7140 end Process_Convention
;
7142 ----------------------------------------
7143 -- Process_Disable_Enable_Atomic_Sync --
7144 ----------------------------------------
7146 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7148 Check_No_Identifiers
;
7149 Check_At_Most_N_Arguments
(1);
7151 -- Modeled internally as
7152 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7156 Pragma_Identifier
=>
7157 Make_Identifier
(Loc
, Nam
),
7158 Pragma_Argument_Associations
=> New_List
(
7159 Make_Pragma_Argument_Association
(Loc
,
7161 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7163 if Present
(Arg1
) then
7164 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7168 end Process_Disable_Enable_Atomic_Sync
;
7170 -----------------------------------------------------
7171 -- Process_Extended_Import_Export_Exception_Pragma --
7172 -----------------------------------------------------
7174 procedure Process_Extended_Import_Export_Exception_Pragma
7175 (Arg_Internal
: Node_Id
;
7176 Arg_External
: Node_Id
;
7184 if not OpenVMS_On_Target
then
7186 ("??pragma% ignored (applies only to Open'V'M'S)");
7189 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7190 Def_Id
:= Entity
(Arg_Internal
);
7192 if Ekind
(Def_Id
) /= E_Exception
then
7194 ("pragma% must refer to declared exception", Arg_Internal
);
7197 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7199 if Present
(Arg_Form
) then
7200 Check_Arg_Is_One_Of
(Arg_Form
, Name_Ada
, Name_VMS
);
7203 if Present
(Arg_Form
)
7204 and then Chars
(Arg_Form
) = Name_Ada
7208 Set_Is_VMS_Exception
(Def_Id
);
7209 Set_Exception_Code
(Def_Id
, No_Uint
);
7212 if Present
(Arg_Code
) then
7213 if not Is_VMS_Exception
(Def_Id
) then
7215 ("Code option for pragma% not allowed for Ada case",
7219 Check_Arg_Is_Static_Expression
(Arg_Code
, Any_Integer
);
7220 Code_Val
:= Expr_Value
(Arg_Code
);
7222 if not UI_Is_In_Int_Range
(Code_Val
) then
7224 ("Code option for pragma% must be in 32-bit range",
7228 Set_Exception_Code
(Def_Id
, Code_Val
);
7231 end Process_Extended_Import_Export_Exception_Pragma
;
7233 -------------------------------------------------
7234 -- Process_Extended_Import_Export_Internal_Arg --
7235 -------------------------------------------------
7237 procedure Process_Extended_Import_Export_Internal_Arg
7238 (Arg_Internal
: Node_Id
:= Empty
)
7241 if No
(Arg_Internal
) then
7242 Error_Pragma
("Internal parameter required for pragma%");
7245 if Nkind
(Arg_Internal
) = N_Identifier
then
7248 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7249 and then (Prag_Id
= Pragma_Import_Function
7251 Prag_Id
= Pragma_Export_Function
)
7257 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7260 Check_Arg_Is_Local_Name
(Arg_Internal
);
7261 end Process_Extended_Import_Export_Internal_Arg
;
7263 --------------------------------------------------
7264 -- Process_Extended_Import_Export_Object_Pragma --
7265 --------------------------------------------------
7267 procedure Process_Extended_Import_Export_Object_Pragma
7268 (Arg_Internal
: Node_Id
;
7269 Arg_External
: Node_Id
;
7275 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7276 Def_Id
:= Entity
(Arg_Internal
);
7278 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7280 ("pragma% must designate an object", Arg_Internal
);
7283 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7285 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7288 ("previous Common/Psect_Object applies, pragma % not permitted",
7292 if Rep_Item_Too_Late
(Def_Id
, N
) then
7296 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7298 if Present
(Arg_Size
) then
7299 Check_Arg_Is_External_Name
(Arg_Size
);
7302 -- Export_Object case
7304 if Prag_Id
= Pragma_Export_Object
then
7305 if not Is_Library_Level_Entity
(Def_Id
) then
7307 ("argument for pragma% must be library level entity",
7311 if Ekind
(Current_Scope
) = E_Generic_Package
then
7312 Error_Pragma
("pragma& cannot appear in a generic unit");
7315 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7317 ("exported object must have compile time known size",
7321 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7322 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7324 Set_Exported
(Def_Id
, Arg_Internal
);
7327 -- Import_Object case
7330 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7332 ("cannot use pragma% for task/protected object",
7336 if Ekind
(Def_Id
) = E_Constant
then
7338 ("cannot import a constant", Arg_Internal
);
7341 if Warn_On_Export_Import
7342 and then Has_Discriminants
(Etype
(Def_Id
))
7345 ("imported value must be initialized??", Arg_Internal
);
7348 if Warn_On_Export_Import
7349 and then Is_Access_Type
(Etype
(Def_Id
))
7352 ("cannot import object of an access type??", Arg_Internal
);
7355 if Warn_On_Export_Import
7356 and then Is_Imported
(Def_Id
)
7358 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7360 -- Check for explicit initialization present. Note that an
7361 -- initialization generated by the code generator, e.g. for an
7362 -- access type, does not count here.
7364 elsif Present
(Expression
(Parent
(Def_Id
)))
7367 (Original_Node
(Expression
(Parent
(Def_Id
))))
7369 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7371 ("imported entities cannot be initialized (RM B.1(24))",
7372 "\no initialization allowed for & declared#", Arg1
);
7374 Set_Imported
(Def_Id
);
7375 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7378 end Process_Extended_Import_Export_Object_Pragma
;
7380 ------------------------------------------------------
7381 -- Process_Extended_Import_Export_Subprogram_Pragma --
7382 ------------------------------------------------------
7384 procedure Process_Extended_Import_Export_Subprogram_Pragma
7385 (Arg_Internal
: Node_Id
;
7386 Arg_External
: Node_Id
;
7387 Arg_Parameter_Types
: Node_Id
;
7388 Arg_Result_Type
: Node_Id
:= Empty
;
7389 Arg_Mechanism
: Node_Id
;
7390 Arg_Result_Mechanism
: Node_Id
:= Empty
;
7391 Arg_First_Optional_Parameter
: Node_Id
:= Empty
)
7397 Ambiguous
: Boolean;
7401 function Same_Base_Type
7403 Formal
: Entity_Id
) return Boolean;
7404 -- Determines if Ptype references the type of Formal. Note that only
7405 -- the base types need to match according to the spec. Ptype here is
7406 -- the argument from the pragma, which is either a type name, or an
7407 -- access attribute.
7409 --------------------
7410 -- Same_Base_Type --
7411 --------------------
7413 function Same_Base_Type
7415 Formal
: Entity_Id
) return Boolean
7417 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7421 -- Case where pragma argument is typ'Access
7423 if Nkind
(Ptype
) = N_Attribute_Reference
7424 and then Attribute_Name
(Ptype
) = Name_Access
7426 Pref
:= Prefix
(Ptype
);
7429 if not Is_Entity_Name
(Pref
)
7430 or else Entity
(Pref
) = Any_Type
7435 -- We have a match if the corresponding argument is of an
7436 -- anonymous access type, and its designated type matches the
7437 -- type of the prefix of the access attribute
7439 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7440 and then Base_Type
(Entity
(Pref
)) =
7441 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7443 -- Case where pragma argument is a type name
7448 if not Is_Entity_Name
(Ptype
)
7449 or else Entity
(Ptype
) = Any_Type
7454 -- We have a match if the corresponding argument is of the type
7455 -- given in the pragma (comparing base types)
7457 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7461 -- Start of processing for
7462 -- Process_Extended_Import_Export_Subprogram_Pragma
7465 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7469 -- Loop through homonyms (overloadings) of the entity
7471 Hom_Id
:= Entity
(Arg_Internal
);
7472 while Present
(Hom_Id
) loop
7473 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7475 -- We need a subprogram in the current scope
7477 if not Is_Subprogram
(Def_Id
)
7478 or else Scope
(Def_Id
) /= Current_Scope
7485 -- Pragma cannot apply to subprogram body
7487 if Is_Subprogram
(Def_Id
)
7488 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7492 ("pragma% requires separate spec"
7493 & " and must come before body");
7496 -- Test result type if given, note that the result type
7497 -- parameter can only be present for the function cases.
7499 if Present
(Arg_Result_Type
)
7500 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7504 elsif Etype
(Def_Id
) /= Standard_Void_Type
7506 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7510 -- Test parameter types if given. Note that this parameter
7511 -- has not been analyzed (and must not be, since it is
7512 -- semantic nonsense), so we get it as the parser left it.
7514 elsif Present
(Arg_Parameter_Types
) then
7515 Check_Matching_Types
: declare
7520 Formal
:= First_Formal
(Def_Id
);
7522 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7523 if Present
(Formal
) then
7527 -- A list of one type, e.g. (List) is parsed as
7528 -- a parenthesized expression.
7530 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7531 and then Paren_Count
(Arg_Parameter_Types
) = 1
7534 or else Present
(Next_Formal
(Formal
))
7539 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7542 -- A list of more than one type is parsed as a aggregate
7544 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7545 and then Paren_Count
(Arg_Parameter_Types
) = 0
7547 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7548 while Present
(Ptype
) or else Present
(Formal
) loop
7551 or else not Same_Base_Type
(Ptype
, Formal
)
7556 Next_Formal
(Formal
);
7561 -- Anything else is of the wrong form
7565 ("wrong form for Parameter_Types parameter",
7566 Arg_Parameter_Types
);
7568 end Check_Matching_Types
;
7571 -- Match is now False if the entry we found did not match
7572 -- either a supplied Parameter_Types or Result_Types argument
7578 -- Ambiguous case, the flag Ambiguous shows if we already
7579 -- detected this and output the initial messages.
7582 if not Ambiguous
then
7584 Error_Msg_Name_1
:= Pname
;
7586 ("pragma% does not uniquely identify subprogram!",
7588 Error_Msg_Sloc
:= Sloc
(Ent
);
7589 Error_Msg_N
("matching subprogram #!", N
);
7593 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7594 Error_Msg_N
("matching subprogram #!", N
);
7599 Hom_Id
:= Homonym
(Hom_Id
);
7602 -- See if we found an entry
7605 if not Ambiguous
then
7606 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7608 ("pragma% cannot be given for generic subprogram");
7611 ("pragma% does not identify local subprogram");
7618 -- Import pragmas must be for imported entities
7620 if Prag_Id
= Pragma_Import_Function
7622 Prag_Id
= Pragma_Import_Procedure
7624 Prag_Id
= Pragma_Import_Valued_Procedure
7626 if not Is_Imported
(Ent
) then
7628 ("pragma Import or Interface must precede pragma%");
7631 -- Here we have the Export case which can set the entity as exported
7633 -- But does not do so if the specified external name is null, since
7634 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7635 -- compatible) to request no external name.
7637 elsif Nkind
(Arg_External
) = N_String_Literal
7638 and then String_Length
(Strval
(Arg_External
)) = 0
7642 -- In all other cases, set entity as exported
7645 Set_Exported
(Ent
, Arg_Internal
);
7648 -- Special processing for Valued_Procedure cases
7650 if Prag_Id
= Pragma_Import_Valued_Procedure
7652 Prag_Id
= Pragma_Export_Valued_Procedure
7654 Formal
:= First_Formal
(Ent
);
7657 Error_Pragma
("at least one parameter required for pragma%");
7659 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7660 Error_Pragma
("first parameter must have mode out for pragma%");
7663 Set_Is_Valued_Procedure
(Ent
);
7667 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7669 -- Process Result_Mechanism argument if present. We have already
7670 -- checked that this is only allowed for the function case.
7672 if Present
(Arg_Result_Mechanism
) then
7673 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7676 -- Process Mechanism parameter if present. Note that this parameter
7677 -- is not analyzed, and must not be analyzed since it is semantic
7678 -- nonsense, so we get it in exactly as the parser left it.
7680 if Present
(Arg_Mechanism
) then
7688 -- A single mechanism association without a formal parameter
7689 -- name is parsed as a parenthesized expression. All other
7690 -- cases are parsed as aggregates, so we rewrite the single
7691 -- parameter case as an aggregate for consistency.
7693 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7694 and then Paren_Count
(Arg_Mechanism
) = 1
7696 Rewrite
(Arg_Mechanism
,
7697 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7698 Expressions
=> New_List
(
7699 Relocate_Node
(Arg_Mechanism
))));
7702 -- Case of only mechanism name given, applies to all formals
7704 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7705 Formal
:= First_Formal
(Ent
);
7706 while Present
(Formal
) loop
7707 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7708 Next_Formal
(Formal
);
7711 -- Case of list of mechanism associations given
7714 if Null_Record_Present
(Arg_Mechanism
) then
7716 ("inappropriate form for Mechanism parameter",
7720 -- Deal with positional ones first
7722 Formal
:= First_Formal
(Ent
);
7724 if Present
(Expressions
(Arg_Mechanism
)) then
7725 Mname
:= First
(Expressions
(Arg_Mechanism
));
7726 while Present
(Mname
) loop
7729 ("too many mechanism associations", Mname
);
7732 Set_Mechanism_Value
(Formal
, Mname
);
7733 Next_Formal
(Formal
);
7738 -- Deal with named entries
7740 if Present
(Component_Associations
(Arg_Mechanism
)) then
7741 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7742 while Present
(Massoc
) loop
7743 Choice
:= First
(Choices
(Massoc
));
7745 if Nkind
(Choice
) /= N_Identifier
7746 or else Present
(Next
(Choice
))
7749 ("incorrect form for mechanism association",
7753 Formal
:= First_Formal
(Ent
);
7757 ("parameter name & not present", Choice
);
7760 if Chars
(Choice
) = Chars
(Formal
) then
7762 (Formal
, Expression
(Massoc
));
7764 -- Set entity on identifier (needed by ASIS)
7766 Set_Entity
(Choice
, Formal
);
7771 Next_Formal
(Formal
);
7781 -- Process First_Optional_Parameter argument if present. We have
7782 -- already checked that this is only allowed for the Import case.
7784 if Present
(Arg_First_Optional_Parameter
) then
7785 if Nkind
(Arg_First_Optional_Parameter
) /= N_Identifier
then
7787 ("first optional parameter must be formal parameter name",
7788 Arg_First_Optional_Parameter
);
7791 Formal
:= First_Formal
(Ent
);
7795 ("specified formal parameter& not found",
7796 Arg_First_Optional_Parameter
);
7799 exit when Chars
(Formal
) =
7800 Chars
(Arg_First_Optional_Parameter
);
7802 Next_Formal
(Formal
);
7805 Set_First_Optional_Parameter
(Ent
, Formal
);
7807 -- Check specified and all remaining formals have right form
7809 while Present
(Formal
) loop
7810 if Ekind
(Formal
) /= E_In_Parameter
then
7812 ("optional formal& is not of mode in!",
7813 Arg_First_Optional_Parameter
, Formal
);
7816 Dval
:= Default_Value
(Formal
);
7820 ("optional formal& does not have default value!",
7821 Arg_First_Optional_Parameter
, Formal
);
7823 elsif Compile_Time_Known_Value_Or_Aggr
(Dval
) then
7828 ("default value for optional formal& is non-static!",
7829 Arg_First_Optional_Parameter
, Formal
);
7833 Set_Is_Optional_Parameter
(Formal
);
7834 Next_Formal
(Formal
);
7837 end Process_Extended_Import_Export_Subprogram_Pragma
;
7839 --------------------------
7840 -- Process_Generic_List --
7841 --------------------------
7843 procedure Process_Generic_List
is
7848 Check_No_Identifiers
;
7849 Check_At_Least_N_Arguments
(1);
7851 -- Check all arguments are names of generic units or instances
7854 while Present
(Arg
) loop
7855 Exp
:= Get_Pragma_Arg
(Arg
);
7858 if not Is_Entity_Name
(Exp
)
7860 (not Is_Generic_Instance
(Entity
(Exp
))
7862 not Is_Generic_Unit
(Entity
(Exp
)))
7865 ("pragma% argument must be name of generic unit/instance",
7871 end Process_Generic_List
;
7873 ------------------------------------
7874 -- Process_Import_Predefined_Type --
7875 ------------------------------------
7877 procedure Process_Import_Predefined_Type
is
7878 Loc
: constant Source_Ptr
:= Sloc
(N
);
7880 Ftyp
: Node_Id
:= Empty
;
7886 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7889 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7890 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7894 Ftyp
:= Node
(Elmt
);
7896 if Present
(Ftyp
) then
7898 -- Don't build a derived type declaration, because predefined C
7899 -- types have no declaration anywhere, so cannot really be named.
7900 -- Instead build a full type declaration, starting with an
7901 -- appropriate type definition is built
7903 if Is_Floating_Point_Type
(Ftyp
) then
7904 Def
:= Make_Floating_Point_Definition
(Loc
,
7905 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7906 Make_Real_Range_Specification
(Loc
,
7907 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7908 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7910 -- Should never have a predefined type we cannot handle
7913 raise Program_Error
;
7916 -- Build and insert a Full_Type_Declaration, which will be
7917 -- analyzed as soon as this list entry has been analyzed.
7919 Decl
:= Make_Full_Type_Declaration
(Loc
,
7920 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7921 Type_Definition
=> Def
);
7923 Insert_After
(N
, Decl
);
7924 Mark_Rewrite_Insertion
(Decl
);
7927 Error_Pragma_Arg
("no matching type found for pragma%",
7930 end Process_Import_Predefined_Type
;
7932 ---------------------------------
7933 -- Process_Import_Or_Interface --
7934 ---------------------------------
7936 procedure Process_Import_Or_Interface
is
7942 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7943 -- pragma Import (Entity, "external name");
7945 if Relaxed_RM_Semantics
7946 and then Arg_Count
= 2
7947 and then Prag_Id
= Pragma_Import
7948 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7951 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7954 if not Is_Entity_Name
(Def_Id
) then
7955 Error_Pragma_Arg
("entity name required", Arg1
);
7958 Def_Id
:= Entity
(Def_Id
);
7959 Kill_Size_Check_Code
(Def_Id
);
7960 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7963 Process_Convention
(C
, Def_Id
);
7964 Kill_Size_Check_Code
(Def_Id
);
7965 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7968 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7970 -- We do not permit Import to apply to a renaming declaration
7972 if Present
(Renamed_Object
(Def_Id
)) then
7974 ("pragma% not allowed for object renaming", Arg2
);
7976 -- User initialization is not allowed for imported object, but
7977 -- the object declaration may contain a default initialization,
7978 -- that will be discarded. Note that an explicit initialization
7979 -- only counts if it comes from source, otherwise it is simply
7980 -- the code generator making an implicit initialization explicit.
7982 elsif Present
(Expression
(Parent
(Def_Id
)))
7983 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
7985 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7987 ("no initialization allowed for declaration of& #",
7988 "\imported entities cannot be initialized (RM B.1(24))",
7992 Set_Imported
(Def_Id
);
7993 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7995 -- Note that we do not set Is_Public here. That's because we
7996 -- only want to set it if there is no address clause, and we
7997 -- don't know that yet, so we delay that processing till
8000 -- pragma Import completes deferred constants
8002 if Ekind
(Def_Id
) = E_Constant
then
8003 Set_Has_Completion
(Def_Id
);
8006 -- It is not possible to import a constant of an unconstrained
8007 -- array type (e.g. string) because there is no simple way to
8008 -- write a meaningful subtype for it.
8010 if Is_Array_Type
(Etype
(Def_Id
))
8011 and then not Is_Constrained
(Etype
(Def_Id
))
8014 ("imported constant& must have a constrained subtype",
8019 elsif Is_Subprogram
(Def_Id
)
8020 or else Is_Generic_Subprogram
(Def_Id
)
8022 -- If the name is overloaded, pragma applies to all of the denoted
8023 -- entities in the same declarative part, unless the pragma comes
8024 -- from an aspect specification or was generated by the compiler
8025 -- (such as for pragma Provide_Shift_Operators).
8028 while Present
(Hom_Id
) loop
8030 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8032 -- Ignore inherited subprograms because the pragma will apply
8033 -- to the parent operation, which is the one called.
8035 if Is_Overloadable
(Def_Id
)
8036 and then Present
(Alias
(Def_Id
))
8040 -- If it is not a subprogram, it must be in an outer scope and
8041 -- pragma does not apply.
8043 elsif not Is_Subprogram
(Def_Id
)
8044 and then not Is_Generic_Subprogram
(Def_Id
)
8048 -- The pragma does not apply to primitives of interfaces
8050 elsif Is_Dispatching_Operation
(Def_Id
)
8051 and then Present
(Find_Dispatching_Type
(Def_Id
))
8052 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8056 -- Verify that the homonym is in the same declarative part (not
8057 -- just the same scope). If the pragma comes from an aspect
8058 -- specification we know that it is part of the declaration.
8060 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8061 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8062 and then not From_Aspect_Specification
(N
)
8067 Set_Imported
(Def_Id
);
8069 -- Reject an Import applied to an abstract subprogram
8071 if Is_Subprogram
(Def_Id
)
8072 and then Is_Abstract_Subprogram
(Def_Id
)
8074 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8076 ("cannot import abstract subprogram& declared#",
8080 -- Special processing for Convention_Intrinsic
8082 if C
= Convention_Intrinsic
then
8084 -- Link_Name argument not allowed for intrinsic
8088 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8090 -- If no external name is present, then check that this
8091 -- is a valid intrinsic subprogram. If an external name
8092 -- is present, then this is handled by the back end.
8095 Check_Intrinsic_Subprogram
8096 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8100 -- Verify that the subprogram does not have a completion
8101 -- through a renaming declaration. For other completions the
8102 -- pragma appears as a too late representation.
8105 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8109 and then Nkind
(Decl
) = N_Subprogram_Declaration
8110 and then Present
(Corresponding_Body
(Decl
))
8111 and then Nkind
(Unit_Declaration_Node
8112 (Corresponding_Body
(Decl
))) =
8113 N_Subprogram_Renaming_Declaration
8115 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8117 ("cannot import&, renaming already provided for "
8118 & "declaration #", N
, Def_Id
);
8122 Set_Has_Completion
(Def_Id
);
8123 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8126 if Is_Compilation_Unit
(Hom_Id
) then
8128 -- Its possible homonyms are not affected by the pragma.
8129 -- Such homonyms might be present in the context of other
8130 -- units being compiled.
8134 elsif From_Aspect_Specification
(N
) then
8137 -- If the pragma was created by the compiler, then we don't
8138 -- want it to apply to other homonyms. This kind of case can
8139 -- occur when using pragma Provide_Shift_Operators, which
8140 -- generates implicit shift and rotate operators with Import
8141 -- pragmas that might apply to earlier explicit or implicit
8142 -- declarations marked with Import (for example, coming from
8143 -- an earlier pragma Provide_Shift_Operators for another type),
8144 -- and we don't generally want other homonyms being treated
8145 -- as imported or the pragma flagged as an illegal duplicate.
8147 elsif not Comes_From_Source
(N
) then
8151 Hom_Id
:= Homonym
(Hom_Id
);
8155 -- When the convention is Java or CIL, we also allow Import to
8156 -- be given for packages, generic packages, exceptions, record
8157 -- components, and access to subprograms.
8159 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
8161 (Is_Package_Or_Generic_Package
(Def_Id
)
8162 or else Ekind
(Def_Id
) = E_Exception
8163 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
8164 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
8166 Set_Imported
(Def_Id
);
8167 Set_Is_Public
(Def_Id
);
8168 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8170 -- Import a CPP class
8172 elsif C
= Convention_CPP
8173 and then (Is_Record_Type
(Def_Id
)
8174 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8176 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8177 if Present
(Full_View
(Def_Id
)) then
8178 Def_Id
:= Full_View
(Def_Id
);
8182 ("cannot import 'C'P'P type before full declaration seen",
8183 Get_Pragma_Arg
(Arg2
));
8185 -- Although we have reported the error we decorate it as
8186 -- CPP_Class to avoid reporting spurious errors
8188 Set_Is_CPP_Class
(Def_Id
);
8193 -- Types treated as CPP classes must be declared limited (note:
8194 -- this used to be a warning but there is no real benefit to it
8195 -- since we did effectively intend to treat the type as limited
8198 if not Is_Limited_Type
(Def_Id
) then
8200 ("imported 'C'P'P type must be limited",
8201 Get_Pragma_Arg
(Arg2
));
8204 if Etype
(Def_Id
) /= Def_Id
8205 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8207 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8210 Set_Is_CPP_Class
(Def_Id
);
8212 -- Imported CPP types must not have discriminants (because C++
8213 -- classes do not have discriminants).
8215 if Has_Discriminants
(Def_Id
) then
8217 ("imported 'C'P'P type cannot have discriminants",
8218 First
(Discriminant_Specifications
8219 (Declaration_Node
(Def_Id
))));
8222 -- Check that components of imported CPP types do not have default
8223 -- expressions. For private types this check is performed when the
8224 -- full view is analyzed (see Process_Full_View).
8226 if not Is_Private_Type
(Def_Id
) then
8227 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8230 -- Import a CPP exception
8232 elsif C
= Convention_CPP
8233 and then Ekind
(Def_Id
) = E_Exception
8237 ("'External_'Name arguments is required for 'Cpp exception",
8240 -- As only a string is allowed, Check_Arg_Is_External_Name
8242 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
8245 if Present
(Arg4
) then
8247 ("Link_Name argument not allowed for imported Cpp exception",
8251 -- Do not call Set_Interface_Name as the name of the exception
8252 -- shouldn't be modified (and in particular it shouldn't be
8253 -- the External_Name). For exceptions, the External_Name is the
8254 -- name of the RTTI structure.
8256 -- ??? Emit an error if pragma Import/Export_Exception is present
8258 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8260 Check_Arg_Count
(3);
8261 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
8263 Process_Import_Predefined_Type
;
8267 ("second argument of pragma% must be object, subprogram "
8268 & "or incomplete type",
8272 -- If this pragma applies to a compilation unit, then the unit, which
8273 -- is a subprogram, does not require (or allow) a body. We also do
8274 -- not need to elaborate imported procedures.
8276 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8278 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8280 Set_Body_Required
(Cunit
, False);
8283 end Process_Import_Or_Interface
;
8285 --------------------
8286 -- Process_Inline --
8287 --------------------
8289 procedure Process_Inline
(Status
: Inline_Status
) is
8296 Effective
: Boolean := False;
8297 -- Set True if inline has some effect, i.e. if there is at least one
8298 -- subprogram set as inlined as a result of the use of the pragma.
8300 procedure Make_Inline
(Subp
: Entity_Id
);
8301 -- Subp is the defining unit name of the subprogram declaration. Set
8302 -- the flag, as well as the flag in the corresponding body, if there
8305 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8306 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8307 -- Has_Pragma_Inline_Always for the Inline_Always case.
8309 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8310 -- Returns True if it can be determined at this stage that inlining
8311 -- is not possible, for example if the body is available and contains
8312 -- exception handlers, we prevent inlining, since otherwise we can
8313 -- get undefined symbols at link time. This function also emits a
8314 -- warning if front-end inlining is enabled and the pragma appears
8317 -- ??? is business with link symbols still valid, or does it relate
8318 -- to front end ZCX which is being phased out ???
8320 ---------------------------
8321 -- Inlining_Not_Possible --
8322 ---------------------------
8324 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8325 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8329 if Nkind
(Decl
) = N_Subprogram_Body
then
8330 Stats
:= Handled_Statement_Sequence
(Decl
);
8331 return Present
(Exception_Handlers
(Stats
))
8332 or else Present
(At_End_Proc
(Stats
));
8334 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8335 and then Present
(Corresponding_Body
(Decl
))
8337 if Front_End_Inlining
8338 and then Analyzed
(Corresponding_Body
(Decl
))
8340 Error_Msg_N
("pragma appears too late, ignored??", N
);
8343 -- If the subprogram is a renaming as body, the body is just a
8344 -- call to the renamed subprogram, and inlining is trivially
8348 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8349 N_Subprogram_Renaming_Declaration
8355 Handled_Statement_Sequence
8356 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8359 Present
(Exception_Handlers
(Stats
))
8360 or else Present
(At_End_Proc
(Stats
));
8364 -- If body is not available, assume the best, the check is
8365 -- performed again when compiling enclosing package bodies.
8369 end Inlining_Not_Possible
;
8375 procedure Make_Inline
(Subp
: Entity_Id
) is
8376 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8377 Inner_Subp
: Entity_Id
:= Subp
;
8380 -- Ignore if bad type, avoid cascaded error
8382 if Etype
(Subp
) = Any_Type
then
8386 -- Ignore if all inlining is suppressed
8388 elsif Suppress_All_Inlining
then
8392 -- If inlining is not possible, for now do not treat as an error
8394 elsif Status
/= Suppressed
8395 and then Inlining_Not_Possible
(Subp
)
8400 -- Here we have a candidate for inlining, but we must exclude
8401 -- derived operations. Otherwise we would end up trying to inline
8402 -- a phantom declaration, and the result would be to drag in a
8403 -- body which has no direct inlining associated with it. That
8404 -- would not only be inefficient but would also result in the
8405 -- backend doing cross-unit inlining in cases where it was
8406 -- definitely inappropriate to do so.
8408 -- However, a simple Comes_From_Source test is insufficient, since
8409 -- we do want to allow inlining of generic instances which also do
8410 -- not come from source. We also need to recognize specs generated
8411 -- by the front-end for bodies that carry the pragma. Finally,
8412 -- predefined operators do not come from source but are not
8413 -- inlineable either.
8415 elsif Is_Generic_Instance
(Subp
)
8416 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8420 elsif not Comes_From_Source
(Subp
)
8421 and then Scope
(Subp
) /= Standard_Standard
8427 -- The referenced entity must either be the enclosing entity, or
8428 -- an entity declared within the current open scope.
8430 if Present
(Scope
(Subp
))
8431 and then Scope
(Subp
) /= Current_Scope
8432 and then Subp
/= Current_Scope
8435 ("argument of% must be entity in current scope", Assoc
);
8439 -- Processing for procedure, operator or function. If subprogram
8440 -- is aliased (as for an instance) indicate that the renamed
8441 -- entity (if declared in the same unit) is inlined.
8443 if Is_Subprogram
(Subp
) then
8444 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8446 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8447 Set_Inline_Flags
(Inner_Subp
);
8449 Decl
:= Parent
(Parent
(Inner_Subp
));
8451 if Nkind
(Decl
) = N_Subprogram_Declaration
8452 and then Present
(Corresponding_Body
(Decl
))
8454 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8456 elsif Is_Generic_Instance
(Subp
) then
8458 -- Indicate that the body needs to be created for
8459 -- inlining subsequent calls. The instantiation node
8460 -- follows the declaration of the wrapper package
8463 if Scope
(Subp
) /= Standard_Standard
8465 Need_Subprogram_Instance_Body
8466 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8472 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8473 -- appear in a formal part to apply to a formal subprogram.
8474 -- Do not apply check within an instance or a formal package
8475 -- the test will have been applied to the original generic.
8477 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8478 and then List_Containing
(Decl
) = List_Containing
(N
)
8479 and then not In_Instance
8482 ("Inline cannot apply to a formal subprogram", N
);
8484 -- If Subp is a renaming, it is the renamed entity that
8485 -- will appear in any call, and be inlined. However, for
8486 -- ASIS uses it is convenient to indicate that the renaming
8487 -- itself is an inlined subprogram, so that some gnatcheck
8488 -- rules can be applied in the absence of expansion.
8490 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8491 Set_Inline_Flags
(Subp
);
8497 -- For a generic subprogram set flag as well, for use at the point
8498 -- of instantiation, to determine whether the body should be
8501 elsif Is_Generic_Subprogram
(Subp
) then
8502 Set_Inline_Flags
(Subp
);
8505 -- Literals are by definition inlined
8507 elsif Kind
= E_Enumeration_Literal
then
8510 -- Anything else is an error
8514 ("expect subprogram name for pragma%", Assoc
);
8518 ----------------------
8519 -- Set_Inline_Flags --
8520 ----------------------
8522 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8524 -- First set the Has_Pragma_XXX flags and issue the appropriate
8525 -- errors and warnings for suspicious combinations.
8527 if Prag_Id
= Pragma_No_Inline
then
8528 if Has_Pragma_Inline_Always
(Subp
) then
8530 ("Inline_Always and No_Inline are mutually exclusive", N
);
8531 elsif Has_Pragma_Inline
(Subp
) then
8533 ("Inline and No_Inline both specified for& ??",
8534 N
, Entity
(Subp_Id
));
8537 Set_Has_Pragma_No_Inline
(Subp
);
8539 if Prag_Id
= Pragma_Inline_Always
then
8540 if Has_Pragma_No_Inline
(Subp
) then
8542 ("Inline_Always and No_Inline are mutually exclusive",
8546 Set_Has_Pragma_Inline_Always
(Subp
);
8548 if Has_Pragma_No_Inline
(Subp
) then
8550 ("Inline and No_Inline both specified for& ??",
8551 N
, Entity
(Subp_Id
));
8555 if not Has_Pragma_Inline
(Subp
) then
8556 Set_Has_Pragma_Inline
(Subp
);
8561 -- Then adjust the Is_Inlined flag. It can never be set if the
8562 -- subprogram is subject to pragma No_Inline.
8566 Set_Is_Inlined
(Subp
, False);
8570 if not Has_Pragma_No_Inline
(Subp
) then
8571 Set_Is_Inlined
(Subp
, True);
8574 end Set_Inline_Flags
;
8576 -- Start of processing for Process_Inline
8579 Check_No_Identifiers
;
8580 Check_At_Least_N_Arguments
(1);
8582 if Status
= Enabled
then
8583 Inline_Processing_Required
:= True;
8587 while Present
(Assoc
) loop
8588 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8592 if Is_Entity_Name
(Subp_Id
) then
8593 Subp
:= Entity
(Subp_Id
);
8595 if Subp
= Any_Id
then
8597 -- If previous error, avoid cascaded errors
8599 Check_Error_Detected
;
8606 -- For the pragma case, climb homonym chain. This is
8607 -- what implements allowing the pragma in the renaming
8608 -- case, with the result applying to the ancestors, and
8609 -- also allows Inline to apply to all previous homonyms.
8611 if not From_Aspect_Specification
(N
) then
8612 while Present
(Homonym
(Subp
))
8613 and then Scope
(Homonym
(Subp
)) = Current_Scope
8615 Make_Inline
(Homonym
(Subp
));
8616 Subp
:= Homonym
(Subp
);
8624 ("inappropriate argument for pragma%", Assoc
);
8627 and then Warn_On_Redundant_Constructs
8628 and then not (Status
= Suppressed
or else Suppress_All_Inlining
)
8630 if Inlining_Not_Possible
(Subp
) then
8632 ("pragma Inline for& is ignored?r?",
8633 N
, Entity
(Subp_Id
));
8636 ("pragma Inline for& is redundant?r?",
8637 N
, Entity
(Subp_Id
));
8645 ----------------------------
8646 -- Process_Interface_Name --
8647 ----------------------------
8649 procedure Process_Interface_Name
8650 (Subprogram_Def
: Entity_Id
;
8656 String_Val
: String_Id
;
8658 procedure Check_Form_Of_Interface_Name
8660 Ext_Name_Case
: Boolean);
8661 -- SN is a string literal node for an interface name. This routine
8662 -- performs some minimal checks that the name is reasonable. In
8663 -- particular that no spaces or other obviously incorrect characters
8664 -- appear. This is only a warning, since any characters are allowed.
8665 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8667 ----------------------------------
8668 -- Check_Form_Of_Interface_Name --
8669 ----------------------------------
8671 procedure Check_Form_Of_Interface_Name
8673 Ext_Name_Case
: Boolean)
8675 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8676 SL
: constant Nat
:= String_Length
(S
);
8681 Error_Msg_N
("interface name cannot be null string", SN
);
8684 for J
in 1 .. SL
loop
8685 C
:= Get_String_Char
(S
, J
);
8687 -- Look for dubious character and issue unconditional warning.
8688 -- Definitely dubious if not in character range.
8690 if not In_Character_Range
(C
)
8692 -- For all cases except CLI target,
8693 -- commas, spaces and slashes are dubious (in CLI, we use
8694 -- commas and backslashes in external names to specify
8695 -- assembly version and public key, while slashes and spaces
8696 -- can be used in names to mark nested classes and
8699 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8700 and then (Get_Character
(C
) = ','
8702 Get_Character
(C
) = '\'))
8703 or else (VM_Target
/= CLI_Target
8704 and then (Get_Character
(C
) = ' '
8706 Get_Character
(C
) = '/'))
8709 ("??interface name contains illegal character",
8710 Sloc
(SN
) + Source_Ptr
(J
));
8713 end Check_Form_Of_Interface_Name
;
8715 -- Start of processing for Process_Interface_Name
8718 if No
(Link_Arg
) then
8719 if No
(Ext_Arg
) then
8720 if VM_Target
= CLI_Target
8721 and then Ekind
(Subprogram_Def
) = E_Package
8722 and then Nkind
(Parent
(Subprogram_Def
)) =
8723 N_Package_Specification
8724 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8729 (Generic_Parent
(Parent
(Subprogram_Def
))));
8734 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8736 Link_Nam
:= Expression
(Ext_Arg
);
8739 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8740 Ext_Nam
:= Expression
(Ext_Arg
);
8745 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8746 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8747 Ext_Nam
:= Expression
(Ext_Arg
);
8748 Link_Nam
:= Expression
(Link_Arg
);
8751 -- Check expressions for external name and link name are static
8753 if Present
(Ext_Nam
) then
8754 Check_Arg_Is_Static_Expression
(Ext_Nam
, Standard_String
);
8755 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8757 -- Verify that external name is not the name of a local entity,
8758 -- which would hide the imported one and could lead to run-time
8759 -- surprises. The problem can only arise for entities declared in
8760 -- a package body (otherwise the external name is fully qualified
8761 -- and will not conflict).
8769 if Prag_Id
= Pragma_Import
then
8770 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8772 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
8774 if Nam
/= Chars
(Subprogram_Def
)
8775 and then Present
(E
)
8776 and then not Is_Overloadable
(E
)
8777 and then Is_Immediately_Visible
(E
)
8778 and then not Is_Imported
(E
)
8779 and then Ekind
(Scope
(E
)) = E_Package
8782 while Present
(Par
) loop
8783 if Nkind
(Par
) = N_Package_Body
then
8784 Error_Msg_Sloc
:= Sloc
(E
);
8786 ("imported entity is hidden by & declared#",
8791 Par
:= Parent
(Par
);
8798 if Present
(Link_Nam
) then
8799 Check_Arg_Is_Static_Expression
(Link_Nam
, Standard_String
);
8800 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8803 -- If there is no link name, just set the external name
8805 if No
(Link_Nam
) then
8806 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8808 -- For the Link_Name case, the given literal is preceded by an
8809 -- asterisk, which indicates to GCC that the given name should be
8810 -- taken literally, and in particular that no prepending of
8811 -- underlines should occur, even in systems where this is the
8817 if VM_Target
= No_VM
then
8818 Store_String_Char
(Get_Char_Code
('*'));
8821 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8822 Store_String_Chars
(String_Val
);
8824 Make_String_Literal
(Sloc
(Link_Nam
),
8825 Strval
=> End_String
);
8828 -- Set the interface name. If the entity is a generic instance, use
8829 -- its alias, which is the callable entity.
8831 if Is_Generic_Instance
(Subprogram_Def
) then
8832 Set_Encoded_Interface_Name
8833 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8835 Set_Encoded_Interface_Name
8836 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8839 -- We allow duplicated export names in CIL/Java, as they are always
8840 -- enclosed in a namespace that differentiates them, and overloaded
8841 -- entities are supported by the VM.
8843 if Convention
(Subprogram_Def
) /= Convention_CIL
8845 Convention
(Subprogram_Def
) /= Convention_Java
8847 Check_Duplicated_Export_Name
(Link_Nam
);
8849 end Process_Interface_Name
;
8851 -----------------------------------------
8852 -- Process_Interrupt_Or_Attach_Handler --
8853 -----------------------------------------
8855 procedure Process_Interrupt_Or_Attach_Handler
is
8856 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8857 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8858 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8861 Set_Is_Interrupt_Handler
(Handler_Proc
);
8863 -- If the pragma is not associated with a handler procedure within a
8864 -- protected type, then it must be for a nonprotected procedure for
8865 -- the AAMP target, in which case we don't associate a representation
8866 -- item with the procedure's scope.
8868 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8869 if Prag_Id
= Pragma_Interrupt_Handler
8871 Prag_Id
= Pragma_Attach_Handler
8873 Record_Rep_Item
(Proc_Scope
, N
);
8876 end Process_Interrupt_Or_Attach_Handler
;
8878 --------------------------------------------------
8879 -- Process_Restrictions_Or_Restriction_Warnings --
8880 --------------------------------------------------
8882 -- Note: some of the simple identifier cases were handled in par-prag,
8883 -- but it is harmless (and more straightforward) to simply handle all
8884 -- cases here, even if it means we repeat a bit of work in some cases.
8886 procedure Process_Restrictions_Or_Restriction_Warnings
8890 R_Id
: Restriction_Id
;
8896 -- Ignore all Restrictions pragmas in CodePeer mode
8898 if CodePeer_Mode
then
8902 Check_Ada_83_Warning
;
8903 Check_At_Least_N_Arguments
(1);
8904 Check_Valid_Configuration_Pragma
;
8907 while Present
(Arg
) loop
8909 Expr
:= Get_Pragma_Arg
(Arg
);
8911 -- Case of no restriction identifier present
8913 if Id
= No_Name
then
8914 if Nkind
(Expr
) /= N_Identifier
then
8916 ("invalid form for restriction", Arg
);
8921 (Process_Restriction_Synonyms
(Expr
));
8923 if R_Id
not in All_Boolean_Restrictions
then
8924 Error_Msg_Name_1
:= Pname
;
8926 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8928 -- Check for possible misspelling
8930 for J
in Restriction_Id
loop
8932 Rnm
: constant String := Restriction_Id
'Image (J
);
8935 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8936 Name_Len
:= Rnm
'Length;
8937 Set_Casing
(All_Lower_Case
);
8939 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8941 (Identifier_Casing
(Current_Source_File
));
8942 Error_Msg_String
(1 .. Rnm
'Length) :=
8943 Name_Buffer
(1 .. Name_Len
);
8944 Error_Msg_Strlen
:= Rnm
'Length;
8945 Error_Msg_N
-- CODEFIX
8946 ("\possible misspelling of ""~""",
8947 Get_Pragma_Arg
(Arg
));
8956 if Implementation_Restriction
(R_Id
) then
8957 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8960 -- Special processing for No_Elaboration_Code restriction
8962 if R_Id
= No_Elaboration_Code
then
8964 -- Restriction is only recognized within a configuration
8965 -- pragma file, or within a unit of the main extended
8966 -- program. Note: the test for Main_Unit is needed to
8967 -- properly include the case of configuration pragma files.
8969 if not (Current_Sem_Unit
= Main_Unit
8970 or else In_Extended_Main_Source_Unit
(N
))
8974 -- Don't allow in a subunit unless already specified in
8977 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8978 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8979 and then not Restriction_Active
(No_Elaboration_Code
)
8982 ("invalid specification of ""No_Elaboration_Code""",
8985 ("\restriction cannot be specified in a subunit", N
);
8987 ("\unless also specified in body or spec", N
);
8990 -- If we have a No_Elaboration_Code pragma that we
8991 -- accept, then it needs to be added to the configuration
8992 -- restrcition set so that we get proper application to
8993 -- other units in the main extended source as required.
8996 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
9000 -- If this is a warning, then set the warning unless we already
9001 -- have a real restriction active (we never want a warning to
9002 -- override a real restriction).
9005 if not Restriction_Active
(R_Id
) then
9006 Set_Restriction
(R_Id
, N
);
9007 Restriction_Warnings
(R_Id
) := True;
9010 -- If real restriction case, then set it and make sure that the
9011 -- restriction warning flag is off, since a real restriction
9012 -- always overrides a warning.
9015 Set_Restriction
(R_Id
, N
);
9016 Restriction_Warnings
(R_Id
) := False;
9019 -- Check for obsolescent restrictions in Ada 2005 mode
9022 and then Ada_Version
>= Ada_2005
9023 and then (R_Id
= No_Asynchronous_Control
9025 R_Id
= No_Unchecked_Deallocation
9027 R_Id
= No_Unchecked_Conversion
)
9029 Check_Restriction
(No_Obsolescent_Features
, N
);
9032 -- A very special case that must be processed here: pragma
9033 -- Restrictions (No_Exceptions) turns off all run-time
9034 -- checking. This is a bit dubious in terms of the formal
9035 -- language definition, but it is what is intended by RM
9036 -- H.4(12). Restriction_Warnings never affects generated code
9037 -- so this is done only in the real restriction case.
9039 -- Atomic_Synchronization is not a real check, so it is not
9040 -- affected by this processing).
9042 if R_Id
= No_Exceptions
and then not Warn
then
9043 for J
in Scope_Suppress
.Suppress
'Range loop
9044 if J
/= Atomic_Synchronization
then
9045 Scope_Suppress
.Suppress
(J
) := True;
9050 -- Case of No_Dependence => unit-name. Note that the parser
9051 -- already made the necessary entry in the No_Dependence table.
9053 elsif Id
= Name_No_Dependence
then
9054 if not OK_No_Dependence_Unit_Name
(Expr
) then
9058 -- Case of No_Specification_Of_Aspect => Identifier.
9060 elsif Id
= Name_No_Specification_Of_Aspect
then
9065 if Nkind
(Expr
) /= N_Identifier
then
9068 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
9071 if A_Id
= No_Aspect
then
9072 Error_Pragma_Arg
("invalid restriction name", Arg
);
9074 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
9078 elsif Id
= Name_No_Use_Of_Attribute
then
9079 if Nkind
(Expr
) /= N_Identifier
9080 or else not Is_Attribute_Name
(Chars
(Expr
))
9082 Error_Msg_N
("unknown attribute name??", Expr
);
9085 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9088 elsif Id
= Name_No_Use_Of_Pragma
then
9089 if Nkind
(Expr
) /= N_Identifier
9090 or else not Is_Pragma_Name
(Chars
(Expr
))
9092 Error_Msg_N
("unknown pragma name??", Expr
);
9095 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9098 -- All other cases of restriction identifier present
9101 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9102 Analyze_And_Resolve
(Expr
, Any_Integer
);
9104 if R_Id
not in All_Parameter_Restrictions
then
9106 ("invalid restriction parameter identifier", Arg
);
9108 elsif not Is_OK_Static_Expression
(Expr
) then
9109 Flag_Non_Static_Expr
9110 ("value must be static expression!", Expr
);
9113 elsif not Is_Integer_Type
(Etype
(Expr
))
9114 or else Expr_Value
(Expr
) < 0
9117 ("value must be non-negative integer", Arg
);
9120 -- Restriction pragma is active
9122 Val
:= Expr_Value
(Expr
);
9124 if not UI_Is_In_Int_Range
(Val
) then
9126 ("pragma ignored, value too large??", Arg
);
9129 -- Warning case. If the real restriction is active, then we
9130 -- ignore the request, since warning never overrides a real
9131 -- restriction. Otherwise we set the proper warning. Note that
9132 -- this circuit sets the warning again if it is already set,
9133 -- which is what we want, since the constant may have changed.
9136 if not Restriction_Active
(R_Id
) then
9138 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9139 Restriction_Warnings
(R_Id
) := True;
9142 -- Real restriction case, set restriction and make sure warning
9143 -- flag is off since real restriction always overrides warning.
9146 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9147 Restriction_Warnings
(R_Id
) := False;
9153 end Process_Restrictions_Or_Restriction_Warnings
;
9155 ---------------------------------
9156 -- Process_Suppress_Unsuppress --
9157 ---------------------------------
9159 -- Note: this procedure makes entries in the check suppress data
9160 -- structures managed by Sem. See spec of package Sem for full
9161 -- details on how we handle recording of check suppression.
9163 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9168 In_Package_Spec
: constant Boolean :=
9169 Is_Package_Or_Generic_Package
(Current_Scope
)
9170 and then not In_Package_Body
(Current_Scope
);
9172 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9173 -- Used to suppress a single check on the given entity
9175 --------------------------------
9176 -- Suppress_Unsuppress_Echeck --
9177 --------------------------------
9179 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9181 -- Check for error of trying to set atomic synchronization for
9182 -- a non-atomic variable.
9184 if C
= Atomic_Synchronization
9185 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9188 ("pragma & requires atomic type or variable",
9189 Pragma_Identifier
(Original_Node
(N
)));
9192 Set_Checks_May_Be_Suppressed
(E
);
9194 if In_Package_Spec
then
9195 Push_Global_Suppress_Stack_Entry
9198 Suppress
=> Suppress_Case
);
9200 Push_Local_Suppress_Stack_Entry
9203 Suppress
=> Suppress_Case
);
9206 -- If this is a first subtype, and the base type is distinct,
9207 -- then also set the suppress flags on the base type.
9209 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9210 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9212 end Suppress_Unsuppress_Echeck
;
9214 -- Start of processing for Process_Suppress_Unsuppress
9217 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9218 -- on user code: we want to generate checks for analysis purposes, as
9219 -- set respectively by -gnatC and -gnatd.F
9221 if (CodePeer_Mode
or GNATprove_Mode
)
9222 and then Comes_From_Source
(N
)
9227 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9228 -- declarative part or a package spec (RM 11.5(5)).
9230 if not Is_Configuration_Pragma
then
9231 Check_Is_In_Decl_Part_Or_Package_Spec
;
9234 Check_At_Least_N_Arguments
(1);
9235 Check_At_Most_N_Arguments
(2);
9236 Check_No_Identifier
(Arg1
);
9237 Check_Arg_Is_Identifier
(Arg1
);
9239 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9241 if C
= No_Check_Id
then
9243 ("argument of pragma% is not valid check name", Arg1
);
9246 if Arg_Count
= 1 then
9248 -- Make an entry in the local scope suppress table. This is the
9249 -- table that directly shows the current value of the scope
9250 -- suppress check for any check id value.
9252 if C
= All_Checks
then
9254 -- For All_Checks, we set all specific predefined checks with
9255 -- the exception of Elaboration_Check, which is handled
9256 -- specially because of not wanting All_Checks to have the
9257 -- effect of deactivating static elaboration order processing.
9258 -- Atomic_Synchronization is also not affected, since this is
9259 -- not a real check.
9261 for J
in Scope_Suppress
.Suppress
'Range loop
9262 if J
/= Elaboration_Check
9264 J
/= Atomic_Synchronization
9266 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9270 -- If not All_Checks, and predefined check, then set appropriate
9271 -- scope entry. Note that we will set Elaboration_Check if this
9272 -- is explicitly specified. Atomic_Synchronization is allowed
9273 -- only if internally generated and entity is atomic.
9275 elsif C
in Predefined_Check_Id
9276 and then (not Comes_From_Source
(N
)
9277 or else C
/= Atomic_Synchronization
)
9279 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9282 -- Also make an entry in the Local_Entity_Suppress table
9284 Push_Local_Suppress_Stack_Entry
9287 Suppress
=> Suppress_Case
);
9289 -- Case of two arguments present, where the check is suppressed for
9290 -- a specified entity (given as the second argument of the pragma)
9293 -- This is obsolescent in Ada 2005 mode
9295 if Ada_Version
>= Ada_2005
then
9296 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9299 Check_Optional_Identifier
(Arg2
, Name_On
);
9300 E_Id
:= Get_Pragma_Arg
(Arg2
);
9303 if not Is_Entity_Name
(E_Id
) then
9305 ("second argument of pragma% must be entity name", Arg2
);
9314 -- Enforce RM 11.5(7) which requires that for a pragma that
9315 -- appears within a package spec, the named entity must be
9316 -- within the package spec. We allow the package name itself
9317 -- to be mentioned since that makes sense, although it is not
9318 -- strictly allowed by 11.5(7).
9321 and then E
/= Current_Scope
9322 and then Scope
(E
) /= Current_Scope
9325 ("entity in pragma% is not in package spec (RM 11.5(7))",
9329 -- Loop through homonyms. As noted below, in the case of a package
9330 -- spec, only homonyms within the package spec are considered.
9333 Suppress_Unsuppress_Echeck
(E
, C
);
9335 if Is_Generic_Instance
(E
)
9336 and then Is_Subprogram
(E
)
9337 and then Present
(Alias
(E
))
9339 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9342 -- Move to next homonym if not aspect spec case
9344 exit when From_Aspect_Specification
(N
);
9348 -- If we are within a package specification, the pragma only
9349 -- applies to homonyms in the same scope.
9351 exit when In_Package_Spec
9352 and then Scope
(E
) /= Current_Scope
;
9355 end Process_Suppress_Unsuppress
;
9361 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9363 if Is_Imported
(E
) then
9365 ("cannot export entity& that was previously imported", Arg
);
9367 elsif Present
(Address_Clause
(E
))
9368 and then not Relaxed_RM_Semantics
9371 ("cannot export entity& that has an address clause", Arg
);
9374 Set_Is_Exported
(E
);
9376 -- Generate a reference for entity explicitly, because the
9377 -- identifier may be overloaded and name resolution will not
9380 Generate_Reference
(E
, Arg
);
9382 -- Deal with exporting non-library level entity
9384 if not Is_Library_Level_Entity
(E
) then
9386 -- Not allowed at all for subprograms
9388 if Is_Subprogram
(E
) then
9389 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9391 -- Otherwise set public and statically allocated
9395 Set_Is_Statically_Allocated
(E
);
9397 -- Warn if the corresponding W flag is set and the pragma comes
9398 -- from source. The latter may not be true e.g. on VMS where we
9399 -- expand export pragmas for exception codes associated with
9400 -- imported or exported exceptions. We do not want to generate
9401 -- a warning for something that the user did not write.
9403 if Warn_On_Export_Import
9404 and then Comes_From_Source
(Arg
)
9407 ("?x?& has been made static as a result of Export",
9410 ("\?x?this usage is non-standard and non-portable",
9416 if Warn_On_Export_Import
and then Is_Type
(E
) then
9417 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9420 if Warn_On_Export_Import
and Inside_A_Generic
then
9422 ("all instances of& will have the same external name?x?",
9427 ----------------------------------------------
9428 -- Set_Extended_Import_Export_External_Name --
9429 ----------------------------------------------
9431 procedure Set_Extended_Import_Export_External_Name
9432 (Internal_Ent
: Entity_Id
;
9433 Arg_External
: Node_Id
)
9435 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9439 if No
(Arg_External
) then
9443 Check_Arg_Is_External_Name
(Arg_External
);
9445 if Nkind
(Arg_External
) = N_String_Literal
then
9446 if String_Length
(Strval
(Arg_External
)) = 0 then
9449 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9452 elsif Nkind
(Arg_External
) = N_Identifier
then
9453 New_Name
:= Get_Default_External_Name
(Arg_External
);
9455 -- Check_Arg_Is_External_Name should let through only identifiers and
9456 -- string literals or static string expressions (which are folded to
9457 -- string literals).
9460 raise Program_Error
;
9463 -- If we already have an external name set (by a prior normal Import
9464 -- or Export pragma), then the external names must match
9466 if Present
(Interface_Name
(Internal_Ent
)) then
9468 -- Ignore mismatching names in CodePeer mode, to support some
9469 -- old compilers which would export the same procedure under
9470 -- different names, e.g:
9472 -- pragma Export_Procedure (P, "a");
9473 -- pragma Export_Procedure (P, "b");
9475 if CodePeer_Mode
then
9479 Check_Matching_Internal_Names
: declare
9480 S1
: constant String_Id
:= Strval
(Old_Name
);
9481 S2
: constant String_Id
:= Strval
(New_Name
);
9484 pragma No_Return
(Mismatch
);
9485 -- Called if names do not match
9491 procedure Mismatch
is
9493 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9495 ("external name does not match that given #",
9499 -- Start of processing for Check_Matching_Internal_Names
9502 if String_Length
(S1
) /= String_Length
(S2
) then
9506 for J
in 1 .. String_Length
(S1
) loop
9507 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9512 end Check_Matching_Internal_Names
;
9514 -- Otherwise set the given name
9517 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9518 Check_Duplicated_Export_Name
(New_Name
);
9520 end Set_Extended_Import_Export_External_Name
;
9526 procedure Set_Imported
(E
: Entity_Id
) is
9528 -- Error message if already imported or exported
9530 if Is_Exported
(E
) or else Is_Imported
(E
) then
9532 -- Error if being set Exported twice
9534 if Is_Exported
(E
) then
9535 Error_Msg_NE
("entity& was previously exported", N
, E
);
9537 -- Ignore error in CodePeer mode where we treat all imported
9538 -- subprograms as unknown.
9540 elsif CodePeer_Mode
then
9543 -- OK if Import/Interface case
9545 elsif Import_Interface_Present
(N
) then
9548 -- Error if being set Imported twice
9551 Error_Msg_NE
("entity& was previously imported", N
, E
);
9554 Error_Msg_Name_1
:= Pname
;
9556 ("\(pragma% applies to all previous entities)", N
);
9558 Error_Msg_Sloc
:= Sloc
(E
);
9559 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9561 -- Here if not previously imported or exported, OK to import
9564 Set_Is_Imported
(E
);
9566 -- For subprogram, set Import_Pragma field
9568 if Is_Subprogram
(E
) then
9569 Set_Import_Pragma
(E
, N
);
9572 -- If the entity is an object that is not at the library level,
9573 -- then it is statically allocated. We do not worry about objects
9574 -- with address clauses in this context since they are not really
9575 -- imported in the linker sense.
9578 and then not Is_Library_Level_Entity
(E
)
9579 and then No
(Address_Clause
(E
))
9581 Set_Is_Statically_Allocated
(E
);
9588 -------------------------
9589 -- Set_Mechanism_Value --
9590 -------------------------
9592 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9593 -- analyzed, since it is semantic nonsense), so we get it in the exact
9594 -- form created by the parser.
9596 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9599 Mech_Name_Id
: Name_Id
;
9601 procedure Bad_Class
;
9602 pragma No_Return
(Bad_Class
);
9603 -- Signal bad descriptor class name
9605 procedure Bad_Mechanism
;
9606 pragma No_Return
(Bad_Mechanism
);
9607 -- Signal bad mechanism name
9613 procedure Bad_Class
is
9615 Error_Pragma_Arg
("unrecognized descriptor class name", Class
);
9618 -------------------------
9619 -- Bad_Mechanism_Value --
9620 -------------------------
9622 procedure Bad_Mechanism
is
9624 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9627 -- Start of processing for Set_Mechanism_Value
9630 if Mechanism
(Ent
) /= Default_Mechanism
then
9632 ("mechanism for & has already been set", Mech_Name
, Ent
);
9635 -- MECHANISM_NAME ::= value | reference | descriptor |
9638 if Nkind
(Mech_Name
) = N_Identifier
then
9639 if Chars
(Mech_Name
) = Name_Value
then
9640 Set_Mechanism
(Ent
, By_Copy
);
9643 elsif Chars
(Mech_Name
) = Name_Reference
then
9644 Set_Mechanism
(Ent
, By_Reference
);
9647 elsif Chars
(Mech_Name
) = Name_Descriptor
then
9648 Check_VMS
(Mech_Name
);
9650 -- Descriptor => Short_Descriptor if pragma was given
9652 if Short_Descriptors
then
9653 Set_Mechanism
(Ent
, By_Short_Descriptor
);
9655 Set_Mechanism
(Ent
, By_Descriptor
);
9660 elsif Chars
(Mech_Name
) = Name_Short_Descriptor
then
9661 Check_VMS
(Mech_Name
);
9662 Set_Mechanism
(Ent
, By_Short_Descriptor
);
9665 elsif Chars
(Mech_Name
) = Name_Copy
then
9667 ("bad mechanism name, Value assumed", Mech_Name
);
9673 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
9674 -- short_descriptor (CLASS_NAME)
9675 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9677 -- Note: this form is parsed as an indexed component
9679 elsif Nkind
(Mech_Name
) = N_Indexed_Component
then
9680 Class
:= First
(Expressions
(Mech_Name
));
9682 if Nkind
(Prefix
(Mech_Name
)) /= N_Identifier
9684 not Nam_In
(Chars
(Prefix
(Mech_Name
)), Name_Descriptor
,
9685 Name_Short_Descriptor
)
9686 or else Present
(Next
(Class
))
9690 Mech_Name_Id
:= Chars
(Prefix
(Mech_Name
));
9692 -- Change Descriptor => Short_Descriptor if pragma was given
9694 if Mech_Name_Id
= Name_Descriptor
9695 and then Short_Descriptors
9697 Mech_Name_Id
:= Name_Short_Descriptor
;
9701 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
9702 -- short_descriptor (Class => CLASS_NAME)
9703 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9705 -- Note: this form is parsed as a function call
9707 elsif Nkind
(Mech_Name
) = N_Function_Call
then
9708 Param
:= First
(Parameter_Associations
(Mech_Name
));
9710 if Nkind
(Name
(Mech_Name
)) /= N_Identifier
9712 not Nam_In
(Chars
(Name
(Mech_Name
)), Name_Descriptor
,
9713 Name_Short_Descriptor
)
9714 or else Present
(Next
(Param
))
9715 or else No
(Selector_Name
(Param
))
9716 or else Chars
(Selector_Name
(Param
)) /= Name_Class
9720 Class
:= Explicit_Actual_Parameter
(Param
);
9721 Mech_Name_Id
:= Chars
(Name
(Mech_Name
));
9728 -- Fall through here with Class set to descriptor class name
9730 Check_VMS
(Mech_Name
);
9732 if Nkind
(Class
) /= N_Identifier
then
9735 elsif Mech_Name_Id
= Name_Descriptor
9736 and then Chars
(Class
) = Name_UBS
9738 Set_Mechanism
(Ent
, By_Descriptor_UBS
);
9740 elsif Mech_Name_Id
= Name_Descriptor
9741 and then Chars
(Class
) = Name_UBSB
9743 Set_Mechanism
(Ent
, By_Descriptor_UBSB
);
9745 elsif Mech_Name_Id
= Name_Descriptor
9746 and then Chars
(Class
) = Name_UBA
9748 Set_Mechanism
(Ent
, By_Descriptor_UBA
);
9750 elsif Mech_Name_Id
= Name_Descriptor
9751 and then Chars
(Class
) = Name_S
9753 Set_Mechanism
(Ent
, By_Descriptor_S
);
9755 elsif Mech_Name_Id
= Name_Descriptor
9756 and then Chars
(Class
) = Name_SB
9758 Set_Mechanism
(Ent
, By_Descriptor_SB
);
9760 elsif Mech_Name_Id
= Name_Descriptor
9761 and then Chars
(Class
) = Name_A
9763 Set_Mechanism
(Ent
, By_Descriptor_A
);
9765 elsif Mech_Name_Id
= Name_Descriptor
9766 and then Chars
(Class
) = Name_NCA
9768 Set_Mechanism
(Ent
, By_Descriptor_NCA
);
9770 elsif Mech_Name_Id
= Name_Short_Descriptor
9771 and then Chars
(Class
) = Name_UBS
9773 Set_Mechanism
(Ent
, By_Short_Descriptor_UBS
);
9775 elsif Mech_Name_Id
= Name_Short_Descriptor
9776 and then Chars
(Class
) = Name_UBSB
9778 Set_Mechanism
(Ent
, By_Short_Descriptor_UBSB
);
9780 elsif Mech_Name_Id
= Name_Short_Descriptor
9781 and then Chars
(Class
) = Name_UBA
9783 Set_Mechanism
(Ent
, By_Short_Descriptor_UBA
);
9785 elsif Mech_Name_Id
= Name_Short_Descriptor
9786 and then Chars
(Class
) = Name_S
9788 Set_Mechanism
(Ent
, By_Short_Descriptor_S
);
9790 elsif Mech_Name_Id
= Name_Short_Descriptor
9791 and then Chars
(Class
) = Name_SB
9793 Set_Mechanism
(Ent
, By_Short_Descriptor_SB
);
9795 elsif Mech_Name_Id
= Name_Short_Descriptor
9796 and then Chars
(Class
) = Name_A
9798 Set_Mechanism
(Ent
, By_Short_Descriptor_A
);
9800 elsif Mech_Name_Id
= Name_Short_Descriptor
9801 and then Chars
(Class
) = Name_NCA
9803 Set_Mechanism
(Ent
, By_Short_Descriptor_NCA
);
9808 end Set_Mechanism_Value
;
9810 --------------------------
9811 -- Set_Rational_Profile --
9812 --------------------------
9814 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9815 -- and extension to the semantics of renaming declarations.
9817 procedure Set_Rational_Profile
is
9819 Implicit_Packing
:= True;
9820 Overriding_Renamings
:= True;
9821 Use_VADS_Size
:= True;
9822 end Set_Rational_Profile
;
9824 ---------------------------
9825 -- Set_Ravenscar_Profile --
9826 ---------------------------
9828 -- The tasks to be done here are
9830 -- Set required policies
9832 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9833 -- pragma Locking_Policy (Ceiling_Locking)
9835 -- Set Detect_Blocking mode
9837 -- Set required restrictions (see System.Rident for detailed list)
9839 -- Set the No_Dependence rules
9840 -- No_Dependence => Ada.Asynchronous_Task_Control
9841 -- No_Dependence => Ada.Calendar
9842 -- No_Dependence => Ada.Execution_Time.Group_Budget
9843 -- No_Dependence => Ada.Execution_Time.Timers
9844 -- No_Dependence => Ada.Task_Attributes
9845 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9847 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9848 Prefix_Entity
: Entity_Id
;
9849 Selector_Entity
: Entity_Id
;
9850 Prefix_Node
: Node_Id
;
9854 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9856 if Task_Dispatching_Policy
/= ' '
9857 and then Task_Dispatching_Policy
/= 'F'
9859 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9860 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9862 -- Set the FIFO_Within_Priorities policy, but always preserve
9863 -- System_Location since we like the error message with the run time
9867 Task_Dispatching_Policy
:= 'F';
9869 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9870 Task_Dispatching_Policy_Sloc
:= Loc
;
9874 -- pragma Locking_Policy (Ceiling_Locking)
9876 if Locking_Policy
/= ' '
9877 and then Locking_Policy
/= 'C'
9879 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9880 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9882 -- Set the Ceiling_Locking policy, but preserve System_Location since
9883 -- we like the error message with the run time name.
9886 Locking_Policy
:= 'C';
9888 if Locking_Policy_Sloc
/= System_Location
then
9889 Locking_Policy_Sloc
:= Loc
;
9893 -- pragma Detect_Blocking
9895 Detect_Blocking
:= True;
9897 -- Set the corresponding restrictions
9899 Set_Profile_Restrictions
9900 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9902 -- Set the No_Dependence restrictions
9904 -- The following No_Dependence restrictions:
9905 -- No_Dependence => Ada.Asynchronous_Task_Control
9906 -- No_Dependence => Ada.Calendar
9907 -- No_Dependence => Ada.Task_Attributes
9908 -- are already set by previous call to Set_Profile_Restrictions.
9910 -- Set the following restrictions which were added to Ada 2005:
9911 -- No_Dependence => Ada.Execution_Time.Group_Budget
9912 -- No_Dependence => Ada.Execution_Time.Timers
9914 if Ada_Version
>= Ada_2005
then
9915 Name_Buffer
(1 .. 3) := "ada";
9918 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9920 Name_Buffer
(1 .. 14) := "execution_time";
9923 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9926 Make_Selected_Component
9928 Prefix
=> Prefix_Entity
,
9929 Selector_Name
=> Selector_Entity
);
9931 Name_Buffer
(1 .. 13) := "group_budgets";
9934 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9937 Make_Selected_Component
9939 Prefix
=> Prefix_Node
,
9940 Selector_Name
=> Selector_Entity
);
9942 Set_Restriction_No_Dependence
9944 Warn
=> Treat_Restrictions_As_Warnings
,
9945 Profile
=> Ravenscar
);
9947 Name_Buffer
(1 .. 6) := "timers";
9950 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9953 Make_Selected_Component
9955 Prefix
=> Prefix_Node
,
9956 Selector_Name
=> Selector_Entity
);
9958 Set_Restriction_No_Dependence
9960 Warn
=> Treat_Restrictions_As_Warnings
,
9961 Profile
=> Ravenscar
);
9964 -- Set the following restrictions which was added to Ada 2012 (see
9966 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9968 if Ada_Version
>= Ada_2012
then
9969 Name_Buffer
(1 .. 6) := "system";
9972 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9974 Name_Buffer
(1 .. 15) := "multiprocessors";
9977 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9980 Make_Selected_Component
9982 Prefix
=> Prefix_Entity
,
9983 Selector_Name
=> Selector_Entity
);
9985 Name_Buffer
(1 .. 19) := "dispatching_domains";
9988 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9991 Make_Selected_Component
9993 Prefix
=> Prefix_Node
,
9994 Selector_Name
=> Selector_Entity
);
9996 Set_Restriction_No_Dependence
9998 Warn
=> Treat_Restrictions_As_Warnings
,
9999 Profile
=> Ravenscar
);
10001 end Set_Ravenscar_Profile
;
10003 -- Start of processing for Analyze_Pragma
10006 -- The following code is a defense against recursion. Not clear that
10007 -- this can happen legitimately, but perhaps some error situations
10008 -- can cause it, and we did see this recursion during testing.
10010 if Analyzed
(N
) then
10013 Set_Analyzed
(N
, True);
10016 -- Deal with unrecognized pragma
10018 Pname
:= Pragma_Name
(N
);
10020 if not Is_Pragma_Name
(Pname
) then
10021 if Warn_On_Unrecognized_Pragma
then
10022 Error_Msg_Name_1
:= Pname
;
10023 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
10025 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
10026 if Is_Bad_Spelling_Of
(Pname
, PN
) then
10027 Error_Msg_Name_1
:= PN
;
10028 Error_Msg_N
-- CODEFIX
10029 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
10038 -- Here to start processing for recognized pragma
10040 Prag_Id
:= Get_Pragma_Id
(Pname
);
10041 Pname
:= Original_Aspect_Name
(N
);
10043 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10044 -- is already set, indicating that we have already checked the policy
10045 -- at the right point. This happens for example in the case of a pragma
10046 -- that is derived from an Aspect.
10048 if Is_Ignored
(N
) or else Is_Checked
(N
) then
10051 -- For a pragma that is a rewriting of another pragma, copy the
10052 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10054 elsif Is_Rewrite_Substitution
(N
)
10055 and then Nkind
(Original_Node
(N
)) = N_Pragma
10056 and then Original_Node
(N
) /= N
10058 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
10059 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
10061 -- Otherwise query the applicable policy at this point
10064 Check_Applicable_Policy
(N
);
10066 -- If pragma is disabled, rewrite as NULL and skip analysis
10068 if Is_Disabled
(N
) then
10069 Rewrite
(N
, Make_Null_Statement
(Loc
));
10075 -- Preset arguments
10083 if Present
(Pragma_Argument_Associations
(N
)) then
10084 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
10085 Arg1
:= First
(Pragma_Argument_Associations
(N
));
10087 if Present
(Arg1
) then
10088 Arg2
:= Next
(Arg1
);
10090 if Present
(Arg2
) then
10091 Arg3
:= Next
(Arg2
);
10093 if Present
(Arg3
) then
10094 Arg4
:= Next
(Arg3
);
10100 Check_Restriction_No_Use_Of_Pragma
(N
);
10102 -- An enumeration type defines the pragmas that are supported by the
10103 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10104 -- into the corresponding enumeration value for the following case.
10112 -- pragma Abort_Defer;
10114 when Pragma_Abort_Defer
=>
10116 Check_Arg_Count
(0);
10118 -- The only required semantic processing is to check the
10119 -- placement. This pragma must appear at the start of the
10120 -- statement sequence of a handled sequence of statements.
10122 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
10123 or else N
/= First
(Statements
(Parent
(N
)))
10128 --------------------
10129 -- Abstract_State --
10130 --------------------
10132 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10134 -- ABSTRACT_STATE_LIST ::=
10136 -- | STATE_NAME_WITH_OPTIONS
10137 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
10139 -- STATE_NAME_WITH_OPTIONS ::=
10141 -- | (STATE_NAME with OPTION_LIST)
10143 -- OPTION_LIST ::= OPTION {, OPTION}
10147 -- | NAME_VALUE_OPTION
10149 -- SIMPLE_OPTION ::= identifier
10151 -- NAME_VALUE_OPTION ::=
10152 -- Part_Of => ABSTRACT_STATE
10153 -- | External [=> EXTERNAL_PROPERTY_LIST]
10155 -- EXTERNAL_PROPERTY_LIST ::=
10156 -- EXTERNAL_PROPERTY
10157 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
10159 -- EXTERNAL_PROPERTY ::=
10160 -- Async_Readers [=> boolean_EXPRESSION]
10161 -- | Async_Writers [=> boolean_EXPRESSION]
10162 -- | Effective_Reads [=> boolean_EXPRESSION]
10163 -- | Effective_Writes [=> boolean_EXPRESSION]
10164 -- others => boolean_EXPRESSION
10166 -- STATE_NAME ::= defining_identifier
10168 -- ABSTRACT_STATE ::= name
10170 when Pragma_Abstract_State
=> Abstract_State
: declare
10171 Missing_Parentheses
: Boolean := False;
10172 -- Flag set when a state declaration with options is not properly
10175 -- Flags used to verify the consistency of states
10177 Non_Null_Seen
: Boolean := False;
10178 Null_Seen
: Boolean := False;
10180 Pack_Id
: Entity_Id
;
10181 -- Entity of related package when pragma Abstract_State appears
10183 procedure Analyze_Abstract_State
(State
: Node_Id
);
10184 -- Verify the legality of a single state declaration. Create and
10185 -- decorate a state abstraction entity and introduce it into the
10186 -- visibility chain.
10188 ----------------------------
10189 -- Analyze_Abstract_State --
10190 ----------------------------
10192 procedure Analyze_Abstract_State
(State
: Node_Id
) is
10194 -- Flags used to verify the consistency of options
10196 AR_Seen
: Boolean := False;
10197 AW_Seen
: Boolean := False;
10198 ER_Seen
: Boolean := False;
10199 EW_Seen
: Boolean := False;
10200 External_Seen
: Boolean := False;
10201 Others_Seen
: Boolean := False;
10202 Part_Of_Seen
: Boolean := False;
10204 -- Flags used to store the static value of all external states'
10207 AR_Val
: Boolean := False;
10208 AW_Val
: Boolean := False;
10209 ER_Val
: Boolean := False;
10210 EW_Val
: Boolean := False;
10212 State_Id
: Entity_Id
:= Empty
;
10213 -- The entity to be generated for the current state declaration
10215 procedure Analyze_External_Option
(Opt
: Node_Id
);
10216 -- Verify the legality of option External
10218 procedure Analyze_External_Property
10220 Expr
: Node_Id
:= Empty
);
10221 -- Verify the legailty of a single external property. Prop
10222 -- denotes the external property. Expr is the expression used
10223 -- to set the property.
10225 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
10226 -- Verify the legality of option Part_Of
10228 procedure Check_Duplicate_Option
10230 Status
: in out Boolean);
10231 -- Flag Status denotes whether a particular option has been
10232 -- seen while processing a state. This routine verifies that
10233 -- Opt is not a duplicate option and sets the flag Status
10234 -- (SPARK RM 7.1.4(1)).
10236 procedure Check_Duplicate_Property
10238 Status
: in out Boolean);
10239 -- Flag Status denotes whether a particular property has been
10240 -- seen while processing option External. This routine verifies
10241 -- that Prop is not a duplicate property and sets flag Status.
10242 -- Opt is not a duplicate property and sets the flag Status.
10243 -- (SPARK RM 7.1.4(2))
10245 procedure Create_Abstract_State
10249 Is_Null
: Boolean);
10250 -- Generate an abstract state entity with name Nam and enter it
10251 -- into visibility. Decl is the "declaration" of the state as
10252 -- it appears in pragma Abstract_State. Loc is the location of
10253 -- the related state "declaration". Flag Is_Null should be set
10254 -- when the associated Abstract_State pragma defines a null
10257 -----------------------------
10258 -- Analyze_External_Option --
10259 -----------------------------
10261 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10262 Errors
: constant Nat
:= Serious_Errors_Detected
;
10264 Props
: Node_Id
:= Empty
;
10267 Check_Duplicate_Option
(Opt
, External_Seen
);
10269 if Nkind
(Opt
) = N_Component_Association
then
10270 Props
:= Expression
(Opt
);
10273 -- External state with properties
10275 if Present
(Props
) then
10277 -- Multiple properties appear as an aggregate
10279 if Nkind
(Props
) = N_Aggregate
then
10281 -- Simple property form
10283 Prop
:= First
(Expressions
(Props
));
10284 while Present
(Prop
) loop
10285 Analyze_External_Property
(Prop
);
10289 -- Property with expression form
10291 Prop
:= First
(Component_Associations
(Props
));
10292 while Present
(Prop
) loop
10293 Analyze_External_Property
10294 (Prop
=> First
(Choices
(Prop
)),
10295 Expr
=> Expression
(Prop
));
10303 Analyze_External_Property
(Props
);
10306 -- An external state defined without any properties defaults
10307 -- all properties to True.
10316 -- Once all external properties have been processed, verify
10317 -- their mutual interaction. Do not perform the check when
10318 -- at least one of the properties is illegal as this will
10319 -- produce a bogus error.
10321 if Errors
= Serious_Errors_Detected
then
10322 Check_External_Properties
10323 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10325 end Analyze_External_Option
;
10327 -------------------------------
10328 -- Analyze_External_Property --
10329 -------------------------------
10331 procedure Analyze_External_Property
10333 Expr
: Node_Id
:= Empty
)
10335 Expr_Val
: Boolean;
10338 -- Check the placement of "others" (if available)
10340 if Nkind
(Prop
) = N_Others_Choice
then
10341 if Others_Seen
then
10343 ("only one others choice allowed in option External",
10346 Others_Seen
:= True;
10349 elsif Others_Seen
then
10351 ("others must be the last property in option External",
10354 -- The only remaining legal options are the four predefined
10355 -- external properties.
10357 elsif Nkind
(Prop
) = N_Identifier
10358 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10359 Name_Async_Writers
,
10360 Name_Effective_Reads
,
10361 Name_Effective_Writes
)
10365 -- Otherwise the construct is not a valid property
10368 SPARK_Msg_N
("invalid external state property", Prop
);
10372 -- Ensure that the expression of the external state property
10373 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10375 if Present
(Expr
) then
10376 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10378 if Is_Static_Expression
(Expr
) then
10379 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10382 ("expression of external state property must be "
10386 -- The lack of expression defaults the property to True
10392 -- Named properties
10394 if Nkind
(Prop
) = N_Identifier
then
10395 if Chars
(Prop
) = Name_Async_Readers
then
10396 Check_Duplicate_Property
(Prop
, AR_Seen
);
10397 AR_Val
:= Expr_Val
;
10399 elsif Chars
(Prop
) = Name_Async_Writers
then
10400 Check_Duplicate_Property
(Prop
, AW_Seen
);
10401 AW_Val
:= Expr_Val
;
10403 elsif Chars
(Prop
) = Name_Effective_Reads
then
10404 Check_Duplicate_Property
(Prop
, ER_Seen
);
10405 ER_Val
:= Expr_Val
;
10408 Check_Duplicate_Property
(Prop
, EW_Seen
);
10409 EW_Val
:= Expr_Val
;
10412 -- The handling of property "others" must take into account
10413 -- all other named properties that have been encountered so
10414 -- far. Only those that have not been seen are affected by
10418 if not AR_Seen
then
10419 AR_Val
:= Expr_Val
;
10422 if not AW_Seen
then
10423 AW_Val
:= Expr_Val
;
10426 if not ER_Seen
then
10427 ER_Val
:= Expr_Val
;
10430 if not EW_Seen
then
10431 EW_Val
:= Expr_Val
;
10434 end Analyze_External_Property
;
10436 ----------------------------
10437 -- Analyze_Part_Of_Option --
10438 ----------------------------
10440 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10441 Encaps
: constant Node_Id
:= Expression
(Opt
);
10442 Encaps_Id
: Entity_Id
;
10446 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10449 (Item_Id
=> State_Id
,
10451 Indic
=> First
(Choices
(Opt
)),
10454 -- The Part_Of indicator turns an abstract state into a
10455 -- constituent of the encapsulating state.
10458 Encaps_Id
:= Entity
(Encaps
);
10460 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10461 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10463 end Analyze_Part_Of_Option
;
10465 ----------------------------
10466 -- Check_Duplicate_Option --
10467 ----------------------------
10469 procedure Check_Duplicate_Option
10471 Status
: in out Boolean)
10475 SPARK_Msg_N
("duplicate state option", Opt
);
10479 end Check_Duplicate_Option
;
10481 ------------------------------
10482 -- Check_Duplicate_Property --
10483 ------------------------------
10485 procedure Check_Duplicate_Property
10487 Status
: in out Boolean)
10491 SPARK_Msg_N
("duplicate external property", Prop
);
10495 end Check_Duplicate_Property
;
10497 ---------------------------
10498 -- Create_Abstract_State --
10499 ---------------------------
10501 procedure Create_Abstract_State
10508 -- The generated state abstraction reuses the same chars
10509 -- from the original state declaration. Decorate the entity.
10511 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10513 -- Null states never come from source
10515 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10516 Set_Parent
(State_Id
, State
);
10517 Set_Ekind
(State_Id
, E_Abstract_State
);
10518 Set_Etype
(State_Id
, Standard_Void_Type
);
10519 Set_Encapsulating_State
(State_Id
, Empty
);
10520 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10521 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10523 -- Establish a link between the state declaration and the
10524 -- abstract state entity. Note that a null state remains as
10525 -- N_Null and does not carry any linkages.
10527 if not Is_Null
then
10528 if Present
(Decl
) then
10529 Set_Entity
(Decl
, State_Id
);
10530 Set_Etype
(Decl
, Standard_Void_Type
);
10533 -- Every non-null state must be defined, nameable and
10536 Push_Scope
(Pack_Id
);
10537 Generate_Definition
(State_Id
);
10538 Enter_Name
(State_Id
);
10541 end Create_Abstract_State
;
10548 -- Start of processing for Analyze_Abstract_State
10551 -- A package with a null abstract state is not allowed to
10552 -- declare additional states.
10556 ("package & has null abstract state", State
, Pack_Id
);
10558 -- Null states appear as internally generated entities
10560 elsif Nkind
(State
) = N_Null
then
10561 Create_Abstract_State
10562 (Nam
=> New_Internal_Name
('S'),
10564 Loc
=> Sloc
(State
),
10568 -- Catch a case where a null state appears in a list of
10569 -- non-null states.
10571 if Non_Null_Seen
then
10573 ("package & has non-null abstract state",
10577 -- Simple state declaration
10579 elsif Nkind
(State
) = N_Identifier
then
10580 Create_Abstract_State
10581 (Nam
=> Chars
(State
),
10583 Loc
=> Sloc
(State
),
10585 Non_Null_Seen
:= True;
10587 -- State declaration with various options. This construct
10588 -- appears as an extension aggregate in the tree.
10590 elsif Nkind
(State
) = N_Extension_Aggregate
then
10591 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10592 Create_Abstract_State
10593 (Nam
=> Chars
(Ancestor_Part
(State
)),
10594 Decl
=> Ancestor_Part
(State
),
10595 Loc
=> Sloc
(Ancestor_Part
(State
)),
10597 Non_Null_Seen
:= True;
10600 ("state name must be an identifier",
10601 Ancestor_Part
(State
));
10604 -- Catch an attempt to introduce a simple option which is
10605 -- currently not allowed. An exception to this is External
10606 -- defined without any properties.
10608 Opt
:= First
(Expressions
(State
));
10609 while Present
(Opt
) loop
10610 if Nkind
(Opt
) = N_Identifier
then
10611 if Chars
(Opt
) = Name_External
then
10612 Analyze_External_Option
(Opt
);
10614 -- Option Part_Of without an encapsulating state is
10615 -- illegal. (SPARK RM 7.1.4(9)).
10617 elsif Chars
(Opt
) = Name_Part_Of
then
10619 ("indicator Part_Of must denote an abstract "
10622 -- Do not emit an error message when a previous state
10623 -- declaration with options was not parenthesized as
10624 -- the option is actually another state declaration.
10626 -- with Abstract_State
10627 -- (State_1 with ..., -- missing parentheses
10628 -- (State_2 with ...),
10629 -- State_3) -- ok state declaration
10631 elsif Missing_Parentheses
then
10634 -- Otherwise the option is not allowed. Note that it
10635 -- is not possible to distinguish between an option
10636 -- and a state declaration when a previous state with
10637 -- options not properly parentheses.
10639 -- with Abstract_State
10640 -- (State_1 with ..., -- missing parentheses
10641 -- State_2); -- could be an option
10645 ("simple option not allowed in state declaration",
10649 -- Catch a case where missing parentheses around a state
10650 -- declaration with options cause a subsequent state
10651 -- declaration with options to be treated as an option.
10653 -- with Abstract_State
10654 -- (State_1 with ..., -- missing parentheses
10655 -- (State_2 with ...))
10657 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10658 Missing_Parentheses
:= True;
10660 ("state declaration must be parenthesized",
10661 Ancestor_Part
(State
));
10663 -- Otherwise the option is malformed
10666 SPARK_Msg_N
("malformed option", Opt
);
10672 -- Options External and Part_Of appear as component
10675 Opt
:= First
(Component_Associations
(State
));
10676 while Present
(Opt
) loop
10677 Opt_Nam
:= First
(Choices
(Opt
));
10679 if Nkind
(Opt_Nam
) = N_Identifier
then
10680 if Chars
(Opt_Nam
) = Name_External
then
10681 Analyze_External_Option
(Opt
);
10683 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10684 Analyze_Part_Of_Option
(Opt
);
10687 SPARK_Msg_N
("invalid state option", Opt
);
10690 SPARK_Msg_N
("invalid state option", Opt
);
10696 -- Any other attempt to declare a state is illegal. This is a
10697 -- syntax error, always report.
10700 Error_Msg_N
("malformed abstract state declaration", State
);
10704 -- Guard against a junk state. In such cases no entity is
10705 -- generated and the subsequent checks cannot be applied.
10707 if Present
(State_Id
) then
10709 -- Verify whether the state does not introduce an illegal
10710 -- hidden state within a package subject to a null abstract
10713 Check_No_Hidden_State
(State_Id
);
10715 -- Check whether the lack of option Part_Of agrees with the
10716 -- placement of the abstract state with respect to the state
10719 if not Part_Of_Seen
then
10720 Check_Missing_Part_Of
(State_Id
);
10723 -- Associate the state with its related package
10725 if No
(Abstract_States
(Pack_Id
)) then
10726 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10729 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10731 end Analyze_Abstract_State
;
10735 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10738 -- Start of processing for Abstract_State
10742 Check_Arg_Count
(1);
10743 Ensure_Aggregate_Form
(Arg1
);
10745 -- Ensure the proper placement of the pragma. Abstract states must
10746 -- be associated with a package declaration.
10748 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10749 N_Package_Declaration
)
10755 State
:= Expression
(Arg1
);
10756 Pack_Id
:= Defining_Entity
(Context
);
10758 -- Multiple non-null abstract states appear as an aggregate
10760 if Nkind
(State
) = N_Aggregate
then
10761 State
:= First
(Expressions
(State
));
10762 while Present
(State
) loop
10763 Analyze_Abstract_State
(State
);
10767 -- Various forms of a single abstract state. Note that these may
10768 -- include malformed state declarations.
10771 Analyze_Abstract_State
(State
);
10774 -- Save the pragma for retrieval by other tools
10776 Add_Contract_Item
(N
, Pack_Id
);
10778 -- Verify the declaration order of pragmas Abstract_State and
10781 Check_Declaration_Order
10783 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10784 end Abstract_State
;
10792 -- Note: this pragma also has some specific processing in Par.Prag
10793 -- because we want to set the Ada version mode during parsing.
10795 when Pragma_Ada_83
=>
10797 Check_Arg_Count
(0);
10799 -- We really should check unconditionally for proper configuration
10800 -- pragma placement, since we really don't want mixed Ada modes
10801 -- within a single unit, and the GNAT reference manual has always
10802 -- said this was a configuration pragma, but we did not check and
10803 -- are hesitant to add the check now.
10805 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10806 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10807 -- or Ada 2012 mode.
10809 if Ada_Version
>= Ada_2005
then
10810 Check_Valid_Configuration_Pragma
;
10813 -- Now set Ada 83 mode
10815 Ada_Version
:= Ada_83
;
10816 Ada_Version_Explicit
:= Ada_83
;
10817 Ada_Version_Pragma
:= N
;
10825 -- Note: this pragma also has some specific processing in Par.Prag
10826 -- because we want to set the Ada 83 version mode during parsing.
10828 when Pragma_Ada_95
=>
10830 Check_Arg_Count
(0);
10832 -- We really should check unconditionally for proper configuration
10833 -- pragma placement, since we really don't want mixed Ada modes
10834 -- within a single unit, and the GNAT reference manual has always
10835 -- said this was a configuration pragma, but we did not check and
10836 -- are hesitant to add the check now.
10838 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10839 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10841 if Ada_Version
>= Ada_2005
then
10842 Check_Valid_Configuration_Pragma
;
10845 -- Now set Ada 95 mode
10847 Ada_Version
:= Ada_95
;
10848 Ada_Version_Explicit
:= Ada_95
;
10849 Ada_Version_Pragma
:= N
;
10851 ---------------------
10852 -- Ada_05/Ada_2005 --
10853 ---------------------
10856 -- pragma Ada_05 (LOCAL_NAME);
10858 -- pragma Ada_2005;
10859 -- pragma Ada_2005 (LOCAL_NAME):
10861 -- Note: these pragmas also have some specific processing in Par.Prag
10862 -- because we want to set the Ada 2005 version mode during parsing.
10864 -- The one argument form is used for managing the transition from
10865 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10866 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10867 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10868 -- mode, a preference rule is established which does not choose
10869 -- such an entity unless it is unambiguously specified. This avoids
10870 -- extra subprograms marked this way from generating ambiguities in
10871 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10872 -- intended for exclusive use in the GNAT run-time library.
10874 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10880 if Arg_Count
= 1 then
10881 Check_Arg_Is_Local_Name
(Arg1
);
10882 E_Id
:= Get_Pragma_Arg
(Arg1
);
10884 if Etype
(E_Id
) = Any_Type
then
10888 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10889 Record_Rep_Item
(Entity
(E_Id
), N
);
10892 Check_Arg_Count
(0);
10894 -- For Ada_2005 we unconditionally enforce the documented
10895 -- configuration pragma placement, since we do not want to
10896 -- tolerate mixed modes in a unit involving Ada 2005. That
10897 -- would cause real difficulties for those cases where there
10898 -- are incompatibilities between Ada 95 and Ada 2005.
10900 Check_Valid_Configuration_Pragma
;
10902 -- Now set appropriate Ada mode
10904 Ada_Version
:= Ada_2005
;
10905 Ada_Version_Explicit
:= Ada_2005
;
10906 Ada_Version_Pragma
:= N
;
10910 ---------------------
10911 -- Ada_12/Ada_2012 --
10912 ---------------------
10915 -- pragma Ada_12 (LOCAL_NAME);
10917 -- pragma Ada_2012;
10918 -- pragma Ada_2012 (LOCAL_NAME):
10920 -- Note: these pragmas also have some specific processing in Par.Prag
10921 -- because we want to set the Ada 2012 version mode during parsing.
10923 -- The one argument form is used for managing the transition from Ada
10924 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10925 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10926 -- mode will generate a warning. In addition, in any pre-Ada_2012
10927 -- mode, a preference rule is established which does not choose
10928 -- such an entity unless it is unambiguously specified. This avoids
10929 -- extra subprograms marked this way from generating ambiguities in
10930 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10931 -- intended for exclusive use in the GNAT run-time library.
10933 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10939 if Arg_Count
= 1 then
10940 Check_Arg_Is_Local_Name
(Arg1
);
10941 E_Id
:= Get_Pragma_Arg
(Arg1
);
10943 if Etype
(E_Id
) = Any_Type
then
10947 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10948 Record_Rep_Item
(Entity
(E_Id
), N
);
10951 Check_Arg_Count
(0);
10953 -- For Ada_2012 we unconditionally enforce the documented
10954 -- configuration pragma placement, since we do not want to
10955 -- tolerate mixed modes in a unit involving Ada 2012. That
10956 -- would cause real difficulties for those cases where there
10957 -- are incompatibilities between Ada 95 and Ada 2012. We could
10958 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10960 Check_Valid_Configuration_Pragma
;
10962 -- Now set appropriate Ada mode
10964 Ada_Version
:= Ada_2012
;
10965 Ada_Version_Explicit
:= Ada_2012
;
10966 Ada_Version_Pragma
:= N
;
10970 ----------------------
10971 -- All_Calls_Remote --
10972 ----------------------
10974 -- pragma All_Calls_Remote [(library_package_NAME)];
10976 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10977 Lib_Entity
: Entity_Id
;
10980 Check_Ada_83_Warning
;
10981 Check_Valid_Library_Unit_Pragma
;
10983 if Nkind
(N
) = N_Null_Statement
then
10987 Lib_Entity
:= Find_Lib_Unit_Name
;
10989 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10991 if Present
(Lib_Entity
)
10992 and then not Debug_Flag_U
10994 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10995 Error_Pragma
("pragma% only apply to rci unit");
10997 -- Set flag for entity of the library unit
11000 Set_Has_All_Calls_Remote
(Lib_Entity
);
11004 end All_Calls_Remote
;
11006 ---------------------------
11007 -- Allow_Integer_Address --
11008 ---------------------------
11010 -- pragma Allow_Integer_Address;
11012 when Pragma_Allow_Integer_Address
=>
11014 Check_Valid_Configuration_Pragma
;
11015 Check_Arg_Count
(0);
11017 -- If Address is a private type, then set the flag to allow
11018 -- integer address values. If Address is not private (e.g. on
11019 -- VMS, where it is an integer type), then this pragma has no
11020 -- purpose, so it is simply ignored.
11022 if Is_Private_Type
(RTE
(RE_Address
)) then
11023 Opt
.Allow_Integer_Address
:= True;
11031 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11032 -- ARG ::= NAME | EXPRESSION
11034 -- The first two arguments are by convention intended to refer to an
11035 -- external tool and a tool-specific function. These arguments are
11038 when Pragma_Annotate
=> Annotate
: declare
11044 Check_At_Least_N_Arguments
(1);
11046 -- See if last argument is Entity => local_Name, and if so process
11047 -- and then remove it for remaining processing.
11050 Last_Arg
: constant Node_Id
:=
11051 Last
(Pragma_Argument_Associations
(N
));
11054 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
11055 and then Chars
(Last_Arg
) = Name_Entity
11057 Check_Arg_Is_Local_Name
(Last_Arg
);
11058 Arg_Count
:= Arg_Count
- 1;
11060 -- Not allowed in compiler units (bootstrap issues)
11062 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
11066 -- Continue processing with last argument removed for now
11068 Check_Arg_Is_Identifier
(Arg1
);
11069 Check_No_Identifiers
;
11072 -- Second parameter is optional, it is never analyzed
11077 -- Here if we have a second parameter
11080 -- Second parameter must be identifier
11082 Check_Arg_Is_Identifier
(Arg2
);
11084 -- Process remaining parameters if any
11086 Arg
:= Next
(Arg2
);
11087 while Present
(Arg
) loop
11088 Exp
:= Get_Pragma_Arg
(Arg
);
11091 if Is_Entity_Name
(Exp
) then
11094 -- For string literals, we assume Standard_String as the
11095 -- type, unless the string contains wide or wide_wide
11098 elsif Nkind
(Exp
) = N_String_Literal
then
11099 if Has_Wide_Wide_Character
(Exp
) then
11100 Resolve
(Exp
, Standard_Wide_Wide_String
);
11101 elsif Has_Wide_Character
(Exp
) then
11102 Resolve
(Exp
, Standard_Wide_String
);
11104 Resolve
(Exp
, Standard_String
);
11107 elsif Is_Overloaded
(Exp
) then
11109 ("ambiguous argument for pragma%", Exp
);
11120 -------------------------------------------------
11121 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11122 -------------------------------------------------
11125 -- ( [Check => ] Boolean_EXPRESSION
11126 -- [, [Message =>] Static_String_EXPRESSION]);
11128 -- pragma Assert_And_Cut
11129 -- ( [Check => ] Boolean_EXPRESSION
11130 -- [, [Message =>] Static_String_EXPRESSION]);
11133 -- ( [Check => ] Boolean_EXPRESSION
11134 -- [, [Message =>] Static_String_EXPRESSION]);
11136 -- pragma Loop_Invariant
11137 -- ( [Check => ] Boolean_EXPRESSION
11138 -- [, [Message =>] Static_String_EXPRESSION]);
11140 when Pragma_Assert |
11141 Pragma_Assert_And_Cut |
11143 Pragma_Loop_Invariant
=>
11148 Has_Loop_Entry
: Boolean;
11151 function Contains_Loop_Entry
return Boolean;
11152 -- Tests if Expr contains a Loop_Entry attribute reference
11154 -------------------------
11155 -- Contains_Loop_Entry --
11156 -------------------------
11158 function Contains_Loop_Entry
return Boolean is
11159 function Process
(N
: Node_Id
) return Traverse_Result
;
11160 -- Process function for traversal to look for Loop_Entry
11166 function Process
(N
: Node_Id
) return Traverse_Result
is
11168 if Nkind
(N
) = N_Attribute_Reference
11169 and then Attribute_Name
(N
) = Name_Loop_Entry
11171 Has_Loop_Entry
:= True;
11178 procedure Traverse
is new Traverse_Proc
(Process
);
11180 -- Start of processing for Contains_Loop_Entry
11183 Has_Loop_Entry
:= False;
11185 return Has_Loop_Entry
;
11186 end Contains_Loop_Entry
;
11188 -- Start of processing for Assert
11191 -- Assert is an Ada 2005 RM-defined pragma
11193 if Prag_Id
= Pragma_Assert
then
11196 -- The remaining ones are GNAT pragmas
11202 Check_At_Least_N_Arguments
(1);
11203 Check_At_Most_N_Arguments
(2);
11204 Check_Arg_Order
((Name_Check
, Name_Message
));
11205 Check_Optional_Identifier
(Arg1
, Name_Check
);
11206 Expr
:= Get_Pragma_Arg
(Arg1
);
11208 -- Special processing for Loop_Invariant or for other cases if
11209 -- a Loop_Entry attribute is present.
11211 if Prag_Id
= Pragma_Loop_Invariant
11212 or else Contains_Loop_Entry
11214 -- Check restricted placement, must be within a loop
11216 Check_Loop_Pragma_Placement
;
11218 -- Do preanalyze to deal with embedded Loop_Entry attribute
11220 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
11223 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11224 -- a corresponding Check pragma:
11226 -- pragma Check (name, condition [, msg]);
11228 -- Where name is the identifier matching the pragma name. So
11229 -- rewrite pragma in this manner, transfer the message argument
11230 -- if present, and analyze the result
11232 -- Note: When dealing with a semantically analyzed tree, the
11233 -- information that a Check node N corresponds to a source Assert,
11234 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11235 -- pragma kind of Original_Node(N).
11238 Make_Pragma_Argument_Association
(Loc
,
11239 Expression
=> Make_Identifier
(Loc
, Pname
)),
11240 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11241 Expression
=> Expr
));
11243 if Arg_Count
> 1 then
11244 Check_Optional_Identifier
(Arg2
, Name_Message
);
11245 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
11248 -- Rewrite as Check pragma
11252 Chars
=> Name_Check
,
11253 Pragma_Argument_Associations
=> Newa
));
11257 ----------------------
11258 -- Assertion_Policy --
11259 ----------------------
11261 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11263 -- The following form is Ada 2012 only, but we allow it in all modes
11265 -- Pragma Assertion_Policy (
11266 -- ASSERTION_KIND => POLICY_IDENTIFIER
11267 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11269 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11271 -- RM_ASSERTION_KIND ::= Assert |
11272 -- Static_Predicate |
11273 -- Dynamic_Predicate |
11278 -- Type_Invariant |
11279 -- Type_Invariant'Class
11281 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11283 -- Contract_Cases |
11285 -- Initial_Condition |
11286 -- Loop_Invariant |
11292 -- Statement_Assertions
11294 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11295 -- ID_ASSERTION_KIND list contains implementation-defined additions
11296 -- recognized by GNAT. The effect is to control the behavior of
11297 -- identically named aspects and pragmas, depending on the specified
11298 -- policy identifier:
11300 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11302 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11303 -- implementation defined addition that results in totally ignoring
11304 -- the corresponding assertion. If Disable is specified, then the
11305 -- argument of the assertion is not even analyzed. This is useful
11306 -- when the aspect/pragma argument references entities in a with'ed
11307 -- package that is replaced by a dummy package in the final build.
11309 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11310 -- and Type_Invariant'Class were recognized by the parser and
11311 -- transformed into references to the special internal identifiers
11312 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11313 -- processing is required here.
11315 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11324 -- This can always appear as a configuration pragma
11326 if Is_Configuration_Pragma
then
11329 -- It can also appear in a declarative part or package spec in Ada
11330 -- 2012 mode. We allow this in other modes, but in that case we
11331 -- consider that we have an Ada 2012 pragma on our hands.
11334 Check_Is_In_Decl_Part_Or_Package_Spec
;
11338 -- One argument case with no identifier (first form above)
11341 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11342 or else Chars
(Arg1
) = No_Name
)
11344 Check_Arg_Is_One_Of
11345 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11347 -- Treat one argument Assertion_Policy as equivalent to:
11349 -- pragma Check_Policy (Assertion, policy)
11351 -- So rewrite pragma in that manner and link on to the chain
11352 -- of Check_Policy pragmas, marking the pragma as analyzed.
11354 Policy
:= Get_Pragma_Arg
(Arg1
);
11358 Chars
=> Name_Check_Policy
,
11359 Pragma_Argument_Associations
=> New_List
(
11360 Make_Pragma_Argument_Association
(Loc
,
11361 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11363 Make_Pragma_Argument_Association
(Loc
,
11365 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11368 -- Here if we have two or more arguments
11371 Check_At_Least_N_Arguments
(1);
11374 -- Loop through arguments
11377 while Present
(Arg
) loop
11378 LocP
:= Sloc
(Arg
);
11380 -- Kind must be specified
11382 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11383 or else Chars
(Arg
) = No_Name
11386 ("missing assertion kind for pragma%", Arg
);
11389 -- Check Kind and Policy have allowed forms
11391 Kind
:= Chars
(Arg
);
11393 if not Is_Valid_Assertion_Kind
(Kind
) then
11395 ("invalid assertion kind for pragma%", Arg
);
11398 Check_Arg_Is_One_Of
11399 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11401 -- We rewrite the Assertion_Policy pragma as a series of
11402 -- Check_Policy pragmas:
11404 -- Check_Policy (Kind, Policy);
11408 Chars
=> Name_Check_Policy
,
11409 Pragma_Argument_Associations
=> New_List
(
11410 Make_Pragma_Argument_Association
(LocP
,
11411 Expression
=> Make_Identifier
(LocP
, Kind
)),
11412 Make_Pragma_Argument_Association
(LocP
,
11413 Expression
=> Get_Pragma_Arg
(Arg
)))));
11418 -- Rewrite the Assertion_Policy pragma as null since we have
11419 -- now inserted all the equivalent Check pragmas.
11421 Rewrite
(N
, Make_Null_Statement
(Loc
));
11424 end Assertion_Policy
;
11426 ------------------------------
11427 -- Assume_No_Invalid_Values --
11428 ------------------------------
11430 -- pragma Assume_No_Invalid_Values (On | Off);
11432 when Pragma_Assume_No_Invalid_Values
=>
11434 Check_Valid_Configuration_Pragma
;
11435 Check_Arg_Count
(1);
11436 Check_No_Identifiers
;
11437 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11439 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11440 Assume_No_Invalid_Values
:= True;
11442 Assume_No_Invalid_Values
:= False;
11445 --------------------------
11446 -- Attribute_Definition --
11447 --------------------------
11449 -- pragma Attribute_Definition
11450 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11451 -- [Entity =>] LOCAL_NAME,
11452 -- [Expression =>] EXPRESSION | NAME);
11454 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11455 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11460 Check_Arg_Count
(3);
11461 Check_Optional_Identifier
(Arg1
, "attribute");
11462 Check_Optional_Identifier
(Arg2
, "entity");
11463 Check_Optional_Identifier
(Arg3
, "expression");
11465 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11466 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11470 Check_Arg_Is_Local_Name
(Arg2
);
11472 -- If the attribute is not recognized, then issue a warning (not
11473 -- an error), and ignore the pragma.
11475 Aname
:= Chars
(Attribute_Designator
);
11477 if not Is_Attribute_Name
(Aname
) then
11478 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11482 -- Otherwise, rewrite the pragma as an attribute definition clause
11485 Make_Attribute_Definition_Clause
(Loc
,
11486 Name
=> Get_Pragma_Arg
(Arg2
),
11488 Expression
=> Get_Pragma_Arg
(Arg3
)));
11490 end Attribute_Definition
;
11496 -- pragma AST_Entry (entry_IDENTIFIER);
11498 when Pragma_AST_Entry
=> AST_Entry
: declare
11504 Check_Arg_Count
(1);
11505 Check_No_Identifiers
;
11506 Check_Arg_Is_Local_Name
(Arg1
);
11507 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
11509 -- Note: the implementation of the AST_Entry pragma could handle
11510 -- the entry family case fine, but for now we are consistent with
11511 -- the DEC rules, and do not allow the pragma, which of course
11512 -- has the effect of also forbidding the attribute.
11514 if Ekind
(Ent
) /= E_Entry
then
11516 ("pragma% argument must be simple entry name", Arg1
);
11518 elsif Is_AST_Entry
(Ent
) then
11520 ("duplicate % pragma for entry", Arg1
);
11522 elsif Has_Homonym
(Ent
) then
11524 ("pragma% argument cannot specify overloaded entry", Arg1
);
11528 FF
: constant Entity_Id
:= First_Formal
(Ent
);
11531 if Present
(FF
) then
11532 if Present
(Next_Formal
(FF
)) then
11534 ("entry for pragma% can have only one argument",
11537 elsif Parameter_Mode
(FF
) /= E_In_Parameter
then
11539 ("entry parameter for pragma% must have mode IN",
11545 Set_Is_AST_Entry
(Ent
);
11549 ------------------------------------------------------------------
11550 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11551 ------------------------------------------------------------------
11553 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11554 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11555 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11556 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11558 -- FLAG ::= boolean_EXPRESSION
11560 when Pragma_Async_Readers |
11561 Pragma_Async_Writers |
11562 Pragma_Effective_Reads |
11563 Pragma_Effective_Writes
=>
11564 Async_Effective
: declare
11566 Obj_Id
: Entity_Id
;
11570 Check_No_Identifiers
;
11571 Check_At_Least_N_Arguments
(1);
11572 Check_At_Most_N_Arguments
(2);
11573 Check_Arg_Is_Local_Name
(Arg1
);
11575 Arg1
:= Get_Pragma_Arg
(Arg1
);
11577 -- Perform minimal verification to ensure that the argument is at
11578 -- least a variable. Subsequent finer grained checks will be done
11579 -- at the end of the declarative region the contains the pragma.
11581 if Is_Entity_Name
(Arg1
) and then Present
(Entity
(Arg1
)) then
11582 Obj_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
11584 -- It is not efficient to examine preceding statements in order
11585 -- to detect duplicate pragmas as Boolean aspects may appear
11586 -- anywhere between the related object declaration and its
11587 -- freeze point. As an alternative, inspect the contents of the
11588 -- variable contract.
11590 if Ekind
(Obj_Id
) = E_Variable
then
11591 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11593 if Present
(Duplic
) then
11594 Error_Msg_Name_1
:= Pname
;
11595 Error_Msg_Sloc
:= Sloc
(Duplic
);
11596 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11598 -- Chain the pragma on the contract for further processing.
11599 -- This also aids in detecting duplicates.
11602 Add_Contract_Item
(N
, Obj_Id
);
11605 -- The minimum legality requirements have been met, do not
11606 -- fall through to the error message.
11612 -- If we get here, then the pragma applies to a non-object
11613 -- construct, issue a generic error (SPARK RM 7.1.3(2)).
11615 Error_Pragma
("pragma % must apply to a volatile object");
11616 end Async_Effective
;
11622 -- pragma Asynchronous (LOCAL_NAME);
11624 when Pragma_Asynchronous
=> Asynchronous
: declare
11630 Formal
: Entity_Id
;
11632 procedure Process_Async_Pragma
;
11633 -- Common processing for procedure and access-to-procedure case
11635 --------------------------
11636 -- Process_Async_Pragma --
11637 --------------------------
11639 procedure Process_Async_Pragma
is
11642 Set_Is_Asynchronous
(Nm
);
11646 -- The formals should be of mode IN (RM E.4.1(6))
11649 while Present
(S
) loop
11650 Formal
:= Defining_Identifier
(S
);
11652 if Nkind
(Formal
) = N_Defining_Identifier
11653 and then Ekind
(Formal
) /= E_In_Parameter
11656 ("pragma% procedure can only have IN parameter",
11663 Set_Is_Asynchronous
(Nm
);
11664 end Process_Async_Pragma
;
11666 -- Start of processing for pragma Asynchronous
11669 Check_Ada_83_Warning
;
11670 Check_No_Identifiers
;
11671 Check_Arg_Count
(1);
11672 Check_Arg_Is_Local_Name
(Arg1
);
11674 if Debug_Flag_U
then
11678 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11679 Analyze
(Get_Pragma_Arg
(Arg1
));
11680 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11682 if not Is_Remote_Call_Interface
(C_Ent
)
11683 and then not Is_Remote_Types
(C_Ent
)
11685 -- This pragma should only appear in an RCI or Remote Types
11686 -- unit (RM E.4.1(4)).
11689 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11692 if Ekind
(Nm
) = E_Procedure
11693 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11695 if not Is_Remote_Call_Interface
(Nm
) then
11697 ("pragma% cannot be applied on non-remote procedure",
11701 L
:= Parameter_Specifications
(Parent
(Nm
));
11702 Process_Async_Pragma
;
11705 elsif Ekind
(Nm
) = E_Function
then
11707 ("pragma% cannot be applied to function", Arg1
);
11709 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11710 if Is_Record_Type
(Nm
) then
11712 -- A record type that is the Equivalent_Type for a remote
11713 -- access-to-subprogram type.
11715 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11718 -- A non-expanded RAS type (distribution is not enabled)
11720 N
:= Declaration_Node
(Nm
);
11723 if Nkind
(N
) = N_Full_Type_Declaration
11724 and then Nkind
(Type_Definition
(N
)) =
11725 N_Access_Procedure_Definition
11727 L
:= Parameter_Specifications
(Type_Definition
(N
));
11728 Process_Async_Pragma
;
11730 if Is_Asynchronous
(Nm
)
11731 and then Expander_Active
11732 and then Get_PCS_Name
/= Name_No_DSA
11734 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11739 ("pragma% cannot reference access-to-function type",
11743 -- Only other possibility is Access-to-class-wide type
11745 elsif Is_Access_Type
(Nm
)
11746 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11748 Check_First_Subtype
(Arg1
);
11749 Set_Is_Asynchronous
(Nm
);
11750 if Expander_Active
then
11751 RACW_Type_Is_Asynchronous
(Nm
);
11755 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11763 -- pragma Atomic (LOCAL_NAME);
11765 when Pragma_Atomic
=>
11766 Process_Atomic_Shared_Volatile
;
11768 -----------------------
11769 -- Atomic_Components --
11770 -----------------------
11772 -- pragma Atomic_Components (array_LOCAL_NAME);
11774 -- This processing is shared by Volatile_Components
11776 when Pragma_Atomic_Components |
11777 Pragma_Volatile_Components
=>
11779 Atomic_Components
: declare
11786 Check_Ada_83_Warning
;
11787 Check_No_Identifiers
;
11788 Check_Arg_Count
(1);
11789 Check_Arg_Is_Local_Name
(Arg1
);
11790 E_Id
:= Get_Pragma_Arg
(Arg1
);
11792 if Etype
(E_Id
) = Any_Type
then
11796 E
:= Entity
(E_Id
);
11798 Check_Duplicate_Pragma
(E
);
11800 if Rep_Item_Too_Early
(E
, N
)
11802 Rep_Item_Too_Late
(E
, N
)
11807 D
:= Declaration_Node
(E
);
11810 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11812 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11813 and then Nkind
(D
) = N_Object_Declaration
11814 and then Nkind
(Object_Definition
(D
)) =
11815 N_Constrained_Array_Definition
)
11817 -- The flag is set on the object, or on the base type
11819 if Nkind
(D
) /= N_Object_Declaration
then
11820 E
:= Base_Type
(E
);
11823 Set_Has_Volatile_Components
(E
);
11825 if Prag_Id
= Pragma_Atomic_Components
then
11826 Set_Has_Atomic_Components
(E
);
11830 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11832 end Atomic_Components
;
11834 --------------------
11835 -- Attach_Handler --
11836 --------------------
11838 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11840 when Pragma_Attach_Handler
=>
11841 Check_Ada_83_Warning
;
11842 Check_No_Identifiers
;
11843 Check_Arg_Count
(2);
11845 if No_Run_Time_Mode
then
11846 Error_Msg_CRT
("Attach_Handler pragma", N
);
11848 Check_Interrupt_Or_Attach_Handler
;
11850 -- The expression that designates the attribute may depend on a
11851 -- discriminant, and is therefore a per-object expression, to
11852 -- be expanded in the init proc. If expansion is enabled, then
11853 -- perform semantic checks on a copy only.
11858 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11861 -- In Relaxed_RM_Semantics mode, we allow any static
11862 -- integer value, for compatibility with other compilers.
11864 if Relaxed_RM_Semantics
11865 and then Nkind
(Parg2
) = N_Integer_Literal
11867 Typ
:= Standard_Integer
;
11869 Typ
:= RTE
(RE_Interrupt_ID
);
11872 if Expander_Active
then
11873 Temp
:= New_Copy_Tree
(Parg2
);
11874 Set_Parent
(Temp
, N
);
11875 Preanalyze_And_Resolve
(Temp
, Typ
);
11878 Resolve
(Parg2
, Typ
);
11882 Process_Interrupt_Or_Attach_Handler
;
11885 --------------------
11886 -- C_Pass_By_Copy --
11887 --------------------
11889 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11891 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11897 Check_Valid_Configuration_Pragma
;
11898 Check_Arg_Count
(1);
11899 Check_Optional_Identifier
(Arg1
, "max_size");
11901 Arg
:= Get_Pragma_Arg
(Arg1
);
11902 Check_Arg_Is_Static_Expression
(Arg
, Any_Integer
);
11904 Val
:= Expr_Value
(Arg
);
11908 ("maximum size for pragma% must be positive", Arg1
);
11910 elsif UI_Is_In_Int_Range
(Val
) then
11911 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11913 -- If a giant value is given, Int'Last will do well enough.
11914 -- If sometime someone complains that a record larger than
11915 -- two gigabytes is not copied, we will worry about it then.
11918 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11920 end C_Pass_By_Copy
;
11926 -- pragma Check ([Name =>] CHECK_KIND,
11927 -- [Check =>] Boolean_EXPRESSION
11928 -- [,[Message =>] String_EXPRESSION]);
11930 -- CHECK_KIND ::= IDENTIFIER |
11933 -- Invariant'Class |
11934 -- Type_Invariant'Class
11936 -- The identifiers Assertions and Statement_Assertions are not
11937 -- allowed, since they have special meaning for Check_Policy.
11939 when Pragma_Check
=> Check
: declare
11947 Check_At_Least_N_Arguments
(2);
11948 Check_At_Most_N_Arguments
(3);
11949 Check_Optional_Identifier
(Arg1
, Name_Name
);
11950 Check_Optional_Identifier
(Arg2
, Name_Check
);
11952 if Arg_Count
= 3 then
11953 Check_Optional_Identifier
(Arg3
, Name_Message
);
11954 Str
:= Get_Pragma_Arg
(Arg3
);
11957 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11958 Check_Arg_Is_Identifier
(Arg1
);
11959 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11961 -- Check forbidden name Assertions or Statement_Assertions
11964 when Name_Assertions
=>
11966 ("""Assertions"" is not allowed as a check kind "
11967 & "for pragma%", Arg1
);
11969 when Name_Statement_Assertions
=>
11971 ("""Statement_Assertions"" is not allowed as a check kind "
11972 & "for pragma%", Arg1
);
11978 -- Check applicable policy. We skip this if Checked/Ignored status
11979 -- is already set (e.g. in the casse of a pragma from an aspect).
11981 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11984 -- For a non-source pragma that is a rewriting of another pragma,
11985 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11987 elsif Is_Rewrite_Substitution
(N
)
11988 and then Nkind
(Original_Node
(N
)) = N_Pragma
11989 and then Original_Node
(N
) /= N
11991 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11992 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11994 -- Otherwise query the applicable policy at this point
11997 case Check_Kind
(Cname
) is
11998 when Name_Ignore
=>
11999 Set_Is_Ignored
(N
, True);
12000 Set_Is_Checked
(N
, False);
12003 Set_Is_Ignored
(N
, False);
12004 Set_Is_Checked
(N
, True);
12006 -- For disable, rewrite pragma as null statement and skip
12007 -- rest of the analysis of the pragma.
12009 when Name_Disable
=>
12010 Rewrite
(N
, Make_Null_Statement
(Loc
));
12014 -- No other possibilities
12017 raise Program_Error
;
12021 -- If check kind was not Disable, then continue pragma analysis
12023 Expr
:= Get_Pragma_Arg
(Arg2
);
12025 -- Deal with SCO generation
12028 when Name_Predicate |
12031 -- Nothing to do: since checks occur in client units,
12032 -- the SCO for the aspect in the declaration unit is
12033 -- conservatively always enabled.
12039 if Is_Checked
(N
) and then not Split_PPC
(N
) then
12041 -- Mark aspect/pragma SCO as enabled
12043 Set_SCO_Pragma_Enabled
(Loc
);
12047 -- Deal with analyzing the string argument.
12049 if Arg_Count
= 3 then
12051 -- If checks are not on we don't want any expansion (since
12052 -- such expansion would not get properly deleted) but
12053 -- we do want to analyze (to get proper references).
12054 -- The Preanalyze_And_Resolve routine does just what we want
12056 if Is_Ignored
(N
) then
12057 Preanalyze_And_Resolve
(Str
, Standard_String
);
12059 -- Otherwise we need a proper analysis and expansion
12062 Analyze_And_Resolve
(Str
, Standard_String
);
12066 -- Now you might think we could just do the same with the Boolean
12067 -- expression if checks are off (and expansion is on) and then
12068 -- rewrite the check as a null statement. This would work but we
12069 -- would lose the useful warnings about an assertion being bound
12070 -- to fail even if assertions are turned off.
12072 -- So instead we wrap the boolean expression in an if statement
12073 -- that looks like:
12075 -- if False and then condition then
12079 -- The reason we do this rewriting during semantic analysis rather
12080 -- than as part of normal expansion is that we cannot analyze and
12081 -- expand the code for the boolean expression directly, or it may
12082 -- cause insertion of actions that would escape the attempt to
12083 -- suppress the check code.
12085 -- Note that the Sloc for the if statement corresponds to the
12086 -- argument condition, not the pragma itself. The reason for
12087 -- this is that we may generate a warning if the condition is
12088 -- False at compile time, and we do not want to delete this
12089 -- warning when we delete the if statement.
12091 if Expander_Active
and Is_Ignored
(N
) then
12092 Eloc
:= Sloc
(Expr
);
12095 Make_If_Statement
(Eloc
,
12097 Make_And_Then
(Eloc
,
12098 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
12099 Right_Opnd
=> Expr
),
12100 Then_Statements
=> New_List
(
12101 Make_Null_Statement
(Eloc
))));
12103 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12105 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12107 -- Check is active or expansion not active. In these cases we can
12108 -- just go ahead and analyze the boolean with no worries.
12111 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12112 Analyze_And_Resolve
(Expr
, Any_Boolean
);
12113 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12117 --------------------------
12118 -- Check_Float_Overflow --
12119 --------------------------
12121 -- pragma Check_Float_Overflow;
12123 when Pragma_Check_Float_Overflow
=>
12125 Check_Valid_Configuration_Pragma
;
12126 Check_Arg_Count
(0);
12127 Check_Float_Overflow
:= True;
12133 -- pragma Check_Name (check_IDENTIFIER);
12135 when Pragma_Check_Name
=>
12137 Check_No_Identifiers
;
12138 Check_Valid_Configuration_Pragma
;
12139 Check_Arg_Count
(1);
12140 Check_Arg_Is_Identifier
(Arg1
);
12143 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
12146 for J
in Check_Names
.First
.. Check_Names
.Last
loop
12147 if Check_Names
.Table
(J
) = Nam
then
12152 Check_Names
.Append
(Nam
);
12159 -- This is the old style syntax, which is still allowed in all modes:
12161 -- pragma Check_Policy ([Name =>] CHECK_KIND
12162 -- [Policy =>] POLICY_IDENTIFIER);
12164 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12166 -- CHECK_KIND ::= IDENTIFIER |
12169 -- Type_Invariant'Class |
12172 -- This is the new style syntax, compatible with Assertion_Policy
12173 -- and also allowed in all modes.
12175 -- Pragma Check_Policy (
12176 -- CHECK_KIND => POLICY_IDENTIFIER
12177 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12179 -- Note: the identifiers Name and Policy are not allowed as
12180 -- Check_Kind values. This avoids ambiguities between the old and
12181 -- new form syntax.
12183 when Pragma_Check_Policy
=> Check_Policy
: declare
12188 Check_At_Least_N_Arguments
(1);
12190 -- A Check_Policy pragma can appear either as a configuration
12191 -- pragma, or in a declarative part or a package spec (see RM
12192 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12193 -- followed for Check_Policy).
12195 if not Is_Configuration_Pragma
then
12196 Check_Is_In_Decl_Part_Or_Package_Spec
;
12199 -- Figure out if we have the old or new syntax. We have the
12200 -- old syntax if the first argument has no identifier, or the
12201 -- identifier is Name.
12203 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
12204 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
12208 Check_Arg_Count
(2);
12209 Check_Optional_Identifier
(Arg1
, Name_Name
);
12210 Kind
:= Get_Pragma_Arg
(Arg1
);
12211 Rewrite_Assertion_Kind
(Kind
);
12212 Check_Arg_Is_Identifier
(Arg1
);
12214 -- Check forbidden check kind
12216 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
12217 Error_Msg_Name_2
:= Chars
(Kind
);
12219 ("pragma% does not allow% as check name", Arg1
);
12224 Check_Optional_Identifier
(Arg2
, Name_Policy
);
12225 Check_Arg_Is_One_Of
12227 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
12229 -- And chain pragma on the Check_Policy_List for search
12231 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
12232 Opt
.Check_Policy_List
:= N
;
12234 -- For the new syntax, what we do is to convert each argument to
12235 -- an old syntax equivalent. We do that because we want to chain
12236 -- old style Check_Policy pragmas for the search (we don't want
12237 -- to have to deal with multiple arguments in the search).
12247 while Present
(Arg
) loop
12248 LocP
:= Sloc
(Arg
);
12249 Argx
:= Get_Pragma_Arg
(Arg
);
12251 -- Kind must be specified
12253 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12254 or else Chars
(Arg
) = No_Name
12257 ("missing assertion kind for pragma%", Arg
);
12260 -- Construct equivalent old form syntax Check_Policy
12261 -- pragma and insert it to get remaining checks.
12265 Chars
=> Name_Check_Policy
,
12266 Pragma_Argument_Associations
=> New_List
(
12267 Make_Pragma_Argument_Association
(LocP
,
12269 Make_Identifier
(LocP
, Chars
(Arg
))),
12270 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12271 Expression
=> Argx
))));
12276 -- Rewrite original Check_Policy pragma to null, since we
12277 -- have converted it into a series of old syntax pragmas.
12279 Rewrite
(N
, Make_Null_Statement
(Loc
));
12285 ---------------------
12286 -- CIL_Constructor --
12287 ---------------------
12289 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12291 -- Processing for this pragma is shared with Java_Constructor
12297 -- pragma Comment (static_string_EXPRESSION)
12299 -- Processing for pragma Comment shares the circuitry for pragma
12300 -- Ident. The only differences are that Ident enforces a limit of 31
12301 -- characters on its argument, and also enforces limitations on
12302 -- placement for DEC compatibility. Pragma Comment shares neither of
12303 -- these restrictions.
12305 -------------------
12306 -- Common_Object --
12307 -------------------
12309 -- pragma Common_Object (
12310 -- [Internal =>] LOCAL_NAME
12311 -- [, [External =>] EXTERNAL_SYMBOL]
12312 -- [, [Size =>] EXTERNAL_SYMBOL]);
12314 -- Processing for this pragma is shared with Psect_Object
12316 ------------------------
12317 -- Compile_Time_Error --
12318 ------------------------
12320 -- pragma Compile_Time_Error
12321 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12323 when Pragma_Compile_Time_Error
=>
12325 Process_Compile_Time_Warning_Or_Error
;
12327 --------------------------
12328 -- Compile_Time_Warning --
12329 --------------------------
12331 -- pragma Compile_Time_Warning
12332 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12334 when Pragma_Compile_Time_Warning
=>
12336 Process_Compile_Time_Warning_Or_Error
;
12338 ---------------------------
12339 -- Compiler_Unit_Warning --
12340 ---------------------------
12342 -- pragma Compiler_Unit_Warning;
12346 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12347 -- errors not warnings. This means that we had introduced a big extra
12348 -- inertia to compiler changes, since even if we implemented a new
12349 -- feature, and even if all versions to be used for bootstrapping
12350 -- implemented this new feature, we could not use it, since old
12351 -- compilers would give errors for using this feature in units
12352 -- having Compiler_Unit pragmas.
12354 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12355 -- problem. We no longer have any units mentioning Compiler_Unit,
12356 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12357 -- and thus generates a warning which can be ignored. So that deals
12358 -- with the problem of old compilers not implementing the newer form
12361 -- Newer compilers recognize the new pragma, but generate warning
12362 -- messages instead of errors, which again can be ignored in the
12363 -- case of an old compiler which implements a wanted new feature
12364 -- but at the time felt like warning about it for older compilers.
12366 -- We retain Compiler_Unit so that new compilers can be used to build
12367 -- older run-times that use this pragma. That's an unusual case, but
12368 -- it's easy enough to handle, so why not?
12370 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12372 Check_Arg_Count
(0);
12374 -- Only recognized in main unit
12376 if Current_Sem_Unit
= Main_Unit
then
12377 Compiler_Unit
:= True;
12380 -----------------------------
12381 -- Complete_Representation --
12382 -----------------------------
12384 -- pragma Complete_Representation;
12386 when Pragma_Complete_Representation
=>
12388 Check_Arg_Count
(0);
12390 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12392 ("pragma & must appear within record representation clause");
12395 ----------------------------
12396 -- Complex_Representation --
12397 ----------------------------
12399 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12401 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12408 Check_Arg_Count
(1);
12409 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12410 Check_Arg_Is_Local_Name
(Arg1
);
12411 E_Id
:= Get_Pragma_Arg
(Arg1
);
12413 if Etype
(E_Id
) = Any_Type
then
12417 E
:= Entity
(E_Id
);
12419 if not Is_Record_Type
(E
) then
12421 ("argument for pragma% must be record type", Arg1
);
12424 Ent
:= First_Entity
(E
);
12427 or else No
(Next_Entity
(Ent
))
12428 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12429 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12430 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12433 ("record for pragma% must have two fields of the same "
12434 & "floating-point type", Arg1
);
12437 Set_Has_Complex_Representation
(Base_Type
(E
));
12439 -- We need to treat the type has having a non-standard
12440 -- representation, for back-end purposes, even though in
12441 -- general a complex will have the default representation
12442 -- of a record with two real components.
12444 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12446 end Complex_Representation
;
12448 -------------------------
12449 -- Component_Alignment --
12450 -------------------------
12452 -- pragma Component_Alignment (
12453 -- [Form =>] ALIGNMENT_CHOICE
12454 -- [, [Name =>] type_LOCAL_NAME]);
12456 -- ALIGNMENT_CHOICE ::=
12458 -- | Component_Size_4
12462 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12463 Args
: Args_List
(1 .. 2);
12464 Names
: constant Name_List
(1 .. 2) := (
12468 Form
: Node_Id
renames Args
(1);
12469 Name
: Node_Id
renames Args
(2);
12471 Atype
: Component_Alignment_Kind
;
12476 Gather_Associations
(Names
, Args
);
12479 Error_Pragma
("missing Form argument for pragma%");
12482 Check_Arg_Is_Identifier
(Form
);
12484 -- Get proper alignment, note that Default = Component_Size on all
12485 -- machines we have so far, and we want to set this value rather
12486 -- than the default value to indicate that it has been explicitly
12487 -- set (and thus will not get overridden by the default component
12488 -- alignment for the current scope)
12490 if Chars
(Form
) = Name_Component_Size
then
12491 Atype
:= Calign_Component_Size
;
12493 elsif Chars
(Form
) = Name_Component_Size_4
then
12494 Atype
:= Calign_Component_Size_4
;
12496 elsif Chars
(Form
) = Name_Default
then
12497 Atype
:= Calign_Component_Size
;
12499 elsif Chars
(Form
) = Name_Storage_Unit
then
12500 Atype
:= Calign_Storage_Unit
;
12504 ("invalid Form parameter for pragma%", Form
);
12507 -- Case with no name, supplied, affects scope table entry
12511 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12513 -- Case of name supplied
12516 Check_Arg_Is_Local_Name
(Name
);
12518 Typ
:= Entity
(Name
);
12521 or else Rep_Item_Too_Early
(Typ
, N
)
12525 Typ
:= Underlying_Type
(Typ
);
12528 if not Is_Record_Type
(Typ
)
12529 and then not Is_Array_Type
(Typ
)
12532 ("Name parameter of pragma% must identify record or "
12533 & "array type", Name
);
12536 -- An explicit Component_Alignment pragma overrides an
12537 -- implicit pragma Pack, but not an explicit one.
12539 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12540 Set_Is_Packed
(Base_Type
(Typ
), False);
12541 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12544 end Component_AlignmentP
;
12546 --------------------
12547 -- Contract_Cases --
12548 --------------------
12550 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12552 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12554 -- CASE_GUARD ::= boolean_EXPRESSION | others
12556 -- CONSEQUENCE ::= boolean_EXPRESSION
12558 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12559 Subp_Decl
: Node_Id
;
12563 Check_Arg_Count
(1);
12564 Ensure_Aggregate_Form
(Arg1
);
12566 -- The pragma is analyzed at the end of the declarative part which
12567 -- contains the related subprogram. Reset the analyzed flag.
12569 Set_Analyzed
(N
, False);
12571 -- Ensure the proper placement of the pragma. Contract_Cases must
12572 -- be associated with a subprogram declaration or a body that acts
12576 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12578 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12581 -- Body acts as spec
12583 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12584 and then No
(Corresponding_Spec
(Subp_Decl
))
12588 -- Body stub acts as spec
12590 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12591 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12600 -- When the pragma appears on a subprogram body, perform the full
12603 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12604 Analyze_Contract_Cases_In_Decl_Part
(N
);
12606 -- When Contract_Cases applies to a subprogram compilation unit,
12607 -- the corresponding pragma is placed after the unit's declaration
12608 -- node and needs to be analyzed immediately.
12610 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12611 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12613 Analyze_Contract_Cases_In_Decl_Part
(N
);
12616 -- Chain the pragma on the contract for further processing
12618 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12619 end Contract_Cases
;
12625 -- pragma Controlled (first_subtype_LOCAL_NAME);
12627 when Pragma_Controlled
=> Controlled
: declare
12631 Check_No_Identifiers
;
12632 Check_Arg_Count
(1);
12633 Check_Arg_Is_Local_Name
(Arg1
);
12634 Arg
:= Get_Pragma_Arg
(Arg1
);
12636 if not Is_Entity_Name
(Arg
)
12637 or else not Is_Access_Type
(Entity
(Arg
))
12639 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12641 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12649 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12650 -- [Entity =>] LOCAL_NAME);
12652 when Pragma_Convention
=> Convention
: declare
12655 pragma Warnings
(Off
, C
);
12656 pragma Warnings
(Off
, E
);
12658 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12659 Check_Ada_83_Warning
;
12660 Check_Arg_Count
(2);
12661 Process_Convention
(C
, E
);
12664 ---------------------------
12665 -- Convention_Identifier --
12666 ---------------------------
12668 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12669 -- [Convention =>] convention_IDENTIFIER);
12671 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12677 Check_Arg_Order
((Name_Name
, Name_Convention
));
12678 Check_Arg_Count
(2);
12679 Check_Optional_Identifier
(Arg1
, Name_Name
);
12680 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12681 Check_Arg_Is_Identifier
(Arg1
);
12682 Check_Arg_Is_Identifier
(Arg2
);
12683 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12684 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12686 if Is_Convention_Name
(Cname
) then
12687 Record_Convention_Identifier
12688 (Idnam
, Get_Convention_Id
(Cname
));
12691 ("second arg for % pragma must be convention", Arg2
);
12693 end Convention_Identifier
;
12699 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12701 when Pragma_CPP_Class
=> CPP_Class
: declare
12705 if Warn_On_Obsolescent_Feature
then
12707 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12708 & "effect; replace it by pragma import?j?", N
);
12711 Check_Arg_Count
(1);
12715 Chars
=> Name_Import
,
12716 Pragma_Argument_Associations
=> New_List
(
12717 Make_Pragma_Argument_Association
(Loc
,
12718 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12719 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12723 ---------------------
12724 -- CPP_Constructor --
12725 ---------------------
12727 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12728 -- [, [External_Name =>] static_string_EXPRESSION ]
12729 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12731 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12734 Def_Id
: Entity_Id
;
12735 Tag_Typ
: Entity_Id
;
12739 Check_At_Least_N_Arguments
(1);
12740 Check_At_Most_N_Arguments
(3);
12741 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12742 Check_Arg_Is_Local_Name
(Arg1
);
12744 Id
:= Get_Pragma_Arg
(Arg1
);
12745 Find_Program_Unit_Name
(Id
);
12747 -- If we did not find the name, we are done
12749 if Etype
(Id
) = Any_Type
then
12753 Def_Id
:= Entity
(Id
);
12755 -- Check if already defined as constructor
12757 if Is_Constructor
(Def_Id
) then
12759 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12763 if Ekind
(Def_Id
) = E_Function
12764 and then (Is_CPP_Class
(Etype
(Def_Id
))
12765 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12767 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12769 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12771 ("'C'P'P constructor must be defined in the scope of "
12772 & "its returned type", Arg1
);
12775 if Arg_Count
>= 2 then
12776 Set_Imported
(Def_Id
);
12777 Set_Is_Public
(Def_Id
);
12778 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12781 Set_Has_Completion
(Def_Id
);
12782 Set_Is_Constructor
(Def_Id
);
12783 Set_Convention
(Def_Id
, Convention_CPP
);
12785 -- Imported C++ constructors are not dispatching primitives
12786 -- because in C++ they don't have a dispatch table slot.
12787 -- However, in Ada the constructor has the profile of a
12788 -- function that returns a tagged type and therefore it has
12789 -- been treated as a primitive operation during semantic
12790 -- analysis. We now remove it from the list of primitive
12791 -- operations of the type.
12793 if Is_Tagged_Type
(Etype
(Def_Id
))
12794 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12795 and then Is_Dispatching_Operation
(Def_Id
)
12797 Tag_Typ
:= Etype
(Def_Id
);
12799 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12800 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12804 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12805 Set_Is_Dispatching_Operation
(Def_Id
, False);
12808 -- For backward compatibility, if the constructor returns a
12809 -- class wide type, and we internally change the return type to
12810 -- the corresponding root type.
12812 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12813 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12817 ("pragma% requires function returning a 'C'P'P_Class type",
12820 end CPP_Constructor
;
12826 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12830 if Warn_On_Obsolescent_Feature
then
12832 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12841 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12845 if Warn_On_Obsolescent_Feature
then
12847 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12856 -- pragma CPU (EXPRESSION);
12858 when Pragma_CPU
=> CPU
: declare
12859 P
: constant Node_Id
:= Parent
(N
);
12865 Check_No_Identifiers
;
12866 Check_Arg_Count
(1);
12870 if Nkind
(P
) = N_Subprogram_Body
then
12871 Check_In_Main_Program
;
12873 Arg
:= Get_Pragma_Arg
(Arg1
);
12874 Analyze_And_Resolve
(Arg
, Any_Integer
);
12876 Ent
:= Defining_Unit_Name
(Specification
(P
));
12878 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12879 Ent
:= Defining_Identifier
(Ent
);
12884 if not Is_Static_Expression
(Arg
) then
12885 Flag_Non_Static_Expr
12886 ("main subprogram affinity is not static!", Arg
);
12889 -- If constraint error, then we already signalled an error
12891 elsif Raises_Constraint_Error
(Arg
) then
12894 -- Otherwise check in range
12898 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12899 -- This is the entity System.Multiprocessors.CPU_Range;
12901 Val
: constant Uint
:= Expr_Value
(Arg
);
12904 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12906 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12909 ("main subprogram CPU is out of range", Arg1
);
12915 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12919 elsif Nkind
(P
) = N_Task_Definition
then
12920 Arg
:= Get_Pragma_Arg
(Arg1
);
12921 Ent
:= Defining_Identifier
(Parent
(P
));
12923 -- The expression must be analyzed in the special manner
12924 -- described in "Handling of Default and Per-Object
12925 -- Expressions" in sem.ads.
12927 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12929 -- Anything else is incorrect
12935 -- Check duplicate pragma before we chain the pragma in the Rep
12936 -- Item chain of Ent.
12938 Check_Duplicate_Pragma
(Ent
);
12939 Record_Rep_Item
(Ent
, N
);
12946 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12948 when Pragma_Debug
=> Debug
: declare
12955 -- The condition for executing the call is that the expander
12956 -- is active and that we are not ignoring this debug pragma.
12961 (Expander_Active
and then not Is_Ignored
(N
)),
12964 if not Is_Ignored
(N
) then
12965 Set_SCO_Pragma_Enabled
(Loc
);
12968 if Arg_Count
= 2 then
12970 Make_And_Then
(Loc
,
12971 Left_Opnd
=> Relocate_Node
(Cond
),
12972 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12973 Call
:= Get_Pragma_Arg
(Arg2
);
12975 Call
:= Get_Pragma_Arg
(Arg1
);
12979 N_Indexed_Component
,
12983 N_Selected_Component
)
12985 -- If this pragma Debug comes from source, its argument was
12986 -- parsed as a name form (which is syntactically identical).
12987 -- In a generic context a parameterless call will be left as
12988 -- an expanded name (if global) or selected_component if local.
12989 -- Change it to a procedure call statement now.
12991 Change_Name_To_Procedure_Call_Statement
(Call
);
12993 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12995 -- Already in the form of a procedure call statement: nothing
12996 -- to do (could happen in case of an internally generated
13002 -- All other cases: diagnose error
13005 ("argument of pragma ""Debug"" is not procedure call",
13010 -- Rewrite into a conditional with an appropriate condition. We
13011 -- wrap the procedure call in a block so that overhead from e.g.
13012 -- use of the secondary stack does not generate execution overhead
13013 -- for suppressed conditions.
13015 -- Normally the analysis that follows will freeze the subprogram
13016 -- being called. However, if the call is to a null procedure,
13017 -- we want to freeze it before creating the block, because the
13018 -- analysis that follows may be done with expansion disabled, in
13019 -- which case the body will not be generated, leading to spurious
13022 if Nkind
(Call
) = N_Procedure_Call_Statement
13023 and then Is_Entity_Name
(Name
(Call
))
13025 Analyze
(Name
(Call
));
13026 Freeze_Before
(N
, Entity
(Name
(Call
)));
13030 Make_Implicit_If_Statement
(N
,
13032 Then_Statements
=> New_List
(
13033 Make_Block_Statement
(Loc
,
13034 Handled_Statement_Sequence
=>
13035 Make_Handled_Sequence_Of_Statements
(Loc
,
13036 Statements
=> New_List
(Relocate_Node
(Call
)))))));
13039 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13040 -- after analysis of the normally rewritten node, to capture all
13041 -- references to entities, which avoids issuing wrong warnings
13042 -- about unused entities.
13044 if GNATprove_Mode
then
13045 Rewrite
(N
, Make_Null_Statement
(Loc
));
13053 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13055 when Pragma_Debug_Policy
=>
13057 Check_Arg_Count
(1);
13058 Check_No_Identifiers
;
13059 Check_Arg_Is_Identifier
(Arg1
);
13061 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13062 -- rewrite it that way, and let the rest of the checking come
13063 -- from analyzing the rewritten pragma.
13067 Chars
=> Name_Check_Policy
,
13068 Pragma_Argument_Associations
=> New_List
(
13069 Make_Pragma_Argument_Association
(Loc
,
13070 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
13072 Make_Pragma_Argument_Association
(Loc
,
13073 Expression
=> Get_Pragma_Arg
(Arg1
)))));
13080 -- pragma Depends (DEPENDENCY_RELATION);
13082 -- DEPENDENCY_RELATION ::=
13084 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
13086 -- DEPENDENCY_CLAUSE ::=
13087 -- OUTPUT_LIST =>[+] INPUT_LIST
13088 -- | NULL_DEPENDENCY_CLAUSE
13090 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13092 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13094 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13096 -- OUTPUT ::= NAME | FUNCTION_RESULT
13099 -- where FUNCTION_RESULT is a function Result attribute_reference
13101 when Pragma_Depends
=> Depends
: declare
13102 Subp_Decl
: Node_Id
;
13106 Check_Arg_Count
(1);
13107 Ensure_Aggregate_Form
(Arg1
);
13109 -- Ensure the proper placement of the pragma. Depends must be
13110 -- associated with a subprogram declaration or a body that acts
13114 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
13116 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13119 -- Body acts as spec
13121 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13122 and then No
(Corresponding_Spec
(Subp_Decl
))
13126 -- Body stub acts as spec
13128 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13129 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13138 -- When the pragma appears on a subprogram body, perform the full
13141 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
13142 Analyze_Depends_In_Decl_Part
(N
);
13144 -- When Depends applies to a subprogram compilation unit, the
13145 -- corresponding pragma is placed after the unit's declaration
13146 -- node and needs to be analyzed immediately.
13148 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13149 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
13151 Analyze_Depends_In_Decl_Part
(N
);
13154 -- Chain the pragma on the contract for further processing
13156 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13159 ---------------------
13160 -- Detect_Blocking --
13161 ---------------------
13163 -- pragma Detect_Blocking;
13165 when Pragma_Detect_Blocking
=>
13167 Check_Arg_Count
(0);
13168 Check_Valid_Configuration_Pragma
;
13169 Detect_Blocking
:= True;
13171 --------------------------
13172 -- Default_Storage_Pool --
13173 --------------------------
13175 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13177 when Pragma_Default_Storage_Pool
=>
13179 Check_Arg_Count
(1);
13181 -- Default_Storage_Pool can appear as a configuration pragma, or
13182 -- in a declarative part or a package spec.
13184 if not Is_Configuration_Pragma
then
13185 Check_Is_In_Decl_Part_Or_Package_Spec
;
13188 -- Case of Default_Storage_Pool (null);
13190 if Nkind
(Expression
(Arg1
)) = N_Null
then
13191 Analyze
(Expression
(Arg1
));
13193 -- This is an odd case, this is not really an expression, so
13194 -- we don't have a type for it. So just set the type to Empty.
13196 Set_Etype
(Expression
(Arg1
), Empty
);
13198 -- Case of Default_Storage_Pool (storage_pool_NAME);
13201 -- If it's a configuration pragma, then the only allowed
13202 -- argument is "null".
13204 if Is_Configuration_Pragma
then
13205 Error_Pragma_Arg
("NULL expected", Arg1
);
13208 -- The expected type for a non-"null" argument is
13209 -- Root_Storage_Pool'Class.
13211 Analyze_And_Resolve
13212 (Get_Pragma_Arg
(Arg1
),
13213 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
13216 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
13217 -- for an access type will use this information to set the
13218 -- appropriate attributes of the access type.
13220 Default_Pool
:= Expression
(Arg1
);
13222 ------------------------------------
13223 -- Disable_Atomic_Synchronization --
13224 ------------------------------------
13226 -- pragma Disable_Atomic_Synchronization [(Entity)];
13228 when Pragma_Disable_Atomic_Synchronization
=>
13230 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13232 -------------------
13233 -- Discard_Names --
13234 -------------------
13236 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13238 when Pragma_Discard_Names
=> Discard_Names
: declare
13243 Check_Ada_83_Warning
;
13245 -- Deal with configuration pragma case
13247 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13248 Global_Discard_Names
:= True;
13251 -- Otherwise, check correct appropriate context
13254 Check_Is_In_Decl_Part_Or_Package_Spec
;
13256 if Arg_Count
= 0 then
13258 -- If there is no parameter, then from now on this pragma
13259 -- applies to any enumeration, exception or tagged type
13260 -- defined in the current declarative part, and recursively
13261 -- to any nested scope.
13263 Set_Discard_Names
(Current_Scope
);
13267 Check_Arg_Count
(1);
13268 Check_Optional_Identifier
(Arg1
, Name_On
);
13269 Check_Arg_Is_Local_Name
(Arg1
);
13271 E_Id
:= Get_Pragma_Arg
(Arg1
);
13273 if Etype
(E_Id
) = Any_Type
then
13276 E
:= Entity
(E_Id
);
13279 if (Is_First_Subtype
(E
)
13281 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13282 or else Ekind
(E
) = E_Exception
13284 Set_Discard_Names
(E
);
13285 Record_Rep_Item
(E
, N
);
13289 ("inappropriate entity for pragma%", Arg1
);
13296 ------------------------
13297 -- Dispatching_Domain --
13298 ------------------------
13300 -- pragma Dispatching_Domain (EXPRESSION);
13302 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13303 P
: constant Node_Id
:= Parent
(N
);
13309 Check_No_Identifiers
;
13310 Check_Arg_Count
(1);
13312 -- This pragma is born obsolete, but not the aspect
13314 if not From_Aspect_Specification
(N
) then
13316 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13319 if Nkind
(P
) = N_Task_Definition
then
13320 Arg
:= Get_Pragma_Arg
(Arg1
);
13321 Ent
:= Defining_Identifier
(Parent
(P
));
13323 -- The expression must be analyzed in the special manner
13324 -- described in "Handling of Default and Per-Object
13325 -- Expressions" in sem.ads.
13327 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13329 -- Check duplicate pragma before we chain the pragma in the Rep
13330 -- Item chain of Ent.
13332 Check_Duplicate_Pragma
(Ent
);
13333 Record_Rep_Item
(Ent
, N
);
13335 -- Anything else is incorrect
13340 end Dispatching_Domain
;
13346 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13348 when Pragma_Elaborate
=> Elaborate
: declare
13353 -- Pragma must be in context items list of a compilation unit
13355 if not Is_In_Context_Clause
then
13359 -- Must be at least one argument
13361 if Arg_Count
= 0 then
13362 Error_Pragma
("pragma% requires at least one argument");
13365 -- In Ada 83 mode, there can be no items following it in the
13366 -- context list except other pragmas and implicit with clauses
13367 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13368 -- placement rule does not apply.
13370 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13372 while Present
(Citem
) loop
13373 if Nkind
(Citem
) = N_Pragma
13374 or else (Nkind
(Citem
) = N_With_Clause
13375 and then Implicit_With
(Citem
))
13380 ("(Ada 83) pragma% must be at end of context clause");
13387 -- Finally, the arguments must all be units mentioned in a with
13388 -- clause in the same context clause. Note we already checked (in
13389 -- Par.Prag) that the arguments are all identifiers or selected
13393 Outer
: while Present
(Arg
) loop
13394 Citem
:= First
(List_Containing
(N
));
13395 Inner
: while Citem
/= N
loop
13396 if Nkind
(Citem
) = N_With_Clause
13397 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13399 Set_Elaborate_Present
(Citem
, True);
13400 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13401 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
13403 -- With the pragma present, elaboration calls on
13404 -- subprograms from the named unit need no further
13405 -- checks, as long as the pragma appears in the current
13406 -- compilation unit. If the pragma appears in some unit
13407 -- in the context, there might still be a need for an
13408 -- Elaborate_All_Desirable from the current compilation
13409 -- to the named unit, so we keep the check enabled.
13411 if In_Extended_Main_Source_Unit
(N
) then
13412 Set_Suppress_Elaboration_Warnings
13413 (Entity
(Name
(Citem
)));
13424 ("argument of pragma% is not withed unit", Arg
);
13430 -- Give a warning if operating in static mode with one of the
13431 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13433 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
13435 ("?l?use of pragma Elaborate may not be safe", N
);
13437 ("?l?use pragma Elaborate_All instead if possible", N
);
13441 -------------------
13442 -- Elaborate_All --
13443 -------------------
13445 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13447 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13452 Check_Ada_83_Warning
;
13454 -- Pragma must be in context items list of a compilation unit
13456 if not Is_In_Context_Clause
then
13460 -- Must be at least one argument
13462 if Arg_Count
= 0 then
13463 Error_Pragma
("pragma% requires at least one argument");
13466 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13467 -- have to appear at the end of the context clause, but may
13468 -- appear mixed in with other items, even in Ada 83 mode.
13470 -- Final check: the arguments must all be units mentioned in
13471 -- a with clause in the same context clause. Note that we
13472 -- already checked (in Par.Prag) that all the arguments are
13473 -- either identifiers or selected components.
13476 Outr
: while Present
(Arg
) loop
13477 Citem
:= First
(List_Containing
(N
));
13478 Innr
: while Citem
/= N
loop
13479 if Nkind
(Citem
) = N_With_Clause
13480 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13482 Set_Elaborate_All_Present
(Citem
, True);
13483 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13485 -- Suppress warnings and elaboration checks on the named
13486 -- unit if the pragma is in the current compilation, as
13487 -- for pragma Elaborate.
13489 if In_Extended_Main_Source_Unit
(N
) then
13490 Set_Suppress_Elaboration_Warnings
13491 (Entity
(Name
(Citem
)));
13500 Set_Error_Posted
(N
);
13502 ("argument of pragma% is not withed unit", Arg
);
13509 --------------------
13510 -- Elaborate_Body --
13511 --------------------
13513 -- pragma Elaborate_Body [( library_unit_NAME )];
13515 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13516 Cunit_Node
: Node_Id
;
13517 Cunit_Ent
: Entity_Id
;
13520 Check_Ada_83_Warning
;
13521 Check_Valid_Library_Unit_Pragma
;
13523 if Nkind
(N
) = N_Null_Statement
then
13527 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13528 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13530 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13533 Error_Pragma
("pragma% must refer to a spec, not a body");
13535 Set_Body_Required
(Cunit_Node
, True);
13536 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13538 -- If we are in dynamic elaboration mode, then we suppress
13539 -- elaboration warnings for the unit, since it is definitely
13540 -- fine NOT to do dynamic checks at the first level (and such
13541 -- checks will be suppressed because no elaboration boolean
13542 -- is created for Elaborate_Body packages).
13544 -- But in the static model of elaboration, Elaborate_Body is
13545 -- definitely NOT good enough to ensure elaboration safety on
13546 -- its own, since the body may WITH other units that are not
13547 -- safe from an elaboration point of view, so a client must
13548 -- still do an Elaborate_All on such units.
13550 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13551 -- Elaborate_Body always suppressed elab warnings.
13553 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13554 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13557 end Elaborate_Body
;
13559 ------------------------
13560 -- Elaboration_Checks --
13561 ------------------------
13563 -- pragma Elaboration_Checks (Static | Dynamic);
13565 when Pragma_Elaboration_Checks
=>
13567 Check_Arg_Count
(1);
13568 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13569 Dynamic_Elaboration_Checks
:=
13570 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
13576 -- pragma Eliminate (
13577 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13578 -- [,[Entity =>] IDENTIFIER |
13579 -- SELECTED_COMPONENT |
13581 -- [, OVERLOADING_RESOLUTION]);
13583 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13586 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13587 -- FUNCTION_PROFILE
13589 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13591 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13592 -- Result_Type => result_SUBTYPE_NAME]
13594 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13595 -- SUBTYPE_NAME ::= STRING_LITERAL
13597 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13598 -- SOURCE_TRACE ::= STRING_LITERAL
13600 when Pragma_Eliminate
=> Eliminate
: declare
13601 Args
: Args_List
(1 .. 5);
13602 Names
: constant Name_List
(1 .. 5) := (
13605 Name_Parameter_Types
,
13607 Name_Source_Location
);
13609 Unit_Name
: Node_Id
renames Args
(1);
13610 Entity
: Node_Id
renames Args
(2);
13611 Parameter_Types
: Node_Id
renames Args
(3);
13612 Result_Type
: Node_Id
renames Args
(4);
13613 Source_Location
: Node_Id
renames Args
(5);
13617 Check_Valid_Configuration_Pragma
;
13618 Gather_Associations
(Names
, Args
);
13620 if No
(Unit_Name
) then
13621 Error_Pragma
("missing Unit_Name argument for pragma%");
13625 and then (Present
(Parameter_Types
)
13627 Present
(Result_Type
)
13629 Present
(Source_Location
))
13631 Error_Pragma
("missing Entity argument for pragma%");
13634 if (Present
(Parameter_Types
)
13636 Present
(Result_Type
))
13638 Present
(Source_Location
)
13641 ("parameter profile and source location cannot be used "
13642 & "together in pragma%");
13645 Process_Eliminate_Pragma
13654 -----------------------------------
13655 -- Enable_Atomic_Synchronization --
13656 -----------------------------------
13658 -- pragma Enable_Atomic_Synchronization [(Entity)];
13660 when Pragma_Enable_Atomic_Synchronization
=>
13662 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13669 -- [ Convention =>] convention_IDENTIFIER,
13670 -- [ Entity =>] LOCAL_NAME
13671 -- [, [External_Name =>] static_string_EXPRESSION ]
13672 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13674 when Pragma_Export
=> Export
: declare
13676 Def_Id
: Entity_Id
;
13678 pragma Warnings
(Off
, C
);
13681 Check_Ada_83_Warning
;
13685 Name_External_Name
,
13688 Check_At_Least_N_Arguments
(2);
13689 Check_At_Most_N_Arguments
(4);
13691 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13692 -- pragma Export (Entity, "external name");
13694 if Relaxed_RM_Semantics
13695 and then Arg_Count
= 2
13696 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13699 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13702 if not Is_Entity_Name
(Def_Id
) then
13703 Error_Pragma_Arg
("entity name required", Arg1
);
13706 Def_Id
:= Entity
(Def_Id
);
13707 Set_Exported
(Def_Id
, Arg1
);
13710 Process_Convention
(C
, Def_Id
);
13712 if Ekind
(Def_Id
) /= E_Constant
then
13713 Note_Possible_Modification
13714 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13717 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13718 Set_Exported
(Def_Id
, Arg2
);
13721 -- If the entity is a deferred constant, propagate the information
13722 -- to the full view, because gigi elaborates the full view only.
13724 if Ekind
(Def_Id
) = E_Constant
13725 and then Present
(Full_View
(Def_Id
))
13728 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13730 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13731 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13732 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13737 ----------------------
13738 -- Export_Exception --
13739 ----------------------
13741 -- pragma Export_Exception (
13742 -- [Internal =>] LOCAL_NAME
13743 -- [, [External =>] EXTERNAL_SYMBOL]
13744 -- [, [Form =>] Ada | VMS]
13745 -- [, [Code =>] static_integer_EXPRESSION]);
13747 when Pragma_Export_Exception
=> Export_Exception
: declare
13748 Args
: Args_List
(1 .. 4);
13749 Names
: constant Name_List
(1 .. 4) := (
13755 Internal
: Node_Id
renames Args
(1);
13756 External
: Node_Id
renames Args
(2);
13757 Form
: Node_Id
renames Args
(3);
13758 Code
: Node_Id
renames Args
(4);
13763 if Inside_A_Generic
then
13764 Error_Pragma
("pragma% cannot be used for generic entities");
13767 Gather_Associations
(Names
, Args
);
13768 Process_Extended_Import_Export_Exception_Pragma
(
13769 Arg_Internal
=> Internal
,
13770 Arg_External
=> External
,
13774 if not Is_VMS_Exception
(Entity
(Internal
)) then
13775 Set_Exported
(Entity
(Internal
), Internal
);
13777 end Export_Exception
;
13779 ---------------------
13780 -- Export_Function --
13781 ---------------------
13783 -- pragma Export_Function (
13784 -- [Internal =>] LOCAL_NAME
13785 -- [, [External =>] EXTERNAL_SYMBOL]
13786 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13787 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13788 -- [, [Mechanism =>] MECHANISM]
13789 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13791 -- EXTERNAL_SYMBOL ::=
13793 -- | static_string_EXPRESSION
13795 -- PARAMETER_TYPES ::=
13797 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13799 -- TYPE_DESIGNATOR ::=
13801 -- | subtype_Name ' Access
13805 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13807 -- MECHANISM_ASSOCIATION ::=
13808 -- [formal_parameter_NAME =>] MECHANISM_NAME
13810 -- MECHANISM_NAME ::=
13813 -- | Descriptor [([Class =>] CLASS_NAME)]
13815 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13817 when Pragma_Export_Function
=> Export_Function
: declare
13818 Args
: Args_List
(1 .. 6);
13819 Names
: constant Name_List
(1 .. 6) := (
13822 Name_Parameter_Types
,
13825 Name_Result_Mechanism
);
13827 Internal
: Node_Id
renames Args
(1);
13828 External
: Node_Id
renames Args
(2);
13829 Parameter_Types
: Node_Id
renames Args
(3);
13830 Result_Type
: Node_Id
renames Args
(4);
13831 Mechanism
: Node_Id
renames Args
(5);
13832 Result_Mechanism
: Node_Id
renames Args
(6);
13836 Gather_Associations
(Names
, Args
);
13837 Process_Extended_Import_Export_Subprogram_Pragma
(
13838 Arg_Internal
=> Internal
,
13839 Arg_External
=> External
,
13840 Arg_Parameter_Types
=> Parameter_Types
,
13841 Arg_Result_Type
=> Result_Type
,
13842 Arg_Mechanism
=> Mechanism
,
13843 Arg_Result_Mechanism
=> Result_Mechanism
);
13844 end Export_Function
;
13846 -------------------
13847 -- Export_Object --
13848 -------------------
13850 -- pragma Export_Object (
13851 -- [Internal =>] LOCAL_NAME
13852 -- [, [External =>] EXTERNAL_SYMBOL]
13853 -- [, [Size =>] EXTERNAL_SYMBOL]);
13855 -- EXTERNAL_SYMBOL ::=
13857 -- | static_string_EXPRESSION
13859 -- PARAMETER_TYPES ::=
13861 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13863 -- TYPE_DESIGNATOR ::=
13865 -- | subtype_Name ' Access
13869 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13871 -- MECHANISM_ASSOCIATION ::=
13872 -- [formal_parameter_NAME =>] MECHANISM_NAME
13874 -- MECHANISM_NAME ::=
13877 -- | Descriptor [([Class =>] CLASS_NAME)]
13879 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13881 when Pragma_Export_Object
=> Export_Object
: declare
13882 Args
: Args_List
(1 .. 3);
13883 Names
: constant Name_List
(1 .. 3) := (
13888 Internal
: Node_Id
renames Args
(1);
13889 External
: Node_Id
renames Args
(2);
13890 Size
: Node_Id
renames Args
(3);
13894 Gather_Associations
(Names
, Args
);
13895 Process_Extended_Import_Export_Object_Pragma
(
13896 Arg_Internal
=> Internal
,
13897 Arg_External
=> External
,
13901 ----------------------
13902 -- Export_Procedure --
13903 ----------------------
13905 -- pragma Export_Procedure (
13906 -- [Internal =>] LOCAL_NAME
13907 -- [, [External =>] EXTERNAL_SYMBOL]
13908 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13909 -- [, [Mechanism =>] MECHANISM]);
13911 -- EXTERNAL_SYMBOL ::=
13913 -- | static_string_EXPRESSION
13915 -- PARAMETER_TYPES ::=
13917 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13919 -- TYPE_DESIGNATOR ::=
13921 -- | subtype_Name ' Access
13925 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13927 -- MECHANISM_ASSOCIATION ::=
13928 -- [formal_parameter_NAME =>] MECHANISM_NAME
13930 -- MECHANISM_NAME ::=
13933 -- | Descriptor [([Class =>] CLASS_NAME)]
13935 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13937 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13938 Args
: Args_List
(1 .. 4);
13939 Names
: constant Name_List
(1 .. 4) := (
13942 Name_Parameter_Types
,
13945 Internal
: Node_Id
renames Args
(1);
13946 External
: Node_Id
renames Args
(2);
13947 Parameter_Types
: Node_Id
renames Args
(3);
13948 Mechanism
: Node_Id
renames Args
(4);
13952 Gather_Associations
(Names
, Args
);
13953 Process_Extended_Import_Export_Subprogram_Pragma
(
13954 Arg_Internal
=> Internal
,
13955 Arg_External
=> External
,
13956 Arg_Parameter_Types
=> Parameter_Types
,
13957 Arg_Mechanism
=> Mechanism
);
13958 end Export_Procedure
;
13964 -- pragma Export_Value (
13965 -- [Value =>] static_integer_EXPRESSION,
13966 -- [Link_Name =>] static_string_EXPRESSION);
13968 when Pragma_Export_Value
=>
13970 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13971 Check_Arg_Count
(2);
13973 Check_Optional_Identifier
(Arg1
, Name_Value
);
13974 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
13976 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13977 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
13979 -----------------------------
13980 -- Export_Valued_Procedure --
13981 -----------------------------
13983 -- pragma Export_Valued_Procedure (
13984 -- [Internal =>] LOCAL_NAME
13985 -- [, [External =>] EXTERNAL_SYMBOL,]
13986 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13987 -- [, [Mechanism =>] MECHANISM]);
13989 -- EXTERNAL_SYMBOL ::=
13991 -- | static_string_EXPRESSION
13993 -- PARAMETER_TYPES ::=
13995 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13997 -- TYPE_DESIGNATOR ::=
13999 -- | subtype_Name ' Access
14003 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14005 -- MECHANISM_ASSOCIATION ::=
14006 -- [formal_parameter_NAME =>] MECHANISM_NAME
14008 -- MECHANISM_NAME ::=
14011 -- | Descriptor [([Class =>] CLASS_NAME)]
14013 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14015 when Pragma_Export_Valued_Procedure
=>
14016 Export_Valued_Procedure
: declare
14017 Args
: Args_List
(1 .. 4);
14018 Names
: constant Name_List
(1 .. 4) := (
14021 Name_Parameter_Types
,
14024 Internal
: Node_Id
renames Args
(1);
14025 External
: Node_Id
renames Args
(2);
14026 Parameter_Types
: Node_Id
renames Args
(3);
14027 Mechanism
: Node_Id
renames Args
(4);
14031 Gather_Associations
(Names
, Args
);
14032 Process_Extended_Import_Export_Subprogram_Pragma
(
14033 Arg_Internal
=> Internal
,
14034 Arg_External
=> External
,
14035 Arg_Parameter_Types
=> Parameter_Types
,
14036 Arg_Mechanism
=> Mechanism
);
14037 end Export_Valued_Procedure
;
14039 -------------------
14040 -- Extend_System --
14041 -------------------
14043 -- pragma Extend_System ([Name =>] Identifier);
14045 when Pragma_Extend_System
=> Extend_System
: declare
14048 Check_Valid_Configuration_Pragma
;
14049 Check_Arg_Count
(1);
14050 Check_Optional_Identifier
(Arg1
, Name_Name
);
14051 Check_Arg_Is_Identifier
(Arg1
);
14053 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14056 and then Name_Buffer
(1 .. 4) = "aux_"
14058 if Present
(System_Extend_Pragma_Arg
) then
14059 if Chars
(Get_Pragma_Arg
(Arg1
)) =
14060 Chars
(Expression
(System_Extend_Pragma_Arg
))
14064 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
14065 Error_Pragma
("pragma% conflicts with that #");
14069 System_Extend_Pragma_Arg
:= Arg1
;
14071 if not GNAT_Mode
then
14072 System_Extend_Unit
:= Arg1
;
14076 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
14080 ------------------------
14081 -- Extensions_Allowed --
14082 ------------------------
14084 -- pragma Extensions_Allowed (ON | OFF);
14086 when Pragma_Extensions_Allowed
=>
14088 Check_Arg_Count
(1);
14089 Check_No_Identifiers
;
14090 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14092 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14093 Extensions_Allowed
:= True;
14094 Ada_Version
:= Ada_Version_Type
'Last;
14097 Extensions_Allowed
:= False;
14098 Ada_Version
:= Ada_Version_Explicit
;
14099 Ada_Version_Pragma
:= Empty
;
14106 -- pragma External (
14107 -- [ Convention =>] convention_IDENTIFIER,
14108 -- [ Entity =>] LOCAL_NAME
14109 -- [, [External_Name =>] static_string_EXPRESSION ]
14110 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14112 when Pragma_External
=> External
: declare
14113 Def_Id
: Entity_Id
;
14116 pragma Warnings
(Off
, C
);
14123 Name_External_Name
,
14125 Check_At_Least_N_Arguments
(2);
14126 Check_At_Most_N_Arguments
(4);
14127 Process_Convention
(C
, Def_Id
);
14128 Note_Possible_Modification
14129 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14130 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14131 Set_Exported
(Def_Id
, Arg2
);
14134 --------------------------
14135 -- External_Name_Casing --
14136 --------------------------
14138 -- pragma External_Name_Casing (
14139 -- UPPERCASE | LOWERCASE
14140 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14142 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14145 Check_No_Identifiers
;
14147 if Arg_Count
= 2 then
14148 Check_Arg_Is_One_Of
14149 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14151 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14153 Opt
.External_Name_Exp_Casing
:= As_Is
;
14155 when Name_Uppercase
=>
14156 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14158 when Name_Lowercase
=>
14159 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14166 Check_Arg_Count
(1);
14169 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14171 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14172 when Name_Uppercase
=>
14173 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14175 when Name_Lowercase
=>
14176 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14181 end External_Name_Casing
;
14187 -- pragma Fast_Math;
14189 when Pragma_Fast_Math
=>
14191 Check_No_Identifiers
;
14192 Check_Valid_Configuration_Pragma
;
14195 --------------------------
14196 -- Favor_Top_Level --
14197 --------------------------
14199 -- pragma Favor_Top_Level (type_NAME);
14201 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14202 Named_Entity
: Entity_Id
;
14206 Check_No_Identifiers
;
14207 Check_Arg_Count
(1);
14208 Check_Arg_Is_Local_Name
(Arg1
);
14209 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14211 -- If it's an access-to-subprogram type (in particular, not a
14212 -- subtype), set the flag on that type.
14214 if Is_Access_Subprogram_Type
(Named_Entity
) then
14215 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14217 -- Otherwise it's an error (name denotes the wrong sort of entity)
14221 ("access-to-subprogram type expected",
14222 Get_Pragma_Arg
(Arg1
));
14224 end Favor_Top_Level
;
14226 ---------------------------
14227 -- Finalize_Storage_Only --
14228 ---------------------------
14230 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14232 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14233 Assoc
: constant Node_Id
:= Arg1
;
14234 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14239 Check_No_Identifiers
;
14240 Check_Arg_Count
(1);
14241 Check_Arg_Is_Local_Name
(Arg1
);
14243 Find_Type
(Type_Id
);
14244 Typ
:= Entity
(Type_Id
);
14247 or else Rep_Item_Too_Early
(Typ
, N
)
14251 Typ
:= Underlying_Type
(Typ
);
14254 if not Is_Controlled
(Typ
) then
14255 Error_Pragma
("pragma% must specify controlled type");
14258 Check_First_Subtype
(Arg1
);
14260 if Finalize_Storage_Only
(Typ
) then
14261 Error_Pragma
("duplicate pragma%, only one allowed");
14263 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14264 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14266 end Finalize_Storage
;
14268 --------------------------
14269 -- Float_Representation --
14270 --------------------------
14272 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
14274 -- FLOAT_REP ::= VAX_Float | IEEE_Float
14276 when Pragma_Float_Representation
=> Float_Representation
: declare
14284 if Arg_Count
= 1 then
14285 Check_Valid_Configuration_Pragma
;
14287 Check_Arg_Count
(2);
14288 Check_Optional_Identifier
(Arg2
, Name_Entity
);
14289 Check_Arg_Is_Local_Name
(Arg2
);
14292 Check_No_Identifier
(Arg1
);
14293 Check_Arg_Is_One_Of
(Arg1
, Name_VAX_Float
, Name_IEEE_Float
);
14295 if not OpenVMS_On_Target
then
14296 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
14298 ("??pragma% ignored (applies only to Open'V'M'S)");
14304 -- One argument case
14306 if Arg_Count
= 1 then
14307 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
14308 if Opt
.Float_Format
= 'I' then
14309 Error_Pragma
("'I'E'E'E format previously specified");
14312 Opt
.Float_Format
:= 'V';
14315 if Opt
.Float_Format
= 'V' then
14316 Error_Pragma
("'V'A'X format previously specified");
14319 Opt
.Float_Format
:= 'I';
14322 Set_Standard_Fpt_Formats
;
14324 -- Two argument case
14327 Argx
:= Get_Pragma_Arg
(Arg2
);
14329 if not Is_Entity_Name
(Argx
)
14330 or else not Is_Floating_Point_Type
(Entity
(Argx
))
14333 ("second argument of% pragma must be floating-point type",
14337 Ent
:= Entity
(Argx
);
14338 Digs
:= UI_To_Int
(Digits_Value
(Ent
));
14340 -- Two arguments, VAX_Float case
14342 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
14344 when 6 => Set_F_Float
(Ent
);
14345 when 9 => Set_D_Float
(Ent
);
14346 when 15 => Set_G_Float
(Ent
);
14350 ("wrong digits value, must be 6,9 or 15", Arg2
);
14353 -- Two arguments, IEEE_Float case
14357 when 6 => Set_IEEE_Short
(Ent
);
14358 when 15 => Set_IEEE_Long
(Ent
);
14362 ("wrong digits value, must be 6 or 15", Arg2
);
14366 end Float_Representation
;
14372 -- pragma Global (GLOBAL_SPECIFICATION);
14374 -- GLOBAL_SPECIFICATION ::=
14377 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14379 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14381 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14382 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14383 -- GLOBAL_ITEM ::= NAME
14385 when Pragma_Global
=> Global
: declare
14386 Subp_Decl
: Node_Id
;
14390 Check_Arg_Count
(1);
14391 Ensure_Aggregate_Form
(Arg1
);
14393 -- Ensure the proper placement of the pragma. Global must be
14394 -- associated with a subprogram declaration or a body that acts
14398 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14400 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14403 -- Body acts as spec
14405 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14406 and then No
(Corresponding_Spec
(Subp_Decl
))
14410 -- Body stub acts as spec
14412 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14413 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14422 -- When the pragma appears on a subprogram body, perform the full
14425 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14426 Analyze_Global_In_Decl_Part
(N
);
14428 -- When Global applies to a subprogram compilation unit, the
14429 -- corresponding pragma is placed after the unit's declaration
14430 -- node and needs to be analyzed immediately.
14432 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14433 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14435 Analyze_Global_In_Decl_Part
(N
);
14438 -- Chain the pragma on the contract for further processing
14440 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14447 -- pragma Ident (static_string_EXPRESSION)
14449 -- Note: pragma Comment shares this processing. Pragma Comment is
14450 -- identical to Ident, except that the restriction of the argument to
14451 -- 31 characters and the placement restrictions are not enforced for
14454 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14459 Check_Arg_Count
(1);
14460 Check_No_Identifiers
;
14461 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
14464 -- For pragma Ident, preserve DEC compatibility by requiring the
14465 -- pragma to appear in a declarative part or package spec.
14467 if Prag_Id
= Pragma_Ident
then
14468 Check_Is_In_Decl_Part_Or_Package_Spec
;
14471 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14478 GP
:= Parent
(Parent
(N
));
14480 if Nkind_In
(GP
, N_Package_Declaration
,
14481 N_Generic_Package_Declaration
)
14486 -- If we have a compilation unit, then record the ident value,
14487 -- checking for improper duplication.
14489 if Nkind
(GP
) = N_Compilation_Unit
then
14490 CS
:= Ident_String
(Current_Sem_Unit
);
14492 if Present
(CS
) then
14494 -- For Ident, we do not permit multiple instances
14496 if Prag_Id
= Pragma_Ident
then
14497 Error_Pragma
("duplicate% pragma not permitted");
14499 -- For Comment, we concatenate the string, unless we want
14500 -- to preserve the tree structure for ASIS.
14502 elsif not ASIS_Mode
then
14503 Start_String
(Strval
(CS
));
14504 Store_String_Char
(' ');
14505 Store_String_Chars
(Strval
(Str
));
14506 Set_Strval
(CS
, End_String
);
14510 -- In VMS, the effect of IDENT is achieved by passing
14511 -- --identification=name as a --for-linker switch.
14513 if OpenVMS_On_Target
then
14516 ("--for-linker=--identification=");
14517 String_To_Name_Buffer
(Strval
(Str
));
14518 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
14520 -- Only the last processed IDENT is saved. The main
14521 -- purpose is so an IDENT associated with a main
14522 -- procedure will be used in preference to an IDENT
14523 -- associated with a with'd package.
14525 Replace_Linker_Option_String
14526 (End_String
, "--for-linker=--identification=");
14529 Set_Ident_String
(Current_Sem_Unit
, Str
);
14532 -- For subunits, we just ignore the Ident, since in GNAT these
14533 -- are not separate object files, and hence not separate units
14534 -- in the unit table.
14536 elsif Nkind
(GP
) = N_Subunit
then
14539 -- Otherwise we have a misplaced pragma Ident, but we ignore
14540 -- this if we are in an instantiation, since it comes from
14541 -- a generic, and has no relevance to the instantiation.
14543 elsif Prag_Id
= Pragma_Ident
then
14544 if Instantiation_Location
(Loc
) = No_Location
then
14545 Error_Pragma
("pragma% only allowed at outer level");
14551 ----------------------------
14552 -- Implementation_Defined --
14553 ----------------------------
14555 -- pragma Implementation_Defined (LOCAL_NAME);
14557 -- Marks previously declared entity as implementation defined. For
14558 -- an overloaded entity, applies to the most recent homonym.
14560 -- pragma Implementation_Defined;
14562 -- The form with no arguments appears anywhere within a scope, most
14563 -- typically a package spec, and indicates that all entities that are
14564 -- defined within the package spec are Implementation_Defined.
14566 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14571 Check_No_Identifiers
;
14573 -- Form with no arguments
14575 if Arg_Count
= 0 then
14576 Set_Is_Implementation_Defined
(Current_Scope
);
14578 -- Form with one argument
14581 Check_Arg_Count
(1);
14582 Check_Arg_Is_Local_Name
(Arg1
);
14583 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14584 Set_Is_Implementation_Defined
(Ent
);
14586 end Implementation_Defined
;
14592 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14594 -- IMPLEMENTATION_KIND ::=
14595 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14597 -- "By_Any" and "Optional" are treated as synonyms in order to
14598 -- support Ada 2012 aspect Synchronization.
14600 when Pragma_Implemented
=> Implemented
: declare
14601 Proc_Id
: Entity_Id
;
14606 Check_Arg_Count
(2);
14607 Check_No_Identifiers
;
14608 Check_Arg_Is_Identifier
(Arg1
);
14609 Check_Arg_Is_Local_Name
(Arg1
);
14610 Check_Arg_Is_One_Of
(Arg2
,
14613 Name_By_Protected_Procedure
,
14616 -- Extract the name of the local procedure
14618 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14620 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14621 -- primitive procedure of a synchronized tagged type.
14623 if Ekind
(Proc_Id
) = E_Procedure
14624 and then Is_Primitive
(Proc_Id
)
14625 and then Present
(First_Formal
(Proc_Id
))
14627 Typ
:= Etype
(First_Formal
(Proc_Id
));
14629 if Is_Tagged_Type
(Typ
)
14632 -- Check for a protected, a synchronized or a task interface
14634 ((Is_Interface
(Typ
)
14635 and then Is_Synchronized_Interface
(Typ
))
14637 -- Check for a protected type or a task type that implements
14641 (Is_Concurrent_Record_Type
(Typ
)
14642 and then Present
(Interfaces
(Typ
)))
14644 -- Check for a private record extension with keyword
14648 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14649 E_Record_Subtype_With_Private
)
14650 and then Synchronized_Present
(Parent
(Typ
))))
14655 ("controlling formal must be of synchronized tagged type",
14660 -- Procedures declared inside a protected type must be accepted
14662 elsif Ekind
(Proc_Id
) = E_Procedure
14663 and then Is_Protected_Type
(Scope
(Proc_Id
))
14667 -- The first argument is not a primitive procedure
14671 ("pragma % must be applied to a primitive procedure", Arg1
);
14675 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14676 -- By_Protected_Procedure to the primitive procedure of a task
14679 if Chars
(Arg2
) = Name_By_Protected_Procedure
14680 and then Is_Interface
(Typ
)
14681 and then Is_Task_Interface
(Typ
)
14684 ("implementation kind By_Protected_Procedure cannot be "
14685 & "applied to a task interface primitive", Arg2
);
14689 Record_Rep_Item
(Proc_Id
, N
);
14692 ----------------------
14693 -- Implicit_Packing --
14694 ----------------------
14696 -- pragma Implicit_Packing;
14698 when Pragma_Implicit_Packing
=>
14700 Check_Arg_Count
(0);
14701 Implicit_Packing
:= True;
14708 -- [Convention =>] convention_IDENTIFIER,
14709 -- [Entity =>] LOCAL_NAME
14710 -- [, [External_Name =>] static_string_EXPRESSION ]
14711 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14713 when Pragma_Import
=>
14714 Check_Ada_83_Warning
;
14718 Name_External_Name
,
14721 Check_At_Least_N_Arguments
(2);
14722 Check_At_Most_N_Arguments
(4);
14723 Process_Import_Or_Interface
;
14725 ----------------------
14726 -- Import_Exception --
14727 ----------------------
14729 -- pragma Import_Exception (
14730 -- [Internal =>] LOCAL_NAME
14731 -- [, [External =>] EXTERNAL_SYMBOL]
14732 -- [, [Form =>] Ada | VMS]
14733 -- [, [Code =>] static_integer_EXPRESSION]);
14735 when Pragma_Import_Exception
=> Import_Exception
: declare
14736 Args
: Args_List
(1 .. 4);
14737 Names
: constant Name_List
(1 .. 4) := (
14743 Internal
: Node_Id
renames Args
(1);
14744 External
: Node_Id
renames Args
(2);
14745 Form
: Node_Id
renames Args
(3);
14746 Code
: Node_Id
renames Args
(4);
14750 Gather_Associations
(Names
, Args
);
14752 if Present
(External
) and then Present
(Code
) then
14754 ("cannot give both External and Code options for pragma%");
14757 Process_Extended_Import_Export_Exception_Pragma
(
14758 Arg_Internal
=> Internal
,
14759 Arg_External
=> External
,
14763 if not Is_VMS_Exception
(Entity
(Internal
)) then
14764 Set_Imported
(Entity
(Internal
));
14766 end Import_Exception
;
14768 ---------------------
14769 -- Import_Function --
14770 ---------------------
14772 -- pragma Import_Function (
14773 -- [Internal =>] LOCAL_NAME,
14774 -- [, [External =>] EXTERNAL_SYMBOL]
14775 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14776 -- [, [Result_Type =>] SUBTYPE_MARK]
14777 -- [, [Mechanism =>] MECHANISM]
14778 -- [, [Result_Mechanism =>] MECHANISM_NAME]
14779 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14781 -- EXTERNAL_SYMBOL ::=
14783 -- | static_string_EXPRESSION
14785 -- PARAMETER_TYPES ::=
14787 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14789 -- TYPE_DESIGNATOR ::=
14791 -- | subtype_Name ' Access
14795 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14797 -- MECHANISM_ASSOCIATION ::=
14798 -- [formal_parameter_NAME =>] MECHANISM_NAME
14800 -- MECHANISM_NAME ::=
14803 -- | Descriptor [([Class =>] CLASS_NAME)]
14805 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14807 when Pragma_Import_Function
=> Import_Function
: declare
14808 Args
: Args_List
(1 .. 7);
14809 Names
: constant Name_List
(1 .. 7) := (
14812 Name_Parameter_Types
,
14815 Name_Result_Mechanism
,
14816 Name_First_Optional_Parameter
);
14818 Internal
: Node_Id
renames Args
(1);
14819 External
: Node_Id
renames Args
(2);
14820 Parameter_Types
: Node_Id
renames Args
(3);
14821 Result_Type
: Node_Id
renames Args
(4);
14822 Mechanism
: Node_Id
renames Args
(5);
14823 Result_Mechanism
: Node_Id
renames Args
(6);
14824 First_Optional_Parameter
: Node_Id
renames Args
(7);
14828 Gather_Associations
(Names
, Args
);
14829 Process_Extended_Import_Export_Subprogram_Pragma
(
14830 Arg_Internal
=> Internal
,
14831 Arg_External
=> External
,
14832 Arg_Parameter_Types
=> Parameter_Types
,
14833 Arg_Result_Type
=> Result_Type
,
14834 Arg_Mechanism
=> Mechanism
,
14835 Arg_Result_Mechanism
=> Result_Mechanism
,
14836 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
14837 end Import_Function
;
14839 -------------------
14840 -- Import_Object --
14841 -------------------
14843 -- pragma Import_Object (
14844 -- [Internal =>] LOCAL_NAME
14845 -- [, [External =>] EXTERNAL_SYMBOL]
14846 -- [, [Size =>] EXTERNAL_SYMBOL]);
14848 -- EXTERNAL_SYMBOL ::=
14850 -- | static_string_EXPRESSION
14852 when Pragma_Import_Object
=> Import_Object
: declare
14853 Args
: Args_List
(1 .. 3);
14854 Names
: constant Name_List
(1 .. 3) := (
14859 Internal
: Node_Id
renames Args
(1);
14860 External
: Node_Id
renames Args
(2);
14861 Size
: Node_Id
renames Args
(3);
14865 Gather_Associations
(Names
, Args
);
14866 Process_Extended_Import_Export_Object_Pragma
(
14867 Arg_Internal
=> Internal
,
14868 Arg_External
=> External
,
14872 ----------------------
14873 -- Import_Procedure --
14874 ----------------------
14876 -- pragma Import_Procedure (
14877 -- [Internal =>] LOCAL_NAME
14878 -- [, [External =>] EXTERNAL_SYMBOL]
14879 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14880 -- [, [Mechanism =>] MECHANISM]
14881 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14883 -- EXTERNAL_SYMBOL ::=
14885 -- | static_string_EXPRESSION
14887 -- PARAMETER_TYPES ::=
14889 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14891 -- TYPE_DESIGNATOR ::=
14893 -- | subtype_Name ' Access
14897 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14899 -- MECHANISM_ASSOCIATION ::=
14900 -- [formal_parameter_NAME =>] MECHANISM_NAME
14902 -- MECHANISM_NAME ::=
14905 -- | Descriptor [([Class =>] CLASS_NAME)]
14907 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14909 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14910 Args
: Args_List
(1 .. 5);
14911 Names
: constant Name_List
(1 .. 5) := (
14914 Name_Parameter_Types
,
14916 Name_First_Optional_Parameter
);
14918 Internal
: Node_Id
renames Args
(1);
14919 External
: Node_Id
renames Args
(2);
14920 Parameter_Types
: Node_Id
renames Args
(3);
14921 Mechanism
: Node_Id
renames Args
(4);
14922 First_Optional_Parameter
: Node_Id
renames Args
(5);
14926 Gather_Associations
(Names
, Args
);
14927 Process_Extended_Import_Export_Subprogram_Pragma
(
14928 Arg_Internal
=> Internal
,
14929 Arg_External
=> External
,
14930 Arg_Parameter_Types
=> Parameter_Types
,
14931 Arg_Mechanism
=> Mechanism
,
14932 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
14933 end Import_Procedure
;
14935 -----------------------------
14936 -- Import_Valued_Procedure --
14937 -----------------------------
14939 -- pragma Import_Valued_Procedure (
14940 -- [Internal =>] LOCAL_NAME
14941 -- [, [External =>] EXTERNAL_SYMBOL]
14942 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14943 -- [, [Mechanism =>] MECHANISM]
14944 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14946 -- EXTERNAL_SYMBOL ::=
14948 -- | static_string_EXPRESSION
14950 -- PARAMETER_TYPES ::=
14952 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14954 -- TYPE_DESIGNATOR ::=
14956 -- | subtype_Name ' Access
14960 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14962 -- MECHANISM_ASSOCIATION ::=
14963 -- [formal_parameter_NAME =>] MECHANISM_NAME
14965 -- MECHANISM_NAME ::=
14968 -- | Descriptor [([Class =>] CLASS_NAME)]
14970 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14972 when Pragma_Import_Valued_Procedure
=>
14973 Import_Valued_Procedure
: declare
14974 Args
: Args_List
(1 .. 5);
14975 Names
: constant Name_List
(1 .. 5) := (
14978 Name_Parameter_Types
,
14980 Name_First_Optional_Parameter
);
14982 Internal
: Node_Id
renames Args
(1);
14983 External
: Node_Id
renames Args
(2);
14984 Parameter_Types
: Node_Id
renames Args
(3);
14985 Mechanism
: Node_Id
renames Args
(4);
14986 First_Optional_Parameter
: Node_Id
renames Args
(5);
14990 Gather_Associations
(Names
, Args
);
14991 Process_Extended_Import_Export_Subprogram_Pragma
(
14992 Arg_Internal
=> Internal
,
14993 Arg_External
=> External
,
14994 Arg_Parameter_Types
=> Parameter_Types
,
14995 Arg_Mechanism
=> Mechanism
,
14996 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
14997 end Import_Valued_Procedure
;
15003 -- pragma Independent (record_component_LOCAL_NAME);
15005 when Pragma_Independent
=> Independent
: declare
15010 Check_Ada_83_Warning
;
15012 Check_No_Identifiers
;
15013 Check_Arg_Count
(1);
15014 Check_Arg_Is_Local_Name
(Arg1
);
15015 E_Id
:= Get_Pragma_Arg
(Arg1
);
15017 if Etype
(E_Id
) = Any_Type
then
15021 E
:= Entity
(E_Id
);
15023 -- Check we have a record component. We have not yet setup
15024 -- components fully, so identify by syntactic structure.
15026 if Nkind
(Declaration_Node
(E
)) /= N_Component_Declaration
then
15028 ("argument for pragma% must be record component", Arg1
);
15031 -- Check duplicate before we chain ourselves
15033 Check_Duplicate_Pragma
(E
);
15037 if Rep_Item_Too_Early
(E
, N
)
15039 Rep_Item_Too_Late
(E
, N
)
15044 -- Set flag in component
15046 Set_Is_Independent
(E
);
15048 Independence_Checks
.Append
((N
, E
));
15051 ----------------------------
15052 -- Independent_Components --
15053 ----------------------------
15055 -- pragma Atomic_Components (array_LOCAL_NAME);
15057 -- This processing is shared by Volatile_Components
15059 when Pragma_Independent_Components
=> Independent_Components
: declare
15067 Check_Ada_83_Warning
;
15069 Check_No_Identifiers
;
15070 Check_Arg_Count
(1);
15071 Check_Arg_Is_Local_Name
(Arg1
);
15072 E_Id
:= Get_Pragma_Arg
(Arg1
);
15074 if Etype
(E_Id
) = Any_Type
then
15078 E
:= Entity
(E_Id
);
15080 -- Check duplicate before we chain ourselves
15082 Check_Duplicate_Pragma
(E
);
15084 -- Check appropriate entity
15086 if Rep_Item_Too_Early
(E
, N
)
15088 Rep_Item_Too_Late
(E
, N
)
15093 D
:= Declaration_Node
(E
);
15096 if K
= N_Full_Type_Declaration
15097 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15099 Independence_Checks
.Append
((N
, Base_Type
(E
)));
15100 Set_Has_Independent_Components
(Base_Type
(E
));
15102 -- For record type, set all components independent
15104 if Is_Record_Type
(E
) then
15105 C
:= First_Component
(E
);
15106 while Present
(C
) loop
15107 Set_Is_Independent
(C
);
15108 Next_Component
(C
);
15112 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15113 and then Nkind
(D
) = N_Object_Declaration
15114 and then Nkind
(Object_Definition
(D
)) =
15115 N_Constrained_Array_Definition
15117 Independence_Checks
.Append
((N
, Base_Type
(Etype
(E
))));
15118 Set_Has_Independent_Components
(Base_Type
(Etype
(E
)));
15121 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15123 end Independent_Components
;
15125 -----------------------
15126 -- Initial_Condition --
15127 -----------------------
15129 -- pragma Initial_Condition (boolean_EXPRESSION);
15131 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15132 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15133 Pack_Id
: Entity_Id
;
15138 Check_Arg_Count
(1);
15140 -- Ensure the proper placement of the pragma. Initial_Condition
15141 -- must be associated with a package declaration.
15143 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15144 N_Package_Declaration
)
15151 while Present
(Stmt
) loop
15153 -- Skip prior pragmas, but check for duplicates
15155 if Nkind
(Stmt
) = N_Pragma
then
15156 if Pragma_Name
(Stmt
) = Pname
then
15157 Error_Msg_Name_1
:= Pname
;
15158 Error_Msg_Sloc
:= Sloc
(Stmt
);
15159 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15162 -- Skip internally generated code
15164 elsif not Comes_From_Source
(Stmt
) then
15167 -- The pragma does not apply to a legal construct, issue an
15168 -- error and stop the analysis.
15175 Stmt
:= Prev
(Stmt
);
15178 -- The pragma must be analyzed at the end of the visible
15179 -- declarations of the related package. Save the pragma for later
15180 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15181 -- the contract of the package.
15183 Pack_Id
:= Defining_Entity
(Context
);
15184 Add_Contract_Item
(N
, Pack_Id
);
15186 -- Verify the declaration order of pragma Initial_Condition with
15187 -- respect to pragmas Abstract_State and Initializes when SPARK
15188 -- checks are enabled.
15190 if SPARK_Mode
/= Off
then
15191 Check_Declaration_Order
15192 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15195 Check_Declaration_Order
15196 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
15199 end Initial_Condition
;
15201 ------------------------
15202 -- Initialize_Scalars --
15203 ------------------------
15205 -- pragma Initialize_Scalars;
15207 when Pragma_Initialize_Scalars
=>
15209 Check_Arg_Count
(0);
15210 Check_Valid_Configuration_Pragma
;
15211 Check_Restriction
(No_Initialize_Scalars
, N
);
15213 -- Initialize_Scalars creates false positives in CodePeer, and
15214 -- incorrect negative results in GNATprove mode, so ignore this
15215 -- pragma in these modes.
15217 if not Restriction_Active
(No_Initialize_Scalars
)
15218 and then not (CodePeer_Mode
or GNATprove_Mode
)
15220 Init_Or_Norm_Scalars
:= True;
15221 Initialize_Scalars
:= True;
15228 -- pragma Initializes (INITIALIZATION_SPEC);
15230 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15232 -- INITIALIZATION_LIST ::=
15233 -- INITIALIZATION_ITEM
15234 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15236 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15241 -- | (INPUT {, INPUT})
15245 when Pragma_Initializes
=> Initializes
: declare
15246 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15247 Pack_Id
: Entity_Id
;
15252 Check_Arg_Count
(1);
15253 Ensure_Aggregate_Form
(Arg1
);
15255 -- Ensure the proper placement of the pragma. Initializes must be
15256 -- associated with a package declaration.
15258 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15259 N_Package_Declaration
)
15266 while Present
(Stmt
) loop
15268 -- Skip prior pragmas, but check for duplicates
15270 if Nkind
(Stmt
) = N_Pragma
then
15271 if Pragma_Name
(Stmt
) = Pname
then
15272 Error_Msg_Name_1
:= Pname
;
15273 Error_Msg_Sloc
:= Sloc
(Stmt
);
15274 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15277 -- Skip internally generated code
15279 elsif not Comes_From_Source
(Stmt
) then
15282 -- The pragma does not apply to a legal construct, issue an
15283 -- error and stop the analysis.
15290 Stmt
:= Prev
(Stmt
);
15293 -- The pragma must be analyzed at the end of the visible
15294 -- declarations of the related package. Save the pragma for later
15295 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15296 -- contract of the package.
15298 Pack_Id
:= Defining_Entity
(Context
);
15299 Add_Contract_Item
(N
, Pack_Id
);
15301 -- Verify the declaration order of pragmas Abstract_State and
15302 -- Initializes when SPARK checks are enabled.
15304 if SPARK_Mode
/= Off
then
15305 Check_Declaration_Order
15306 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15315 -- pragma Inline ( NAME {, NAME} );
15317 when Pragma_Inline
=>
15319 -- Inline status is Enabled if inlining option is active
15321 if Inline_Active
then
15322 Process_Inline
(Enabled
);
15324 Process_Inline
(Disabled
);
15327 -------------------
15328 -- Inline_Always --
15329 -------------------
15331 -- pragma Inline_Always ( NAME {, NAME} );
15333 when Pragma_Inline_Always
=>
15336 -- Pragma always active unless in CodePeer or GNATprove mode,
15337 -- since this causes walk order issues.
15339 if not (CodePeer_Mode
or GNATprove_Mode
) then
15340 Process_Inline
(Enabled
);
15343 --------------------
15344 -- Inline_Generic --
15345 --------------------
15347 -- pragma Inline_Generic (NAME {, NAME});
15349 when Pragma_Inline_Generic
=>
15351 Process_Generic_List
;
15353 ----------------------
15354 -- Inspection_Point --
15355 ----------------------
15357 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15359 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15364 -- A dummy procedure called when pragma Inspection_Point is
15365 -- analyzed. This is just to help debugging the front end. If
15366 -- a pragma Inspection_Point is added to a source program, then
15367 -- breaking on ip will get you to that point in the program.
15378 -- Start of processing for Inspection_Point
15383 if Arg_Count
> 0 then
15386 Exp
:= Get_Pragma_Arg
(Arg
);
15389 if not Is_Entity_Name
(Exp
)
15390 or else not Is_Object
(Entity
(Exp
))
15392 Error_Pragma_Arg
("object name required", Arg
);
15396 exit when No
(Arg
);
15399 end Inspection_Point
;
15405 -- pragma Interface (
15406 -- [ Convention =>] convention_IDENTIFIER,
15407 -- [ Entity =>] LOCAL_NAME
15408 -- [, [External_Name =>] static_string_EXPRESSION ]
15409 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15411 when Pragma_Interface
=>
15416 Name_External_Name
,
15418 Check_At_Least_N_Arguments
(2);
15419 Check_At_Most_N_Arguments
(4);
15420 Process_Import_Or_Interface
;
15422 -- In Ada 2005, the permission to use Interface (a reserved word)
15423 -- as a pragma name is considered an obsolescent feature, and this
15424 -- pragma was already obsolescent in Ada 95.
15426 if Ada_Version
>= Ada_95
then
15428 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15430 if Warn_On_Obsolescent_Feature
then
15432 ("pragma Interface is an obsolescent feature?j?", N
);
15434 ("|use pragma Import instead?j?", N
);
15438 --------------------
15439 -- Interface_Name --
15440 --------------------
15442 -- pragma Interface_Name (
15443 -- [ Entity =>] LOCAL_NAME
15444 -- [,[External_Name =>] static_string_EXPRESSION ]
15445 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15447 when Pragma_Interface_Name
=> Interface_Name
: declare
15449 Def_Id
: Entity_Id
;
15450 Hom_Id
: Entity_Id
;
15456 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15457 Check_At_Least_N_Arguments
(2);
15458 Check_At_Most_N_Arguments
(3);
15459 Id
:= Get_Pragma_Arg
(Arg1
);
15462 -- This is obsolete from Ada 95 on, but it is an implementation
15463 -- defined pragma, so we do not consider that it violates the
15464 -- restriction (No_Obsolescent_Features).
15466 if Ada_Version
>= Ada_95
then
15467 if Warn_On_Obsolescent_Feature
then
15469 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15471 ("|use pragma Import instead?j?", N
);
15475 if not Is_Entity_Name
(Id
) then
15477 ("first argument for pragma% must be entity name", Arg1
);
15478 elsif Etype
(Id
) = Any_Type
then
15481 Def_Id
:= Entity
(Id
);
15484 -- Special DEC-compatible processing for the object case, forces
15485 -- object to be imported.
15487 if Ekind
(Def_Id
) = E_Variable
then
15488 Kill_Size_Check_Code
(Def_Id
);
15489 Note_Possible_Modification
(Id
, Sure
=> False);
15491 -- Initialization is not allowed for imported variable
15493 if Present
(Expression
(Parent
(Def_Id
)))
15494 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15496 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15498 ("no initialization allowed for declaration of& #",
15502 -- For compatibility, support VADS usage of providing both
15503 -- pragmas Interface and Interface_Name to obtain the effect
15504 -- of a single Import pragma.
15506 if Is_Imported
(Def_Id
)
15507 and then Present
(First_Rep_Item
(Def_Id
))
15508 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15510 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15514 Set_Imported
(Def_Id
);
15517 Set_Is_Public
(Def_Id
);
15518 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15521 -- Otherwise must be subprogram
15523 elsif not Is_Subprogram
(Def_Id
) then
15525 ("argument of pragma% is not subprogram", Arg1
);
15528 Check_At_Most_N_Arguments
(3);
15532 -- Loop through homonyms
15535 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15537 if Is_Imported
(Def_Id
) then
15538 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15542 exit when From_Aspect_Specification
(N
);
15543 Hom_Id
:= Homonym
(Hom_Id
);
15545 exit when No
(Hom_Id
)
15546 or else Scope
(Hom_Id
) /= Current_Scope
;
15551 ("argument of pragma% is not imported subprogram",
15555 end Interface_Name
;
15557 -----------------------
15558 -- Interrupt_Handler --
15559 -----------------------
15561 -- pragma Interrupt_Handler (handler_NAME);
15563 when Pragma_Interrupt_Handler
=>
15564 Check_Ada_83_Warning
;
15565 Check_Arg_Count
(1);
15566 Check_No_Identifiers
;
15568 if No_Run_Time_Mode
then
15569 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15571 Check_Interrupt_Or_Attach_Handler
;
15572 Process_Interrupt_Or_Attach_Handler
;
15575 ------------------------
15576 -- Interrupt_Priority --
15577 ------------------------
15579 -- pragma Interrupt_Priority [(EXPRESSION)];
15581 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15582 P
: constant Node_Id
:= Parent
(N
);
15587 Check_Ada_83_Warning
;
15589 if Arg_Count
/= 0 then
15590 Arg
:= Get_Pragma_Arg
(Arg1
);
15591 Check_Arg_Count
(1);
15592 Check_No_Identifiers
;
15594 -- The expression must be analyzed in the special manner
15595 -- described in "Handling of Default and Per-Object
15596 -- Expressions" in sem.ads.
15598 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15601 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15606 Ent
:= Defining_Identifier
(Parent
(P
));
15608 -- Check duplicate pragma before we chain the pragma in the Rep
15609 -- Item chain of Ent.
15611 Check_Duplicate_Pragma
(Ent
);
15612 Record_Rep_Item
(Ent
, N
);
15614 end Interrupt_Priority
;
15616 ---------------------
15617 -- Interrupt_State --
15618 ---------------------
15620 -- pragma Interrupt_State (
15621 -- [Name =>] INTERRUPT_ID,
15622 -- [State =>] INTERRUPT_STATE);
15624 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15625 -- INTERRUPT_STATE => System | Runtime | User
15627 -- Note: if the interrupt id is given as an identifier, then it must
15628 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15629 -- given as a static integer expression which must be in the range of
15630 -- Ada.Interrupts.Interrupt_ID.
15632 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15633 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15634 -- This is the entity Ada.Interrupts.Interrupt_ID;
15636 State_Type
: Character;
15637 -- Set to 's'/'r'/'u' for System/Runtime/User
15640 -- Index to entry in Interrupt_States table
15643 -- Value of interrupt
15645 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15646 -- The first argument to the pragma
15648 Int_Ent
: Entity_Id
;
15649 -- Interrupt entity in Ada.Interrupts.Names
15653 Check_Arg_Order
((Name_Name
, Name_State
));
15654 Check_Arg_Count
(2);
15656 Check_Optional_Identifier
(Arg1
, Name_Name
);
15657 Check_Optional_Identifier
(Arg2
, Name_State
);
15658 Check_Arg_Is_Identifier
(Arg2
);
15660 -- First argument is identifier
15662 if Nkind
(Arg1X
) = N_Identifier
then
15664 -- Search list of names in Ada.Interrupts.Names
15666 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15668 if No
(Int_Ent
) then
15669 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15671 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15672 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15676 Next_Entity
(Int_Ent
);
15679 -- First argument is not an identifier, so it must be a static
15680 -- expression of type Ada.Interrupts.Interrupt_ID.
15683 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
15684 Int_Val
:= Expr_Value
(Arg1X
);
15686 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15688 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15691 ("value not in range of type "
15692 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15698 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15699 when Name_Runtime
=> State_Type
:= 'r';
15700 when Name_System
=> State_Type
:= 's';
15701 when Name_User
=> State_Type
:= 'u';
15704 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15707 -- Check if entry is already stored
15709 IST_Num
:= Interrupt_States
.First
;
15711 -- If entry not found, add it
15713 if IST_Num
> Interrupt_States
.Last
then
15714 Interrupt_States
.Append
15715 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15716 Interrupt_State
=> State_Type
,
15717 Pragma_Loc
=> Loc
));
15720 -- Case of entry for the same entry
15722 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15725 -- If state matches, done, no need to make redundant entry
15728 State_Type
= Interrupt_States
.Table
(IST_Num
).
15731 -- Otherwise if state does not match, error
15734 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15736 ("state conflicts with that given #", Arg2
);
15740 IST_Num
:= IST_Num
+ 1;
15742 end Interrupt_State
;
15748 -- pragma Invariant
15749 -- ([Entity =>] type_LOCAL_NAME,
15750 -- [Check =>] EXPRESSION
15751 -- [,[Message =>] String_Expression]);
15753 when Pragma_Invariant
=> Invariant
: declare
15759 pragma Unreferenced
(Discard
);
15763 Check_At_Least_N_Arguments
(2);
15764 Check_At_Most_N_Arguments
(3);
15765 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15766 Check_Optional_Identifier
(Arg2
, Name_Check
);
15768 if Arg_Count
= 3 then
15769 Check_Optional_Identifier
(Arg3
, Name_Message
);
15770 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
15773 Check_Arg_Is_Local_Name
(Arg1
);
15775 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15776 Find_Type
(Type_Id
);
15777 Typ
:= Entity
(Type_Id
);
15779 if Typ
= Any_Type
then
15782 -- An invariant must apply to a private type, or appear in the
15783 -- private part of a package spec and apply to a completion.
15784 -- a class-wide invariant can only appear on a private declaration
15785 -- or private extension, not a completion.
15787 elsif Ekind_In
(Typ
, E_Private_Type
,
15788 E_Record_Type_With_Private
,
15789 E_Limited_Private_Type
)
15793 elsif In_Private_Part
(Current_Scope
)
15794 and then Has_Private_Declaration
(Typ
)
15795 and then not Class_Present
(N
)
15799 elsif In_Private_Part
(Current_Scope
) then
15801 ("pragma% only allowed for private type declared in "
15802 & "visible part", Arg1
);
15806 ("pragma% only allowed for private type", Arg1
);
15809 -- Note that the type has at least one invariant, and also that
15810 -- it has inheritable invariants if we have Invariant'Class
15811 -- or Type_Invariant'Class. Build the corresponding invariant
15812 -- procedure declaration, so that calls to it can be generated
15813 -- before the body is built (e.g. within an expression function).
15815 PDecl
:= Build_Invariant_Procedure_Declaration
(Typ
);
15817 Insert_After
(N
, PDecl
);
15820 if Class_Present
(N
) then
15821 Set_Has_Inheritable_Invariants
(Typ
);
15824 -- The remaining processing is simply to link the pragma on to
15825 -- the rep item chain, for processing when the type is frozen.
15826 -- This is accomplished by a call to Rep_Item_Too_Late.
15828 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15831 ----------------------
15832 -- Java_Constructor --
15833 ----------------------
15835 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15837 -- Also handles pragma CIL_Constructor
15839 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15840 Java_Constructor
: declare
15841 Convention
: Convention_Id
;
15842 Def_Id
: Entity_Id
;
15843 Hom_Id
: Entity_Id
;
15845 This_Formal
: Entity_Id
;
15849 Check_Arg_Count
(1);
15850 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15851 Check_Arg_Is_Local_Name
(Arg1
);
15853 Id
:= Get_Pragma_Arg
(Arg1
);
15854 Find_Program_Unit_Name
(Id
);
15856 -- If we did not find the name, we are done
15858 if Etype
(Id
) = Any_Type
then
15862 -- Check wrong use of pragma in wrong VM target
15864 if VM_Target
= No_VM
then
15867 elsif VM_Target
= CLI_Target
15868 and then Prag_Id
= Pragma_Java_Constructor
15870 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15872 elsif VM_Target
= JVM_Target
15873 and then Prag_Id
= Pragma_CIL_Constructor
15875 Error_Pragma
("must use pragma 'Java_'Constructor");
15879 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15880 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15881 when others => null;
15884 Hom_Id
:= Entity
(Id
);
15886 -- Loop through homonyms
15889 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15891 -- The constructor is required to be a function
15893 if Ekind
(Def_Id
) /= E_Function
then
15894 if VM_Target
= JVM_Target
then
15896 ("pragma% requires function returning a 'Java access "
15900 ("pragma% requires function returning a 'C'I'L access "
15905 -- Check arguments: For tagged type the first formal must be
15906 -- named "this" and its type must be a named access type
15907 -- designating a class-wide tagged type that has convention
15908 -- CIL/Java. The first formal must also have a null default
15909 -- value. For example:
15911 -- type Typ is tagged ...
15912 -- type Ref is access all Typ;
15913 -- pragma Convention (CIL, Typ);
15915 -- function New_Typ (This : Ref) return Ref;
15916 -- function New_Typ (This : Ref; I : Integer) return Ref;
15917 -- pragma Cil_Constructor (New_Typ);
15919 -- Reason: The first formal must NOT be a primitive of the
15922 -- This rule also applies to constructors of delegates used
15923 -- to interface with standard target libraries. For example:
15925 -- type Delegate is access procedure ...
15926 -- pragma Import (CIL, Delegate, ...);
15928 -- function new_Delegate
15929 -- (This : Delegate := null; ... ) return Delegate;
15931 -- For value-types this rule does not apply.
15933 if not Is_Value_Type
(Etype
(Def_Id
)) then
15934 if No
(First_Formal
(Def_Id
)) then
15935 Error_Msg_Name_1
:= Pname
;
15936 Error_Msg_N
("% function must have parameters", Def_Id
);
15940 -- In the JRE library we have several occurrences in which
15941 -- the "this" parameter is not the first formal.
15943 This_Formal
:= First_Formal
(Def_Id
);
15945 -- In the JRE library we have several occurrences in which
15946 -- the "this" parameter is not the first formal. Search for
15949 if VM_Target
= JVM_Target
then
15950 while Present
(This_Formal
)
15951 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15953 Next_Formal
(This_Formal
);
15956 if No
(This_Formal
) then
15957 This_Formal
:= First_Formal
(Def_Id
);
15961 -- Warning: The first parameter should be named "this".
15962 -- We temporarily allow it because we have the following
15963 -- case in the Java runtime (file s-osinte.ads) ???
15965 -- function new_Thread
15966 -- (Self_Id : System.Address) return Thread_Id;
15967 -- pragma Java_Constructor (new_Thread);
15969 if VM_Target
= JVM_Target
15970 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15972 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15976 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15977 Error_Msg_Name_1
:= Pname
;
15979 ("first formal of % function must be named `this`",
15980 Parent
(This_Formal
));
15982 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15983 Error_Msg_Name_1
:= Pname
;
15985 ("first formal of % function must be an access type",
15986 Parameter_Type
(Parent
(This_Formal
)));
15988 -- For delegates the type of the first formal must be a
15989 -- named access-to-subprogram type (see previous example)
15991 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15992 and then Ekind
(Etype
(This_Formal
))
15993 /= E_Access_Subprogram_Type
15995 Error_Msg_Name_1
:= Pname
;
15997 ("first formal of % function must be a named access "
15998 & "to subprogram type",
15999 Parameter_Type
(Parent
(This_Formal
)));
16001 -- Warning: We should reject anonymous access types because
16002 -- the constructor must not be handled as a primitive of the
16003 -- tagged type. We temporarily allow it because this profile
16004 -- is currently generated by cil2ada???
16006 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
16007 and then not Ekind_In
(Etype
(This_Formal
),
16009 E_General_Access_Type
,
16010 E_Anonymous_Access_Type
)
16012 Error_Msg_Name_1
:= Pname
;
16014 ("first formal of % function must be a named access "
16015 & "type", Parameter_Type
(Parent
(This_Formal
)));
16017 elsif Atree
.Convention
16018 (Designated_Type
(Etype
(This_Formal
))) /= Convention
16020 Error_Msg_Name_1
:= Pname
;
16022 if Convention
= Convention_Java
then
16024 ("pragma% requires convention 'Cil in designated "
16025 & "type", Parameter_Type
(Parent
(This_Formal
)));
16028 ("pragma% requires convention 'Java in designated "
16029 & "type", Parameter_Type
(Parent
(This_Formal
)));
16032 elsif No
(Expression
(Parent
(This_Formal
)))
16033 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
16035 Error_Msg_Name_1
:= Pname
;
16037 ("pragma% requires first formal with default `null`",
16038 Parameter_Type
(Parent
(This_Formal
)));
16042 -- Check result type: the constructor must be a function
16044 -- * a value type (only allowed in the CIL compiler)
16045 -- * an access-to-subprogram type with convention Java/CIL
16046 -- * an access-type designating a type that has convention
16049 if Is_Value_Type
(Etype
(Def_Id
)) then
16052 -- Access-to-subprogram type with convention Java/CIL
16054 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
16055 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
16056 if Convention
= Convention_Java
then
16058 ("pragma% requires function returning a 'Java "
16059 & "access type", Arg1
);
16061 pragma Assert
(Convention
= Convention_CIL
);
16063 ("pragma% requires function returning a 'C'I'L "
16064 & "access type", Arg1
);
16068 elsif Is_Access_Type
(Etype
(Def_Id
)) then
16069 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
16070 E_General_Access_Type
)
16073 (Designated_Type
(Etype
(Def_Id
))) /= Convention
16075 Error_Msg_Name_1
:= Pname
;
16077 if Convention
= Convention_Java
then
16079 ("pragma% requires function returning a named "
16080 & "'Java access type", Arg1
);
16083 ("pragma% requires function returning a named "
16084 & "'C'I'L access type", Arg1
);
16089 Set_Is_Constructor
(Def_Id
);
16090 Set_Convention
(Def_Id
, Convention
);
16091 Set_Is_Imported
(Def_Id
);
16093 exit when From_Aspect_Specification
(N
);
16094 Hom_Id
:= Homonym
(Hom_Id
);
16096 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
16098 end Java_Constructor
;
16100 ----------------------
16101 -- Java_Interface --
16102 ----------------------
16104 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16106 when Pragma_Java_Interface
=> Java_Interface
: declare
16112 Check_Arg_Count
(1);
16113 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16114 Check_Arg_Is_Local_Name
(Arg1
);
16116 Arg
:= Get_Pragma_Arg
(Arg1
);
16119 if Etype
(Arg
) = Any_Type
then
16123 if not Is_Entity_Name
(Arg
)
16124 or else not Is_Type
(Entity
(Arg
))
16126 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
16129 Typ
:= Underlying_Type
(Entity
(Arg
));
16131 -- For now simply check some of the semantic constraints on the
16132 -- type. This currently leaves out some restrictions on interface
16133 -- types, namely that the parent type must be java.lang.Object.Typ
16134 -- and that all primitives of the type should be declared
16137 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
16139 ("pragma% requires an abstract tagged type", Arg1
);
16141 elsif not Has_Discriminants
(Typ
)
16142 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
16143 /= E_Anonymous_Access_Type
16145 not Is_Class_Wide_Type
16146 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
16149 ("type must have a class-wide access discriminant", Arg1
);
16151 end Java_Interface
;
16157 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16159 when Pragma_Keep_Names
=> Keep_Names
: declare
16164 Check_Arg_Count
(1);
16165 Check_Optional_Identifier
(Arg1
, Name_On
);
16166 Check_Arg_Is_Local_Name
(Arg1
);
16168 Arg
:= Get_Pragma_Arg
(Arg1
);
16171 if Etype
(Arg
) = Any_Type
then
16175 if not Is_Entity_Name
(Arg
)
16176 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16179 ("pragma% requires a local enumeration type", Arg1
);
16182 Set_Discard_Names
(Entity
(Arg
), False);
16189 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16191 when Pragma_License
=>
16193 Check_Arg_Count
(1);
16194 Check_No_Identifiers
;
16195 Check_Valid_Configuration_Pragma
;
16196 Check_Arg_Is_Identifier
(Arg1
);
16199 Sind
: constant Source_File_Index
:=
16200 Source_Index
(Current_Sem_Unit
);
16203 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16205 Set_License
(Sind
, GPL
);
16207 when Name_Modified_GPL
=>
16208 Set_License
(Sind
, Modified_GPL
);
16210 when Name_Restricted
=>
16211 Set_License
(Sind
, Restricted
);
16213 when Name_Unrestricted
=>
16214 Set_License
(Sind
, Unrestricted
);
16217 Error_Pragma_Arg
("invalid license name", Arg1
);
16225 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16227 when Pragma_Link_With
=> Link_With
: declare
16233 if Operating_Mode
= Generate_Code
16234 and then In_Extended_Main_Source_Unit
(N
)
16236 Check_At_Least_N_Arguments
(1);
16237 Check_No_Identifiers
;
16238 Check_Is_In_Decl_Part_Or_Package_Spec
;
16239 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
16243 while Present
(Arg
) loop
16244 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
16246 -- Store argument, converting sequences of spaces to a
16247 -- single null character (this is one of the differences
16248 -- in processing between Link_With and Linker_Options).
16250 Arg_Store
: declare
16251 C
: constant Char_Code
:= Get_Char_Code
(' ');
16252 S
: constant String_Id
:=
16253 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16254 L
: constant Nat
:= String_Length
(S
);
16257 procedure Skip_Spaces
;
16258 -- Advance F past any spaces
16264 procedure Skip_Spaces
is
16266 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16271 -- Start of processing for Arg_Store
16274 Skip_Spaces
; -- skip leading spaces
16276 -- Loop through characters, changing any embedded
16277 -- sequence of spaces to a single null character (this
16278 -- is how Link_With/Linker_Options differ)
16281 if Get_String_Char
(S
, F
) = C
then
16284 Store_String_Char
(ASCII
.NUL
);
16287 Store_String_Char
(Get_String_Char
(S
, F
));
16295 if Present
(Arg
) then
16296 Store_String_Char
(ASCII
.NUL
);
16300 Store_Linker_Option_String
(End_String
);
16308 -- pragma Linker_Alias (
16309 -- [Entity =>] LOCAL_NAME
16310 -- [Target =>] static_string_EXPRESSION);
16312 when Pragma_Linker_Alias
=>
16314 Check_Arg_Order
((Name_Entity
, Name_Target
));
16315 Check_Arg_Count
(2);
16316 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16317 Check_Optional_Identifier
(Arg2
, Name_Target
);
16318 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16319 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
16321 -- The only processing required is to link this item on to the
16322 -- list of rep items for the given entity. This is accomplished
16323 -- by the call to Rep_Item_Too_Late (when no error is detected
16324 -- and False is returned).
16326 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16329 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16332 ------------------------
16333 -- Linker_Constructor --
16334 ------------------------
16336 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16338 -- Code is shared with Linker_Destructor
16340 -----------------------
16341 -- Linker_Destructor --
16342 -----------------------
16344 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16346 when Pragma_Linker_Constructor |
16347 Pragma_Linker_Destructor
=>
16348 Linker_Constructor
: declare
16354 Check_Arg_Count
(1);
16355 Check_No_Identifiers
;
16356 Check_Arg_Is_Local_Name
(Arg1
);
16357 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16359 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16361 if not Is_Library_Level_Entity
(Proc
) then
16363 ("argument for pragma% must be library level entity", Arg1
);
16366 -- The only processing required is to link this item on to the
16367 -- list of rep items for the given entity. This is accomplished
16368 -- by the call to Rep_Item_Too_Late (when no error is detected
16369 -- and False is returned).
16371 if Rep_Item_Too_Late
(Proc
, N
) then
16374 Set_Has_Gigi_Rep_Item
(Proc
);
16376 end Linker_Constructor
;
16378 --------------------
16379 -- Linker_Options --
16380 --------------------
16382 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16384 when Pragma_Linker_Options
=> Linker_Options
: declare
16388 Check_Ada_83_Warning
;
16389 Check_No_Identifiers
;
16390 Check_Arg_Count
(1);
16391 Check_Is_In_Decl_Part_Or_Package_Spec
;
16392 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
16393 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16396 while Present
(Arg
) loop
16397 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
16398 Store_String_Char
(ASCII
.NUL
);
16400 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16404 if Operating_Mode
= Generate_Code
16405 and then In_Extended_Main_Source_Unit
(N
)
16407 Store_Linker_Option_String
(End_String
);
16409 end Linker_Options
;
16411 --------------------
16412 -- Linker_Section --
16413 --------------------
16415 -- pragma Linker_Section (
16416 -- [Entity =>] LOCAL_NAME
16417 -- [Section =>] static_string_EXPRESSION);
16419 when Pragma_Linker_Section
=> Linker_Section
: declare
16425 Check_Arg_Order
((Name_Entity
, Name_Section
));
16426 Check_Arg_Count
(2);
16427 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16428 Check_Optional_Identifier
(Arg2
, Name_Section
);
16429 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16430 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
16432 -- Check kind of entity
16434 Arg
:= Get_Pragma_Arg
(Arg1
);
16435 Ent
:= Entity
(Arg
);
16437 case Ekind
(Ent
) is
16439 -- Objects (constants and variables) and types. For these cases
16440 -- all we need to do is to set the Linker_Section_pragma field.
16442 when E_Constant | E_Variable | Type_Kind
=>
16443 Set_Linker_Section_Pragma
(Ent
, N
);
16447 when Subprogram_Kind
=>
16449 -- Aspect case, entity already set
16451 if From_Aspect_Specification
(N
) then
16452 Set_Linker_Section_Pragma
16453 (Entity
(Corresponding_Aspect
(N
)), N
);
16455 -- Pragma case, we must climb the homonym chain, but skip
16456 -- any for which the linker section is already set.
16460 if No
(Linker_Section_Pragma
(Ent
)) then
16461 Set_Linker_Section_Pragma
(Ent
, N
);
16464 Ent
:= Homonym
(Ent
);
16466 or else Scope
(Ent
) /= Current_Scope
;
16470 -- All other cases are illegal
16474 ("pragma% applies only to objects, subprograms, and types",
16477 end Linker_Section
;
16483 -- pragma List (On | Off)
16485 -- There is nothing to do here, since we did all the processing for
16486 -- this pragma in Par.Prag (so that it works properly even in syntax
16489 when Pragma_List
=>
16496 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16498 when Pragma_Lock_Free
=> Lock_Free
: declare
16499 P
: constant Node_Id
:= Parent
(N
);
16505 Check_No_Identifiers
;
16506 Check_At_Most_N_Arguments
(1);
16508 -- Protected definition case
16510 if Nkind
(P
) = N_Protected_Definition
then
16511 Ent
:= Defining_Identifier
(Parent
(P
));
16515 if Arg_Count
= 1 then
16516 Arg
:= Get_Pragma_Arg
(Arg1
);
16517 Val
:= Is_True
(Static_Boolean
(Arg
));
16519 -- No arguments (expression is considered to be True)
16525 -- Check duplicate pragma before we chain the pragma in the Rep
16526 -- Item chain of Ent.
16528 Check_Duplicate_Pragma
(Ent
);
16529 Record_Rep_Item
(Ent
, N
);
16530 Set_Uses_Lock_Free
(Ent
, Val
);
16532 -- Anything else is incorrect placement
16539 --------------------
16540 -- Locking_Policy --
16541 --------------------
16543 -- pragma Locking_Policy (policy_IDENTIFIER);
16545 when Pragma_Locking_Policy
=> declare
16546 subtype LP_Range
is Name_Id
16547 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16552 Check_Ada_83_Warning
;
16553 Check_Arg_Count
(1);
16554 Check_No_Identifiers
;
16555 Check_Arg_Is_Locking_Policy
(Arg1
);
16556 Check_Valid_Configuration_Pragma
;
16557 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16560 when Name_Ceiling_Locking
=>
16562 when Name_Inheritance_Locking
=>
16564 when Name_Concurrent_Readers_Locking
=>
16568 if Locking_Policy
/= ' '
16569 and then Locking_Policy
/= LP
16571 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16572 Error_Pragma
("locking policy incompatible with policy#");
16574 -- Set new policy, but always preserve System_Location since we
16575 -- like the error message with the run time name.
16578 Locking_Policy
:= LP
;
16580 if Locking_Policy_Sloc
/= System_Location
then
16581 Locking_Policy_Sloc
:= Loc
;
16590 -- pragma Long_Float (D_Float | G_Float);
16592 when Pragma_Long_Float
=> Long_Float : declare
16595 Check_Valid_Configuration_Pragma
;
16596 Check_Arg_Count
(1);
16597 Check_No_Identifier
(Arg1
);
16598 Check_Arg_Is_One_Of
(Arg1
, Name_D_Float
, Name_G_Float
);
16600 if not OpenVMS_On_Target
then
16601 Error_Pragma
("??pragma% ignored (applies only to Open'V'M'S)");
16606 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_D_Float
then
16607 if Opt
.Float_Format_Long
= 'G' then
16609 ("G_Float previously specified", Arg1
);
16611 elsif Current_Sem_Unit
/= Main_Unit
16612 and then Opt
.Float_Format_Long
/= 'D'
16615 ("main unit not compiled with pragma Long_Float (D_Float)",
16616 "\pragma% must be used consistently for whole partition",
16620 Opt
.Float_Format_Long
:= 'D';
16623 -- G_Float case (this is the default, does not need overriding)
16626 if Opt
.Float_Format_Long
= 'D' then
16627 Error_Pragma
("D_Float previously specified");
16629 elsif Current_Sem_Unit
/= Main_Unit
16630 and then Opt
.Float_Format_Long
/= 'G'
16633 ("main unit not compiled with pragma Long_Float (G_Float)",
16634 "\pragma% must be used consistently for whole partition",
16638 Opt
.Float_Format_Long
:= 'G';
16642 Set_Standard_Fpt_Formats
;
16645 -------------------
16646 -- Loop_Optimize --
16647 -------------------
16649 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16651 -- OPTIMIZATION_HINT ::=
16652 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16654 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16659 Check_At_Least_N_Arguments
(1);
16660 Check_No_Identifiers
;
16662 Hint
:= First
(Pragma_Argument_Associations
(N
));
16663 while Present
(Hint
) loop
16664 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16665 Name_No_Unroll
, Name_Unroll
, Name_No_Vector
, Name_Vector
);
16669 Check_Loop_Pragma_Placement
;
16676 -- pragma Loop_Variant
16677 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16679 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16681 -- CHANGE_DIRECTION ::= Increases | Decreases
16683 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16688 Check_At_Least_N_Arguments
(1);
16689 Check_Loop_Pragma_Placement
;
16691 -- Process all increasing / decreasing expressions
16693 Variant
:= First
(Pragma_Argument_Associations
(N
));
16694 while Present
(Variant
) loop
16695 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16698 Error_Pragma_Arg
("wrong change modifier", Variant
);
16701 Preanalyze_Assert_Expression
16702 (Expression
(Variant
), Any_Discrete
);
16708 -----------------------
16709 -- Machine_Attribute --
16710 -----------------------
16712 -- pragma Machine_Attribute (
16713 -- [Entity =>] LOCAL_NAME,
16714 -- [Attribute_Name =>] static_string_EXPRESSION
16715 -- [, [Info =>] static_EXPRESSION] );
16717 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16718 Def_Id
: Entity_Id
;
16722 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16724 if Arg_Count
= 3 then
16725 Check_Optional_Identifier
(Arg3
, Name_Info
);
16726 Check_Arg_Is_Static_Expression
(Arg3
);
16728 Check_Arg_Count
(2);
16731 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16732 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16733 Check_Arg_Is_Local_Name
(Arg1
);
16734 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
16735 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16737 if Is_Access_Type
(Def_Id
) then
16738 Def_Id
:= Designated_Type
(Def_Id
);
16741 if Rep_Item_Too_Early
(Def_Id
, N
) then
16745 Def_Id
:= Underlying_Type
(Def_Id
);
16747 -- The only processing required is to link this item on to the
16748 -- list of rep items for the given entity. This is accomplished
16749 -- by the call to Rep_Item_Too_Late (when no error is detected
16750 -- and False is returned).
16752 if Rep_Item_Too_Late
(Def_Id
, N
) then
16755 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16757 end Machine_Attribute
;
16764 -- (MAIN_OPTION [, MAIN_OPTION]);
16767 -- [STACK_SIZE =>] static_integer_EXPRESSION
16768 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16769 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16771 when Pragma_Main
=> Main
: declare
16772 Args
: Args_List
(1 .. 3);
16773 Names
: constant Name_List
(1 .. 3) := (
16775 Name_Task_Stack_Size_Default
,
16776 Name_Time_Slicing_Enabled
);
16782 Gather_Associations
(Names
, Args
);
16784 for J
in 1 .. 2 loop
16785 if Present
(Args
(J
)) then
16786 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
16790 if Present
(Args
(3)) then
16791 Check_Arg_Is_Static_Expression
(Args
(3), Standard_Boolean
);
16795 while Present
(Nod
) loop
16796 if Nkind
(Nod
) = N_Pragma
16797 and then Pragma_Name
(Nod
) = Name_Main
16799 Error_Msg_Name_1
:= Pname
;
16800 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16811 -- pragma Main_Storage
16812 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16814 -- MAIN_STORAGE_OPTION ::=
16815 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16816 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16818 when Pragma_Main_Storage
=> Main_Storage
: declare
16819 Args
: Args_List
(1 .. 2);
16820 Names
: constant Name_List
(1 .. 2) := (
16821 Name_Working_Storage
,
16828 Gather_Associations
(Names
, Args
);
16830 for J
in 1 .. 2 loop
16831 if Present
(Args
(J
)) then
16832 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
16836 Check_In_Main_Program
;
16839 while Present
(Nod
) loop
16840 if Nkind
(Nod
) = N_Pragma
16841 and then Pragma_Name
(Nod
) = Name_Main_Storage
16843 Error_Msg_Name_1
:= Pname
;
16844 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16855 -- pragma Memory_Size (NUMERIC_LITERAL)
16857 when Pragma_Memory_Size
=>
16860 -- Memory size is simply ignored
16862 Check_No_Identifiers
;
16863 Check_Arg_Count
(1);
16864 Check_Arg_Is_Integer_Literal
(Arg1
);
16872 -- The only correct use of this pragma is on its own in a file, in
16873 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16874 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16875 -- check for a file containing nothing but a No_Body pragma). If we
16876 -- attempt to process it during normal semantics processing, it means
16877 -- it was misplaced.
16879 when Pragma_No_Body
=>
16887 -- pragma No_Inline ( NAME {, NAME} );
16889 when Pragma_No_Inline
=>
16891 Process_Inline
(Suppressed
);
16897 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16899 when Pragma_No_Return
=> No_Return
: declare
16907 Check_At_Least_N_Arguments
(1);
16909 -- Loop through arguments of pragma
16912 while Present
(Arg
) loop
16913 Check_Arg_Is_Local_Name
(Arg
);
16914 Id
:= Get_Pragma_Arg
(Arg
);
16917 if not Is_Entity_Name
(Id
) then
16918 Error_Pragma_Arg
("entity name required", Arg
);
16921 if Etype
(Id
) = Any_Type
then
16925 -- Loop to find matching procedures
16930 and then Scope
(E
) = Current_Scope
16932 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16935 -- Set flag on any alias as well
16937 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16938 Set_No_Return
(Alias
(E
));
16944 exit when From_Aspect_Specification
(N
);
16948 -- If entity in not in current scope it may be the enclosing
16949 -- suprogram body to which the aspect applies.
16952 if Entity
(Id
) = Current_Scope
16953 and then From_Aspect_Specification
(N
)
16955 Set_No_Return
(Entity
(Id
));
16957 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16969 -- pragma No_Run_Time;
16971 -- Note: this pragma is retained for backwards compatibility. See
16972 -- body of Rtsfind for full details on its handling.
16974 when Pragma_No_Run_Time
=>
16976 Check_Valid_Configuration_Pragma
;
16977 Check_Arg_Count
(0);
16979 No_Run_Time_Mode
:= True;
16980 Configurable_Run_Time_Mode
:= True;
16982 -- Set Duration to 32 bits if word size is 32
16984 if Ttypes
.System_Word_Size
= 32 then
16985 Duration_32_Bits_On_Target
:= True;
16988 -- Set appropriate restrictions
16990 Set_Restriction
(No_Finalization
, N
);
16991 Set_Restriction
(No_Exception_Handlers
, N
);
16992 Set_Restriction
(Max_Tasks
, N
, 0);
16993 Set_Restriction
(No_Tasking
, N
);
16995 ------------------------
16996 -- No_Strict_Aliasing --
16997 ------------------------
16999 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17001 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
17006 Check_At_Most_N_Arguments
(1);
17008 if Arg_Count
= 0 then
17009 Check_Valid_Configuration_Pragma
;
17010 Opt
.No_Strict_Aliasing
:= True;
17013 Check_Optional_Identifier
(Arg2
, Name_Entity
);
17014 Check_Arg_Is_Local_Name
(Arg1
);
17015 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17017 if E_Id
= Any_Type
then
17019 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
17020 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
17023 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
17025 end No_Strict_Aliasing
;
17027 -----------------------
17028 -- Normalize_Scalars --
17029 -----------------------
17031 -- pragma Normalize_Scalars;
17033 when Pragma_Normalize_Scalars
=>
17034 Check_Ada_83_Warning
;
17035 Check_Arg_Count
(0);
17036 Check_Valid_Configuration_Pragma
;
17038 -- Normalize_Scalars creates false positives in CodePeer, and
17039 -- incorrect negative results in GNATprove mode, so ignore this
17040 -- pragma in these modes.
17042 if not (CodePeer_Mode
or GNATprove_Mode
) then
17043 Normalize_Scalars
:= True;
17044 Init_Or_Norm_Scalars
:= True;
17051 -- pragma Obsolescent;
17053 -- pragma Obsolescent (
17054 -- [Message =>] static_string_EXPRESSION
17055 -- [,[Version =>] Ada_05]]);
17057 -- pragma Obsolescent (
17058 -- [Entity =>] NAME
17059 -- [,[Message =>] static_string_EXPRESSION
17060 -- [,[Version =>] Ada_05]] );
17062 when Pragma_Obsolescent
=> Obsolescent
: declare
17066 procedure Set_Obsolescent
(E
: Entity_Id
);
17067 -- Given an entity Ent, mark it as obsolescent if appropriate
17069 ---------------------
17070 -- Set_Obsolescent --
17071 ---------------------
17073 procedure Set_Obsolescent
(E
: Entity_Id
) is
17082 -- Entity name was given
17084 if Present
(Ename
) then
17086 -- If entity name matches, we are fine. Save entity in
17087 -- pragma argument, for ASIS use.
17089 if Chars
(Ename
) = Chars
(Ent
) then
17090 Set_Entity
(Ename
, Ent
);
17091 Generate_Reference
(Ent
, Ename
);
17093 -- If entity name does not match, only possibility is an
17094 -- enumeration literal from an enumeration type declaration.
17096 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17098 ("pragma % entity name does not match declaration");
17101 Ent
:= First_Literal
(E
);
17105 ("pragma % entity name does not match any "
17106 & "enumeration literal");
17108 elsif Chars
(Ent
) = Chars
(Ename
) then
17109 Set_Entity
(Ename
, Ent
);
17110 Generate_Reference
(Ent
, Ename
);
17114 Ent
:= Next_Literal
(Ent
);
17120 -- Ent points to entity to be marked
17122 if Arg_Count
>= 1 then
17124 -- Deal with static string argument
17126 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
17127 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17129 for J
in 1 .. String_Length
(S
) loop
17130 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17132 ("pragma% argument does not allow wide characters",
17137 Obsolescent_Warnings
.Append
17138 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17140 -- Check for Ada_05 parameter
17142 if Arg_Count
/= 1 then
17143 Check_Arg_Count
(2);
17146 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17149 Check_Arg_Is_Identifier
(Argx
);
17151 if Chars
(Argx
) /= Name_Ada_05
then
17152 Error_Msg_Name_2
:= Name_Ada_05
;
17154 ("only allowed argument for pragma% is %", Argx
);
17157 if Ada_Version_Explicit
< Ada_2005
17158 or else not Warn_On_Ada_2005_Compatibility
17166 -- Set flag if pragma active
17169 Set_Is_Obsolescent
(Ent
);
17173 end Set_Obsolescent
;
17175 -- Start of processing for pragma Obsolescent
17180 Check_At_Most_N_Arguments
(3);
17182 -- See if first argument specifies an entity name
17186 (Chars
(Arg1
) = Name_Entity
17188 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17190 N_Operator_Symbol
))
17192 Ename
:= Get_Pragma_Arg
(Arg1
);
17194 -- Eliminate first argument, so we can share processing
17198 Arg_Count
:= Arg_Count
- 1;
17200 -- No Entity name argument given
17206 if Arg_Count
>= 1 then
17207 Check_Optional_Identifier
(Arg1
, Name_Message
);
17209 if Arg_Count
= 2 then
17210 Check_Optional_Identifier
(Arg2
, Name_Version
);
17214 -- Get immediately preceding declaration
17217 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17221 -- Cases where we do not follow anything other than another pragma
17225 -- First case: library level compilation unit declaration with
17226 -- the pragma immediately following the declaration.
17228 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17230 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17233 -- Case 2: library unit placement for package
17237 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17239 if Is_Package_Or_Generic_Package
(Ent
) then
17240 Set_Obsolescent
(Ent
);
17246 -- Cases where we must follow a declaration
17249 if Nkind
(Decl
) not in N_Declaration
17250 and then Nkind
(Decl
) not in N_Later_Decl_Item
17251 and then Nkind
(Decl
) not in N_Generic_Declaration
17252 and then Nkind
(Decl
) not in N_Renaming_Declaration
17255 ("pragma% misplaced, "
17256 & "must immediately follow a declaration");
17259 Set_Obsolescent
(Defining_Entity
(Decl
));
17269 -- pragma Optimize (Time | Space | Off);
17271 -- The actual check for optimize is done in Gigi. Note that this
17272 -- pragma does not actually change the optimization setting, it
17273 -- simply checks that it is consistent with the pragma.
17275 when Pragma_Optimize
=>
17276 Check_No_Identifiers
;
17277 Check_Arg_Count
(1);
17278 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17280 ------------------------
17281 -- Optimize_Alignment --
17282 ------------------------
17284 -- pragma Optimize_Alignment (Time | Space | Off);
17286 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17288 Check_No_Identifiers
;
17289 Check_Arg_Count
(1);
17290 Check_Valid_Configuration_Pragma
;
17293 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17297 Opt
.Optimize_Alignment
:= 'T';
17299 Opt
.Optimize_Alignment
:= 'S';
17301 Opt
.Optimize_Alignment
:= 'O';
17303 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17307 -- Set indication that mode is set locally. If we are in fact in a
17308 -- configuration pragma file, this setting is harmless since the
17309 -- switch will get reset anyway at the start of each unit.
17311 Optimize_Alignment_Local
:= True;
17312 end Optimize_Alignment
;
17318 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17320 when Pragma_Ordered
=> Ordered
: declare
17321 Assoc
: constant Node_Id
:= Arg1
;
17327 Check_No_Identifiers
;
17328 Check_Arg_Count
(1);
17329 Check_Arg_Is_Local_Name
(Arg1
);
17331 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17332 Find_Type
(Type_Id
);
17333 Typ
:= Entity
(Type_Id
);
17335 if Typ
= Any_Type
then
17338 Typ
:= Underlying_Type
(Typ
);
17341 if not Is_Enumeration_Type
(Typ
) then
17342 Error_Pragma
("pragma% must specify enumeration type");
17345 Check_First_Subtype
(Arg1
);
17346 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17349 -------------------
17350 -- Overflow_Mode --
17351 -------------------
17353 -- pragma Overflow_Mode
17354 -- ([General => ] MODE [, [Assertions => ] MODE]);
17356 -- MODE := STRICT | MINIMIZED | ELIMINATED
17358 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17359 -- since System.Bignums makes this assumption. This is true of nearly
17360 -- all (all?) targets.
17362 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17363 function Get_Overflow_Mode
17365 Arg
: Node_Id
) return Overflow_Mode_Type
;
17366 -- Function to process one pragma argument, Arg. If an identifier
17367 -- is present, it must be Name. Mode type is returned if a valid
17368 -- argument exists, otherwise an error is signalled.
17370 -----------------------
17371 -- Get_Overflow_Mode --
17372 -----------------------
17374 function Get_Overflow_Mode
17376 Arg
: Node_Id
) return Overflow_Mode_Type
17378 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17381 Check_Optional_Identifier
(Arg
, Name
);
17382 Check_Arg_Is_Identifier
(Argx
);
17384 if Chars
(Argx
) = Name_Strict
then
17387 elsif Chars
(Argx
) = Name_Minimized
then
17390 elsif Chars
(Argx
) = Name_Eliminated
then
17391 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17393 ("Eliminated not implemented on this target", Argx
);
17399 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17401 end Get_Overflow_Mode
;
17403 -- Start of processing for Overflow_Mode
17407 Check_At_Least_N_Arguments
(1);
17408 Check_At_Most_N_Arguments
(2);
17410 -- Process first argument
17412 Scope_Suppress
.Overflow_Mode_General
:=
17413 Get_Overflow_Mode
(Name_General
, Arg1
);
17415 -- Case of only one argument
17417 if Arg_Count
= 1 then
17418 Scope_Suppress
.Overflow_Mode_Assertions
:=
17419 Scope_Suppress
.Overflow_Mode_General
;
17421 -- Case of two arguments present
17424 Scope_Suppress
.Overflow_Mode_Assertions
:=
17425 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17429 --------------------------
17430 -- Overriding Renamings --
17431 --------------------------
17433 -- pragma Overriding_Renamings;
17435 when Pragma_Overriding_Renamings
=>
17437 Check_Arg_Count
(0);
17438 Check_Valid_Configuration_Pragma
;
17439 Overriding_Renamings
:= True;
17445 -- pragma Pack (first_subtype_LOCAL_NAME);
17447 when Pragma_Pack
=> Pack
: declare
17448 Assoc
: constant Node_Id
:= Arg1
;
17452 Ignore
: Boolean := False;
17455 Check_No_Identifiers
;
17456 Check_Arg_Count
(1);
17457 Check_Arg_Is_Local_Name
(Arg1
);
17458 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17460 if not Is_Entity_Name
(Type_Id
)
17461 or else not Is_Type
(Entity
(Type_Id
))
17464 ("argument for pragma% must be type or subtype", Arg1
);
17467 Find_Type
(Type_Id
);
17468 Typ
:= Entity
(Type_Id
);
17471 or else Rep_Item_Too_Early
(Typ
, N
)
17475 Typ
:= Underlying_Type
(Typ
);
17478 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17479 Error_Pragma
("pragma% must specify array or record type");
17482 Check_First_Subtype
(Arg1
);
17483 Check_Duplicate_Pragma
(Typ
);
17487 if Is_Array_Type
(Typ
) then
17488 Ctyp
:= Component_Type
(Typ
);
17490 -- Ignore pack that does nothing
17492 if Known_Static_Esize
(Ctyp
)
17493 and then Known_Static_RM_Size
(Ctyp
)
17494 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17495 and then Addressable
(Esize
(Ctyp
))
17500 -- Process OK pragma Pack. Note that if there is a separate
17501 -- component clause present, the Pack will be cancelled. This
17502 -- processing is in Freeze.
17504 if not Rep_Item_Too_Late
(Typ
, N
) then
17506 -- In CodePeer mode, we do not need complex front-end
17507 -- expansions related to pragma Pack, so disable handling
17510 if CodePeer_Mode
then
17513 -- Don't attempt any packing for VM targets. We possibly
17514 -- could deal with some cases of array bit-packing, but we
17515 -- don't bother, since this is not a typical kind of
17516 -- representation in the VM context anyway (and would not
17517 -- for example work nicely with the debugger).
17519 elsif VM_Target
/= No_VM
then
17520 if not GNAT_Mode
then
17522 ("??pragma% ignored in this configuration");
17525 -- Normal case where we do the pack action
17529 Set_Is_Packed
(Base_Type
(Typ
));
17530 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17533 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17537 -- For record types, the pack is always effective
17539 else pragma Assert
(Is_Record_Type
(Typ
));
17540 if not Rep_Item_Too_Late
(Typ
, N
) then
17542 -- Ignore pack request with warning in VM mode (skip warning
17543 -- if we are compiling GNAT run time library).
17545 if VM_Target
/= No_VM
then
17546 if not GNAT_Mode
then
17548 ("??pragma% ignored in this configuration");
17551 -- Normal case of pack request active
17554 Set_Is_Packed
(Base_Type
(Typ
));
17555 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17556 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17568 -- There is nothing to do here, since we did all the processing for
17569 -- this pragma in Par.Prag (so that it works properly even in syntax
17572 when Pragma_Page
=>
17579 -- pragma Part_Of (ABSTRACT_STATE);
17581 -- ABSTRACT_STATE ::= NAME
17583 when Pragma_Part_Of
=> Part_Of
: declare
17584 procedure Propagate_Part_Of
17585 (Pack_Id
: Entity_Id
;
17586 State_Id
: Entity_Id
;
17587 Instance
: Node_Id
);
17588 -- Propagate the Part_Of indicator to all abstract states and
17589 -- variables declared in the visible state space of a package
17590 -- denoted by Pack_Id. State_Id is the encapsulating state.
17591 -- Instance is the package instantiation node.
17593 -----------------------
17594 -- Propagate_Part_Of --
17595 -----------------------
17597 procedure Propagate_Part_Of
17598 (Pack_Id
: Entity_Id
;
17599 State_Id
: Entity_Id
;
17600 Instance
: Node_Id
)
17602 Has_Item
: Boolean := False;
17603 -- Flag set when the visible state space contains at least one
17604 -- abstract state or variable.
17606 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17607 -- Propagate the Part_Of indicator to all abstract states and
17608 -- variables declared in the visible state space of a package
17609 -- denoted by Pack_Id.
17611 -----------------------
17612 -- Propagate_Part_Of --
17613 -----------------------
17615 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17616 Item_Id
: Entity_Id
;
17619 -- Traverse the entity chain of the package and set relevant
17620 -- attributes of abstract states and variables declared in
17621 -- the visible state space of the package.
17623 Item_Id
:= First_Entity
(Pack_Id
);
17624 while Present
(Item_Id
)
17625 and then not In_Private_Part
(Item_Id
)
17627 -- Do not consider internally generated items
17629 if not Comes_From_Source
(Item_Id
) then
17632 -- The Part_Of indicator turns an abstract state or
17633 -- variable into a constituent of the encapsulating
17636 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17641 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17642 Set_Encapsulating_State
(Item_Id
, State_Id
);
17644 -- Recursively handle nested packages and instantiations
17646 elsif Ekind
(Item_Id
) = E_Package
then
17647 Propagate_Part_Of
(Item_Id
);
17650 Next_Entity
(Item_Id
);
17652 end Propagate_Part_Of
;
17654 -- Start of processing for Propagate_Part_Of
17657 Propagate_Part_Of
(Pack_Id
);
17659 -- Detect a package instantiation that is subject to a Part_Of
17660 -- indicator, but has no visible state.
17662 if not Has_Item
then
17664 ("package instantiation & has Part_Of indicator but "
17665 & "lacks visible state", Instance
, Pack_Id
);
17667 end Propagate_Part_Of
;
17671 Item_Id
: Entity_Id
;
17674 State_Id
: Entity_Id
;
17677 -- Start of processing for Part_Of
17681 Check_Arg_Count
(1);
17683 -- Ensure the proper placement of the pragma. Part_Of must appear
17684 -- on a variable declaration or a package instantiation.
17687 while Present
(Stmt
) loop
17689 -- Skip prior pragmas, but check for duplicates
17691 if Nkind
(Stmt
) = N_Pragma
then
17692 if Pragma_Name
(Stmt
) = Pname
then
17693 Error_Msg_Name_1
:= Pname
;
17694 Error_Msg_Sloc
:= Sloc
(Stmt
);
17695 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17698 -- Skip internally generated code
17700 elsif not Comes_From_Source
(Stmt
) then
17703 -- The pragma applies to an object declaration (possibly a
17704 -- variable) or a package instantiation. Stop the traversal
17705 -- and continue the analysis.
17707 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17708 N_Package_Instantiation
)
17712 -- The pragma does not apply to a legal construct, issue an
17713 -- error and stop the analysis.
17720 Stmt
:= Prev
(Stmt
);
17723 -- When the context is an object declaration, ensure that we are
17724 -- dealing with a variable.
17726 if Nkind
(Stmt
) = N_Object_Declaration
17727 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17729 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17733 -- Extract the entity of the related object declaration or package
17734 -- instantiation. In the case of the instantiation, use the entity
17735 -- of the instance spec.
17737 if Nkind
(Stmt
) = N_Package_Instantiation
then
17738 Stmt
:= Instance_Spec
(Stmt
);
17741 Item_Id
:= Defining_Entity
(Stmt
);
17742 State
:= Get_Pragma_Arg
(Arg1
);
17744 -- Detect any discrepancies between the placement of the object
17745 -- or package instantiation with respect to state space and the
17746 -- encapsulating state.
17749 (Item_Id
=> Item_Id
,
17755 State_Id
:= Entity
(State
);
17757 -- Add the pragma to the contract of the item. This aids with
17758 -- the detection of a missing but required Part_Of indicator.
17760 Add_Contract_Item
(N
, Item_Id
);
17762 -- The Part_Of indicator turns a variable into a constituent
17763 -- of the encapsulating state.
17765 if Ekind
(Item_Id
) = E_Variable
then
17766 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17767 Set_Encapsulating_State
(Item_Id
, State_Id
);
17769 -- Propagate the Part_Of indicator to the visible state space
17770 -- of the package instantiation.
17774 (Pack_Id
=> Item_Id
,
17775 State_Id
=> State_Id
,
17781 ----------------------------------
17782 -- Partition_Elaboration_Policy --
17783 ----------------------------------
17785 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17787 when Pragma_Partition_Elaboration_Policy
=> declare
17788 subtype PEP_Range
is Name_Id
17789 range First_Partition_Elaboration_Policy_Name
17790 .. Last_Partition_Elaboration_Policy_Name
;
17791 PEP_Val
: PEP_Range
;
17796 Check_Arg_Count
(1);
17797 Check_No_Identifiers
;
17798 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17799 Check_Valid_Configuration_Pragma
;
17800 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17803 when Name_Concurrent
=>
17805 when Name_Sequential
=>
17809 if Partition_Elaboration_Policy
/= ' '
17810 and then Partition_Elaboration_Policy
/= PEP
17812 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17814 ("partition elaboration policy incompatible with policy#");
17816 -- Set new policy, but always preserve System_Location since we
17817 -- like the error message with the run time name.
17820 Partition_Elaboration_Policy
:= PEP
;
17822 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17823 Partition_Elaboration_Policy_Sloc
:= Loc
;
17832 -- pragma Passive [(PASSIVE_FORM)];
17834 -- PASSIVE_FORM ::= Semaphore | No
17836 when Pragma_Passive
=>
17839 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17840 Error_Pragma
("pragma% must be within task definition");
17843 if Arg_Count
/= 0 then
17844 Check_Arg_Count
(1);
17845 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17848 ----------------------------------
17849 -- Preelaborable_Initialization --
17850 ----------------------------------
17852 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17854 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17859 Check_Arg_Count
(1);
17860 Check_No_Identifiers
;
17861 Check_Arg_Is_Identifier
(Arg1
);
17862 Check_Arg_Is_Local_Name
(Arg1
);
17863 Check_First_Subtype
(Arg1
);
17864 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17866 -- The pragma may come from an aspect on a private declaration,
17867 -- even if the freeze point at which this is analyzed in the
17868 -- private part after the full view.
17870 if Has_Private_Declaration
(Ent
)
17871 and then From_Aspect_Specification
(N
)
17875 elsif Is_Private_Type
(Ent
)
17876 or else Is_Protected_Type
(Ent
)
17877 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17883 ("pragma % can only be applied to private, formal derived or "
17884 & "protected type",
17888 -- Give an error if the pragma is applied to a protected type that
17889 -- does not qualify (due to having entries, or due to components
17890 -- that do not qualify).
17892 if Is_Protected_Type
(Ent
)
17893 and then not Has_Preelaborable_Initialization
(Ent
)
17896 ("protected type & does not have preelaborable "
17897 & "initialization", Ent
);
17899 -- Otherwise mark the type as definitely having preelaborable
17903 Set_Known_To_Have_Preelab_Init
(Ent
);
17906 if Has_Pragma_Preelab_Init
(Ent
)
17907 and then Warn_On_Redundant_Constructs
17909 Error_Pragma
("?r?duplicate pragma%!");
17911 Set_Has_Pragma_Preelab_Init
(Ent
);
17915 --------------------
17916 -- Persistent_BSS --
17917 --------------------
17919 -- pragma Persistent_BSS [(object_NAME)];
17921 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17928 Check_At_Most_N_Arguments
(1);
17930 -- Case of application to specific object (one argument)
17932 if Arg_Count
= 1 then
17933 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17935 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17937 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17940 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17943 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17944 Decl
:= Parent
(Ent
);
17946 -- Check for duplication before inserting in list of
17947 -- representation items.
17949 Check_Duplicate_Pragma
(Ent
);
17951 if Rep_Item_Too_Late
(Ent
, N
) then
17955 if Present
(Expression
(Decl
)) then
17957 ("object for pragma% cannot have initialization", Arg1
);
17960 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17962 ("object type for pragma% is not potentially persistent",
17967 Make_Linker_Section_Pragma
17968 (Ent
, Sloc
(N
), ".persistent.bss");
17969 Insert_After
(N
, Prag
);
17972 -- Case of use as configuration pragma with no arguments
17975 Check_Valid_Configuration_Pragma
;
17976 Persistent_BSS_Mode
:= True;
17978 end Persistent_BSS
;
17984 -- pragma Polling (ON | OFF);
17986 when Pragma_Polling
=>
17988 Check_Arg_Count
(1);
17989 Check_No_Identifiers
;
17990 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17991 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17997 -- pragma Post (Boolean_EXPRESSION);
17998 -- pragma Post_Class (Boolean_EXPRESSION);
18000 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
18001 PC_Pragma
: Node_Id
;
18005 Check_Arg_Count
(1);
18006 Check_No_Identifiers
;
18009 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
18010 -- flag Class_Present to True for the Post_Class case.
18012 Set_Class_Present
(N
, Prag_Id
= Pragma_Post_Class
);
18013 PC_Pragma
:= New_Copy
(N
);
18014 Set_Pragma_Identifier
18015 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
18016 Rewrite
(N
, PC_Pragma
);
18017 Set_Analyzed
(N
, False);
18021 -------------------
18022 -- Postcondition --
18023 -------------------
18025 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18026 -- [,[Message =>] String_EXPRESSION]);
18028 when Pragma_Postcondition
=> Postcondition
: declare
18033 Check_At_Least_N_Arguments
(1);
18034 Check_At_Most_N_Arguments
(2);
18035 Check_Optional_Identifier
(Arg1
, Name_Check
);
18037 -- Verify the proper placement of the pragma. The remainder of the
18038 -- processing is found in Sem_Ch6/Sem_Ch7.
18040 Check_Precondition_Postcondition
(In_Body
);
18042 -- When the pragma is a source construct appearing inside a body,
18043 -- preanalyze the boolean_expression to detect illegal forward
18047 -- pragma Postcondition (X'Old ...);
18050 if Comes_From_Source
(N
) and then In_Body
then
18051 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
18059 -- pragma Pre (Boolean_EXPRESSION);
18060 -- pragma Pre_Class (Boolean_EXPRESSION);
18062 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
18063 PC_Pragma
: Node_Id
;
18067 Check_Arg_Count
(1);
18068 Check_No_Identifiers
;
18071 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
18072 -- flag Class_Present to True for the Pre_Class case.
18074 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
18075 PC_Pragma
:= New_Copy
(N
);
18076 Set_Pragma_Identifier
18077 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
18078 Rewrite
(N
, PC_Pragma
);
18079 Set_Analyzed
(N
, False);
18087 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18088 -- [,[Message =>] String_EXPRESSION]);
18090 when Pragma_Precondition
=> Precondition
: declare
18095 Check_At_Least_N_Arguments
(1);
18096 Check_At_Most_N_Arguments
(2);
18097 Check_Optional_Identifier
(Arg1
, Name_Check
);
18098 Check_Precondition_Postcondition
(In_Body
);
18100 -- If in spec, nothing more to do. If in body, then we convert
18101 -- the pragma to an equivalent pragma Check. That works fine since
18102 -- pragma Check will analyze the condition in the proper context.
18104 -- The form of the pragma Check is either:
18106 -- pragma Check (Precondition, cond [, msg])
18108 -- pragma Check (Pre, cond [, msg])
18110 -- We use the Pre form if this pragma derived from a Pre aspect.
18111 -- This is needed to make sure that the right set of Policy
18112 -- pragmas are checked.
18116 -- Rewrite as Check pragma
18120 Chars
=> Name_Check
,
18121 Pragma_Argument_Associations
=> New_List
(
18122 Make_Pragma_Argument_Association
(Loc
,
18123 Expression
=> Make_Identifier
(Loc
, Pname
)),
18125 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
18127 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
18129 if Arg_Count
= 2 then
18130 Append_To
(Pragma_Argument_Associations
(N
),
18131 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
18133 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
18144 -- pragma Predicate
18145 -- ([Entity =>] type_LOCAL_NAME,
18146 -- [Check =>] boolean_EXPRESSION);
18148 when Pragma_Predicate
=> Predicate
: declare
18153 pragma Unreferenced
(Discard
);
18157 Check_Arg_Count
(2);
18158 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18159 Check_Optional_Identifier
(Arg2
, Name_Check
);
18161 Check_Arg_Is_Local_Name
(Arg1
);
18163 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18164 Find_Type
(Type_Id
);
18165 Typ
:= Entity
(Type_Id
);
18167 if Typ
= Any_Type
then
18171 -- The remaining processing is simply to link the pragma on to
18172 -- the rep item chain, for processing when the type is frozen.
18173 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18174 -- mark the type as having predicates.
18176 Set_Has_Predicates
(Typ
);
18177 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18184 -- pragma Preelaborate [(library_unit_NAME)];
18186 -- Set the flag Is_Preelaborated of program unit name entity
18188 when Pragma_Preelaborate
=> Preelaborate
: declare
18189 Pa
: constant Node_Id
:= Parent
(N
);
18190 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18194 Check_Ada_83_Warning
;
18195 Check_Valid_Library_Unit_Pragma
;
18197 if Nkind
(N
) = N_Null_Statement
then
18201 Ent
:= Find_Lib_Unit_Name
;
18202 Check_Duplicate_Pragma
(Ent
);
18204 -- This filters out pragmas inside generic parents that show up
18205 -- inside instantiations. Pragmas that come from aspects in the
18206 -- unit are not ignored.
18208 if Present
(Ent
) then
18209 if Pk
= N_Package_Specification
18210 and then Present
(Generic_Parent
(Pa
))
18211 and then not From_Aspect_Specification
(N
)
18216 if not Debug_Flag_U
then
18217 Set_Is_Preelaborated
(Ent
);
18218 Set_Suppress_Elaboration_Warnings
(Ent
);
18228 -- pragma Priority (EXPRESSION);
18230 when Pragma_Priority
=> Priority
: declare
18231 P
: constant Node_Id
:= Parent
(N
);
18236 Check_No_Identifiers
;
18237 Check_Arg_Count
(1);
18241 if Nkind
(P
) = N_Subprogram_Body
then
18242 Check_In_Main_Program
;
18244 Ent
:= Defining_Unit_Name
(Specification
(P
));
18246 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18247 Ent
:= Defining_Identifier
(Ent
);
18250 Arg
:= Get_Pragma_Arg
(Arg1
);
18251 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18255 if not Is_Static_Expression
(Arg
) then
18256 Flag_Non_Static_Expr
18257 ("main subprogram priority is not static!", Arg
);
18260 -- If constraint error, then we already signalled an error
18262 elsif Raises_Constraint_Error
(Arg
) then
18265 -- Otherwise check in range except if Relaxed_RM_Semantics
18266 -- where we ignore the value if out of range.
18270 Val
: constant Uint
:= Expr_Value
(Arg
);
18272 if not Relaxed_RM_Semantics
18275 or else Val
> Expr_Value
(Expression
18276 (Parent
(RTE
(RE_Max_Priority
)))))
18279 ("main subprogram priority is out of range", Arg1
);
18282 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18287 -- Load an arbitrary entity from System.Tasking.Stages or
18288 -- System.Tasking.Restricted.Stages (depending on the
18289 -- supported profile) to make sure that one of these packages
18290 -- is implicitly with'ed, since we need to have the tasking
18291 -- run time active for the pragma Priority to have any effect.
18292 -- Previously with with'ed the package System.Tasking, but
18293 -- this package does not trigger the required initialization
18294 -- of the run-time library.
18297 Discard
: Entity_Id
;
18298 pragma Warnings
(Off
, Discard
);
18300 if Restricted_Profile
then
18301 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18303 Discard
:= RTE
(RE_Activate_Tasks
);
18307 -- Task or Protected, must be of type Integer
18309 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18310 Arg
:= Get_Pragma_Arg
(Arg1
);
18311 Ent
:= Defining_Identifier
(Parent
(P
));
18313 -- The expression must be analyzed in the special manner
18314 -- described in "Handling of Default and Per-Object
18315 -- Expressions" in sem.ads.
18317 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18319 if not Is_Static_Expression
(Arg
) then
18320 Check_Restriction
(Static_Priorities
, Arg
);
18323 -- Anything else is incorrect
18329 -- Check duplicate pragma before we chain the pragma in the Rep
18330 -- Item chain of Ent.
18332 Check_Duplicate_Pragma
(Ent
);
18333 Record_Rep_Item
(Ent
, N
);
18336 -----------------------------------
18337 -- Priority_Specific_Dispatching --
18338 -----------------------------------
18340 -- pragma Priority_Specific_Dispatching (
18341 -- policy_IDENTIFIER,
18342 -- first_priority_EXPRESSION,
18343 -- last_priority_EXPRESSION);
18345 when Pragma_Priority_Specific_Dispatching
=>
18346 Priority_Specific_Dispatching
: declare
18347 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18348 -- This is the entity System.Any_Priority;
18351 Lower_Bound
: Node_Id
;
18352 Upper_Bound
: Node_Id
;
18358 Check_Arg_Count
(3);
18359 Check_No_Identifiers
;
18360 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18361 Check_Valid_Configuration_Pragma
;
18362 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18363 DP
:= Fold_Upper
(Name_Buffer
(1));
18365 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18366 Check_Arg_Is_Static_Expression
(Lower_Bound
, Standard_Integer
);
18367 Lower_Val
:= Expr_Value
(Lower_Bound
);
18369 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18370 Check_Arg_Is_Static_Expression
(Upper_Bound
, Standard_Integer
);
18371 Upper_Val
:= Expr_Value
(Upper_Bound
);
18373 -- It is not allowed to use Task_Dispatching_Policy and
18374 -- Priority_Specific_Dispatching in the same partition.
18376 if Task_Dispatching_Policy
/= ' ' then
18377 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18379 ("pragma% incompatible with Task_Dispatching_Policy#");
18381 -- Check lower bound in range
18383 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18385 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18388 ("first_priority is out of range", Arg2
);
18390 -- Check upper bound in range
18392 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18394 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18397 ("last_priority is out of range", Arg3
);
18399 -- Check that the priority range is valid
18401 elsif Lower_Val
> Upper_Val
then
18403 ("last_priority_expression must be greater than or equal to "
18404 & "first_priority_expression");
18406 -- Store the new policy, but always preserve System_Location since
18407 -- we like the error message with the run-time name.
18410 -- Check overlapping in the priority ranges specified in other
18411 -- Priority_Specific_Dispatching pragmas within the same
18412 -- partition. We can only check those we know about.
18415 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18417 if Specific_Dispatching
.Table
(J
).First_Priority
in
18418 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18419 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18420 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18423 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18425 ("priority range overlaps with "
18426 & "Priority_Specific_Dispatching#");
18430 -- The use of Priority_Specific_Dispatching is incompatible
18431 -- with Task_Dispatching_Policy.
18433 if Task_Dispatching_Policy
/= ' ' then
18434 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18436 ("Priority_Specific_Dispatching incompatible "
18437 & "with Task_Dispatching_Policy#");
18440 -- The use of Priority_Specific_Dispatching forces ceiling
18443 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18444 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18446 ("Priority_Specific_Dispatching incompatible "
18447 & "with Locking_Policy#");
18449 -- Set the Ceiling_Locking policy, but preserve System_Location
18450 -- since we like the error message with the run time name.
18453 Locking_Policy
:= 'C';
18455 if Locking_Policy_Sloc
/= System_Location
then
18456 Locking_Policy_Sloc
:= Loc
;
18460 -- Add entry in the table
18462 Specific_Dispatching
.Append
18463 ((Dispatching_Policy
=> DP
,
18464 First_Priority
=> UI_To_Int
(Lower_Val
),
18465 Last_Priority
=> UI_To_Int
(Upper_Val
),
18466 Pragma_Loc
=> Loc
));
18468 end Priority_Specific_Dispatching
;
18474 -- pragma Profile (profile_IDENTIFIER);
18476 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18478 when Pragma_Profile
=>
18480 Check_Arg_Count
(1);
18481 Check_Valid_Configuration_Pragma
;
18482 Check_No_Identifiers
;
18485 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18488 if Chars
(Argx
) = Name_Ravenscar
then
18489 Set_Ravenscar_Profile
(N
);
18491 elsif Chars
(Argx
) = Name_Restricted
then
18492 Set_Profile_Restrictions
18494 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18496 elsif Chars
(Argx
) = Name_Rational
then
18497 Set_Rational_Profile
;
18499 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18500 Set_Profile_Restrictions
18501 (No_Implementation_Extensions
,
18502 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18505 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18509 ----------------------
18510 -- Profile_Warnings --
18511 ----------------------
18513 -- pragma Profile_Warnings (profile_IDENTIFIER);
18515 -- profile_IDENTIFIER => Restricted | Ravenscar
18517 when Pragma_Profile_Warnings
=>
18519 Check_Arg_Count
(1);
18520 Check_Valid_Configuration_Pragma
;
18521 Check_No_Identifiers
;
18524 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18527 if Chars
(Argx
) = Name_Ravenscar
then
18528 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18530 elsif Chars
(Argx
) = Name_Restricted
then
18531 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18533 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18534 Set_Profile_Restrictions
18535 (No_Implementation_Extensions
, N
, Warn
=> True);
18538 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18542 --------------------------
18543 -- Propagate_Exceptions --
18544 --------------------------
18546 -- pragma Propagate_Exceptions;
18548 -- Note: this pragma is obsolete and has no effect
18550 when Pragma_Propagate_Exceptions
=>
18552 Check_Arg_Count
(0);
18554 if Warn_On_Obsolescent_Feature
then
18556 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18557 "and has no effect?j?", N
);
18560 -----------------------------
18561 -- Provide_Shift_Operators --
18562 -----------------------------
18564 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18566 when Pragma_Provide_Shift_Operators
=>
18567 Provide_Shift_Operators
: declare
18570 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18571 -- Insert declaration and pragma Instrinsic for named shift op
18573 ----------------------------
18574 -- Declare_Shift_Operator --
18575 ----------------------------
18577 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18583 Make_Subprogram_Declaration
(Loc
,
18584 Make_Function_Specification
(Loc
,
18585 Defining_Unit_Name
=>
18586 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18588 Result_Definition
=>
18589 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18591 Parameter_Specifications
=> New_List
(
18592 Make_Parameter_Specification
(Loc
,
18593 Defining_Identifier
=>
18594 Make_Defining_Identifier
(Loc
, Name_Value
),
18596 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18598 Make_Parameter_Specification
(Loc
,
18599 Defining_Identifier
=>
18600 Make_Defining_Identifier
(Loc
, Name_Amount
),
18602 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18606 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18607 Pragma_Argument_Associations
=> New_List
(
18608 Make_Pragma_Argument_Association
(Loc
,
18609 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18610 Make_Pragma_Argument_Association
(Loc
,
18611 Expression
=> Make_Identifier
(Loc
, Nam
))));
18613 Insert_After
(N
, Import
);
18614 Insert_After
(N
, Func
);
18615 end Declare_Shift_Operator
;
18617 -- Start of processing for Provide_Shift_Operators
18621 Check_Arg_Count
(1);
18622 Check_Arg_Is_Local_Name
(Arg1
);
18624 Arg1
:= Get_Pragma_Arg
(Arg1
);
18626 -- We must have an entity name
18628 if not Is_Entity_Name
(Arg1
) then
18630 ("pragma % must apply to integer first subtype", Arg1
);
18633 -- If no Entity, means there was a prior error so ignore
18635 if Present
(Entity
(Arg1
)) then
18636 Ent
:= Entity
(Arg1
);
18638 -- Apply error checks
18640 if not Is_First_Subtype
(Ent
) then
18642 ("cannot apply pragma %",
18643 "\& is not a first subtype",
18646 elsif not Is_Integer_Type
(Ent
) then
18648 ("cannot apply pragma %",
18649 "\& is not an integer type",
18652 elsif Has_Shift_Operator
(Ent
) then
18654 ("cannot apply pragma %",
18655 "\& already has declared shift operators",
18658 elsif Is_Frozen
(Ent
) then
18660 ("pragma % appears too late",
18661 "\& is already frozen",
18665 -- Now declare the operators. We do this during analysis rather
18666 -- than expansion, since we want the operators available if we
18667 -- are operating in -gnatc or ASIS mode.
18669 Declare_Shift_Operator
(Name_Rotate_Left
);
18670 Declare_Shift_Operator
(Name_Rotate_Right
);
18671 Declare_Shift_Operator
(Name_Shift_Left
);
18672 Declare_Shift_Operator
(Name_Shift_Right
);
18673 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18675 end Provide_Shift_Operators
;
18681 -- pragma Psect_Object (
18682 -- [Internal =>] LOCAL_NAME,
18683 -- [, [External =>] EXTERNAL_SYMBOL]
18684 -- [, [Size =>] EXTERNAL_SYMBOL]);
18686 when Pragma_Psect_Object | Pragma_Common_Object
=>
18687 Psect_Object
: declare
18688 Args
: Args_List
(1 .. 3);
18689 Names
: constant Name_List
(1 .. 3) := (
18694 Internal
: Node_Id
renames Args
(1);
18695 External
: Node_Id
renames Args
(2);
18696 Size
: Node_Id
renames Args
(3);
18698 Def_Id
: Entity_Id
;
18700 procedure Check_Too_Long
(Arg
: Node_Id
);
18701 -- Posts message if the argument is an identifier with more
18702 -- than 31 characters, or a string literal with more than
18703 -- 31 characters, and we are operating under VMS
18705 --------------------
18706 -- Check_Too_Long --
18707 --------------------
18709 procedure Check_Too_Long
(Arg
: Node_Id
) is
18710 X
: constant Node_Id
:= Original_Node
(Arg
);
18713 if not Nkind_In
(X
, N_String_Literal
, N_Identifier
) then
18715 ("inappropriate argument for pragma %", Arg
);
18718 if OpenVMS_On_Target
then
18719 if (Nkind
(X
) = N_String_Literal
18720 and then String_Length
(Strval
(X
)) > 31)
18722 (Nkind
(X
) = N_Identifier
18723 and then Length_Of_Name
(Chars
(X
)) > 31)
18726 ("argument for pragma % is longer than 31 characters",
18730 end Check_Too_Long
;
18732 -- Start of processing for Common_Object/Psect_Object
18736 Gather_Associations
(Names
, Args
);
18737 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18739 Def_Id
:= Entity
(Internal
);
18741 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18743 ("pragma% must designate an object", Internal
);
18746 Check_Too_Long
(Internal
);
18748 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18750 ("cannot use pragma% for imported/exported object",
18754 if Is_Concurrent_Type
(Etype
(Internal
)) then
18756 ("cannot specify pragma % for task/protected object",
18760 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18762 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18764 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18767 if Ekind
(Def_Id
) = E_Constant
then
18769 ("cannot specify pragma % for a constant", Internal
);
18772 if Is_Record_Type
(Etype
(Internal
)) then
18778 Ent
:= First_Entity
(Etype
(Internal
));
18779 while Present
(Ent
) loop
18780 Decl
:= Declaration_Node
(Ent
);
18782 if Ekind
(Ent
) = E_Component
18783 and then Nkind
(Decl
) = N_Component_Declaration
18784 and then Present
(Expression
(Decl
))
18785 and then Warn_On_Export_Import
18788 ("?x?object for pragma % has defaults", Internal
);
18798 if Present
(Size
) then
18799 Check_Too_Long
(Size
);
18802 if Present
(External
) then
18803 Check_Arg_Is_External_Name
(External
);
18804 Check_Too_Long
(External
);
18807 -- If all error tests pass, link pragma on to the rep item chain
18809 Record_Rep_Item
(Def_Id
, N
);
18816 -- pragma Pure [(library_unit_NAME)];
18818 when Pragma_Pure
=> Pure
: declare
18822 Check_Ada_83_Warning
;
18823 Check_Valid_Library_Unit_Pragma
;
18825 if Nkind
(N
) = N_Null_Statement
then
18829 Ent
:= Find_Lib_Unit_Name
;
18831 Set_Has_Pragma_Pure
(Ent
);
18832 Set_Suppress_Elaboration_Warnings
(Ent
);
18835 -------------------
18836 -- Pure_Function --
18837 -------------------
18839 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18841 when Pragma_Pure_Function
=> Pure_Function
: declare
18844 Def_Id
: Entity_Id
;
18845 Effective
: Boolean := False;
18849 Check_Arg_Count
(1);
18850 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18851 Check_Arg_Is_Local_Name
(Arg1
);
18852 E_Id
:= Get_Pragma_Arg
(Arg1
);
18854 if Error_Posted
(E_Id
) then
18858 -- Loop through homonyms (overloadings) of referenced entity
18860 E
:= Entity
(E_Id
);
18862 if Present
(E
) then
18864 Def_Id
:= Get_Base_Subprogram
(E
);
18866 if not Ekind_In
(Def_Id
, E_Function
,
18867 E_Generic_Function
,
18871 ("pragma% requires a function name", Arg1
);
18874 Set_Is_Pure
(Def_Id
);
18876 if not Has_Pragma_Pure_Function
(Def_Id
) then
18877 Set_Has_Pragma_Pure_Function
(Def_Id
);
18881 exit when From_Aspect_Specification
(N
);
18883 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18887 and then Warn_On_Redundant_Constructs
18890 ("pragma Pure_Function on& is redundant?r?",
18896 --------------------
18897 -- Queuing_Policy --
18898 --------------------
18900 -- pragma Queuing_Policy (policy_IDENTIFIER);
18902 when Pragma_Queuing_Policy
=> declare
18906 Check_Ada_83_Warning
;
18907 Check_Arg_Count
(1);
18908 Check_No_Identifiers
;
18909 Check_Arg_Is_Queuing_Policy
(Arg1
);
18910 Check_Valid_Configuration_Pragma
;
18911 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18912 QP
:= Fold_Upper
(Name_Buffer
(1));
18914 if Queuing_Policy
/= ' '
18915 and then Queuing_Policy
/= QP
18917 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18918 Error_Pragma
("queuing policy incompatible with policy#");
18920 -- Set new policy, but always preserve System_Location since we
18921 -- like the error message with the run time name.
18924 Queuing_Policy
:= QP
;
18926 if Queuing_Policy_Sloc
/= System_Location
then
18927 Queuing_Policy_Sloc
:= Loc
;
18936 -- pragma Rational, for compatibility with foreign compiler
18938 when Pragma_Rational
=>
18939 Set_Rational_Profile
;
18941 ------------------------------------
18942 -- Refined_Depends/Refined_Global --
18943 ------------------------------------
18945 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18947 -- DEPENDENCY_RELATION ::=
18949 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18951 -- DEPENDENCY_CLAUSE ::=
18952 -- OUTPUT_LIST =>[+] INPUT_LIST
18953 -- | NULL_DEPENDENCY_CLAUSE
18955 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18957 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18959 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18961 -- OUTPUT ::= NAME | FUNCTION_RESULT
18964 -- where FUNCTION_RESULT is a function Result attribute_reference
18966 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18968 -- GLOBAL_SPECIFICATION ::=
18971 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18973 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18975 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18976 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18977 -- GLOBAL_ITEM ::= NAME
18979 when Pragma_Refined_Depends |
18980 Pragma_Refined_Global
=> Refined_Depends_Global
:
18982 Body_Id
: Entity_Id
;
18984 Spec_Id
: Entity_Id
;
18987 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18989 -- Save the pragma in the contract of the subprogram body. The
18990 -- remaining analysis is performed at the end of the enclosing
18994 Add_Contract_Item
(N
, Body_Id
);
18996 end Refined_Depends_Global
;
19002 -- pragma Refined_Post (boolean_EXPRESSION);
19004 when Pragma_Refined_Post
=> Refined_Post
: declare
19005 Body_Id
: Entity_Id
;
19007 Result_Seen
: Boolean := False;
19008 Spec_Id
: Entity_Id
;
19011 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
19013 -- Analyze the boolean expression as a "spec expression"
19016 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
19018 -- Verify that the refined postcondition mentions attribute
19019 -- 'Result and its expression introduces a post-state.
19021 if Warn_On_Suspicious_Contract
19022 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
19024 Check_Result_And_Post_State
(N
, Result_Seen
);
19026 if not Result_Seen
then
19028 ("pragma % does not mention function result?T?");
19032 -- Chain the pragma on the contract for easy retrieval
19034 Add_Contract_Item
(N
, Body_Id
);
19038 -------------------
19039 -- Refined_State --
19040 -------------------
19042 -- pragma Refined_State (REFINEMENT_LIST);
19044 -- REFINEMENT_LIST ::=
19045 -- REFINEMENT_CLAUSE
19046 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19048 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19050 -- CONSTITUENT_LIST ::=
19053 -- | (CONSTITUENT {, CONSTITUENT})
19055 -- CONSTITUENT ::= object_NAME | state_NAME
19057 when Pragma_Refined_State
=> Refined_State
: declare
19058 Context
: constant Node_Id
:= Parent
(N
);
19059 Spec_Id
: Entity_Id
;
19064 Check_Arg_Count
(1);
19066 -- Ensure the proper placement of the pragma. Refined states must
19067 -- be associated with a package body.
19069 if Nkind
(Context
) /= N_Package_Body
then
19075 while Present
(Stmt
) loop
19077 -- Skip prior pragmas, but check for duplicates
19079 if Nkind
(Stmt
) = N_Pragma
then
19080 if Pragma_Name
(Stmt
) = Pname
then
19081 Error_Msg_Name_1
:= Pname
;
19082 Error_Msg_Sloc
:= Sloc
(Stmt
);
19083 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
19086 -- Skip internally generated code
19088 elsif not Comes_From_Source
(Stmt
) then
19091 -- The pragma does not apply to a legal construct, issue an
19092 -- error and stop the analysis.
19099 Stmt
:= Prev
(Stmt
);
19102 Spec_Id
:= Corresponding_Spec
(Context
);
19104 -- State refinement is allowed only when the corresponding package
19105 -- declaration has non-null pragma Abstract_State. Refinement not
19106 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19108 if SPARK_Mode
/= Off
19110 (No
(Abstract_States
(Spec_Id
))
19111 or else Has_Null_Abstract_State
(Spec_Id
))
19114 ("useless refinement, package & does not define abstract "
19115 & "states", N
, Spec_Id
);
19119 -- The pragma must be analyzed at the end of the declarations as
19120 -- it has visibility over the whole declarative region. Save the
19121 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19122 -- adding it to the contract of the package body.
19124 Add_Contract_Item
(N
, Defining_Entity
(Context
));
19127 -----------------------
19128 -- Relative_Deadline --
19129 -----------------------
19131 -- pragma Relative_Deadline (time_span_EXPRESSION);
19133 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19134 P
: constant Node_Id
:= Parent
(N
);
19139 Check_No_Identifiers
;
19140 Check_Arg_Count
(1);
19142 Arg
:= Get_Pragma_Arg
(Arg1
);
19144 -- The expression must be analyzed in the special manner described
19145 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19147 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19151 if Nkind
(P
) = N_Subprogram_Body
then
19152 Check_In_Main_Program
;
19154 -- Only Task and subprogram cases allowed
19156 elsif Nkind
(P
) /= N_Task_Definition
then
19160 -- Check duplicate pragma before we set the corresponding flag
19162 if Has_Relative_Deadline_Pragma
(P
) then
19163 Error_Pragma
("duplicate pragma% not allowed");
19166 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19167 -- Relative_Deadline pragma node cannot be inserted in the Rep
19168 -- Item chain of Ent since it is rewritten by the expander as a
19169 -- procedure call statement that will break the chain.
19171 Set_Has_Relative_Deadline_Pragma
(P
, True);
19172 end Relative_Deadline
;
19174 ------------------------
19175 -- Remote_Access_Type --
19176 ------------------------
19178 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19180 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19185 Check_Arg_Count
(1);
19186 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19187 Check_Arg_Is_Local_Name
(Arg1
);
19189 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19191 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19192 and then Ekind
(E
) = E_General_Access_Type
19193 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19194 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19196 and then Is_Valid_Remote_Object_Type
19197 (Root_Type
(Directly_Designated_Type
(E
)))
19199 Set_Is_Remote_Types
(E
);
19203 ("pragma% applies only to formal access to classwide types",
19206 end Remote_Access_Type
;
19208 ---------------------------
19209 -- Remote_Call_Interface --
19210 ---------------------------
19212 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19214 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19215 Cunit_Node
: Node_Id
;
19216 Cunit_Ent
: Entity_Id
;
19220 Check_Ada_83_Warning
;
19221 Check_Valid_Library_Unit_Pragma
;
19223 if Nkind
(N
) = N_Null_Statement
then
19227 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19228 K
:= Nkind
(Unit
(Cunit_Node
));
19229 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19231 if K
= N_Package_Declaration
19232 or else K
= N_Generic_Package_Declaration
19233 or else K
= N_Subprogram_Declaration
19234 or else K
= N_Generic_Subprogram_Declaration
19235 or else (K
= N_Subprogram_Body
19236 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19241 "pragma% must apply to package or subprogram declaration");
19244 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19245 end Remote_Call_Interface
;
19251 -- pragma Remote_Types [(library_unit_NAME)];
19253 when Pragma_Remote_Types
=> Remote_Types
: declare
19254 Cunit_Node
: Node_Id
;
19255 Cunit_Ent
: Entity_Id
;
19258 Check_Ada_83_Warning
;
19259 Check_Valid_Library_Unit_Pragma
;
19261 if Nkind
(N
) = N_Null_Statement
then
19265 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19266 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19268 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19269 N_Generic_Package_Declaration
)
19272 ("pragma% can only apply to a package declaration");
19275 Set_Is_Remote_Types
(Cunit_Ent
);
19282 -- pragma Ravenscar;
19284 when Pragma_Ravenscar
=>
19286 Check_Arg_Count
(0);
19287 Check_Valid_Configuration_Pragma
;
19288 Set_Ravenscar_Profile
(N
);
19290 if Warn_On_Obsolescent_Feature
then
19292 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19294 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19297 -------------------------
19298 -- Restricted_Run_Time --
19299 -------------------------
19301 -- pragma Restricted_Run_Time;
19303 when Pragma_Restricted_Run_Time
=>
19305 Check_Arg_Count
(0);
19306 Check_Valid_Configuration_Pragma
;
19307 Set_Profile_Restrictions
19308 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19310 if Warn_On_Obsolescent_Feature
then
19312 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19315 ("|use pragma Profile (Restricted) instead?j?", N
);
19322 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19325 -- restriction_IDENTIFIER
19326 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19328 when Pragma_Restrictions
=>
19329 Process_Restrictions_Or_Restriction_Warnings
19330 (Warn
=> Treat_Restrictions_As_Warnings
);
19332 --------------------------
19333 -- Restriction_Warnings --
19334 --------------------------
19336 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19339 -- restriction_IDENTIFIER
19340 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19342 when Pragma_Restriction_Warnings
=>
19344 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19350 -- pragma Reviewable;
19352 when Pragma_Reviewable
=>
19353 Check_Ada_83_Warning
;
19354 Check_Arg_Count
(0);
19356 -- Call dummy debugging function rv. This is done to assist front
19357 -- end debugging. By placing a Reviewable pragma in the source
19358 -- program, a breakpoint on rv catches this place in the source,
19359 -- allowing convenient stepping to the point of interest.
19363 --------------------------
19364 -- Short_Circuit_And_Or --
19365 --------------------------
19367 -- pragma Short_Circuit_And_Or;
19369 when Pragma_Short_Circuit_And_Or
=>
19371 Check_Arg_Count
(0);
19372 Check_Valid_Configuration_Pragma
;
19373 Short_Circuit_And_Or
:= True;
19375 -------------------
19376 -- Share_Generic --
19377 -------------------
19379 -- pragma Share_Generic (GNAME {, GNAME});
19381 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19383 when Pragma_Share_Generic
=>
19385 Process_Generic_List
;
19391 -- pragma Shared (LOCAL_NAME);
19393 when Pragma_Shared
=>
19395 Process_Atomic_Shared_Volatile
;
19397 --------------------
19398 -- Shared_Passive --
19399 --------------------
19401 -- pragma Shared_Passive [(library_unit_NAME)];
19403 -- Set the flag Is_Shared_Passive of program unit name entity
19405 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19406 Cunit_Node
: Node_Id
;
19407 Cunit_Ent
: Entity_Id
;
19410 Check_Ada_83_Warning
;
19411 Check_Valid_Library_Unit_Pragma
;
19413 if Nkind
(N
) = N_Null_Statement
then
19417 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19418 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19420 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19421 N_Generic_Package_Declaration
)
19424 ("pragma% can only apply to a package declaration");
19427 Set_Is_Shared_Passive
(Cunit_Ent
);
19428 end Shared_Passive
;
19430 -----------------------
19431 -- Short_Descriptors --
19432 -----------------------
19434 -- pragma Short_Descriptors;
19436 when Pragma_Short_Descriptors
=>
19438 Check_Arg_Count
(0);
19439 Check_Valid_Configuration_Pragma
;
19440 Short_Descriptors
:= True;
19442 ------------------------------
19443 -- Simple_Storage_Pool_Type --
19444 ------------------------------
19446 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19448 when Pragma_Simple_Storage_Pool_Type
=>
19449 Simple_Storage_Pool_Type
: declare
19455 Check_Arg_Count
(1);
19456 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19458 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19459 Find_Type
(Type_Id
);
19460 Typ
:= Entity
(Type_Id
);
19462 if Typ
= Any_Type
then
19466 -- We require the pragma to apply to a type declared in a package
19467 -- declaration, but not (immediately) within a package body.
19469 if Ekind
(Current_Scope
) /= E_Package
19470 or else In_Package_Body
(Current_Scope
)
19473 ("pragma% can only apply to type declared immediately "
19474 & "within a package declaration");
19477 -- A simple storage pool type must be an immutably limited record
19478 -- or private type. If the pragma is given for a private type,
19479 -- the full type is similarly restricted (which is checked later
19480 -- in Freeze_Entity).
19482 if Is_Record_Type
(Typ
)
19483 and then not Is_Limited_View
(Typ
)
19486 ("pragma% can only apply to explicitly limited record type");
19488 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19490 ("pragma% can only apply to a private type that is limited");
19492 elsif not Is_Record_Type
(Typ
)
19493 and then not Is_Private_Type
(Typ
)
19496 ("pragma% can only apply to limited record or private type");
19499 Record_Rep_Item
(Typ
, N
);
19500 end Simple_Storage_Pool_Type
;
19502 ----------------------
19503 -- Source_File_Name --
19504 ----------------------
19506 -- There are five forms for this pragma:
19508 -- pragma Source_File_Name (
19509 -- [UNIT_NAME =>] unit_NAME,
19510 -- BODY_FILE_NAME => STRING_LITERAL
19511 -- [, [INDEX =>] INTEGER_LITERAL]);
19513 -- pragma Source_File_Name (
19514 -- [UNIT_NAME =>] unit_NAME,
19515 -- SPEC_FILE_NAME => STRING_LITERAL
19516 -- [, [INDEX =>] INTEGER_LITERAL]);
19518 -- pragma Source_File_Name (
19519 -- BODY_FILE_NAME => STRING_LITERAL
19520 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19521 -- [, CASING => CASING_SPEC]);
19523 -- pragma Source_File_Name (
19524 -- SPEC_FILE_NAME => STRING_LITERAL
19525 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19526 -- [, CASING => CASING_SPEC]);
19528 -- pragma Source_File_Name (
19529 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19530 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19531 -- [, CASING => CASING_SPEC]);
19533 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19535 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19536 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19537 -- only be used when no project file is used, while SFNP can only be
19538 -- used when a project file is used.
19540 -- No processing here. Processing was completed during parsing, since
19541 -- we need to have file names set as early as possible. Units are
19542 -- loaded well before semantic processing starts.
19544 -- The only processing we defer to this point is the check for
19545 -- correct placement.
19547 when Pragma_Source_File_Name
=>
19549 Check_Valid_Configuration_Pragma
;
19551 ------------------------------
19552 -- Source_File_Name_Project --
19553 ------------------------------
19555 -- See Source_File_Name for syntax
19557 -- No processing here. Processing was completed during parsing, since
19558 -- we need to have file names set as early as possible. Units are
19559 -- loaded well before semantic processing starts.
19561 -- The only processing we defer to this point is the check for
19562 -- correct placement.
19564 when Pragma_Source_File_Name_Project
=>
19566 Check_Valid_Configuration_Pragma
;
19568 -- Check that a pragma Source_File_Name_Project is used only in a
19569 -- configuration pragmas file.
19571 -- Pragmas Source_File_Name_Project should only be generated by
19572 -- the Project Manager in configuration pragmas files.
19574 -- This is really an ugly test. It seems to depend on some
19575 -- accidental and undocumented property. At the very least it
19576 -- needs to be documented, but it would be better to have a
19577 -- clean way of testing if we are in a configuration file???
19579 if Present
(Parent
(N
)) then
19581 ("pragma% can only appear in a configuration pragmas file");
19584 ----------------------
19585 -- Source_Reference --
19586 ----------------------
19588 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19590 -- Nothing to do, all processing completed in Par.Prag, since we need
19591 -- the information for possible parser messages that are output.
19593 when Pragma_Source_Reference
=>
19600 -- pragma SPARK_Mode [(On | Off)];
19602 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19603 Body_Id
: Entity_Id
;
19606 Mode_Id
: SPARK_Mode_Type
;
19607 Spec_Id
: Entity_Id
;
19610 procedure Check_Pragma_Conformance
19611 (Context_Pragma
: Node_Id
;
19612 Entity_Pragma
: Node_Id
;
19613 Entity
: Entity_Id
);
19614 -- If Context_Pragma is not Empty, verify that the new pragma N
19615 -- is compatible with the pragma Context_Pragma that was inherited
19616 -- from the context:
19617 -- . if Context_Pragma is ON, then the new mode can be anything
19618 -- . if Context_Pragma is OFF, then the only allowed new mode is
19621 -- If Entity is not Empty, verify that the new pragma N is
19622 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19623 -- for Entity (which may be Empty):
19624 -- . if Entity_Pragma is ON, then the new mode can be anything
19625 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19627 -- . if Entity_Pragma is Empty, we always issue an error, as this
19628 -- corresponds to a case where a previous section of Entity
19629 -- had no SPARK_Mode set.
19631 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19632 -- Verify that pragma is applied to library-level entity E
19634 ------------------------------
19635 -- Check_Pragma_Conformance --
19636 ------------------------------
19638 procedure Check_Pragma_Conformance
19639 (Context_Pragma
: Node_Id
;
19640 Entity_Pragma
: Node_Id
;
19641 Entity
: Entity_Id
)
19644 if Present
(Context_Pragma
) then
19645 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19647 -- New mode less restrictive than the established mode
19649 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19650 and then Mode_Id
= On
19653 ("cannot change SPARK_Mode from Off to On", Arg1
);
19654 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19655 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg1
);
19660 if Present
(Entity
) then
19661 if Present
(Entity_Pragma
) then
19662 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19663 and then Mode_Id
= On
19665 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19666 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19668 ("\value Off was set for SPARK_Mode on&#",
19674 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19675 Error_Msg_Sloc
:= Sloc
(Entity
);
19677 ("\no value was set for SPARK_Mode on&#",
19682 end Check_Pragma_Conformance
;
19684 --------------------------------
19685 -- Check_Library_Level_Entity --
19686 --------------------------------
19688 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19689 MsgF
: constant String := "incorrect placement of pragma%";
19692 if not Is_Library_Level_Entity
(E
) then
19693 Error_Msg_Name_1
:= Pname
;
19694 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19696 if Ekind_In
(E
, E_Generic_Package
,
19701 ("\& is not a library-level package", N
, E
);
19704 ("\& is not a library-level subprogram", N
, E
);
19709 end Check_Library_Level_Entity
;
19711 -- Start of processing for Do_SPARK_Mode
19715 Check_No_Identifiers
;
19716 Check_At_Most_N_Arguments
(1);
19718 -- Check the legality of the mode (no argument = ON)
19720 if Arg_Count
= 1 then
19721 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19722 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19727 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19728 Context
:= Parent
(N
);
19730 -- Packages and subprograms declared in a generic unit cannot be
19731 -- subject to the pragma.
19733 if Inside_A_Generic
then
19734 Error_Pragma
("incorrect placement of pragma% in a generic");
19736 -- The pragma appears in a configuration pragmas file
19738 elsif No
(Context
) then
19739 Check_Valid_Configuration_Pragma
;
19741 if Present
(SPARK_Mode_Pragma
) then
19742 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19743 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19747 SPARK_Mode_Pragma
:= N
;
19748 SPARK_Mode
:= Mode_Id
;
19750 -- When the pragma is placed before the declaration of a unit, it
19751 -- configures the whole unit.
19753 elsif Nkind
(Context
) = N_Compilation_Unit
then
19754 Check_Valid_Configuration_Pragma
;
19756 if Nkind
(Unit
(Context
)) in N_Generic_Declaration
19757 or else (Present
(Library_Unit
(Context
))
19758 and then Nkind
(Unit
(Library_Unit
(Context
))) in
19759 N_Generic_Declaration
)
19761 Error_Pragma
("incorrect placement of pragma% in a generic");
19764 SPARK_Mode_Pragma
:= N
;
19765 SPARK_Mode
:= Mode_Id
;
19767 -- The pragma applies to a [library unit] subprogram or package
19770 -- Verify the placement of the pragma with respect to package
19771 -- or subprogram declarations and detect duplicates.
19774 while Present
(Stmt
) loop
19776 -- Skip prior pragmas, but check for duplicates
19778 if Nkind
(Stmt
) = N_Pragma
then
19779 if Pragma_Name
(Stmt
) = Pname
then
19780 Error_Msg_Name_1
:= Pname
;
19781 Error_Msg_Sloc
:= Sloc
(Stmt
);
19782 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19786 -- Skip internally generated code
19788 elsif not Comes_From_Source
(Stmt
) then
19791 elsif Nkind
(Stmt
) in N_Generic_Declaration
then
19793 ("incorrect placement of pragma% on a generic");
19795 -- The pragma applies to a package declaration
19797 elsif Nkind
(Stmt
) = N_Package_Declaration
then
19798 Spec_Id
:= Defining_Entity
(Stmt
);
19799 Check_Library_Level_Entity
(Spec_Id
);
19800 Check_Pragma_Conformance
19801 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19802 Entity_Pragma
=> Empty
,
19805 Set_SPARK_Pragma
(Spec_Id
, N
);
19806 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19807 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19808 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19811 -- The pragma applies to a subprogram declaration
19813 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
19814 Spec_Id
:= Defining_Entity
(Stmt
);
19815 Check_Library_Level_Entity
(Spec_Id
);
19816 Check_Pragma_Conformance
19817 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19818 Entity_Pragma
=> Empty
,
19821 Set_SPARK_Pragma
(Spec_Id
, N
);
19822 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19825 -- The pragma does not apply to a legal construct, issue an
19826 -- error and stop the analysis.
19833 Stmt
:= Prev
(Stmt
);
19836 -- Handle all cases where the pragma is actually an aspect and
19837 -- applies to a library-level package spec, body or subprogram.
19839 -- function F ... with SPARK_Mode => ...;
19840 -- package P with SPARK_Mode => ...;
19841 -- package body P with SPARK_Mode => ... is
19843 -- The following circuitry simply prepares the proper context
19844 -- for the general pragma processing mechanism below.
19846 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19847 Context
:= Unit
(Parent
(Context
));
19849 if Nkind_In
(Context
, N_Package_Declaration
,
19850 N_Subprogram_Declaration
)
19852 Context
:= Specification
(Context
);
19856 -- The pragma is at the top level of a package spec
19859 -- pragma SPARK_Mode;
19866 -- pragma SPARK_Mode;
19868 if Nkind
(Context
) = N_Package_Specification
then
19869 Spec_Id
:= Defining_Entity
(Context
);
19871 -- Pragma applies to private part
19873 if List_Containing
(N
) = Private_Declarations
(Context
) then
19874 Check_Library_Level_Entity
(Spec_Id
);
19875 Check_Pragma_Conformance
19876 (Context_Pragma
=> Empty
,
19877 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19878 Entity
=> Spec_Id
);
19879 SPARK_Mode_Pragma
:= N
;
19880 SPARK_Mode
:= Mode_Id
;
19882 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19883 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19885 -- Pragma applies to public part
19888 Check_Library_Level_Entity
(Spec_Id
);
19889 Check_Pragma_Conformance
19890 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19891 Entity_Pragma
=> Empty
,
19893 SPARK_Mode_Pragma
:= N
;
19894 SPARK_Mode
:= Mode_Id
;
19896 Set_SPARK_Pragma
(Spec_Id
, N
);
19897 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19898 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19899 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19902 -- The pragma appears as an aspect on a subprogram.
19904 -- function F ... with SPARK_Mode => ...;
19906 elsif Nkind_In
(Context
, N_Function_Specification
,
19907 N_Procedure_Specification
)
19909 Spec_Id
:= Defining_Entity
(Context
);
19910 Check_Library_Level_Entity
(Spec_Id
);
19911 Check_Pragma_Conformance
19912 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19913 Entity_Pragma
=> Empty
,
19915 Set_SPARK_Pragma
(Spec_Id
, N
);
19916 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19918 -- Pragma is immediately within a package body
19920 -- package body P is
19921 -- pragma SPARK_Mode;
19923 elsif Nkind
(Context
) = N_Package_Body
then
19924 Spec_Id
:= Corresponding_Spec
(Context
);
19925 Body_Id
:= Defining_Entity
(Context
);
19926 Check_Library_Level_Entity
(Body_Id
);
19927 Check_Pragma_Conformance
19928 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19929 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19930 Entity
=> Spec_Id
);
19931 SPARK_Mode_Pragma
:= N
;
19932 SPARK_Mode
:= Mode_Id
;
19934 Set_SPARK_Pragma
(Body_Id
, N
);
19935 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19936 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19937 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19939 -- Pragma is immediately within a subprogram body
19941 -- function F ... is
19942 -- pragma SPARK_Mode;
19944 elsif Nkind
(Context
) = N_Subprogram_Body
then
19945 Spec_Id
:= Corresponding_Spec
(Context
);
19946 Context
:= Specification
(Context
);
19947 Body_Id
:= Defining_Entity
(Context
);
19948 Check_Library_Level_Entity
(Body_Id
);
19950 if Present
(Spec_Id
) then
19951 Check_Pragma_Conformance
19952 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19953 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19954 Entity
=> Spec_Id
);
19956 Check_Pragma_Conformance
19957 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19958 Entity_Pragma
=> Empty
,
19962 SPARK_Mode_Pragma
:= N
;
19963 SPARK_Mode
:= Mode_Id
;
19965 Set_SPARK_Pragma
(Body_Id
, N
);
19966 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19968 -- The pragma applies to the statements of a package body
19970 -- package body P is
19972 -- pragma SPARK_Mode;
19974 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19975 and then Nkind
(Parent
(Context
)) = N_Package_Body
19977 Context
:= Parent
(Context
);
19978 Spec_Id
:= Corresponding_Spec
(Context
);
19979 Body_Id
:= Defining_Entity
(Context
);
19980 Check_Library_Level_Entity
(Body_Id
);
19981 Check_Pragma_Conformance
19982 (Context_Pragma
=> Empty
,
19983 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19984 Entity
=> Body_Id
);
19985 SPARK_Mode_Pragma
:= N
;
19986 SPARK_Mode
:= Mode_Id
;
19988 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19989 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19991 -- The pragma does not apply to a legal construct, issue error
19999 --------------------------------
20000 -- Static_Elaboration_Desired --
20001 --------------------------------
20003 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20005 when Pragma_Static_Elaboration_Desired
=>
20007 Check_At_Most_N_Arguments
(1);
20009 if Is_Compilation_Unit
(Current_Scope
)
20010 and then Ekind
(Current_Scope
) = E_Package
20012 Set_Static_Elaboration_Desired
(Current_Scope
, True);
20014 Error_Pragma
("pragma% must apply to a library-level package");
20021 -- pragma Storage_Size (EXPRESSION);
20023 when Pragma_Storage_Size
=> Storage_Size
: declare
20024 P
: constant Node_Id
:= Parent
(N
);
20028 Check_No_Identifiers
;
20029 Check_Arg_Count
(1);
20031 -- The expression must be analyzed in the special manner described
20032 -- in "Handling of Default Expressions" in sem.ads.
20034 Arg
:= Get_Pragma_Arg
(Arg1
);
20035 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20037 if not Is_Static_Expression
(Arg
) then
20038 Check_Restriction
(Static_Storage_Size
, Arg
);
20041 if Nkind
(P
) /= N_Task_Definition
then
20046 if Has_Storage_Size_Pragma
(P
) then
20047 Error_Pragma
("duplicate pragma% not allowed");
20049 Set_Has_Storage_Size_Pragma
(P
, True);
20052 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20060 -- pragma Storage_Unit (NUMERIC_LITERAL);
20062 -- Only permitted argument is System'Storage_Unit value
20064 when Pragma_Storage_Unit
=>
20065 Check_No_Identifiers
;
20066 Check_Arg_Count
(1);
20067 Check_Arg_Is_Integer_Literal
(Arg1
);
20069 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20070 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20072 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20074 ("the only allowed argument for pragma% is ^", Arg1
);
20077 --------------------
20078 -- Stream_Convert --
20079 --------------------
20081 -- pragma Stream_Convert (
20082 -- [Entity =>] type_LOCAL_NAME,
20083 -- [Read =>] function_NAME,
20084 -- [Write =>] function NAME);
20086 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20088 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20089 -- Check that the given argument is the name of a local function
20090 -- of one argument that is not overloaded earlier in the current
20091 -- local scope. A check is also made that the argument is a
20092 -- function with one parameter.
20094 --------------------------------------
20095 -- Check_OK_Stream_Convert_Function --
20096 --------------------------------------
20098 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20102 Check_Arg_Is_Local_Name
(Arg
);
20103 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20105 if Has_Homonym
(Ent
) then
20107 ("argument for pragma% may not be overloaded", Arg
);
20110 if Ekind
(Ent
) /= E_Function
20111 or else No
(First_Formal
(Ent
))
20112 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20115 ("argument for pragma% must be function of one argument",
20118 end Check_OK_Stream_Convert_Function
;
20120 -- Start of processing for Stream_Convert
20124 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20125 Check_Arg_Count
(3);
20126 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20127 Check_Optional_Identifier
(Arg2
, Name_Read
);
20128 Check_Optional_Identifier
(Arg3
, Name_Write
);
20129 Check_Arg_Is_Local_Name
(Arg1
);
20130 Check_OK_Stream_Convert_Function
(Arg2
);
20131 Check_OK_Stream_Convert_Function
(Arg3
);
20134 Typ
: constant Entity_Id
:=
20135 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20136 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20137 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20140 Check_First_Subtype
(Arg1
);
20142 -- Check for too early or too late. Note that we don't enforce
20143 -- the rule about primitive operations in this case, since, as
20144 -- is the case for explicit stream attributes themselves, these
20145 -- restrictions are not appropriate. Note that the chaining of
20146 -- the pragma by Rep_Item_Too_Late is actually the critical
20147 -- processing done for this pragma.
20149 if Rep_Item_Too_Early
(Typ
, N
)
20151 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20156 -- Return if previous error
20158 if Etype
(Typ
) = Any_Type
20160 Etype
(Read
) = Any_Type
20162 Etype
(Write
) = Any_Type
20169 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20171 ("incorrect return type for function&", Arg2
);
20174 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20176 ("incorrect parameter type for function&", Arg3
);
20179 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20180 Underlying_Type
(Etype
(Write
))
20183 ("result type of & does not match Read parameter type",
20187 end Stream_Convert
;
20193 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20195 -- This is processed by the parser since some of the style checks
20196 -- take place during source scanning and parsing. This means that
20197 -- we don't need to issue error messages here.
20199 when Pragma_Style_Checks
=> Style_Checks
: declare
20200 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20206 Check_No_Identifiers
;
20208 -- Two argument form
20210 if Arg_Count
= 2 then
20211 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20218 E_Id
:= Get_Pragma_Arg
(Arg2
);
20221 if not Is_Entity_Name
(E_Id
) then
20223 ("second argument of pragma% must be entity name",
20227 E
:= Entity
(E_Id
);
20229 if not Ignore_Style_Checks_Pragmas
then
20234 Set_Suppress_Style_Checks
20235 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20236 exit when No
(Homonym
(E
));
20243 -- One argument form
20246 Check_Arg_Count
(1);
20248 if Nkind
(A
) = N_String_Literal
then
20252 Slen
: constant Natural := Natural (String_Length
(S
));
20253 Options
: String (1 .. Slen
);
20259 C
:= Get_String_Char
(S
, Int
(J
));
20260 exit when not In_Character_Range
(C
);
20261 Options
(J
) := Get_Character
(C
);
20263 -- If at end of string, set options. As per discussion
20264 -- above, no need to check for errors, since we issued
20265 -- them in the parser.
20268 if not Ignore_Style_Checks_Pragmas
then
20269 Set_Style_Check_Options
(Options
);
20279 elsif Nkind
(A
) = N_Identifier
then
20280 if Chars
(A
) = Name_All_Checks
then
20281 if not Ignore_Style_Checks_Pragmas
then
20283 Set_GNAT_Style_Check_Options
;
20285 Set_Default_Style_Check_Options
;
20289 elsif Chars
(A
) = Name_On
then
20290 if not Ignore_Style_Checks_Pragmas
then
20291 Style_Check
:= True;
20294 elsif Chars
(A
) = Name_Off
then
20295 if not Ignore_Style_Checks_Pragmas
then
20296 Style_Check
:= False;
20307 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20309 when Pragma_Subtitle
=>
20311 Check_Arg_Count
(1);
20312 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20313 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
20320 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20322 when Pragma_Suppress
=>
20323 Process_Suppress_Unsuppress
(True);
20329 -- pragma Suppress_All;
20331 -- The only check made here is that the pragma has no arguments.
20332 -- There are no placement rules, and the processing required (setting
20333 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20334 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20335 -- then creates and inserts a pragma Suppress (All_Checks).
20337 when Pragma_Suppress_All
=>
20339 Check_Arg_Count
(0);
20341 -------------------------
20342 -- Suppress_Debug_Info --
20343 -------------------------
20345 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20347 when Pragma_Suppress_Debug_Info
=>
20349 Check_Arg_Count
(1);
20350 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20351 Check_Arg_Is_Local_Name
(Arg1
);
20352 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20354 ----------------------------------
20355 -- Suppress_Exception_Locations --
20356 ----------------------------------
20358 -- pragma Suppress_Exception_Locations;
20360 when Pragma_Suppress_Exception_Locations
=>
20362 Check_Arg_Count
(0);
20363 Check_Valid_Configuration_Pragma
;
20364 Exception_Locations_Suppressed
:= True;
20366 -----------------------------
20367 -- Suppress_Initialization --
20368 -----------------------------
20370 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20372 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20378 Check_Arg_Count
(1);
20379 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20380 Check_Arg_Is_Local_Name
(Arg1
);
20382 E_Id
:= Get_Pragma_Arg
(Arg1
);
20384 if Etype
(E_Id
) = Any_Type
then
20388 E
:= Entity
(E_Id
);
20390 if not Is_Type
(E
) then
20391 Error_Pragma_Arg
("pragma% requires type or subtype", Arg1
);
20394 if Rep_Item_Too_Early
(E
, N
)
20396 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20401 -- For incomplete/private type, set flag on full view
20403 if Is_Incomplete_Or_Private_Type
(E
) then
20404 if No
(Full_View
(Base_Type
(E
))) then
20406 ("argument of pragma% cannot be an incomplete type", Arg1
);
20408 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20411 -- For first subtype, set flag on base type
20413 elsif Is_First_Subtype
(E
) then
20414 Set_Suppress_Initialization
(Base_Type
(E
));
20416 -- For other than first subtype, set flag on subtype itself
20419 Set_Suppress_Initialization
(E
);
20427 -- pragma System_Name (DIRECT_NAME);
20429 -- Syntax check: one argument, which must be the identifier GNAT or
20430 -- the identifier GCC, no other identifiers are acceptable.
20432 when Pragma_System_Name
=>
20434 Check_No_Identifiers
;
20435 Check_Arg_Count
(1);
20436 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20438 -----------------------------
20439 -- Task_Dispatching_Policy --
20440 -----------------------------
20442 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20444 when Pragma_Task_Dispatching_Policy
=> declare
20448 Check_Ada_83_Warning
;
20449 Check_Arg_Count
(1);
20450 Check_No_Identifiers
;
20451 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20452 Check_Valid_Configuration_Pragma
;
20453 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20454 DP
:= Fold_Upper
(Name_Buffer
(1));
20456 if Task_Dispatching_Policy
/= ' '
20457 and then Task_Dispatching_Policy
/= DP
20459 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20461 ("task dispatching policy incompatible with policy#");
20463 -- Set new policy, but always preserve System_Location since we
20464 -- like the error message with the run time name.
20467 Task_Dispatching_Policy
:= DP
;
20469 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20470 Task_Dispatching_Policy_Sloc
:= Loc
;
20479 -- pragma Task_Info (EXPRESSION);
20481 when Pragma_Task_Info
=> Task_Info
: declare
20482 P
: constant Node_Id
:= Parent
(N
);
20488 if Warn_On_Obsolescent_Feature
then
20490 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20491 & "instead?j?", N
);
20494 if Nkind
(P
) /= N_Task_Definition
then
20495 Error_Pragma
("pragma% must appear in task definition");
20498 Check_No_Identifiers
;
20499 Check_Arg_Count
(1);
20501 Analyze_And_Resolve
20502 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20504 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20508 Ent
:= Defining_Identifier
(Parent
(P
));
20510 -- Check duplicate pragma before we chain the pragma in the Rep
20511 -- Item chain of Ent.
20514 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20516 Error_Pragma
("duplicate pragma% not allowed");
20519 Record_Rep_Item
(Ent
, N
);
20526 -- pragma Task_Name (string_EXPRESSION);
20528 when Pragma_Task_Name
=> Task_Name
: declare
20529 P
: constant Node_Id
:= Parent
(N
);
20534 Check_No_Identifiers
;
20535 Check_Arg_Count
(1);
20537 Arg
:= Get_Pragma_Arg
(Arg1
);
20539 -- The expression is used in the call to Create_Task, and must be
20540 -- expanded there, not in the context of the current spec. It must
20541 -- however be analyzed to capture global references, in case it
20542 -- appears in a generic context.
20544 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20546 if Nkind
(P
) /= N_Task_Definition
then
20550 Ent
:= Defining_Identifier
(Parent
(P
));
20552 -- Check duplicate pragma before we chain the pragma in the Rep
20553 -- Item chain of Ent.
20556 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20558 Error_Pragma
("duplicate pragma% not allowed");
20561 Record_Rep_Item
(Ent
, N
);
20568 -- pragma Task_Storage (
20569 -- [Task_Type =>] LOCAL_NAME,
20570 -- [Top_Guard =>] static_integer_EXPRESSION);
20572 when Pragma_Task_Storage
=> Task_Storage
: declare
20573 Args
: Args_List
(1 .. 2);
20574 Names
: constant Name_List
(1 .. 2) := (
20578 Task_Type
: Node_Id
renames Args
(1);
20579 Top_Guard
: Node_Id
renames Args
(2);
20585 Gather_Associations
(Names
, Args
);
20587 if No
(Task_Type
) then
20589 ("missing task_type argument for pragma%");
20592 Check_Arg_Is_Local_Name
(Task_Type
);
20594 Ent
:= Entity
(Task_Type
);
20596 if not Is_Task_Type
(Ent
) then
20598 ("argument for pragma% must be task type", Task_Type
);
20601 if No
(Top_Guard
) then
20603 ("pragma% takes two arguments", Task_Type
);
20605 Check_Arg_Is_Static_Expression
(Top_Guard
, Any_Integer
);
20608 Check_First_Subtype
(Task_Type
);
20610 if Rep_Item_Too_Late
(Ent
, N
) then
20619 -- pragma Test_Case
20620 -- ([Name =>] Static_String_EXPRESSION
20621 -- ,[Mode =>] MODE_TYPE
20622 -- [, Requires => Boolean_EXPRESSION]
20623 -- [, Ensures => Boolean_EXPRESSION]);
20625 -- MODE_TYPE ::= Nominal | Robustness
20627 when Pragma_Test_Case
=>
20631 --------------------------
20632 -- Thread_Local_Storage --
20633 --------------------------
20635 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20637 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20643 Check_Arg_Count
(1);
20644 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20645 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20647 Id
:= Get_Pragma_Arg
(Arg1
);
20650 if not Is_Entity_Name
(Id
)
20651 or else Ekind
(Entity
(Id
)) /= E_Variable
20653 Error_Pragma_Arg
("local variable name required", Arg1
);
20658 if Rep_Item_Too_Early
(E
, N
)
20659 or else Rep_Item_Too_Late
(E
, N
)
20664 Set_Has_Pragma_Thread_Local_Storage
(E
);
20665 Set_Has_Gigi_Rep_Item
(E
);
20666 end Thread_Local_Storage
;
20672 -- pragma Time_Slice (static_duration_EXPRESSION);
20674 when Pragma_Time_Slice
=> Time_Slice
: declare
20680 Check_Arg_Count
(1);
20681 Check_No_Identifiers
;
20682 Check_In_Main_Program
;
20683 Check_Arg_Is_Static_Expression
(Arg1
, Standard_Duration
);
20685 if not Error_Posted
(Arg1
) then
20687 while Present
(Nod
) loop
20688 if Nkind
(Nod
) = N_Pragma
20689 and then Pragma_Name
(Nod
) = Name_Time_Slice
20691 Error_Msg_Name_1
:= Pname
;
20692 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20699 -- Process only if in main unit
20701 if Get_Source_Unit
(Loc
) = Main_Unit
then
20702 Opt
.Time_Slice_Set
:= True;
20703 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20705 if Val
<= Ureal_0
then
20706 Opt
.Time_Slice_Value
:= 0;
20708 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20709 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20712 Opt
.Time_Slice_Value
:=
20713 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20722 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20724 -- TITLING_OPTION ::=
20725 -- [Title =>] STRING_LITERAL
20726 -- | [Subtitle =>] STRING_LITERAL
20728 when Pragma_Title
=> Title
: declare
20729 Args
: Args_List
(1 .. 2);
20730 Names
: constant Name_List
(1 .. 2) := (
20736 Gather_Associations
(Names
, Args
);
20739 for J
in 1 .. 2 loop
20740 if Present
(Args
(J
)) then
20741 Check_Arg_Is_Static_Expression
(Args
(J
), Standard_String
);
20746 ----------------------------
20747 -- Type_Invariant[_Class] --
20748 ----------------------------
20750 -- pragma Type_Invariant[_Class]
20751 -- ([Entity =>] type_LOCAL_NAME,
20752 -- [Check =>] EXPRESSION);
20754 when Pragma_Type_Invariant |
20755 Pragma_Type_Invariant_Class
=>
20756 Type_Invariant
: declare
20757 I_Pragma
: Node_Id
;
20760 Check_Arg_Count
(2);
20762 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20763 -- setting Class_Present for the Type_Invariant_Class case.
20765 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20766 I_Pragma
:= New_Copy
(N
);
20767 Set_Pragma_Identifier
20768 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20769 Rewrite
(N
, I_Pragma
);
20770 Set_Analyzed
(N
, False);
20772 end Type_Invariant
;
20774 ---------------------
20775 -- Unchecked_Union --
20776 ---------------------
20778 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20780 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20781 Assoc
: constant Node_Id
:= Arg1
;
20782 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20792 Check_No_Identifiers
;
20793 Check_Arg_Count
(1);
20794 Check_Arg_Is_Local_Name
(Arg1
);
20796 Find_Type
(Type_Id
);
20798 Typ
:= Entity
(Type_Id
);
20801 or else Rep_Item_Too_Early
(Typ
, N
)
20805 Typ
:= Underlying_Type
(Typ
);
20808 if Rep_Item_Too_Late
(Typ
, N
) then
20812 Check_First_Subtype
(Arg1
);
20814 -- Note remaining cases are references to a type in the current
20815 -- declarative part. If we find an error, we post the error on
20816 -- the relevant type declaration at an appropriate point.
20818 if not Is_Record_Type
(Typ
) then
20819 Error_Msg_N
("unchecked union must be record type", Typ
);
20822 elsif Is_Tagged_Type
(Typ
) then
20823 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20826 elsif not Has_Discriminants
(Typ
) then
20828 ("unchecked union must have one discriminant", Typ
);
20831 -- Note: in previous versions of GNAT we used to check for limited
20832 -- types and give an error, but in fact the standard does allow
20833 -- Unchecked_Union on limited types, so this check was removed.
20835 -- Similarly, GNAT used to require that all discriminants have
20836 -- default values, but this is not mandated by the RM.
20838 -- Proceed with basic error checks completed
20841 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20842 Clist
:= Component_List
(Tdef
);
20844 -- Check presence of component list and variant part
20846 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20848 ("unchecked union must have variant part", Tdef
);
20852 -- Check components
20854 Comp
:= First
(Component_Items
(Clist
));
20855 while Present
(Comp
) loop
20856 Check_Component
(Comp
, Typ
);
20860 -- Check variant part
20862 Vpart
:= Variant_Part
(Clist
);
20864 Variant
:= First
(Variants
(Vpart
));
20865 while Present
(Variant
) loop
20866 Check_Variant
(Variant
, Typ
);
20871 Set_Is_Unchecked_Union
(Typ
);
20872 Set_Convention
(Typ
, Convention_C
);
20873 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20874 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20875 end Unchecked_Union
;
20877 ------------------------
20878 -- Unimplemented_Unit --
20879 ------------------------
20881 -- pragma Unimplemented_Unit;
20883 -- Note: this only gives an error if we are generating code, or if
20884 -- we are in a generic library unit (where the pragma appears in the
20885 -- body, not in the spec).
20887 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20888 Cunitent
: constant Entity_Id
:=
20889 Cunit_Entity
(Get_Source_Unit
(Loc
));
20890 Ent_Kind
: constant Entity_Kind
:=
20895 Check_Arg_Count
(0);
20897 if Operating_Mode
= Generate_Code
20898 or else Ent_Kind
= E_Generic_Function
20899 or else Ent_Kind
= E_Generic_Procedure
20900 or else Ent_Kind
= E_Generic_Package
20902 Get_Name_String
(Chars
(Cunitent
));
20903 Set_Casing
(Mixed_Case
);
20904 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20905 Write_Str
(" is not supported in this configuration");
20907 raise Unrecoverable_Error
;
20909 end Unimplemented_Unit
;
20911 ------------------------
20912 -- Universal_Aliasing --
20913 ------------------------
20915 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20917 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20922 Check_Arg_Count
(1);
20923 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20924 Check_Arg_Is_Local_Name
(Arg1
);
20925 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20927 if E_Id
= Any_Type
then
20929 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20930 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20933 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20934 Record_Rep_Item
(E_Id
, N
);
20935 end Universal_Alias
;
20937 --------------------
20938 -- Universal_Data --
20939 --------------------
20941 -- pragma Universal_Data [(library_unit_NAME)];
20943 when Pragma_Universal_Data
=>
20946 -- If this is a configuration pragma, then set the universal
20947 -- addressing option, otherwise confirm that the pragma satisfies
20948 -- the requirements of library unit pragma placement and leave it
20949 -- to the GNAAMP back end to detect the pragma (avoids transitive
20950 -- setting of the option due to withed units).
20952 if Is_Configuration_Pragma
then
20953 Universal_Addressing_On_AAMP
:= True;
20955 Check_Valid_Library_Unit_Pragma
;
20958 if not AAMP_On_Target
then
20959 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20966 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20968 when Pragma_Unmodified
=> Unmodified
: declare
20969 Arg_Node
: Node_Id
;
20970 Arg_Expr
: Node_Id
;
20971 Arg_Ent
: Entity_Id
;
20975 Check_At_Least_N_Arguments
(1);
20977 -- Loop through arguments
20980 while Present
(Arg_Node
) loop
20981 Check_No_Identifier
(Arg_Node
);
20983 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
20984 -- in fact generate reference, so that the entity will have a
20985 -- reference, which will inhibit any warnings about it not
20986 -- being referenced, and also properly show up in the ali file
20987 -- as a reference. But this reference is recorded before the
20988 -- Has_Pragma_Unreferenced flag is set, so that no warning is
20989 -- generated for this reference.
20991 Check_Arg_Is_Local_Name
(Arg_Node
);
20992 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20994 if Is_Entity_Name
(Arg_Expr
) then
20995 Arg_Ent
:= Entity
(Arg_Expr
);
20997 if not Is_Assignable
(Arg_Ent
) then
20999 ("pragma% can only be applied to a variable",
21002 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21014 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21016 -- or when used in a context clause:
21018 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21020 when Pragma_Unreferenced
=> Unreferenced
: declare
21021 Arg_Node
: Node_Id
;
21022 Arg_Expr
: Node_Id
;
21023 Arg_Ent
: Entity_Id
;
21028 Check_At_Least_N_Arguments
(1);
21030 -- Check case of appearing within context clause
21032 if Is_In_Context_Clause
then
21034 -- The arguments must all be units mentioned in a with clause
21035 -- in the same context clause. Note we already checked (in
21036 -- Par.Prag) that the arguments are either identifiers or
21037 -- selected components.
21040 while Present
(Arg_Node
) loop
21041 Citem
:= First
(List_Containing
(N
));
21042 while Citem
/= N
loop
21043 if Nkind
(Citem
) = N_With_Clause
21045 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21047 Set_Has_Pragma_Unreferenced
21050 (Library_Unit
(Citem
))));
21052 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21061 ("argument of pragma% is not withed unit", Arg_Node
);
21067 -- Case of not in list of context items
21071 while Present
(Arg_Node
) loop
21072 Check_No_Identifier
(Arg_Node
);
21074 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21075 -- will in fact generate reference, so that the entity will
21076 -- have a reference, which will inhibit any warnings about
21077 -- it not being referenced, and also properly show up in the
21078 -- ali file as a reference. But this reference is recorded
21079 -- before the Has_Pragma_Unreferenced flag is set, so that
21080 -- no warning is generated for this reference.
21082 Check_Arg_Is_Local_Name
(Arg_Node
);
21083 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21085 if Is_Entity_Name
(Arg_Expr
) then
21086 Arg_Ent
:= Entity
(Arg_Expr
);
21088 -- If the entity is overloaded, the pragma applies to the
21089 -- most recent overloading, as documented. In this case,
21090 -- name resolution does not generate a reference, so it
21091 -- must be done here explicitly.
21093 if Is_Overloaded
(Arg_Expr
) then
21094 Generate_Reference
(Arg_Ent
, N
);
21097 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21105 --------------------------
21106 -- Unreferenced_Objects --
21107 --------------------------
21109 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21111 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21112 Arg_Node
: Node_Id
;
21113 Arg_Expr
: Node_Id
;
21117 Check_At_Least_N_Arguments
(1);
21120 while Present
(Arg_Node
) loop
21121 Check_No_Identifier
(Arg_Node
);
21122 Check_Arg_Is_Local_Name
(Arg_Node
);
21123 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21125 if not Is_Entity_Name
(Arg_Expr
)
21126 or else not Is_Type
(Entity
(Arg_Expr
))
21129 ("argument for pragma% must be type or subtype", Arg_Node
);
21132 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21135 end Unreferenced_Objects
;
21137 ------------------------------
21138 -- Unreserve_All_Interrupts --
21139 ------------------------------
21141 -- pragma Unreserve_All_Interrupts;
21143 when Pragma_Unreserve_All_Interrupts
=>
21145 Check_Arg_Count
(0);
21147 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21148 Unreserve_All_Interrupts
:= True;
21155 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21157 when Pragma_Unsuppress
=>
21159 Process_Suppress_Unsuppress
(False);
21161 -------------------
21162 -- Use_VADS_Size --
21163 -------------------
21165 -- pragma Use_VADS_Size;
21167 when Pragma_Use_VADS_Size
=>
21169 Check_Arg_Count
(0);
21170 Check_Valid_Configuration_Pragma
;
21171 Use_VADS_Size
:= True;
21173 ---------------------
21174 -- Validity_Checks --
21175 ---------------------
21177 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21179 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21180 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21186 Check_Arg_Count
(1);
21187 Check_No_Identifiers
;
21189 -- Pragma always active unless in CodePeer or GNATprove modes,
21190 -- which use a fixed configuration of validity checks.
21192 if not (CodePeer_Mode
or GNATprove_Mode
) then
21193 if Nkind
(A
) = N_String_Literal
then
21197 Slen
: constant Natural := Natural (String_Length
(S
));
21198 Options
: String (1 .. Slen
);
21202 -- Couldn't we use a for loop here over Options'Range???
21206 C
:= Get_String_Char
(S
, Int
(J
));
21208 -- This is a weird test, it skips setting validity
21209 -- checks entirely if any element of S is out of
21210 -- range of Character, what is that about ???
21212 exit when not In_Character_Range
(C
);
21213 Options
(J
) := Get_Character
(C
);
21216 Set_Validity_Check_Options
(Options
);
21224 elsif Nkind
(A
) = N_Identifier
then
21225 if Chars
(A
) = Name_All_Checks
then
21226 Set_Validity_Check_Options
("a");
21227 elsif Chars
(A
) = Name_On
then
21228 Validity_Checks_On
:= True;
21229 elsif Chars
(A
) = Name_Off
then
21230 Validity_Checks_On
:= False;
21234 end Validity_Checks
;
21240 -- pragma Volatile (LOCAL_NAME);
21242 when Pragma_Volatile
=>
21243 Process_Atomic_Shared_Volatile
;
21245 -------------------------
21246 -- Volatile_Components --
21247 -------------------------
21249 -- pragma Volatile_Components (array_LOCAL_NAME);
21251 -- Volatile is handled by the same circuit as Atomic_Components
21253 ----------------------
21254 -- Warning_As_Error --
21255 ----------------------
21257 when Pragma_Warning_As_Error
=>
21259 Check_Arg_Count
(1);
21260 Check_No_Identifiers
;
21261 Check_Valid_Configuration_Pragma
;
21263 if not Is_Static_String_Expression
(Arg1
) then
21265 ("argument of pragma% must be static string expression",
21268 -- OK static string expression
21271 Acquire_Warning_Match_String
(Arg1
);
21272 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21273 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21274 new String'(Name_Buffer (1 .. Name_Len));
21281 -- pragma Warnings (On | Off [,REASON]);
21282 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
21283 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
21284 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
21286 -- REASON ::= Reason => Static_String_Expression
21288 when Pragma_Warnings => Warnings : declare
21289 Reason : String_Id;
21293 Check_At_Least_N_Arguments (1);
21295 -- See if last argument is labeled Reason. If so, make sure we
21296 -- have a static string expression, and acquire the REASON string.
21297 -- Then remove the REASON argument by decreasing Num_Args by one;
21298 -- Remaining processing looks only at first Num_Args arguments).
21301 Last_Arg : constant Node_Id :=
21302 Last (Pragma_Argument_Associations (N));
21305 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21306 and then Chars (Last_Arg) = Name_Reason
21309 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21310 Reason := End_String;
21311 Arg_Count := Arg_Count - 1;
21313 -- Not allowed in compiler units (bootstrap issues)
21315 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21317 -- No REASON string, set null string as reason
21320 Reason := Null_String_Id;
21324 -- Now proceed with REASON taken care of and eliminated
21326 Check_No_Identifiers;
21328 -- If debug flag -gnatd.i is set, pragma is ignored
21330 if Debug_Flag_Dot_I then
21334 -- Process various forms of the pragma
21337 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21340 -- One argument case
21342 if Arg_Count = 1 then
21344 -- On/Off one argument case was processed by parser
21346 if Nkind (Argx) = N_Identifier
21347 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21351 -- One argument case must be ON/OFF or static string expr
21353 elsif not Is_Static_String_Expression (Arg1) then
21355 ("argument of pragma% must be On/Off or static string "
21356 & "expression", Arg1);
21358 -- One argument string expression case
21362 Lit : constant Node_Id := Expr_Value_S (Argx);
21363 Str : constant String_Id := Strval (Lit);
21364 Len : constant Nat := String_Length (Str);
21372 while J <= Len loop
21373 C := Get_String_Char (Str, J);
21374 OK := In_Character_Range (C);
21377 Chr := Get_Character (C);
21379 -- Dash case: only -Wxxx is accepted
21386 C := Get_String_Char (Str, J);
21387 Chr := Get_Character (C);
21388 exit when Chr = 'W
';
21393 elsif J < Len and then Chr = '.' then
21395 C := Get_String_Char (Str, J);
21396 Chr := Get_Character (C);
21398 if not Set_Dot_Warning_Switch (Chr) then
21400 ("invalid warning switch character "
21401 & '.' & Chr, Arg1);
21407 OK := Set_Warning_Switch (Chr);
21413 ("invalid warning switch character " & Chr,
21422 -- Two or more arguments (must be two)
21425 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21426 Check_Arg_Count (2);
21434 E_Id := Get_Pragma_Arg (Arg2);
21437 -- In the expansion of an inlined body, a reference to
21438 -- the formal may be wrapped in a conversion if the
21439 -- actual is a conversion. Retrieve the real entity name.
21441 if (In_Instance_Body or In_Inlined_Body)
21442 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21444 E_Id := Expression (E_Id);
21447 -- Entity name case
21449 if Is_Entity_Name (E_Id) then
21450 E := Entity (E_Id);
21457 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21460 -- For OFF case, make entry in warnings off
21461 -- pragma table for later processing. But we do
21462 -- not do that within an instance, since these
21463 -- warnings are about what is needed in the
21464 -- template, not an instance of it.
21466 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21467 and then Warn_On_Warnings_Off
21468 and then not In_Instance
21470 Warnings_Off_Pragmas.Append ((N, E, Reason));
21473 if Is_Enumeration_Type (E) then
21477 Lit := First_Literal (E);
21478 while Present (Lit) loop
21479 Set_Warnings_Off (Lit);
21480 Next_Literal (Lit);
21485 exit when No (Homonym (E));
21490 -- Error if not entity or static string expression case
21492 elsif not Is_Static_String_Expression (Arg2) then
21494 ("second argument of pragma% must be entity name "
21495 & "or static string expression", Arg2);
21497 -- Static string expression case
21500 Acquire_Warning_Match_String (Arg2);
21502 -- Note on configuration pragma case: If this is a
21503 -- configuration pragma, then for an OFF pragma, we
21504 -- just set Config True in the call, which is all
21505 -- that needs to be done. For the case of ON, this
21506 -- is normally an error, unless it is canceling the
21507 -- effect of a previous OFF pragma in the same file.
21508 -- In any other case, an error will be signalled (ON
21509 -- with no matching OFF).
21511 -- Note: We set Used if we are inside a generic to
21512 -- disable the test that the non-config case actually
21513 -- cancels a warning. That's because we can't be sure
21514 -- there isn't an instantiation in some other unit
21515 -- where a warning is suppressed.
21517 -- We could do a little better here by checking if the
21518 -- generic unit we are inside is public, but for now
21519 -- we don't bother with that refinement.
21521 if Chars (Argx) = Name_Off then
21522 Set_Specific_Warning_Off
21523 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21524 Config => Is_Configuration_Pragma,
21525 Used => Inside_A_Generic or else In_Instance);
21527 elsif Chars (Argx) = Name_On then
21528 Set_Specific_Warning_On
21529 (Loc, Name_Buffer (1 .. Name_Len), Err);
21533 ("??pragma Warnings On with no matching "
21534 & "Warnings Off", Loc);
21543 -------------------
21544 -- Weak_External --
21545 -------------------
21547 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21549 when Pragma_Weak_External => Weak_External : declare
21554 Check_Arg_Count (1);
21555 Check_Optional_Identifier (Arg1, Name_Entity);
21556 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21557 Ent := Entity (Get_Pragma_Arg (Arg1));
21559 if Rep_Item_Too_Early (Ent, N) then
21562 Ent := Underlying_Type (Ent);
21565 -- The only processing required is to link this item on to the
21566 -- list of rep items for the given entity. This is accomplished
21567 -- by the call to Rep_Item_Too_Late (when no error is detected
21568 -- and False is returned).
21570 if Rep_Item_Too_Late (Ent, N) then
21573 Set_Has_Gigi_Rep_Item (Ent);
21577 -----------------------------
21578 -- Wide_Character_Encoding --
21579 -----------------------------
21581 -- pragma Wide_Character_Encoding (IDENTIFIER);
21583 when Pragma_Wide_Character_Encoding =>
21586 -- Nothing to do, handled in parser. Note that we do not enforce
21587 -- configuration pragma placement, this pragma can appear at any
21588 -- place in the source, allowing mixed encodings within a single
21593 --------------------
21594 -- Unknown_Pragma --
21595 --------------------
21597 -- Should be impossible, since the case of an unknown pragma is
21598 -- separately processed before the case statement is entered.
21600 when Unknown_Pragma =>
21601 raise Program_Error;
21604 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21605 -- until AI is formally approved.
21607 -- Check_Order_Dependence;
21610 when Pragma_Exit => null;
21611 end Analyze_Pragma;
21613 ---------------------------------------------
21614 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21615 ---------------------------------------------
21617 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21619 Subp_Id : Entity_Id)
21621 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21622 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21625 Restore_Scope : Boolean := False;
21626 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21629 -- Ensure that the subprogram and its formals are visible when analyzing
21630 -- the expression of the pragma.
21632 if not In_Open_Scopes (Subp_Id) then
21633 Restore_Scope := True;
21634 Push_Scope (Subp_Id);
21635 Install_Formals (Subp_Id);
21638 -- Preanalyze the boolean expression, we treat this as a spec expression
21639 -- (i.e. similar to a default expression).
21641 Expr := Get_Pragma_Arg (Arg1);
21643 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21644 -- the original aspect expression, which is shared with the generated
21647 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21648 Expr := Expression (Corresponding_Aspect (Prag));
21651 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21653 -- For a class-wide condition, a reference to a controlling formal must
21654 -- be interpreted as having the class-wide type (or an access to such)
21655 -- so that the inherited condition can be properly applied to any
21656 -- overriding operation (see ARM12 6.6.1 (7)).
21658 if Class_Present (Prag) then
21659 Class_Wide_Condition : declare
21660 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21662 ACW : Entity_Id := Empty;
21663 -- Access to T'class, created if there is a controlling formal
21664 -- that is an access parameter.
21666 function Get_ACW return Entity_Id;
21667 -- If the expression has a reference to an controlling access
21668 -- parameter, create an access to T'class for the necessary
21669 -- conversions if one does not exist.
21671 function Process (N : Node_Id) return Traverse_Result;
21672 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21673 -- aspect for a primitive subprogram of a tagged type T, a name
21674 -- that denotes a formal parameter of type T is interpreted as
21675 -- having type T'Class. Similarly, a name that denotes a formal
21676 -- accessparameter of type access-to-T is interpreted as having
21677 -- type access-to-T'Class. This ensures the expression is well-
21678 -- defined for a primitive subprogram of a type descended from T.
21679 -- Note that this replacement is not done for selector names in
21680 -- parameter associations. These carry an entity for reference
21681 -- purposes, but semantically they are just identifiers.
21687 function Get_ACW return Entity_Id is
21688 Loc : constant Source_Ptr := Sloc (Prag);
21694 Make_Full_Type_Declaration (Loc,
21695 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21697 Make_Access_To_Object_Definition (Loc,
21698 Subtype_Indication =>
21699 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21700 All_Present => True));
21702 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21704 ACW := Defining_Identifier (Decl);
21705 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21715 function Process (N : Node_Id) return Traverse_Result is
21716 Loc : constant Source_Ptr := Sloc (N);
21720 if Is_Entity_Name (N)
21721 and then Present (Entity (N))
21722 and then Is_Formal (Entity (N))
21723 and then Nkind (Parent (N)) /= N_Type_Conversion
21725 (Nkind (Parent (N)) /= N_Parameter_Association
21726 or else N /= Selector_Name (Parent (N)))
21728 if Etype (Entity (N)) = T then
21729 Typ := Class_Wide_Type (T);
21731 elsif Is_Access_Type (Etype (Entity (N)))
21732 and then Designated_Type (Etype (Entity (N))) = T
21739 if Present (Typ) then
21741 Make_Type_Conversion (Loc,
21743 New_Occurrence_Of (Typ, Loc),
21744 Expression => New_Occurrence_Of (Entity (N), Loc)));
21745 Set_Etype (N, Typ);
21752 procedure Replace_Type is new Traverse_Proc (Process);
21754 -- Start of processing for Class_Wide_Condition
21757 if not Present (T) then
21759 -- Pre'Class/Post'Class aspect cases
21761 if From_Aspect_Specification (Prag) then
21762 if Nam = Name_uPre then
21763 Error_Msg_Name_1 := Name_Pre;
21765 Error_Msg_Name_1 := Name_Post;
21768 Error_Msg_Name_2 := Name_Class;
21771 ("aspect `%''%` can only be specified for a primitive "
21772 & "operation of a tagged type",
21773 Corresponding_Aspect (Prag));
21775 -- Pre_Class, Post_Class pragma cases
21778 if Nam = Name_uPre then
21779 Error_Msg_Name_1 := Name_Pre_Class;
21781 Error_Msg_Name_1 := Name_Post_Class;
21785 ("pragma% can only be specified for a primitive "
21786 & "operation of a tagged type",
21787 Corresponding_Aspect (Prag));
21791 Replace_Type (Get_Pragma_Arg (Arg1));
21792 end Class_Wide_Condition;
21795 -- Remove the subprogram from the scope stack now that the pre-analysis
21796 -- of the precondition/postcondition is done.
21798 if Restore_Scope then
21801 end Analyze_Pre_Post_Condition_In_Decl_Part;
21803 ------------------------------------------
21804 -- Analyze_Refined_Depends_In_Decl_Part --
21805 ------------------------------------------
21807 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21808 Dependencies : List_Id := No_List;
21810 -- The corresponding Depends pragma along with its clauses
21812 Refinements : List_Id := No_List;
21813 -- The clauses of pragma Refined_Depends
21815 Spec_Id : Entity_Id;
21816 -- The entity of the subprogram subject to pragma Refined_Depends
21818 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21819 -- Verify the legality of a single clause
21821 function Input_Match
21822 (Dep_Input : Node_Id;
21823 Ref_Inputs : List_Id;
21824 Post_Errors : Boolean) return Boolean;
21825 -- Determine whether input Dep_Input matches one of inputs found in list
21826 -- Ref_Inputs. If flag Post_Errors is set, the routine reports missed or
21827 -- extra input items.
21829 function Inputs_Match
21830 (Dep_Clause : Node_Id;
21831 Ref_Clause : Node_Id;
21832 Post_Errors : Boolean) return Boolean;
21833 -- Determine whether the inputs of Depends clause Dep_Clause match those
21834 -- of refinement clause Ref_Clause. If flag Post_Errors is set, then the
21835 -- routine reports missed or extra input items.
21837 function Is_Self_Referential (Item_Id : Entity_Id) return Boolean;
21838 -- Determine whether a formal parameter, variable or state denoted by
21839 -- Item_Id appears both as input and an output in a single clause of
21842 procedure Report_Extra_Clauses;
21843 -- Emit an error for each extra clause the appears in Refined_Depends
21845 -----------------------------
21846 -- Check_Dependency_Clause --
21847 -----------------------------
21849 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21850 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21851 Dep_Id : Entity_Id;
21852 Matching_Clause : Node_Id := Empty;
21853 Next_Ref_Clause : Node_Id;
21854 Ref_Clause : Node_Id;
21855 Ref_Id : Entity_Id;
21856 Ref_Output : Node_Id;
21858 Has_Constituent : Boolean := False;
21859 -- Flag set when the refinement output list contains at least one
21860 -- constituent of the state denoted by Dep_Id.
21862 Has_Null_State : Boolean := False;
21863 -- Flag set when the output of clause Dep_Clause is a state with a
21864 -- null refinement.
21866 Has_Refined_State : Boolean := False;
21867 -- Flag set when the output of clause Dep_Clause is a state with
21868 -- visible refinement.
21871 -- The analysis of pragma Depends should produce normalized clauses
21872 -- with exactly one output. This is important because output items
21873 -- are unique in the whole dependence relation and can be used as
21876 pragma Assert (No (Next (Dep_Output)));
21878 -- Inspect all clauses of Refined_Depends and attempt to match the
21879 -- output of Dep_Clause against an output from the refinement clauses
21882 Ref_Clause := First (Refinements);
21883 while Present (Ref_Clause) loop
21884 Matching_Clause := Empty;
21886 -- Store the next clause now because a match will trim the list of
21887 -- refinement clauses and this side effect should not be visible
21888 -- in pragma Refined_Depends.
21890 Next_Ref_Clause := Next (Ref_Clause);
21892 -- The analysis of pragma Refined_Depends should produce
21893 -- normalized clauses with exactly one output.
21895 Ref_Output := First (Choices (Ref_Clause));
21896 pragma Assert (No (Next (Ref_Output)));
21898 -- Two null output lists match if their inputs match
21900 if Nkind (Dep_Output) = N_Null
21901 and then Nkind (Ref_Output) = N_Null
21903 Matching_Clause := Ref_Clause;
21906 -- Two function 'Result attributes match
if their inputs match
.
21907 -- Note that there is no need to compare the two prefixes because
21908 -- the attributes cannot denote anything but the related function.
21910 elsif Is_Attribute_Result
(Dep_Output
)
21911 and then Is_Attribute_Result
(Ref_Output
)
21913 Matching_Clause
:= Ref_Clause
;
21916 -- The remaining cases are formal parameters, variables and states
21918 elsif Is_Entity_Name
(Dep_Output
) then
21920 -- Handle abstract views of states and variables generated for
21921 -- limited with clauses.
21923 Dep_Id
:= Available_View
(Entity_Of
(Dep_Output
));
21925 if Ekind
(Dep_Id
) = E_Abstract_State
then
21927 -- A state with a null refinement matches either a null
21928 -- output list or nothing at all (no clause):
21930 -- Refined_State => (State => null)
21934 -- Depends => (State => null)
21935 -- Refined_Depends => null -- OK
21937 -- Null output list
21939 -- Depends => (State => <input>)
21940 -- Refined_Depends => (null => <input>) -- OK
21942 if Has_Null_Refinement
(Dep_Id
) then
21943 Has_Null_State
:= True;
21945 -- When a state with null refinement matches a null
21946 -- output, compare their inputs.
21948 if Nkind
(Ref_Output
) = N_Null
then
21949 Matching_Clause
:= Ref_Clause
;
21954 -- The state has a non-null refinement in which case the
21955 -- match is based on constituents and inputs. A state with
21956 -- multiple output constituents may match multiple clauses:
21958 -- Refined_State => (State => (C1, C2))
21959 -- Depends => (State => <input>)
21960 -- Refined_Depends => ((C1, C2) => <input>)
21962 -- When normalized, the above becomes:
21964 -- Refined_Depends => (C1 => <input>,
21967 elsif Has_Non_Null_Refinement
(Dep_Id
) then
21968 Has_Refined_State
:= True;
21970 -- Account for the case where a state with a non-null
21971 -- refinement matches a null output list:
21973 -- Refined_State => (State_1 => (C1, C2),
21974 -- State_2 => (C3, C4))
21975 -- Depends => (State_1 => State_2)
21976 -- Refined_Depends => (null => C3)
21978 if Nkind
(Ref_Output
) = N_Null
21979 and then Inputs_Match
21980 (Dep_Clause
=> Dep_Clause
,
21981 Ref_Clause
=> Ref_Clause
,
21982 Post_Errors
=> False)
21984 Has_Constituent
:= True;
21986 -- Note that the search continues after the clause is
21987 -- removed from the pool of candidates because it may
21988 -- have been normalized into multiple simple clauses.
21990 Remove
(Ref_Clause
);
21992 -- Otherwise the output of the refinement clause must be
21993 -- a valid constituent of the state:
21995 -- Refined_State => (State => (C1, C2))
21996 -- Depends => (State => <input>)
21997 -- Refined_Depends => (C1 => <input>)
21999 elsif Is_Entity_Name
(Ref_Output
) then
22000 Ref_Id
:= Entity_Of
(Ref_Output
);
22002 if Ekind_In
(Ref_Id
, E_Abstract_State
, E_Variable
)
22003 and then Present
(Encapsulating_State
(Ref_Id
))
22004 and then Encapsulating_State
(Ref_Id
) = Dep_Id
22005 and then Inputs_Match
22006 (Dep_Clause
=> Dep_Clause
,
22007 Ref_Clause
=> Ref_Clause
,
22008 Post_Errors
=> False)
22010 Has_Constituent
:= True;
22012 -- Note that the search continues after the clause
22013 -- is removed from the pool of candidates because
22014 -- it may have been normalized into multiple simple
22017 Remove
(Ref_Clause
);
22021 -- The abstract view of a state matches is corresponding
22022 -- non-abstract view:
22024 -- Depends => (Lim_Pack.State => <input>)
22025 -- Refined_Depends => (State => <input>)
22027 elsif Is_Entity_Name
(Ref_Output
)
22028 and then Entity_Of
(Ref_Output
) = Dep_Id
22030 Matching_Clause
:= Ref_Clause
;
22034 -- Formal parameters and variables match if their inputs match
22036 elsif Is_Entity_Name
(Ref_Output
)
22037 and then Entity_Of
(Ref_Output
) = Dep_Id
22039 Matching_Clause
:= Ref_Clause
;
22044 Ref_Clause
:= Next_Ref_Clause
;
22047 -- Handle the case where pragma Depends contains one or more clauses
22048 -- that only mention states with null refinements. In that case the
22049 -- corresponding pragma Refined_Depends may have a null relation.
22051 -- Refined_State => (State => null)
22052 -- Depends => (State => null)
22053 -- Refined_Depends => null -- OK
22055 -- Another instance of the same scenario occurs when the list of
22056 -- refinements has been depleted while processing previous clauses.
22058 if Is_Entity_Name
(Dep_Output
)
22059 and then (No
(Refinements
) or else Is_Empty_List
(Refinements
))
22061 Dep_Id
:= Entity_Of
(Dep_Output
);
22063 if Ekind
(Dep_Id
) = E_Abstract_State
22064 and then Has_Null_Refinement
(Dep_Id
)
22066 Has_Null_State
:= True;
22070 -- The above search produced a match based on unique output. Ensure
22071 -- that the inputs match as well and if they do, remove the clause
22072 -- from the pool of candidates.
22074 if Present
(Matching_Clause
) then
22076 (Ref_Clause
=> Ref_Clause
,
22077 Dep_Clause
=> Matching_Clause
,
22078 Post_Errors
=> True)
22080 Remove
(Matching_Clause
);
22083 -- A state with a visible refinement was matched against one or
22084 -- more clauses containing appropriate constituents.
22086 elsif Has_Constituent
then
22089 -- A state with a null refinement did not warrant a clause
22091 elsif Has_Null_State
then
22094 -- The dependence relation of pragma Refined_Depends does not contain
22095 -- a matching clause, emit an error.
22099 ("dependence clause of subprogram & has no matching refinement "
22100 & "in body", Ref_Clause
, Spec_Id
);
22102 if Has_Refined_State
then
22104 ("\check the use of constituents in dependence refinement",
22108 end Check_Dependency_Clause
;
22114 function Input_Match
22115 (Dep_Input
: Node_Id
;
22116 Ref_Inputs
: List_Id
;
22117 Post_Errors
: Boolean) return Boolean
22119 procedure Match_Error
(Msg
: String; N
: Node_Id
);
22120 -- Emit a matching error if flag Post_Errors is set
22126 procedure Match_Error
(Msg
: String; N
: Node_Id
) is
22128 if Post_Errors
then
22129 SPARK_Msg_N
(Msg
, N
);
22136 Next_Ref_Input
: Node_Id
;
22137 Ref_Id
: Entity_Id
;
22138 Ref_Input
: Node_Id
;
22140 Has_Constituent
: Boolean := False;
22141 -- Flag set when the refinement input list contains at least one
22142 -- constituent of the state denoted by Dep_Id.
22144 Has_Null_State
: Boolean := False;
22145 -- Flag set when the dependency input is a state with a visible null
22148 Has_Refined_State
: Boolean := False;
22149 -- Flag set when the dependency input is a state with visible non-
22150 -- null refinement.
22152 -- Start of processing for Input_Match
22155 -- Match a null input with another null input
22157 if Nkind
(Dep_Input
) = N_Null
then
22158 Ref_Input
:= First
(Ref_Inputs
);
22160 -- Remove the matching null from the pool of candidates
22162 if Nkind
(Ref_Input
) = N_Null
then
22163 Remove
(Ref_Input
);
22168 ("null input cannot be matched in corresponding refinement "
22169 & "clause", Dep_Input
);
22172 -- Remaining cases are formal parameters, variables, and states
22175 -- Handle abstract views of states and variables generated for
22176 -- limited with clauses.
22178 Dep_Id
:= Available_View
(Entity_Of
(Dep_Input
));
22180 -- Inspect all inputs of the refinement clause and attempt to
22181 -- match against the inputs of the dependence clause.
22183 Ref_Input
:= First
(Ref_Inputs
);
22184 while Present
(Ref_Input
) loop
22186 -- Store the next input now because a match will remove it from
22189 Next_Ref_Input
:= Next
(Ref_Input
);
22191 if Ekind
(Dep_Id
) = E_Abstract_State
then
22193 -- A state with a null refinement matches either a null
22194 -- input list or nothing at all (no input):
22196 -- Refined_State => (State => null)
22200 -- Depends => (<output> => (State, Input))
22201 -- Refined_Depends => (<output> => Input) -- OK
22205 -- Depends => (<output> => State)
22206 -- Refined_Depends => (<output> => null) -- OK
22208 if Has_Null_Refinement
(Dep_Id
) then
22209 Has_Null_State
:= True;
22211 -- Remove the matching null from the pool of candidates
22213 if Nkind
(Ref_Input
) = N_Null
then
22214 Remove
(Ref_Input
);
22219 -- The state has a non-null refinement in which case remove
22220 -- all the matching constituents of the state:
22222 -- Refined_State => (State => (C1, C2))
22223 -- Depends => (<output> => State)
22224 -- Refined_Depends => (<output> => (C1, C2))
22226 elsif Has_Non_Null_Refinement
(Dep_Id
) then
22227 Has_Refined_State
:= True;
22229 -- A state with a visible non-null refinement may have a
22230 -- null input_list only when it is self referential.
22232 -- Refined_State => (State => (C1, C2))
22233 -- Depends => (State => State)
22234 -- Refined_Depends => (C2 => null) -- OK
22236 if Nkind
(Ref_Input
) = N_Null
22237 and then Is_Self_Referential
(Dep_Id
)
22239 -- Remove the null from the pool of candidates. Note
22240 -- that the search continues because the state may be
22241 -- represented by multiple constituents.
22243 Has_Constituent
:= True;
22244 Remove
(Ref_Input
);
22246 -- Ref_Input is an entity name
22248 elsif Is_Entity_Name
(Ref_Input
) then
22249 Ref_Id
:= Entity_Of
(Ref_Input
);
22251 -- The input of the refinement clause is a valid
22252 -- constituent of the state. Remove the input from the
22253 -- pool of candidates. Note that the search continues
22254 -- because the state may be represented by multiple
22257 if Ekind_In
(Ref_Id
, E_Abstract_State
,
22259 and then Present
(Encapsulating_State
(Ref_Id
))
22260 and then Encapsulating_State
(Ref_Id
) = Dep_Id
22262 Has_Constituent
:= True;
22263 Remove
(Ref_Input
);
22267 -- The abstract view of a state matches its corresponding
22268 -- non-abstract view:
22270 -- Depends => (<output> => Lim_Pack.State)
22271 -- Refined_Depends => (<output> => State)
22273 elsif Is_Entity_Name
(Ref_Input
)
22274 and then Entity_Of
(Ref_Input
) = Dep_Id
22276 Remove
(Ref_Input
);
22280 -- Formal parameters and variables are matched on entities. If
22281 -- this is the case, remove the input from the candidate list.
22283 elsif Is_Entity_Name
(Ref_Input
)
22284 and then Entity_Of
(Ref_Input
) = Dep_Id
22286 Remove
(Ref_Input
);
22290 Ref_Input
:= Next_Ref_Input
;
22293 -- When a state with a null refinement appears as the last input,
22294 -- it matches nothing:
22296 -- Refined_State => (State => null)
22297 -- Depends => (<output> => (Input, State))
22298 -- Refined_Depends => (<output> => Input) -- OK
22300 if Ekind
(Dep_Id
) = E_Abstract_State
22301 and then Has_Null_Refinement
(Dep_Id
)
22302 and then No
(Ref_Input
)
22304 Has_Null_State
:= True;
22308 -- A state with visible refinement was matched against one or more of
22309 -- its constituents.
22311 if Has_Constituent
then
22314 -- A state with a null refinement matched null or nothing
22316 elsif Has_Null_State
then
22319 -- The input of a dependence clause does not have a matching input in
22320 -- the refinement clause, emit an error.
22324 ("input cannot be matched in corresponding refinement clause",
22327 if Has_Refined_State
then
22329 ("\check the use of constituents in dependence refinement",
22341 function Inputs_Match
22342 (Dep_Clause
: Node_Id
;
22343 Ref_Clause
: Node_Id
;
22344 Post_Errors
: Boolean) return Boolean
22346 Ref_Inputs
: List_Id
;
22347 -- The input list of the refinement clause
22349 procedure Report_Extra_Inputs
;
22350 -- Emit errors for all extra inputs that appear in Ref_Inputs
22352 -------------------------
22353 -- Report_Extra_Inputs --
22354 -------------------------
22356 procedure Report_Extra_Inputs
is
22360 if Present
(Ref_Inputs
) and then Post_Errors
then
22361 Input
:= First
(Ref_Inputs
);
22362 while Present
(Input
) loop
22364 ("unmatched or extra input in refinement clause", Input
);
22369 end Report_Extra_Inputs
;
22373 Dep_Inputs
: constant Node_Id
:= Expression
(Dep_Clause
);
22374 Inputs
: constant Node_Id
:= Expression
(Ref_Clause
);
22375 Dep_Input
: Node_Id
;
22378 -- Start of processing for Inputs_Match
22381 -- Construct a list of all refinement inputs. Note that the input
22382 -- list is copied because the algorithm modifies its contents and
22383 -- this should not be visible in Refined_Depends. The same applies
22384 -- for a solitary input.
22386 if Nkind
(Inputs
) = N_Aggregate
then
22387 Ref_Inputs
:= New_Copy_List
(Expressions
(Inputs
));
22389 Ref_Inputs
:= New_List
(New_Copy
(Inputs
));
22392 -- Depending on whether the original dependency clause mentions
22393 -- states with visible refinement, the corresponding refinement
22394 -- clause may differ greatly in structure and contents:
22396 -- State with null refinement
22398 -- Refined_State => (State => null)
22399 -- Depends => (<output> => State)
22400 -- Refined_Depends => (<output> => null)
22402 -- Depends => (<output> => (State, Input))
22403 -- Refined_Depends => (<output> => Input)
22405 -- Depends => (<output> => (Input_1, State, Input_2))
22406 -- Refined_Depends => (<output> => (Input_1, Input_2))
22408 -- State with non-null refinement
22410 -- Refined_State => (State_1 => (C1, C2))
22411 -- Depends => (<output> => State)
22412 -- Refined_Depends => (<output> => C1)
22414 -- Refined_Depends => (<output> => (C1, C2))
22416 if Nkind
(Dep_Inputs
) = N_Aggregate
then
22417 Dep_Input
:= First
(Expressions
(Dep_Inputs
));
22418 while Present
(Dep_Input
) loop
22420 (Dep_Input
=> Dep_Input
,
22421 Ref_Inputs
=> Ref_Inputs
,
22422 Post_Errors
=> Post_Errors
)
22437 (Dep_Input
=> Dep_Inputs
,
22438 Ref_Inputs
=> Ref_Inputs
,
22439 Post_Errors
=> Post_Errors
);
22442 -- List all inputs that appear as extras
22444 Report_Extra_Inputs
;
22449 -------------------------
22450 -- Is_Self_Referential --
22451 -------------------------
22453 function Is_Self_Referential
(Item_Id
: Entity_Id
) return Boolean is
22454 function Denotes_Item
(N
: Node_Id
) return Boolean;
22455 -- Determine whether an arbitrary node N denotes item Item_Id
22461 function Denotes_Item
(N
: Node_Id
) return Boolean is
22465 and then Present
(Entity
(N
))
22466 and then Entity
(N
) = Item_Id
;
22471 Clauses
: constant Node_Id
:=
22473 (First
(Pragma_Argument_Associations
(Depends
)));
22478 -- Start of processing for Is_Self_Referential
22481 Clause
:= First
(Component_Associations
(Clauses
));
22482 while Present
(Clause
) loop
22484 -- Due to normalization, a dependence clause has exactly one
22485 -- output even if the original clause had multiple outputs.
22487 Output
:= First
(Choices
(Clause
));
22489 -- Detect the following scenario:
22491 -- Item_Id => [(...,] Item_Id [, ...)]
22493 if Denotes_Item
(Output
) then
22494 Input
:= Expression
(Clause
);
22496 -- Multiple inputs appear as an aggregate
22498 if Nkind
(Input
) = N_Aggregate
then
22499 Input
:= First
(Expressions
(Input
));
22501 if Denotes_Item
(Input
) then
22509 elsif Denotes_Item
(Input
) then
22518 end Is_Self_Referential
;
22520 --------------------------
22521 -- Report_Extra_Clauses --
22522 --------------------------
22524 procedure Report_Extra_Clauses
is
22528 if Present
(Refinements
) then
22529 Clause
:= First
(Refinements
);
22530 while Present
(Clause
) loop
22532 -- Do not complain about a null input refinement, since a null
22533 -- input legitimately matches anything.
22535 if Nkind
(Clause
) /= N_Component_Association
22536 or else Nkind
(Expression
(Clause
)) /= N_Null
22539 ("unmatched or extra clause in dependence refinement",
22546 end Report_Extra_Clauses
;
22550 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22551 Errors
: constant Nat
:= Serious_Errors_Detected
;
22552 Refs
: constant Node_Id
:=
22553 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22557 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22560 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22561 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22563 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22566 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22568 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22569 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22571 if No
(Depends
) then
22573 ("useless refinement, declaration of subprogram & lacks aspect or "
22574 & "pragma Depends", N
, Spec_Id
);
22578 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
22580 -- A null dependency relation renders the refinement useless because it
22581 -- cannot possibly mention abstract states with visible refinement. Note
22582 -- that the inverse is not true as states may be refined to null
22583 -- (SPARK RM 7.2.5(2)).
22585 if Nkind
(Deps
) = N_Null
then
22587 ("useless refinement, subprogram & does not depend on abstract "
22588 & "state with visible refinement",
22593 -- Multiple dependency clauses appear as component associations of an
22596 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22597 Dependencies
:= Component_Associations
(Deps
);
22599 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22600 -- This ensures that the categorization of all refined dependency items
22601 -- is consistent with their role.
22603 Analyze_Depends_In_Decl_Part
(N
);
22605 if Serious_Errors_Detected
= Errors
then
22606 if Nkind
(Refs
) = N_Null
then
22607 Refinements
:= No_List
;
22609 -- Multiple dependency clauses appear as component associations of an
22610 -- aggregate. Note that the clauses are copied because the algorithm
22611 -- modifies them and this should not be visible in Refined_Depends.
22613 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22614 Refinements
:= New_Copy_List
(Component_Associations
(Refs
));
22617 -- Inspect all the clauses of pragma Depends looking for a matching
22618 -- clause in pragma Refined_Depends. The approach is to use the
22619 -- sole output of a clause as a key. Output items are unique in a
22620 -- dependence relation. Clause normalization also ensured that all
22621 -- clauses have exactly one output. Depending on what the key is, one
22622 -- or more refinement clauses may satisfy the dependency clause. Each
22623 -- time a dependency clause is matched, its related refinement clause
22624 -- is consumed. In the end, two things may happen:
22626 -- 1) A clause of pragma Depends was not matched in which case
22627 -- Check_Dependency_Clause reports the error.
22629 -- 2) Refined_Depends has an extra clause in which case the error
22630 -- is reported by Report_Extra_Clauses.
22632 Clause
:= First
(Dependencies
);
22633 while Present
(Clause
) loop
22634 Check_Dependency_Clause
(Clause
);
22639 if Serious_Errors_Detected
= Errors
then
22640 Report_Extra_Clauses
;
22642 end Analyze_Refined_Depends_In_Decl_Part
;
22644 -----------------------------------------
22645 -- Analyze_Refined_Global_In_Decl_Part --
22646 -----------------------------------------
22648 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22650 -- The corresponding Global pragma
22652 Has_In_State
: Boolean := False;
22653 Has_In_Out_State
: Boolean := False;
22654 Has_Out_State
: Boolean := False;
22655 Has_Proof_In_State
: Boolean := False;
22656 -- These flags are set when the corresponding Global pragma has a state
22657 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22660 Has_Null_State
: Boolean := False;
22661 -- This flag is set when the corresponding Global pragma has at least
22662 -- one state with a null refinement.
22664 In_Constits
: Elist_Id
:= No_Elist
;
22665 In_Out_Constits
: Elist_Id
:= No_Elist
;
22666 Out_Constits
: Elist_Id
:= No_Elist
;
22667 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22668 -- These lists contain the entities of all Input, In_Out, Output and
22669 -- Proof_In constituents that appear in Refined_Global and participate
22670 -- in state refinement.
22672 In_Items
: Elist_Id
:= No_Elist
;
22673 In_Out_Items
: Elist_Id
:= No_Elist
;
22674 Out_Items
: Elist_Id
:= No_Elist
;
22675 Proof_In_Items
: Elist_Id
:= No_Elist
;
22676 -- These list contain the entities of all Input, In_Out, Output and
22677 -- Proof_In items defined in the corresponding Global pragma.
22679 procedure Check_In_Out_States
;
22680 -- Determine whether the corresponding Global pragma mentions In_Out
22681 -- states with visible refinement and if so, ensure that one of the
22682 -- following completions apply to the constituents of the state:
22683 -- 1) there is at least one constituent of mode In_Out
22684 -- 2) there is at least one Input and one Output constituent
22685 -- 3) not all constituents are present and one of them is of mode
22687 -- This routine may remove elements from In_Constits, In_Out_Constits,
22688 -- Out_Constits and Proof_In_Constits.
22690 procedure Check_Input_States
;
22691 -- Determine whether the corresponding Global pragma mentions Input
22692 -- states with visible refinement and if so, ensure that at least one of
22693 -- its constituents appears as an Input item in Refined_Global.
22694 -- This routine may remove elements from In_Constits, In_Out_Constits,
22695 -- Out_Constits and Proof_In_Constits.
22697 procedure Check_Output_States
;
22698 -- Determine whether the corresponding Global pragma mentions Output
22699 -- states with visible refinement and if so, ensure that all of its
22700 -- constituents appear as Output items in Refined_Global.
22701 -- This routine may remove elements from In_Constits, In_Out_Constits,
22702 -- Out_Constits and Proof_In_Constits.
22704 procedure Check_Proof_In_States
;
22705 -- Determine whether the corresponding Global pragma mentions Proof_In
22706 -- states with visible refinement and if so, ensure that at least one of
22707 -- its constituents appears as a Proof_In item in Refined_Global.
22708 -- This routine may remove elements from In_Constits, In_Out_Constits,
22709 -- Out_Constits and Proof_In_Constits.
22711 procedure Check_Refined_Global_List
22713 Global_Mode
: Name_Id
:= Name_Input
);
22714 -- Verify the legality of a single global list declaration. Global_Mode
22715 -- denotes the current mode in effect.
22717 function Present_Then_Remove
22719 Item
: Entity_Id
) return Boolean;
22720 -- Search List for a particular entity Item. If Item has been found,
22721 -- remove it from List. This routine is used to strip lists In_Constits,
22722 -- In_Out_Constits and Out_Constits of valid constituents.
22724 procedure Report_Extra_Constituents
;
22725 -- Emit an error for each constituent found in lists In_Constits,
22726 -- In_Out_Constits and Out_Constits.
22728 -------------------------
22729 -- Check_In_Out_States --
22730 -------------------------
22732 procedure Check_In_Out_States
is
22733 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22734 -- Determine whether one of the following coverage scenarios is in
22736 -- 1) there is at least one constituent of mode In_Out
22737 -- 2) there is at least one Input and one Output constituent
22738 -- 3) not all constituents are present and one of them is of mode
22740 -- If this is not the case, emit an error.
22742 -----------------------------
22743 -- Check_Constituent_Usage --
22744 -----------------------------
22746 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22747 Constit_Elmt
: Elmt_Id
;
22748 Constit_Id
: Entity_Id
;
22749 Has_Missing
: Boolean := False;
22750 In_Out_Seen
: Boolean := False;
22751 In_Seen
: Boolean := False;
22752 Out_Seen
: Boolean := False;
22755 -- Process all the constituents of the state and note their modes
22756 -- within the global refinement.
22758 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22759 while Present
(Constit_Elmt
) loop
22760 Constit_Id
:= Node
(Constit_Elmt
);
22762 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22765 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22766 In_Out_Seen
:= True;
22768 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22771 -- A Proof_In constituent cannot participate in the completion
22772 -- of an Output state (SPARK RM 7.2.4(5)).
22774 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22775 Error_Msg_Name_1
:= Chars
(State_Id
);
22777 ("constituent & of state % must have mode Input, In_Out "
22778 & "or Output in global refinement",
22782 Has_Missing
:= True;
22785 Next_Elmt
(Constit_Elmt
);
22788 -- A single In_Out constituent is a valid completion
22790 if In_Out_Seen
then
22793 -- A pair of one Input and one Output constituent is a valid
22796 elsif In_Seen
and then Out_Seen
then
22799 -- A single Output constituent is a valid completion only when
22800 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22802 elsif Has_Missing
and then Out_Seen
then
22807 ("global refinement of state & redefines the mode of its "
22808 & "constituents", N
, State_Id
);
22810 end Check_Constituent_Usage
;
22814 Item_Elmt
: Elmt_Id
;
22815 Item_Id
: Entity_Id
;
22817 -- Start of processing for Check_In_Out_States
22820 -- Inspect the In_Out items of the corresponding Global pragma
22821 -- looking for a state with a visible refinement.
22823 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22824 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22825 while Present
(Item_Elmt
) loop
22826 Item_Id
:= Node
(Item_Elmt
);
22828 -- Ensure that one of the three coverage variants is satisfied
22830 if Ekind
(Item_Id
) = E_Abstract_State
22831 and then Has_Non_Null_Refinement
(Item_Id
)
22833 Check_Constituent_Usage
(Item_Id
);
22836 Next_Elmt
(Item_Elmt
);
22839 end Check_In_Out_States
;
22841 ------------------------
22842 -- Check_Input_States --
22843 ------------------------
22845 procedure Check_Input_States
is
22846 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22847 -- Determine whether at least one constituent of state State_Id with
22848 -- visible refinement is used and has mode Input. Ensure that the
22849 -- remaining constituents do not have In_Out, Output or Proof_In
22852 -----------------------------
22853 -- Check_Constituent_Usage --
22854 -----------------------------
22856 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22857 Constit_Elmt
: Elmt_Id
;
22858 Constit_Id
: Entity_Id
;
22859 In_Seen
: Boolean := False;
22862 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22863 while Present
(Constit_Elmt
) loop
22864 Constit_Id
:= Node
(Constit_Elmt
);
22866 -- At least one of the constituents appears as an Input
22868 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22871 -- The constituent appears in the global refinement, but has
22872 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22874 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22875 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22876 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22878 Error_Msg_Name_1
:= Chars
(State_Id
);
22880 ("constituent & of state % must have mode Input in global "
22881 & "refinement", N
, Constit_Id
);
22884 Next_Elmt
(Constit_Elmt
);
22887 -- Not one of the constituents appeared as Input
22889 if not In_Seen
then
22891 ("global refinement of state & must include at least one "
22892 & "constituent of mode Input", N
, State_Id
);
22894 end Check_Constituent_Usage
;
22898 Item_Elmt
: Elmt_Id
;
22899 Item_Id
: Entity_Id
;
22901 -- Start of processing for Check_Input_States
22904 -- Inspect the Input items of the corresponding Global pragma
22905 -- looking for a state with a visible refinement.
22907 if Has_In_State
and then Present
(In_Items
) then
22908 Item_Elmt
:= First_Elmt
(In_Items
);
22909 while Present
(Item_Elmt
) loop
22910 Item_Id
:= Node
(Item_Elmt
);
22912 -- Ensure that at least one of the constituents is utilized and
22913 -- is of mode Input.
22915 if Ekind
(Item_Id
) = E_Abstract_State
22916 and then Has_Non_Null_Refinement
(Item_Id
)
22918 Check_Constituent_Usage
(Item_Id
);
22921 Next_Elmt
(Item_Elmt
);
22924 end Check_Input_States
;
22926 -------------------------
22927 -- Check_Output_States --
22928 -------------------------
22930 procedure Check_Output_States
is
22931 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22932 -- Determine whether all constituents of state State_Id with visible
22933 -- refinement are used and have mode Output. Emit an error if this is
22936 -----------------------------
22937 -- Check_Constituent_Usage --
22938 -----------------------------
22940 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22941 Constit_Elmt
: Elmt_Id
;
22942 Constit_Id
: Entity_Id
;
22943 Posted
: Boolean := False;
22946 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22947 while Present
(Constit_Elmt
) loop
22948 Constit_Id
:= Node
(Constit_Elmt
);
22950 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22953 -- The constituent appears in the global refinement, but has
22954 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22956 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22957 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22958 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22960 Error_Msg_Name_1
:= Chars
(State_Id
);
22962 ("constituent & of state % must have mode Output in "
22963 & "global refinement", N
, Constit_Id
);
22965 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22971 ("output state & must be replaced by all its "
22972 & "constituents in global refinement", N
, State_Id
);
22976 ("\constituent & is missing in output list",
22980 Next_Elmt
(Constit_Elmt
);
22982 end Check_Constituent_Usage
;
22986 Item_Elmt
: Elmt_Id
;
22987 Item_Id
: Entity_Id
;
22989 -- Start of processing for Check_Output_States
22992 -- Inspect the Output items of the corresponding Global pragma
22993 -- looking for a state with a visible refinement.
22995 if Has_Out_State
and then Present
(Out_Items
) then
22996 Item_Elmt
:= First_Elmt
(Out_Items
);
22997 while Present
(Item_Elmt
) loop
22998 Item_Id
:= Node
(Item_Elmt
);
23000 -- Ensure that all of the constituents are utilized and they
23001 -- have mode Output.
23003 if Ekind
(Item_Id
) = E_Abstract_State
23004 and then Has_Non_Null_Refinement
(Item_Id
)
23006 Check_Constituent_Usage
(Item_Id
);
23009 Next_Elmt
(Item_Elmt
);
23012 end Check_Output_States
;
23014 ---------------------------
23015 -- Check_Proof_In_States --
23016 ---------------------------
23018 procedure Check_Proof_In_States
is
23019 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23020 -- Determine whether at least one constituent of state State_Id with
23021 -- visible refinement is used and has mode Proof_In. Ensure that the
23022 -- remaining constituents do not have Input, In_Out or Output modes.
23024 -----------------------------
23025 -- Check_Constituent_Usage --
23026 -----------------------------
23028 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23029 Constit_Elmt
: Elmt_Id
;
23030 Constit_Id
: Entity_Id
;
23031 Proof_In_Seen
: Boolean := False;
23034 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23035 while Present
(Constit_Elmt
) loop
23036 Constit_Id
:= Node
(Constit_Elmt
);
23038 -- At least one of the constituents appears as Proof_In
23040 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23041 Proof_In_Seen
:= True;
23043 -- The constituent appears in the global refinement, but has
23044 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23046 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23047 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23048 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23050 Error_Msg_Name_1
:= Chars
(State_Id
);
23052 ("constituent & of state % must have mode Proof_In in "
23053 & "global refinement", N
, Constit_Id
);
23056 Next_Elmt
(Constit_Elmt
);
23059 -- Not one of the constituents appeared as Proof_In
23061 if not Proof_In_Seen
then
23063 ("global refinement of state & must include at least one "
23064 & "constituent of mode Proof_In", N
, State_Id
);
23066 end Check_Constituent_Usage
;
23070 Item_Elmt
: Elmt_Id
;
23071 Item_Id
: Entity_Id
;
23073 -- Start of processing for Check_Proof_In_States
23076 -- Inspect the Proof_In items of the corresponding Global pragma
23077 -- looking for a state with a visible refinement.
23079 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23080 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23081 while Present
(Item_Elmt
) loop
23082 Item_Id
:= Node
(Item_Elmt
);
23084 -- Ensure that at least one of the constituents is utilized and
23085 -- is of mode Proof_In
23087 if Ekind
(Item_Id
) = E_Abstract_State
23088 and then Has_Non_Null_Refinement
(Item_Id
)
23090 Check_Constituent_Usage
(Item_Id
);
23093 Next_Elmt
(Item_Elmt
);
23096 end Check_Proof_In_States
;
23098 -------------------------------
23099 -- Check_Refined_Global_List --
23100 -------------------------------
23102 procedure Check_Refined_Global_List
23104 Global_Mode
: Name_Id
:= Name_Input
)
23106 procedure Check_Refined_Global_Item
23108 Global_Mode
: Name_Id
);
23109 -- Verify the legality of a single global item declaration. Parameter
23110 -- Global_Mode denotes the current mode in effect.
23112 -------------------------------
23113 -- Check_Refined_Global_Item --
23114 -------------------------------
23116 procedure Check_Refined_Global_Item
23118 Global_Mode
: Name_Id
)
23120 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23122 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23123 -- Issue a common error message for all mode mismatches. Expect
23124 -- denotes the expected mode.
23126 -----------------------------
23127 -- Inconsistent_Mode_Error --
23128 -----------------------------
23130 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23133 ("global item & has inconsistent modes", Item
, Item_Id
);
23135 Error_Msg_Name_1
:= Global_Mode
;
23136 Error_Msg_Name_2
:= Expect
;
23137 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
23138 end Inconsistent_Mode_Error
;
23140 -- Start of processing for Check_Refined_Global_Item
23143 -- When the state or variable acts as a constituent of another
23144 -- state with a visible refinement, collect it for the state
23145 -- completeness checks performed later on.
23147 if Present
(Encapsulating_State
(Item_Id
))
23148 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23150 if Global_Mode
= Name_Input
then
23151 Add_Item
(Item_Id
, In_Constits
);
23153 elsif Global_Mode
= Name_In_Out
then
23154 Add_Item
(Item_Id
, In_Out_Constits
);
23156 elsif Global_Mode
= Name_Output
then
23157 Add_Item
(Item_Id
, Out_Constits
);
23159 elsif Global_Mode
= Name_Proof_In
then
23160 Add_Item
(Item_Id
, Proof_In_Constits
);
23163 -- When not a constituent, ensure that both occurrences of the
23164 -- item in pragmas Global and Refined_Global match.
23166 elsif Contains
(In_Items
, Item_Id
) then
23167 if Global_Mode
/= Name_Input
then
23168 Inconsistent_Mode_Error
(Name_Input
);
23171 elsif Contains
(In_Out_Items
, Item_Id
) then
23172 if Global_Mode
/= Name_In_Out
then
23173 Inconsistent_Mode_Error
(Name_In_Out
);
23176 elsif Contains
(Out_Items
, Item_Id
) then
23177 if Global_Mode
/= Name_Output
then
23178 Inconsistent_Mode_Error
(Name_Output
);
23181 elsif Contains
(Proof_In_Items
, Item_Id
) then
23184 -- The item does not appear in the corresponding Global pragma,
23185 -- it must be an extra (SPARK RM 7.2.4(3)).
23188 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
23190 end Check_Refined_Global_Item
;
23196 -- Start of processing for Check_Refined_Global_List
23199 if Nkind
(List
) = N_Null
then
23202 -- Single global item declaration
23204 elsif Nkind_In
(List
, N_Expanded_Name
,
23206 N_Selected_Component
)
23208 Check_Refined_Global_Item
(List
, Global_Mode
);
23210 -- Simple global list or moded global list declaration
23212 elsif Nkind
(List
) = N_Aggregate
then
23214 -- The declaration of a simple global list appear as a collection
23217 if Present
(Expressions
(List
)) then
23218 Item
:= First
(Expressions
(List
));
23219 while Present
(Item
) loop
23220 Check_Refined_Global_Item
(Item
, Global_Mode
);
23225 -- The declaration of a moded global list appears as a collection
23226 -- of component associations where individual choices denote
23229 elsif Present
(Component_Associations
(List
)) then
23230 Item
:= First
(Component_Associations
(List
));
23231 while Present
(Item
) loop
23232 Check_Refined_Global_List
23233 (List
=> Expression
(Item
),
23234 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23242 raise Program_Error
;
23248 raise Program_Error
;
23250 end Check_Refined_Global_List
;
23252 -------------------------
23253 -- Present_Then_Remove --
23254 -------------------------
23256 function Present_Then_Remove
23258 Item
: Entity_Id
) return Boolean
23263 if Present
(List
) then
23264 Elmt
:= First_Elmt
(List
);
23265 while Present
(Elmt
) loop
23266 if Node
(Elmt
) = Item
then
23267 Remove_Elmt
(List
, Elmt
);
23276 end Present_Then_Remove
;
23278 -------------------------------
23279 -- Report_Extra_Constituents --
23280 -------------------------------
23282 procedure Report_Extra_Constituents
is
23283 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23284 -- Emit an error for every element of List
23286 ---------------------------------------
23287 -- Report_Extra_Constituents_In_List --
23288 ---------------------------------------
23290 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23291 Constit_Elmt
: Elmt_Id
;
23294 if Present
(List
) then
23295 Constit_Elmt
:= First_Elmt
(List
);
23296 while Present
(Constit_Elmt
) loop
23297 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23298 Next_Elmt
(Constit_Elmt
);
23301 end Report_Extra_Constituents_In_List
;
23303 -- Start of processing for Report_Extra_Constituents
23306 Report_Extra_Constituents_In_List
(In_Constits
);
23307 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23308 Report_Extra_Constituents_In_List
(Out_Constits
);
23309 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23310 end Report_Extra_Constituents
;
23314 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23315 Errors
: constant Nat
:= Serious_Errors_Detected
;
23316 Items
: constant Node_Id
:=
23317 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23318 Spec_Id
: Entity_Id
;
23320 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23323 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23324 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23326 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23329 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23331 -- The subprogram declaration lacks pragma Global. This renders
23332 -- Refined_Global useless as there is nothing to refine.
23334 if No
(Global
) then
23336 ("useless refinement, declaration of subprogram & lacks aspect or "
23337 & "pragma Global", N
, Spec_Id
);
23341 -- Extract all relevant items from the corresponding Global pragma
23343 Collect_Global_Items
23345 In_Items
=> In_Items
,
23346 In_Out_Items
=> In_Out_Items
,
23347 Out_Items
=> Out_Items
,
23348 Proof_In_Items
=> Proof_In_Items
,
23349 Has_In_State
=> Has_In_State
,
23350 Has_In_Out_State
=> Has_In_Out_State
,
23351 Has_Out_State
=> Has_Out_State
,
23352 Has_Proof_In_State
=> Has_Proof_In_State
,
23353 Has_Null_State
=> Has_Null_State
);
23355 -- Corresponding Global pragma must mention at least one state witha
23356 -- visible refinement at the point Refined_Global is processed. States
23357 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23359 if not Has_In_State
23360 and then not Has_In_Out_State
23361 and then not Has_Out_State
23362 and then not Has_Proof_In_State
23363 and then not Has_Null_State
23366 ("useless refinement, subprogram & does not depend on abstract "
23367 & "state with visible refinement", N
, Spec_Id
);
23371 -- The global refinement of inputs and outputs cannot be null when the
23372 -- corresponding Global pragma contains at least one item except in the
23373 -- case where we have states with null refinements.
23375 if Nkind
(Items
) = N_Null
23377 (Present
(In_Items
)
23378 or else Present
(In_Out_Items
)
23379 or else Present
(Out_Items
)
23380 or else Present
(Proof_In_Items
))
23381 and then not Has_Null_State
23384 ("refinement cannot be null, subprogram & has global items",
23389 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23390 -- This ensures that the categorization of all refined global items is
23391 -- consistent with their role.
23393 Analyze_Global_In_Decl_Part
(N
);
23395 -- Perform all refinement checks with respect to completeness and mode
23398 if Serious_Errors_Detected
= Errors
then
23399 Check_Refined_Global_List
(Items
);
23402 -- For Input states with visible refinement, at least one constituent
23403 -- must be used as an Input in the global refinement.
23405 if Serious_Errors_Detected
= Errors
then
23406 Check_Input_States
;
23409 -- Verify all possible completion variants for In_Out states with
23410 -- visible refinement.
23412 if Serious_Errors_Detected
= Errors
then
23413 Check_In_Out_States
;
23416 -- For Output states with visible refinement, all constituents must be
23417 -- used as Outputs in the global refinement.
23419 if Serious_Errors_Detected
= Errors
then
23420 Check_Output_States
;
23423 -- For Proof_In states with visible refinement, at least one constituent
23424 -- must be used as Proof_In in the global refinement.
23426 if Serious_Errors_Detected
= Errors
then
23427 Check_Proof_In_States
;
23430 -- Emit errors for all constituents that belong to other states with
23431 -- visible refinement that do not appear in Global.
23433 if Serious_Errors_Detected
= Errors
then
23434 Report_Extra_Constituents
;
23436 end Analyze_Refined_Global_In_Decl_Part
;
23438 ----------------------------------------
23439 -- Analyze_Refined_State_In_Decl_Part --
23440 ----------------------------------------
23442 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23443 Available_States
: Elist_Id
:= No_Elist
;
23444 -- A list of all abstract states defined in the package declaration that
23445 -- are available for refinement. The list is used to report unrefined
23448 Body_Id
: Entity_Id
;
23449 -- The body entity of the package subject to pragma Refined_State
23451 Body_States
: Elist_Id
:= No_Elist
;
23452 -- A list of all hidden states that appear in the body of the related
23453 -- package. The list is used to report unused hidden states.
23455 Constituents_Seen
: Elist_Id
:= No_Elist
;
23456 -- A list that contains all constituents processed so far. The list is
23457 -- used to detect multiple uses of the same constituent.
23459 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23460 -- A list that contains all refined states processed so far. The list is
23461 -- used to detect duplicate refinements.
23463 Spec_Id
: Entity_Id
;
23464 -- The spec entity of the package subject to pragma Refined_State
23466 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23467 -- Perform full analysis of a single refinement clause
23469 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23470 -- Gather the entities of all abstract states and variables declared in
23471 -- the body state space of package Pack_Id.
23473 procedure Report_Unrefined_States
(States
: Elist_Id
);
23474 -- Emit errors for all unrefined abstract states found in list States
23476 procedure Report_Unused_States
(States
: Elist_Id
);
23477 -- Emit errors for all unused states found in list States
23479 -------------------------------
23480 -- Analyze_Refinement_Clause --
23481 -------------------------------
23483 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23484 AR_Constit
: Entity_Id
:= Empty
;
23485 AW_Constit
: Entity_Id
:= Empty
;
23486 ER_Constit
: Entity_Id
:= Empty
;
23487 EW_Constit
: Entity_Id
:= Empty
;
23488 -- The entities of external constituents that contain one of the
23489 -- following enabled properties: Async_Readers, Async_Writers,
23490 -- Effective_Reads and Effective_Writes.
23492 External_Constit_Seen
: Boolean := False;
23493 -- Flag used to mark when at least one external constituent is part
23494 -- of the state refinement.
23496 Non_Null_Seen
: Boolean := False;
23497 Null_Seen
: Boolean := False;
23498 -- Flags used to detect multiple uses of null in a single clause or a
23499 -- mixture of null and non-null constituents.
23501 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23502 -- A list of all candidate constituents subject to indicator Part_Of
23503 -- where the encapsulating state is the current state.
23506 State_Id
: Entity_Id
;
23507 -- The current state being refined
23509 procedure Analyze_Constituent
(Constit
: Node_Id
);
23510 -- Perform full analysis of a single constituent
23512 procedure Check_External_Property
23513 (Prop_Nam
: Name_Id
;
23515 Constit
: Entity_Id
);
23516 -- Determine whether a property denoted by name Prop_Nam is present
23517 -- in both the refined state and constituent Constit. Flag Enabled
23518 -- should be set when the property applies to the refined state. If
23519 -- this is not the case, emit an error message.
23521 procedure Check_Matching_State
;
23522 -- Determine whether the state being refined appears in list
23523 -- Available_States. Emit an error when attempting to re-refine the
23524 -- state or when the state is not defined in the package declaration,
23525 -- otherwise remove the state from Available_States.
23527 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23528 -- Emit errors for all unused Part_Of constituents in list Constits
23530 -------------------------
23531 -- Analyze_Constituent --
23532 -------------------------
23534 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23535 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23536 -- Determine whether constituent Constit denoted by its entity
23537 -- Constit_Id appears in Hidden_States. Emit an error when the
23538 -- constituent is not a valid hidden state of the related package
23539 -- or when it is used more than once. Otherwise remove the
23540 -- constituent from Hidden_States.
23542 --------------------------------
23543 -- Check_Matching_Constituent --
23544 --------------------------------
23546 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23547 procedure Collect_Constituent
;
23548 -- Add constituent Constit_Id to the refinements of State_Id
23550 -------------------------
23551 -- Collect_Constituent --
23552 -------------------------
23554 procedure Collect_Constituent
is
23556 -- Add the constituent to the list of processed items to aid
23557 -- with the detection of duplicates.
23559 Add_Item
(Constit_Id
, Constituents_Seen
);
23561 -- Collect the constituent in the list of refinement items
23562 -- and establish a relation between the refined state and
23565 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23566 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23568 -- The state has at least one legal constituent, mark the
23569 -- start of the refinement region. The region ends when the
23570 -- body declarations end (see routine Analyze_Declarations).
23572 Set_Has_Visible_Refinement
(State_Id
);
23574 -- When the constituent is external, save its relevant
23575 -- property for further checks.
23577 if Async_Readers_Enabled
(Constit_Id
) then
23578 AR_Constit
:= Constit_Id
;
23579 External_Constit_Seen
:= True;
23582 if Async_Writers_Enabled
(Constit_Id
) then
23583 AW_Constit
:= Constit_Id
;
23584 External_Constit_Seen
:= True;
23587 if Effective_Reads_Enabled
(Constit_Id
) then
23588 ER_Constit
:= Constit_Id
;
23589 External_Constit_Seen
:= True;
23592 if Effective_Writes_Enabled
(Constit_Id
) then
23593 EW_Constit
:= Constit_Id
;
23594 External_Constit_Seen
:= True;
23596 end Collect_Constituent
;
23600 State_Elmt
: Elmt_Id
;
23602 -- Start of processing for Check_Matching_Constituent
23605 -- Detect a duplicate use of a constituent
23607 if Contains
(Constituents_Seen
, Constit_Id
) then
23609 ("duplicate use of constituent &", Constit
, Constit_Id
);
23613 -- The constituent is subject to a Part_Of indicator
23615 if Present
(Encapsulating_State
(Constit_Id
)) then
23616 if Encapsulating_State
(Constit_Id
) = State_Id
then
23617 Remove
(Part_Of_Constits
, Constit_Id
);
23618 Collect_Constituent
;
23620 -- The constituent is part of another state and is used
23621 -- incorrectly in the refinement of the current state.
23624 Error_Msg_Name_1
:= Chars
(State_Id
);
23626 ("& cannot act as constituent of state %",
23627 Constit
, Constit_Id
);
23629 ("\Part_Of indicator specifies & as encapsulating "
23630 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23633 -- The only other source of legal constituents is the body
23634 -- state space of the related package.
23637 if Present
(Body_States
) then
23638 State_Elmt
:= First_Elmt
(Body_States
);
23639 while Present
(State_Elmt
) loop
23641 -- Consume a valid constituent to signal that it has
23642 -- been encountered.
23644 if Node
(State_Elmt
) = Constit_Id
then
23645 Remove_Elmt
(Body_States
, State_Elmt
);
23646 Collect_Constituent
;
23650 Next_Elmt
(State_Elmt
);
23654 -- If we get here, then the constituent is not a hidden
23655 -- state of the related package and may not be used in a
23656 -- refinement (SPARK RM 7.2.2(9)).
23658 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23660 ("cannot use & in refinement, constituent is not a hidden "
23661 & "state of package %", Constit
, Constit_Id
);
23663 end Check_Matching_Constituent
;
23667 Constit_Id
: Entity_Id
;
23669 -- Start of processing for Analyze_Constituent
23672 -- Detect multiple uses of null in a single refinement clause or a
23673 -- mixture of null and non-null constituents.
23675 if Nkind
(Constit
) = N_Null
then
23678 ("multiple null constituents not allowed", Constit
);
23680 elsif Non_Null_Seen
then
23682 ("cannot mix null and non-null constituents", Constit
);
23687 -- Collect the constituent in the list of refinement items
23689 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23691 -- The state has at least one legal constituent, mark the
23692 -- start of the refinement region. The region ends when the
23693 -- body declarations end (see Analyze_Declarations).
23695 Set_Has_Visible_Refinement
(State_Id
);
23698 -- Non-null constituents
23701 Non_Null_Seen
:= True;
23705 ("cannot mix null and non-null constituents", Constit
);
23709 Resolve_State
(Constit
);
23711 -- Ensure that the constituent denotes a valid state or a
23714 if Is_Entity_Name
(Constit
) then
23715 Constit_Id
:= Entity_Of
(Constit
);
23717 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
23718 Check_Matching_Constituent
(Constit_Id
);
23722 ("constituent & must denote a variable or state (SPARK "
23723 & "RM 7.2.2(5))", Constit
, Constit_Id
);
23726 -- The constituent is illegal
23729 SPARK_Msg_N
("malformed constituent", Constit
);
23732 end Analyze_Constituent
;
23734 -----------------------------
23735 -- Check_External_Property --
23736 -----------------------------
23738 procedure Check_External_Property
23739 (Prop_Nam
: Name_Id
;
23741 Constit
: Entity_Id
)
23744 Error_Msg_Name_1
:= Prop_Nam
;
23746 -- The property is enabled in the related Abstract_State pragma
23747 -- that defines the state (SPARK RM 7.2.8(3)).
23750 if No
(Constit
) then
23752 ("external state & requires at least one constituent with "
23753 & "property %", State
, State_Id
);
23756 -- The property is missing in the declaration of the state, but
23757 -- a constituent is introducing it in the state refinement
23758 -- (SPARK RM 7.2.8(3)).
23760 elsif Present
(Constit
) then
23761 Error_Msg_Name_2
:= Chars
(Constit
);
23763 ("external state & lacks property % set by constituent %",
23766 end Check_External_Property
;
23768 --------------------------
23769 -- Check_Matching_State --
23770 --------------------------
23772 procedure Check_Matching_State
is
23773 State_Elmt
: Elmt_Id
;
23776 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23778 if Contains
(Refined_States_Seen
, State_Id
) then
23780 ("duplicate refinement of state &", State
, State_Id
);
23784 -- Inspect the abstract states defined in the package declaration
23785 -- looking for a match.
23787 State_Elmt
:= First_Elmt
(Available_States
);
23788 while Present
(State_Elmt
) loop
23790 -- A valid abstract state is being refined in the body. Add
23791 -- the state to the list of processed refined states to aid
23792 -- with the detection of duplicate refinements. Remove the
23793 -- state from Available_States to signal that it has already
23796 if Node
(State_Elmt
) = State_Id
then
23797 Add_Item
(State_Id
, Refined_States_Seen
);
23798 Remove_Elmt
(Available_States
, State_Elmt
);
23802 Next_Elmt
(State_Elmt
);
23805 -- If we get here, we are refining a state that is not defined in
23806 -- the package declaration.
23808 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23810 ("cannot refine state, & is not defined in package %",
23812 end Check_Matching_State
;
23814 --------------------------------
23815 -- Report_Unused_Constituents --
23816 --------------------------------
23818 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
23819 Constit_Elmt
: Elmt_Id
;
23820 Constit_Id
: Entity_Id
;
23821 Posted
: Boolean := False;
23824 if Present
(Constits
) then
23825 Constit_Elmt
:= First_Elmt
(Constits
);
23826 while Present
(Constit_Elmt
) loop
23827 Constit_Id
:= Node
(Constit_Elmt
);
23829 -- Generate an error message of the form:
23831 -- state ... has unused Part_Of constituents
23832 -- abstract state ... defined at ...
23833 -- variable ... defined at ...
23838 ("state & has unused Part_Of constituents",
23842 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
23844 if Ekind
(Constit_Id
) = E_Abstract_State
then
23846 ("\abstract state & defined #", State
, Constit_Id
);
23849 ("\variable & defined #", State
, Constit_Id
);
23852 Next_Elmt
(Constit_Elmt
);
23855 end Report_Unused_Constituents
;
23857 -- Local declarations
23859 Body_Ref
: Node_Id
;
23860 Body_Ref_Elmt
: Elmt_Id
;
23862 Extra_State
: Node_Id
;
23864 -- Start of processing for Analyze_Refinement_Clause
23867 -- A refinement clause appears as a component association where the
23868 -- sole choice is the state and the expressions are the constituents.
23869 -- This is a syntax error, always report.
23871 if Nkind
(Clause
) /= N_Component_Association
then
23872 Error_Msg_N
("malformed state refinement clause", Clause
);
23876 -- Analyze the state name of a refinement clause
23878 State
:= First
(Choices
(Clause
));
23881 Resolve_State
(State
);
23883 -- Ensure that the state name denotes a valid abstract state that is
23884 -- defined in the spec of the related package.
23886 if Is_Entity_Name
(State
) then
23887 State_Id
:= Entity_Of
(State
);
23889 -- Catch any attempts to re-refine a state or refine a state that
23890 -- is not defined in the package declaration.
23892 if Ekind
(State_Id
) = E_Abstract_State
then
23893 Check_Matching_State
;
23896 ("& must denote an abstract state", State
, State_Id
);
23900 -- References to a state with visible refinement are illegal.
23901 -- When nested packages are involved, detecting such references is
23902 -- tricky because pragma Refined_State is analyzed later than the
23903 -- offending pragma Depends or Global. References that occur in
23904 -- such nested context are stored in a list. Emit errors for all
23905 -- references found in Body_References (SPARK RM 6.1.4(8)).
23907 if Present
(Body_References
(State_Id
)) then
23908 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
23909 while Present
(Body_Ref_Elmt
) loop
23910 Body_Ref
:= Node
(Body_Ref_Elmt
);
23912 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
23913 Error_Msg_Sloc
:= Sloc
(State
);
23914 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
23916 Next_Elmt
(Body_Ref_Elmt
);
23920 -- The state name is illegal. This is a syntax error, always report.
23923 Error_Msg_N
("malformed state name in refinement clause", State
);
23927 -- A refinement clause may only refine one state at a time
23929 Extra_State
:= Next
(State
);
23931 if Present
(Extra_State
) then
23933 ("refinement clause cannot cover multiple states", Extra_State
);
23936 -- Replicate the Part_Of constituents of the refined state because
23937 -- the algorithm will consume items.
23939 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
23941 -- Analyze all constituents of the refinement. Multiple constituents
23942 -- appear as an aggregate.
23944 Constit
:= Expression
(Clause
);
23946 if Nkind
(Constit
) = N_Aggregate
then
23947 if Present
(Component_Associations
(Constit
)) then
23949 ("constituents of refinement clause must appear in "
23950 & "positional form", Constit
);
23952 else pragma Assert
(Present
(Expressions
(Constit
)));
23953 Constit
:= First
(Expressions
(Constit
));
23954 while Present
(Constit
) loop
23955 Analyze_Constituent
(Constit
);
23961 -- Various forms of a single constituent. Note that these may include
23962 -- malformed constituents.
23965 Analyze_Constituent
(Constit
);
23968 -- A refined external state is subject to special rules with respect
23969 -- to its properties and constituents.
23971 if Is_External_State
(State_Id
) then
23973 -- The set of properties that all external constituents yield must
23974 -- match that of the refined state. There are two cases to detect:
23975 -- the refined state lacks a property or has an extra property.
23977 if External_Constit_Seen
then
23978 Check_External_Property
23979 (Prop_Nam
=> Name_Async_Readers
,
23980 Enabled
=> Async_Readers_Enabled
(State_Id
),
23981 Constit
=> AR_Constit
);
23983 Check_External_Property
23984 (Prop_Nam
=> Name_Async_Writers
,
23985 Enabled
=> Async_Writers_Enabled
(State_Id
),
23986 Constit
=> AW_Constit
);
23988 Check_External_Property
23989 (Prop_Nam
=> Name_Effective_Reads
,
23990 Enabled
=> Effective_Reads_Enabled
(State_Id
),
23991 Constit
=> ER_Constit
);
23993 Check_External_Property
23994 (Prop_Nam
=> Name_Effective_Writes
,
23995 Enabled
=> Effective_Writes_Enabled
(State_Id
),
23996 Constit
=> EW_Constit
);
23998 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24000 elsif Null_Seen
then
24003 -- The external state has constituents, but none of them are
24004 -- external (SPARK RM 7.2.8(2)).
24008 ("external state & requires at least one external "
24009 & "constituent or null refinement", State
, State_Id
);
24012 -- When a refined state is not external, it should not have external
24013 -- constituents (SPARK RM 7.2.8(1)).
24015 elsif External_Constit_Seen
then
24017 ("non-external state & cannot contain external constituents in "
24018 & "refinement", State
, State_Id
);
24021 -- Ensure that all Part_Of candidate constituents have been mentioned
24022 -- in the refinement clause.
24024 Report_Unused_Constituents
(Part_Of_Constits
);
24025 end Analyze_Refinement_Clause
;
24027 -------------------------
24028 -- Collect_Body_States --
24029 -------------------------
24031 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24032 Result
: Elist_Id
:= No_Elist
;
24033 -- A list containing all body states of Pack_Id
24035 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24036 -- Gather the entities of all abstract states and variables declared
24037 -- in the visible state space of package Pack_Id.
24039 ----------------------------
24040 -- Collect_Visible_States --
24041 ----------------------------
24043 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24044 Item_Id
: Entity_Id
;
24047 -- Traverse the entity chain of the package and inspect all
24050 Item_Id
:= First_Entity
(Pack_Id
);
24051 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24053 -- Do not consider internally generated items as those cannot
24054 -- be named and participate in refinement.
24056 if not Comes_From_Source
(Item_Id
) then
24059 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24060 Add_Item
(Item_Id
, Result
);
24062 -- Recursively gather the visible states of a nested package
24064 elsif Ekind
(Item_Id
) = E_Package
then
24065 Collect_Visible_States
(Item_Id
);
24068 Next_Entity
(Item_Id
);
24070 end Collect_Visible_States
;
24074 Pack_Body
: constant Node_Id
:=
24075 Declaration_Node
(Body_Entity
(Pack_Id
));
24077 Item_Id
: Entity_Id
;
24079 -- Start of processing for Collect_Body_States
24082 -- Inspect the declarations of the body looking for source variables,
24083 -- packages and package instantiations.
24085 Decl
:= First
(Declarations
(Pack_Body
));
24086 while Present
(Decl
) loop
24087 if Nkind
(Decl
) = N_Object_Declaration
then
24088 Item_Id
:= Defining_Entity
(Decl
);
24090 -- Capture source variables only as internally generated
24091 -- temporaries cannot be named and participate in refinement.
24093 if Ekind
(Item_Id
) = E_Variable
24094 and then Comes_From_Source
(Item_Id
)
24096 Add_Item
(Item_Id
, Result
);
24099 elsif Nkind
(Decl
) = N_Package_Declaration
then
24100 Item_Id
:= Defining_Entity
(Decl
);
24102 -- Capture the visible abstract states and variables of a
24103 -- source package [instantiation].
24105 if Comes_From_Source
(Item_Id
) then
24106 Collect_Visible_States
(Item_Id
);
24114 end Collect_Body_States
;
24116 -----------------------------
24117 -- Report_Unrefined_States --
24118 -----------------------------
24120 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24121 State_Elmt
: Elmt_Id
;
24124 if Present
(States
) then
24125 State_Elmt
:= First_Elmt
(States
);
24126 while Present
(State_Elmt
) loop
24128 ("abstract state & must be refined", Node
(State_Elmt
));
24130 Next_Elmt
(State_Elmt
);
24133 end Report_Unrefined_States
;
24135 --------------------------
24136 -- Report_Unused_States --
24137 --------------------------
24139 procedure Report_Unused_States
(States
: Elist_Id
) is
24140 Posted
: Boolean := False;
24141 State_Elmt
: Elmt_Id
;
24142 State_Id
: Entity_Id
;
24145 if Present
(States
) then
24146 State_Elmt
:= First_Elmt
(States
);
24147 while Present
(State_Elmt
) loop
24148 State_Id
:= Node
(State_Elmt
);
24150 -- Generate an error message of the form:
24152 -- body of package ... has unused hidden states
24153 -- abstract state ... defined at ...
24154 -- variable ... defined at ...
24159 ("body of package & has unused hidden states", Body_Id
);
24162 Error_Msg_Sloc
:= Sloc
(State_Id
);
24164 if Ekind
(State_Id
) = E_Abstract_State
then
24166 ("\abstract state & defined #", Body_Id
, State_Id
);
24169 ("\variable & defined #", Body_Id
, State_Id
);
24172 Next_Elmt
(State_Elmt
);
24175 end Report_Unused_States
;
24177 -- Local declarations
24179 Body_Decl
: constant Node_Id
:= Parent
(N
);
24180 Clauses
: constant Node_Id
:=
24181 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
24184 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24189 Body_Id
:= Defining_Entity
(Body_Decl
);
24190 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
24192 -- Replicate the abstract states declared by the package because the
24193 -- matching algorithm will consume states.
24195 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24197 -- Gather all abstract states and variables declared in the visible
24198 -- state space of the package body. These items must be utilized as
24199 -- constituents in a state refinement.
24201 Body_States
:= Collect_Body_States
(Spec_Id
);
24203 -- Multiple non-null state refinements appear as an aggregate
24205 if Nkind
(Clauses
) = N_Aggregate
then
24206 if Present
(Expressions
(Clauses
)) then
24208 ("state refinements must appear as component associations",
24211 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24212 Clause
:= First
(Component_Associations
(Clauses
));
24213 while Present
(Clause
) loop
24214 Analyze_Refinement_Clause
(Clause
);
24220 -- Various forms of a single state refinement. Note that these may
24221 -- include malformed refinements.
24224 Analyze_Refinement_Clause
(Clauses
);
24227 -- List all abstract states that were left unrefined
24229 Report_Unrefined_States
(Available_States
);
24231 -- Ensure that all abstract states and variables declared in the body
24232 -- state space of the related package are utilized as constituents.
24234 Report_Unused_States
(Body_States
);
24235 end Analyze_Refined_State_In_Decl_Part
;
24237 ------------------------------------
24238 -- Analyze_Test_Case_In_Decl_Part --
24239 ------------------------------------
24241 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
24243 -- Install formals and push subprogram spec onto scope stack so that we
24244 -- can see the formals from the pragma.
24247 Install_Formals
(S
);
24249 -- Preanalyze the boolean expressions, we treat these as spec
24250 -- expressions (i.e. similar to a default expression).
24252 if Pragma_Name
(N
) = Name_Test_Case
then
24253 Preanalyze_CTC_Args
24255 Get_Requires_From_CTC_Pragma
(N
),
24256 Get_Ensures_From_CTC_Pragma
(N
));
24259 -- Remove the subprogram from the scope stack now that the pre-analysis
24260 -- of the expressions in the contract case or test case is done.
24263 end Analyze_Test_Case_In_Decl_Part
;
24269 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24274 if Present
(List
) then
24275 Elmt
:= First_Elmt
(List
);
24276 while Present
(Elmt
) loop
24277 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24280 Id
:= Entity_Of
(Node
(Elmt
));
24283 if Id
= Item_Id
then
24294 -----------------------------
24295 -- Check_Applicable_Policy --
24296 -----------------------------
24298 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24302 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
24305 -- No effect if not valid assertion kind name
24307 if not Is_Valid_Assertion_Kind
(Ename
) then
24311 -- Loop through entries in check policy list
24313 PP
:= Opt
.Check_Policy_List
;
24314 while Present
(PP
) loop
24316 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24317 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24321 or else Pnm
= Name_Assertion
24322 or else (Pnm
= Name_Statement_Assertions
24323 and then Nam_In
(Ename
, Name_Assert
,
24324 Name_Assert_And_Cut
,
24326 Name_Loop_Invariant
,
24327 Name_Loop_Variant
))
24329 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24332 when Name_Off | Name_Ignore
=>
24333 Set_Is_Ignored
(N
, True);
24334 Set_Is_Checked
(N
, False);
24336 when Name_On | Name_Check
=>
24337 Set_Is_Checked
(N
, True);
24338 Set_Is_Ignored
(N
, False);
24340 when Name_Disable
=>
24341 Set_Is_Ignored
(N
, True);
24342 Set_Is_Checked
(N
, False);
24343 Set_Is_Disabled
(N
, True);
24345 -- That should be exhaustive, the null here is a defence
24346 -- against a malformed tree from previous errors.
24355 PP
:= Next_Pragma
(PP
);
24359 -- If there are no specific entries that matched, then we let the
24360 -- setting of assertions govern. Note that this provides the needed
24361 -- compatibility with the RM for the cases of assertion, invariant,
24362 -- precondition, predicate, and postcondition.
24364 if Assertions_Enabled
then
24365 Set_Is_Checked
(N
, True);
24366 Set_Is_Ignored
(N
, False);
24368 Set_Is_Checked
(N
, False);
24369 Set_Is_Ignored
(N
, True);
24371 end Check_Applicable_Policy
;
24373 -------------------------------
24374 -- Check_External_Properties --
24375 -------------------------------
24377 procedure Check_External_Properties
24385 -- All properties enabled
24387 if AR
and AW
and ER
and EW
then
24390 -- Async_Readers + Effective_Writes
24391 -- Async_Readers + Async_Writers + Effective_Writes
24393 elsif AR
and EW
and not ER
then
24396 -- Async_Writers + Effective_Reads
24397 -- Async_Readers + Async_Writers + Effective_Reads
24399 elsif AW
and ER
and not EW
then
24402 -- Async_Readers + Async_Writers
24404 elsif AR
and AW
and not ER
and not EW
then
24409 elsif AR
and not AW
and not ER
and not EW
then
24414 elsif AW
and not AR
and not ER
and not EW
then
24419 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24422 end Check_External_Properties
;
24428 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24432 -- Loop through entries in check policy list
24434 PP
:= Opt
.Check_Policy_List
;
24435 while Present
(PP
) loop
24437 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24438 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24442 or else (Pnm
= Name_Assertion
24443 and then Is_Valid_Assertion_Kind
(Nam
))
24444 or else (Pnm
= Name_Statement_Assertions
24445 and then Nam_In
(Nam
, Name_Assert
,
24446 Name_Assert_And_Cut
,
24448 Name_Loop_Invariant
,
24449 Name_Loop_Variant
))
24451 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24452 when Name_On | Name_Check
=>
24454 when Name_Off | Name_Ignore
=>
24455 return Name_Ignore
;
24456 when Name_Disable
=>
24457 return Name_Disable
;
24459 raise Program_Error
;
24463 PP
:= Next_Pragma
(PP
);
24468 -- If there are no specific entries that matched, then we let the
24469 -- setting of assertions govern. Note that this provides the needed
24470 -- compatibility with the RM for the cases of assertion, invariant,
24471 -- precondition, predicate, and postcondition.
24473 if Assertions_Enabled
then
24476 return Name_Ignore
;
24480 ---------------------------
24481 -- Check_Missing_Part_Of --
24482 ---------------------------
24484 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24485 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24486 -- Determine whether a package denoted by Pack_Id declares at least one
24489 -----------------------
24490 -- Has_Visible_State --
24491 -----------------------
24493 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24494 Item_Id
: Entity_Id
;
24497 -- Traverse the entity chain of the package trying to find at least
24498 -- one visible abstract state, variable or a package [instantiation]
24499 -- that declares a visible state.
24501 Item_Id
:= First_Entity
(Pack_Id
);
24502 while Present
(Item_Id
)
24503 and then not In_Private_Part
(Item_Id
)
24505 -- Do not consider internally generated items
24507 if not Comes_From_Source
(Item_Id
) then
24510 -- A visible state has been found
24512 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24515 -- Recursively peek into nested packages and instantiations
24517 elsif Ekind
(Item_Id
) = E_Package
24518 and then Has_Visible_State
(Item_Id
)
24523 Next_Entity
(Item_Id
);
24527 end Has_Visible_State
;
24531 Pack_Id
: Entity_Id
;
24532 Placement
: State_Space_Kind
;
24534 -- Start of processing for Check_Missing_Part_Of
24537 -- Do not consider abstract states, variables or package instantiations
24538 -- coming from an instance as those always inherit the Part_Of indicator
24539 -- of the instance itself.
24541 if In_Instance
then
24544 -- Do not consider internally generated entities as these can never
24545 -- have a Part_Of indicator.
24547 elsif not Comes_From_Source
(Item_Id
) then
24550 -- Perform these checks only when SPARK_Mode is enabled as they will
24551 -- interfere with standard Ada rules and produce false positives.
24553 elsif SPARK_Mode
/= On
then
24557 -- Find where the abstract state, variable or package instantiation
24558 -- lives with respect to the state space.
24560 Find_Placement_In_State_Space
24561 (Item_Id
=> Item_Id
,
24562 Placement
=> Placement
,
24563 Pack_Id
=> Pack_Id
);
24565 -- Items that appear in a non-package construct (subprogram, block, etc)
24566 -- do not require a Part_Of indicator because they can never act as a
24569 if Placement
= Not_In_Package
then
24572 -- An item declared in the body state space of a package always act as a
24573 -- constituent and does not need explicit Part_Of indicator.
24575 elsif Placement
= Body_State_Space
then
24578 -- In general an item declared in the visible state space of a package
24579 -- does not require a Part_Of indicator. The only exception is when the
24580 -- related package is a private child unit in which case Part_Of must
24581 -- denote a state in the parent unit or in one of its descendants.
24583 elsif Placement
= Visible_State_Space
then
24584 if Is_Child_Unit
(Pack_Id
)
24585 and then Is_Private_Descendant
(Pack_Id
)
24587 -- A package instantiation does not need a Part_Of indicator when
24588 -- the related generic template has no visible state.
24590 if Ekind
(Item_Id
) = E_Package
24591 and then Is_Generic_Instance
(Item_Id
)
24592 and then not Has_Visible_State
(Item_Id
)
24596 -- All other cases require Part_Of
24600 ("indicator Part_Of is required in this context "
24601 & "(SPARK RM 7.2.6(3))", Item_Id
);
24602 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24604 ("\& is declared in the visible part of private child "
24605 & "unit %", Item_Id
);
24609 -- When the item appears in the private state space of a packge, it must
24610 -- be a part of some state declared by the said package.
24612 else pragma Assert
(Placement
= Private_State_Space
);
24614 -- The related package does not declare a state, the item cannot act
24615 -- as a Part_Of constituent.
24617 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24620 -- A package instantiation does not need a Part_Of indicator when the
24621 -- related generic template has no visible state.
24623 elsif Ekind
(Pack_Id
) = E_Package
24624 and then Is_Generic_Instance
(Pack_Id
)
24625 and then not Has_Visible_State
(Pack_Id
)
24629 -- All other cases require Part_Of
24633 ("indicator Part_Of is required in this context "
24634 & "(SPARK RM 7.2.6(2))", Item_Id
);
24635 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24637 ("\& is declared in the private part of package %", Item_Id
);
24640 end Check_Missing_Part_Of
;
24642 ---------------------------------
24643 -- Check_SPARK_Aspect_For_ASIS --
24644 ---------------------------------
24646 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
24650 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
24651 Expr
:= Expression
(Corresponding_Aspect
(N
));
24652 if Nkind
(Expr
) /= N_Aggregate
then
24653 Preanalyze_And_Resolve
(Expr
);
24657 Comps
: constant List_Id
:= Component_Associations
(Expr
);
24658 Exprs
: constant List_Id
:= Expressions
(Expr
);
24663 E
:= First
(Exprs
);
24664 while Present
(E
) loop
24669 C
:= First
(Comps
);
24670 while Present
(C
) loop
24671 Analyze
(Expression
(C
));
24677 end Check_SPARK_Aspect_For_ASIS
;
24679 -------------------------------------
24680 -- Check_State_And_Constituent_Use --
24681 -------------------------------------
24683 procedure Check_State_And_Constituent_Use
24684 (States
: Elist_Id
;
24685 Constits
: Elist_Id
;
24688 function Find_Encapsulating_State
24689 (Constit_Id
: Entity_Id
) return Entity_Id
;
24690 -- Given the entity of a constituent, try to find a corresponding
24691 -- encapsulating state that appears in the same context. The routine
24692 -- returns Empty is no such state is found.
24694 ------------------------------
24695 -- Find_Encapsulating_State --
24696 ------------------------------
24698 function Find_Encapsulating_State
24699 (Constit_Id
: Entity_Id
) return Entity_Id
24701 State_Id
: Entity_Id
;
24704 -- Since a constituent may be part of a larger constituent set, climb
24705 -- the encapsulated state chain looking for a state that appears in
24706 -- the same context.
24708 State_Id
:= Encapsulating_State
(Constit_Id
);
24709 while Present
(State_Id
) loop
24710 if Contains
(States
, State_Id
) then
24714 State_Id
:= Encapsulating_State
(State_Id
);
24718 end Find_Encapsulating_State
;
24722 Constit_Elmt
: Elmt_Id
;
24723 Constit_Id
: Entity_Id
;
24724 State_Id
: Entity_Id
;
24726 -- Start of processing for Check_State_And_Constituent_Use
24729 -- Nothing to do if there are no states or constituents
24731 if No
(States
) or else No
(Constits
) then
24735 -- Inspect the list of constituents and try to determine whether its
24736 -- encapsulating state is in list States.
24738 Constit_Elmt
:= First_Elmt
(Constits
);
24739 while Present
(Constit_Elmt
) loop
24740 Constit_Id
:= Node
(Constit_Elmt
);
24742 -- Determine whether the constituent is part of an encapsulating
24743 -- state that appears in the same context and if this is the case,
24744 -- emit an error (SPARK RM 7.2.6(7)).
24746 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
24748 if Present
(State_Id
) then
24749 Error_Msg_Name_1
:= Chars
(Constit_Id
);
24751 ("cannot mention state & and its constituent % in the same "
24752 & "context", Context
, State_Id
);
24756 Next_Elmt
(Constit_Elmt
);
24758 end Check_State_And_Constituent_Use
;
24760 --------------------------
24761 -- Collect_Global_Items --
24762 --------------------------
24764 procedure Collect_Global_Items
24766 In_Items
: in out Elist_Id
;
24767 In_Out_Items
: in out Elist_Id
;
24768 Out_Items
: in out Elist_Id
;
24769 Proof_In_Items
: in out Elist_Id
;
24770 Has_In_State
: out Boolean;
24771 Has_In_Out_State
: out Boolean;
24772 Has_Out_State
: out Boolean;
24773 Has_Proof_In_State
: out Boolean;
24774 Has_Null_State
: out Boolean)
24776 procedure Process_Global_List
24778 Mode
: Name_Id
:= Name_Input
);
24779 -- Collect all items housed in a global list. Formal Mode denotes the
24780 -- current mode in effect.
24782 -------------------------
24783 -- Process_Global_List --
24784 -------------------------
24786 procedure Process_Global_List
24788 Mode
: Name_Id
:= Name_Input
)
24790 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24791 -- Add a single item to the appropriate list. Formal Mode denotes the
24792 -- current mode in effect.
24794 -------------------------
24795 -- Process_Global_Item --
24796 -------------------------
24798 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24799 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
24800 -- The above handles abstract views of variables and states built
24801 -- for limited with clauses.
24804 -- Signal that the global list contains at least one abstract
24805 -- state with a visible refinement. Note that the refinement may
24806 -- be null in which case there are no constituents.
24808 if Ekind
(Item_Id
) = E_Abstract_State
then
24809 if Has_Null_Refinement
(Item_Id
) then
24810 Has_Null_State
:= True;
24812 elsif Has_Non_Null_Refinement
(Item_Id
) then
24813 if Mode
= Name_Input
then
24814 Has_In_State
:= True;
24815 elsif Mode
= Name_In_Out
then
24816 Has_In_Out_State
:= True;
24817 elsif Mode
= Name_Output
then
24818 Has_Out_State
:= True;
24819 elsif Mode
= Name_Proof_In
then
24820 Has_Proof_In_State
:= True;
24825 -- Add the item to the proper list
24827 if Mode
= Name_Input
then
24828 Add_Item
(Item_Id
, In_Items
);
24829 elsif Mode
= Name_In_Out
then
24830 Add_Item
(Item_Id
, In_Out_Items
);
24831 elsif Mode
= Name_Output
then
24832 Add_Item
(Item_Id
, Out_Items
);
24833 elsif Mode
= Name_Proof_In
then
24834 Add_Item
(Item_Id
, Proof_In_Items
);
24836 end Process_Global_Item
;
24842 -- Start of processing for Process_Global_List
24845 if Nkind
(List
) = N_Null
then
24848 -- Single global item declaration
24850 elsif Nkind_In
(List
, N_Expanded_Name
,
24852 N_Selected_Component
)
24854 Process_Global_Item
(List
, Mode
);
24856 -- Single global list or moded global list declaration
24858 elsif Nkind
(List
) = N_Aggregate
then
24860 -- The declaration of a simple global list appear as a collection
24863 if Present
(Expressions
(List
)) then
24864 Item
:= First
(Expressions
(List
));
24865 while Present
(Item
) loop
24866 Process_Global_Item
(Item
, Mode
);
24871 -- The declaration of a moded global list appears as a collection
24872 -- of component associations where individual choices denote mode.
24874 elsif Present
(Component_Associations
(List
)) then
24875 Item
:= First
(Component_Associations
(List
));
24876 while Present
(Item
) loop
24877 Process_Global_List
24878 (List
=> Expression
(Item
),
24879 Mode
=> Chars
(First
(Choices
(Item
))));
24887 raise Program_Error
;
24890 -- To accomodate partial decoration of disabled SPARK features, this
24891 -- routine may be called with illegal input. If this is the case, do
24892 -- not raise Program_Error.
24897 end Process_Global_List
;
24901 Items
: constant Node_Id
:=
24902 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
)));
24904 -- Start of processing for Collect_Global_Items
24907 -- Assume that no states have been encountered
24909 Has_In_State
:= False;
24910 Has_In_Out_State
:= False;
24911 Has_Out_State
:= False;
24912 Has_Proof_In_State
:= False;
24913 Has_Null_State
:= False;
24915 Process_Global_List
(Items
);
24916 end Collect_Global_Items
;
24918 ---------------------------------------
24919 -- Collect_Subprogram_Inputs_Outputs --
24920 ---------------------------------------
24922 procedure Collect_Subprogram_Inputs_Outputs
24923 (Subp_Id
: Entity_Id
;
24924 Subp_Inputs
: in out Elist_Id
;
24925 Subp_Outputs
: in out Elist_Id
;
24926 Global_Seen
: out Boolean)
24928 procedure Collect_Global_List
24930 Mode
: Name_Id
:= Name_Input
);
24931 -- Collect all relevant items from a global list
24933 -------------------------
24934 -- Collect_Global_List --
24935 -------------------------
24937 procedure Collect_Global_List
24939 Mode
: Name_Id
:= Name_Input
)
24941 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24942 -- Add an item to the proper subprogram input or output collection
24944 -------------------------
24945 -- Collect_Global_Item --
24946 -------------------------
24948 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24950 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
24951 Add_Item
(Item
, Subp_Inputs
);
24954 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
24955 Add_Item
(Item
, Subp_Outputs
);
24957 end Collect_Global_Item
;
24964 -- Start of processing for Collect_Global_List
24967 if Nkind
(List
) = N_Null
then
24970 -- Single global item declaration
24972 elsif Nkind_In
(List
, N_Expanded_Name
,
24974 N_Selected_Component
)
24976 Collect_Global_Item
(List
, Mode
);
24978 -- Simple global list or moded global list declaration
24980 elsif Nkind
(List
) = N_Aggregate
then
24981 if Present
(Expressions
(List
)) then
24982 Item
:= First
(Expressions
(List
));
24983 while Present
(Item
) loop
24984 Collect_Global_Item
(Item
, Mode
);
24989 Assoc
:= First
(Component_Associations
(List
));
24990 while Present
(Assoc
) loop
24991 Collect_Global_List
24992 (List
=> Expression
(Assoc
),
24993 Mode
=> Chars
(First
(Choices
(Assoc
))));
24998 -- To accomodate partial decoration of disabled SPARK features, this
24999 -- routine may be called with illegal input. If this is the case, do
25000 -- not raise Program_Error.
25005 end Collect_Global_List
;
25009 Subp_Decl
: constant Node_Id
:= Parent
(Parent
(Subp_Id
));
25010 Formal
: Entity_Id
;
25013 Spec_Id
: Entity_Id
;
25015 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25018 Global_Seen
:= False;
25020 -- Find the entity of the corresponding spec when processing a body
25022 if Nkind
(Subp_Decl
) = N_Subprogram_Body
25023 and then Present
(Corresponding_Spec
(Subp_Decl
))
25025 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
25027 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25028 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25030 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
25033 Spec_Id
:= Subp_Id
;
25036 -- Process all formal parameters
25038 Formal
:= First_Formal
(Spec_Id
);
25039 while Present
(Formal
) loop
25040 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
25041 Add_Item
(Formal
, Subp_Inputs
);
25044 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
25045 Add_Item
(Formal
, Subp_Outputs
);
25047 -- Out parameters can act as inputs when the related type is
25048 -- tagged, unconstrained array, unconstrained record or record
25049 -- with unconstrained components.
25051 if Ekind
(Formal
) = E_Out_Parameter
25052 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25054 Add_Item
(Formal
, Subp_Inputs
);
25058 Next_Formal
(Formal
);
25061 -- When processing a subprogram body, look for pragma Refined_Global as
25062 -- it provides finer granularity of inputs and outputs.
25064 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25065 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25067 -- Subprogram declaration case, look for pragma Global
25070 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25073 if Present
(Global
) then
25074 Global_Seen
:= True;
25075 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
25077 -- The pragma may not have been analyzed because of the arbitrary
25078 -- declaration order of aspects. Make sure that it is analyzed for
25079 -- the purposes of item extraction.
25081 if not Analyzed
(List
) then
25082 if Pragma_Name
(Global
) = Name_Refined_Global
then
25083 Analyze_Refined_Global_In_Decl_Part
(Global
);
25085 Analyze_Global_In_Decl_Part
(Global
);
25089 -- Nothing to be done for a null global list
25091 if Nkind
(List
) /= N_Null
then
25092 Collect_Global_List
(List
);
25095 end Collect_Subprogram_Inputs_Outputs
;
25097 ---------------------------------
25098 -- Delay_Config_Pragma_Analyze --
25099 ---------------------------------
25101 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25103 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25104 Name_Priority_Specific_Dispatching
);
25105 end Delay_Config_Pragma_Analyze
;
25107 -------------------------------------
25108 -- Find_Related_Subprogram_Or_Body --
25109 -------------------------------------
25111 function Find_Related_Subprogram_Or_Body
25113 Do_Checks
: Boolean := False) return Node_Id
25115 Context
: constant Node_Id
:= Parent
(Prag
);
25116 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25119 Look_For_Body
: constant Boolean :=
25120 Nam_In
(Nam
, Name_Refined_Depends
,
25121 Name_Refined_Global
,
25122 Name_Refined_Post
);
25123 -- Refinement pragmas must be associated with a subprogram body [stub]
25126 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
25128 -- If the pragma is a byproduct of aspect expansion, return the related
25129 -- context of the original aspect.
25131 if Present
(Corresponding_Aspect
(Prag
)) then
25132 return Parent
(Corresponding_Aspect
(Prag
));
25135 -- Otherwise the pragma is a source construct, most likely part of a
25136 -- declarative list. Skip preceding declarations while looking for a
25137 -- proper subprogram declaration.
25139 pragma Assert
(Is_List_Member
(Prag
));
25141 Stmt
:= Prev
(Prag
);
25142 while Present
(Stmt
) loop
25144 -- Skip prior pragmas, but check for duplicates
25146 if Nkind
(Stmt
) = N_Pragma
then
25147 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
25148 Error_Msg_Name_1
:= Nam
;
25149 Error_Msg_Sloc
:= Sloc
(Stmt
);
25150 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25153 -- Emit an error when a refinement pragma appears on an expression
25154 -- function without a completion.
25157 and then Look_For_Body
25158 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25159 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25160 and then not Has_Completion
(Defining_Entity
(Stmt
))
25162 Error_Msg_Name_1
:= Nam
;
25164 ("pragma % cannot apply to a stand alone expression function",
25169 -- The refinement pragma applies to a subprogram body stub
25171 elsif Look_For_Body
25172 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25176 -- Skip internally generated code
25178 elsif not Comes_From_Source
(Stmt
) then
25181 -- Return the current construct which is either a subprogram body,
25182 -- a subprogram declaration or is illegal.
25191 -- If we fall through, then the pragma was either the first declaration
25192 -- or it was preceded by other pragmas and no source constructs.
25194 -- The pragma is associated with a library-level subprogram
25196 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25197 return Unit
(Parent
(Context
));
25199 -- The pragma appears inside the declarative part of a subprogram body
25201 elsif Nkind
(Context
) = N_Subprogram_Body
then
25204 -- No candidate subprogram [body] found
25209 end Find_Related_Subprogram_Or_Body
;
25211 -------------------------
25212 -- Get_Base_Subprogram --
25213 -------------------------
25215 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25216 Result
: Entity_Id
;
25219 -- Follow subprogram renaming chain
25223 if Is_Subprogram
(Result
)
25225 Nkind
(Parent
(Declaration_Node
(Result
))) =
25226 N_Subprogram_Renaming_Declaration
25227 and then Present
(Alias
(Result
))
25229 Result
:= Alias
(Result
);
25233 end Get_Base_Subprogram
;
25235 -----------------------
25236 -- Get_SPARK_Mode_Type --
25237 -----------------------
25239 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25241 if N
= Name_On
then
25243 elsif N
= Name_Off
then
25246 -- Any other argument is illegal
25249 raise Program_Error
;
25251 end Get_SPARK_Mode_Type
;
25253 --------------------------------
25254 -- Get_SPARK_Mode_From_Pragma --
25255 --------------------------------
25257 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25262 pragma Assert
(Nkind
(N
) = N_Pragma
);
25263 Args
:= Pragma_Argument_Associations
(N
);
25265 -- Extract the mode from the argument list
25267 if Present
(Args
) then
25268 Mode
:= First
(Pragma_Argument_Associations
(N
));
25269 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25271 -- If SPARK_Mode pragma has no argument, default is ON
25276 end Get_SPARK_Mode_From_Pragma
;
25278 ---------------------------
25279 -- Has_Extra_Parentheses --
25280 ---------------------------
25282 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25286 -- The aggregate should not have an expression list because a clause
25287 -- is always interpreted as a component association. The only way an
25288 -- expression list can sneak in is by adding extra parentheses around
25289 -- the individual clauses:
25291 -- Depends (Output => Input) -- proper form
25292 -- Depends ((Output => Input)) -- extra parentheses
25294 -- Since the extra parentheses are not allowed by the syntax of the
25295 -- pragma, flag them now to avoid emitting misleading errors down the
25298 if Nkind
(Clause
) = N_Aggregate
25299 and then Present
(Expressions
(Clause
))
25301 Expr
:= First
(Expressions
(Clause
));
25302 while Present
(Expr
) loop
25304 -- A dependency clause surrounded by extra parentheses appears
25305 -- as an aggregate of component associations with an optional
25306 -- Paren_Count set.
25308 if Nkind
(Expr
) = N_Aggregate
25309 and then Present
(Component_Associations
(Expr
))
25312 ("dependency clause contains extra parentheses", Expr
);
25314 -- Otherwise the expression is a malformed construct
25317 SPARK_Msg_N
("malformed dependency clause", Expr
);
25327 end Has_Extra_Parentheses
;
25333 procedure Initialize
is
25338 -----------------------------
25339 -- Is_Config_Static_String --
25340 -----------------------------
25342 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25344 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25345 -- This is an internal recursive function that is just like the outer
25346 -- function except that it adds the string to the name buffer rather
25347 -- than placing the string in the name buffer.
25349 ------------------------------
25350 -- Add_Config_Static_String --
25351 ------------------------------
25353 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25360 if Nkind
(N
) = N_Op_Concat
then
25361 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25362 N
:= Right_Opnd
(N
);
25368 if Nkind
(N
) /= N_String_Literal
then
25369 Error_Msg_N
("string literal expected for pragma argument", N
);
25373 for J
in 1 .. String_Length
(Strval
(N
)) loop
25374 C
:= Get_String_Char
(Strval
(N
), J
);
25376 if not In_Character_Range
(C
) then
25378 ("string literal contains invalid wide character",
25379 Sloc
(N
) + 1 + Source_Ptr
(J
));
25383 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25388 end Add_Config_Static_String
;
25390 -- Start of processing for Is_Config_Static_String
25395 return Add_Config_Static_String
(Arg
);
25396 end Is_Config_Static_String
;
25398 -------------------------------
25399 -- Is_Elaboration_SPARK_Mode --
25400 -------------------------------
25402 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
25405 (Nkind
(N
) = N_Pragma
25406 and then Pragma_Name
(N
) = Name_SPARK_Mode
25407 and then Is_List_Member
(N
));
25409 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25410 -- appears in the statement part of the body.
25413 Present
(Parent
(N
))
25414 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
25415 and then List_Containing
(N
) = Statements
(Parent
(N
))
25416 and then Present
(Parent
(Parent
(N
)))
25417 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
25418 end Is_Elaboration_SPARK_Mode
;
25420 -----------------------------------------
25421 -- Is_Non_Significant_Pragma_Reference --
25422 -----------------------------------------
25424 -- This function makes use of the following static table which indicates
25425 -- whether appearance of some name in a given pragma is to be considered
25426 -- as a reference for the purposes of warnings about unreferenced objects.
25428 -- -1 indicates that references in any argument position are significant
25429 -- 0 indicates that appearance in any argument is not significant
25430 -- +n indicates that appearance as argument n is significant, but all
25431 -- other arguments are not significant
25432 -- 99 special processing required (e.g. for pragma Check)
25434 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
25435 (Pragma_AST_Entry
=> -1,
25436 Pragma_Abort_Defer
=> -1,
25437 Pragma_Abstract_State
=> -1,
25438 Pragma_Ada_83
=> -1,
25439 Pragma_Ada_95
=> -1,
25440 Pragma_Ada_05
=> -1,
25441 Pragma_Ada_2005
=> -1,
25442 Pragma_Ada_12
=> -1,
25443 Pragma_Ada_2012
=> -1,
25444 Pragma_All_Calls_Remote
=> -1,
25445 Pragma_Allow_Integer_Address
=> 0,
25446 Pragma_Annotate
=> -1,
25447 Pragma_Assert
=> -1,
25448 Pragma_Assert_And_Cut
=> -1,
25449 Pragma_Assertion_Policy
=> 0,
25450 Pragma_Assume
=> -1,
25451 Pragma_Assume_No_Invalid_Values
=> 0,
25452 Pragma_Async_Readers
=> 0,
25453 Pragma_Async_Writers
=> 0,
25454 Pragma_Asynchronous
=> -1,
25455 Pragma_Atomic
=> 0,
25456 Pragma_Atomic_Components
=> 0,
25457 Pragma_Attach_Handler
=> -1,
25458 Pragma_Attribute_Definition
=> +3,
25459 Pragma_Check
=> 99,
25460 Pragma_Check_Float_Overflow
=> 0,
25461 Pragma_Check_Name
=> 0,
25462 Pragma_Check_Policy
=> 0,
25463 Pragma_CIL_Constructor
=> -1,
25464 Pragma_CPP_Class
=> 0,
25465 Pragma_CPP_Constructor
=> 0,
25466 Pragma_CPP_Virtual
=> 0,
25467 Pragma_CPP_Vtable
=> 0,
25469 Pragma_C_Pass_By_Copy
=> 0,
25470 Pragma_Comment
=> 0,
25471 Pragma_Common_Object
=> -1,
25472 Pragma_Compile_Time_Error
=> -1,
25473 Pragma_Compile_Time_Warning
=> -1,
25474 Pragma_Compiler_Unit
=> 0,
25475 Pragma_Compiler_Unit_Warning
=> 0,
25476 Pragma_Complete_Representation
=> 0,
25477 Pragma_Complex_Representation
=> 0,
25478 Pragma_Component_Alignment
=> -1,
25479 Pragma_Contract_Cases
=> -1,
25480 Pragma_Controlled
=> 0,
25481 Pragma_Convention
=> 0,
25482 Pragma_Convention_Identifier
=> 0,
25483 Pragma_Debug
=> -1,
25484 Pragma_Debug_Policy
=> 0,
25485 Pragma_Detect_Blocking
=> -1,
25486 Pragma_Default_Storage_Pool
=> -1,
25487 Pragma_Depends
=> -1,
25488 Pragma_Disable_Atomic_Synchronization
=> -1,
25489 Pragma_Discard_Names
=> 0,
25490 Pragma_Dispatching_Domain
=> -1,
25491 Pragma_Effective_Reads
=> 0,
25492 Pragma_Effective_Writes
=> 0,
25493 Pragma_Elaborate
=> -1,
25494 Pragma_Elaborate_All
=> -1,
25495 Pragma_Elaborate_Body
=> -1,
25496 Pragma_Elaboration_Checks
=> -1,
25497 Pragma_Eliminate
=> -1,
25498 Pragma_Enable_Atomic_Synchronization
=> -1,
25499 Pragma_Export
=> -1,
25500 Pragma_Export_Exception
=> -1,
25501 Pragma_Export_Function
=> -1,
25502 Pragma_Export_Object
=> -1,
25503 Pragma_Export_Procedure
=> -1,
25504 Pragma_Export_Value
=> -1,
25505 Pragma_Export_Valued_Procedure
=> -1,
25506 Pragma_Extend_System
=> -1,
25507 Pragma_Extensions_Allowed
=> -1,
25508 Pragma_External
=> -1,
25509 Pragma_Favor_Top_Level
=> -1,
25510 Pragma_External_Name_Casing
=> -1,
25511 Pragma_Fast_Math
=> -1,
25512 Pragma_Finalize_Storage_Only
=> 0,
25513 Pragma_Float_Representation
=> 0,
25514 Pragma_Global
=> -1,
25515 Pragma_Ident
=> -1,
25516 Pragma_Implementation_Defined
=> -1,
25517 Pragma_Implemented
=> -1,
25518 Pragma_Implicit_Packing
=> 0,
25519 Pragma_Import
=> +2,
25520 Pragma_Import_Exception
=> 0,
25521 Pragma_Import_Function
=> 0,
25522 Pragma_Import_Object
=> 0,
25523 Pragma_Import_Procedure
=> 0,
25524 Pragma_Import_Valued_Procedure
=> 0,
25525 Pragma_Independent
=> 0,
25526 Pragma_Independent_Components
=> 0,
25527 Pragma_Initial_Condition
=> -1,
25528 Pragma_Initialize_Scalars
=> -1,
25529 Pragma_Initializes
=> -1,
25530 Pragma_Inline
=> 0,
25531 Pragma_Inline_Always
=> 0,
25532 Pragma_Inline_Generic
=> 0,
25533 Pragma_Inspection_Point
=> -1,
25534 Pragma_Interface
=> +2,
25535 Pragma_Interface_Name
=> +2,
25536 Pragma_Interrupt_Handler
=> -1,
25537 Pragma_Interrupt_Priority
=> -1,
25538 Pragma_Interrupt_State
=> -1,
25539 Pragma_Invariant
=> -1,
25540 Pragma_Java_Constructor
=> -1,
25541 Pragma_Java_Interface
=> -1,
25542 Pragma_Keep_Names
=> 0,
25543 Pragma_License
=> -1,
25544 Pragma_Link_With
=> -1,
25545 Pragma_Linker_Alias
=> -1,
25546 Pragma_Linker_Constructor
=> -1,
25547 Pragma_Linker_Destructor
=> -1,
25548 Pragma_Linker_Options
=> -1,
25549 Pragma_Linker_Section
=> -1,
25551 Pragma_Lock_Free
=> -1,
25552 Pragma_Locking_Policy
=> -1,
25553 Pragma_Long_Float
=> -1,
25554 Pragma_Loop_Invariant
=> -1,
25555 Pragma_Loop_Optimize
=> -1,
25556 Pragma_Loop_Variant
=> -1,
25557 Pragma_Machine_Attribute
=> -1,
25559 Pragma_Main_Storage
=> -1,
25560 Pragma_Memory_Size
=> -1,
25561 Pragma_No_Return
=> 0,
25562 Pragma_No_Body
=> 0,
25563 Pragma_No_Inline
=> 0,
25564 Pragma_No_Run_Time
=> -1,
25565 Pragma_No_Strict_Aliasing
=> -1,
25566 Pragma_Normalize_Scalars
=> -1,
25567 Pragma_Obsolescent
=> 0,
25568 Pragma_Optimize
=> -1,
25569 Pragma_Optimize_Alignment
=> -1,
25570 Pragma_Overflow_Mode
=> 0,
25571 Pragma_Overriding_Renamings
=> 0,
25572 Pragma_Ordered
=> 0,
25575 Pragma_Part_Of
=> -1,
25576 Pragma_Partition_Elaboration_Policy
=> -1,
25577 Pragma_Passive
=> -1,
25578 Pragma_Persistent_BSS
=> 0,
25579 Pragma_Polling
=> -1,
25581 Pragma_Postcondition
=> -1,
25582 Pragma_Post_Class
=> -1,
25584 Pragma_Precondition
=> -1,
25585 Pragma_Predicate
=> -1,
25586 Pragma_Preelaborable_Initialization
=> -1,
25587 Pragma_Preelaborate
=> -1,
25588 Pragma_Pre_Class
=> -1,
25589 Pragma_Priority
=> -1,
25590 Pragma_Priority_Specific_Dispatching
=> -1,
25591 Pragma_Profile
=> 0,
25592 Pragma_Profile_Warnings
=> 0,
25593 Pragma_Propagate_Exceptions
=> -1,
25594 Pragma_Provide_Shift_Operators
=> -1,
25595 Pragma_Psect_Object
=> -1,
25597 Pragma_Pure_Function
=> -1,
25598 Pragma_Queuing_Policy
=> -1,
25599 Pragma_Rational
=> -1,
25600 Pragma_Ravenscar
=> -1,
25601 Pragma_Refined_Depends
=> -1,
25602 Pragma_Refined_Global
=> -1,
25603 Pragma_Refined_Post
=> -1,
25604 Pragma_Refined_State
=> -1,
25605 Pragma_Relative_Deadline
=> -1,
25606 Pragma_Remote_Access_Type
=> -1,
25607 Pragma_Remote_Call_Interface
=> -1,
25608 Pragma_Remote_Types
=> -1,
25609 Pragma_Restricted_Run_Time
=> -1,
25610 Pragma_Restriction_Warnings
=> -1,
25611 Pragma_Restrictions
=> -1,
25612 Pragma_Reviewable
=> -1,
25613 Pragma_Short_Circuit_And_Or
=> -1,
25614 Pragma_Share_Generic
=> -1,
25615 Pragma_Shared
=> -1,
25616 Pragma_Shared_Passive
=> -1,
25617 Pragma_Short_Descriptors
=> 0,
25618 Pragma_Simple_Storage_Pool_Type
=> 0,
25619 Pragma_Source_File_Name
=> -1,
25620 Pragma_Source_File_Name_Project
=> -1,
25621 Pragma_Source_Reference
=> -1,
25622 Pragma_SPARK_Mode
=> 0,
25623 Pragma_Storage_Size
=> -1,
25624 Pragma_Storage_Unit
=> -1,
25625 Pragma_Static_Elaboration_Desired
=> -1,
25626 Pragma_Stream_Convert
=> -1,
25627 Pragma_Style_Checks
=> -1,
25628 Pragma_Subtitle
=> -1,
25629 Pragma_Suppress
=> 0,
25630 Pragma_Suppress_Exception_Locations
=> 0,
25631 Pragma_Suppress_All
=> -1,
25632 Pragma_Suppress_Debug_Info
=> 0,
25633 Pragma_Suppress_Initialization
=> 0,
25634 Pragma_System_Name
=> -1,
25635 Pragma_Task_Dispatching_Policy
=> -1,
25636 Pragma_Task_Info
=> -1,
25637 Pragma_Task_Name
=> -1,
25638 Pragma_Task_Storage
=> 0,
25639 Pragma_Test_Case
=> -1,
25640 Pragma_Thread_Local_Storage
=> 0,
25641 Pragma_Time_Slice
=> -1,
25642 Pragma_Title
=> -1,
25643 Pragma_Type_Invariant
=> -1,
25644 Pragma_Type_Invariant_Class
=> -1,
25645 Pragma_Unchecked_Union
=> 0,
25646 Pragma_Unimplemented_Unit
=> -1,
25647 Pragma_Universal_Aliasing
=> -1,
25648 Pragma_Universal_Data
=> -1,
25649 Pragma_Unmodified
=> -1,
25650 Pragma_Unreferenced
=> -1,
25651 Pragma_Unreferenced_Objects
=> -1,
25652 Pragma_Unreserve_All_Interrupts
=> -1,
25653 Pragma_Unsuppress
=> 0,
25654 Pragma_Use_VADS_Size
=> -1,
25655 Pragma_Validity_Checks
=> -1,
25656 Pragma_Volatile
=> 0,
25657 Pragma_Volatile_Components
=> 0,
25658 Pragma_Warning_As_Error
=> -1,
25659 Pragma_Warnings
=> -1,
25660 Pragma_Weak_External
=> -1,
25661 Pragma_Wide_Character_Encoding
=> 0,
25662 Unknown_Pragma
=> 0);
25664 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25673 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25677 Id
:= Get_Pragma_Id
(Parent
(P
));
25678 C
:= Sig_Flags
(Id
);
25690 -- For pragma Check, the first argument is not significant,
25691 -- the second and the third (if present) arguments are
25694 when Pragma_Check
=>
25696 P
= First
(Pragma_Argument_Associations
(Parent
(P
)));
25699 raise Program_Error
;
25703 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25704 for J
in 1 .. C
- 1 loop
25712 return A
= P
; -- is this wrong way round ???
25715 end Is_Non_Significant_Pragma_Reference
;
25717 ------------------------------
25718 -- Is_Pragma_String_Literal --
25719 ------------------------------
25721 -- This function returns true if the corresponding pragma argument is a
25722 -- static string expression. These are the only cases in which string
25723 -- literals can appear as pragma arguments. We also allow a string literal
25724 -- as the first argument to pragma Assert (although it will of course
25725 -- always generate a type error).
25727 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
25728 Pragn
: constant Node_Id
:= Parent
(Par
);
25729 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
25730 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
25736 N
:= First
(Assoc
);
25743 if Pname
= Name_Assert
then
25746 elsif Pname
= Name_Export
then
25749 elsif Pname
= Name_Ident
then
25752 elsif Pname
= Name_Import
then
25755 elsif Pname
= Name_Interface_Name
then
25758 elsif Pname
= Name_Linker_Alias
then
25761 elsif Pname
= Name_Linker_Section
then
25764 elsif Pname
= Name_Machine_Attribute
then
25767 elsif Pname
= Name_Source_File_Name
then
25770 elsif Pname
= Name_Source_Reference
then
25773 elsif Pname
= Name_Title
then
25776 elsif Pname
= Name_Subtitle
then
25782 end Is_Pragma_String_Literal
;
25784 ---------------------------
25785 -- Is_Private_SPARK_Mode --
25786 ---------------------------
25788 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
25791 (Nkind
(N
) = N_Pragma
25792 and then Pragma_Name
(N
) = Name_SPARK_Mode
25793 and then Is_List_Member
(N
));
25795 -- For pragma SPARK_Mode to be private, it has to appear in the private
25796 -- declarations of a package.
25799 Present
(Parent
(N
))
25800 and then Nkind
(Parent
(N
)) = N_Package_Specification
25801 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
25802 end Is_Private_SPARK_Mode
;
25804 -------------------------------------
25805 -- Is_Unconstrained_Or_Tagged_Item --
25806 -------------------------------------
25808 function Is_Unconstrained_Or_Tagged_Item
25809 (Item
: Entity_Id
) return Boolean
25811 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
25812 -- Determine whether record type Typ has at least one unconstrained
25815 ---------------------------------
25816 -- Has_Unconstrained_Component --
25817 ---------------------------------
25819 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
25823 Comp
:= First_Component
(Typ
);
25824 while Present
(Comp
) loop
25825 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
25829 Next_Component
(Comp
);
25833 end Has_Unconstrained_Component
;
25837 Typ
: constant Entity_Id
:= Etype
(Item
);
25839 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
25842 if Is_Tagged_Type
(Typ
) then
25845 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
25848 elsif Is_Record_Type
(Typ
) then
25849 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
25852 return Has_Unconstrained_Component
(Typ
);
25858 end Is_Unconstrained_Or_Tagged_Item
;
25860 -----------------------------
25861 -- Is_Valid_Assertion_Kind --
25862 -----------------------------
25864 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
25871 Name_Static_Predicate |
25872 Name_Dynamic_Predicate |
25877 Name_Type_Invariant |
25878 Name_uType_Invariant |
25882 Name_Assert_And_Cut |
25884 Name_Contract_Cases |
25886 Name_Initial_Condition |
25889 Name_Loop_Invariant |
25890 Name_Loop_Variant |
25891 Name_Postcondition |
25892 Name_Precondition |
25894 Name_Refined_Post |
25895 Name_Statement_Assertions
=> return True;
25897 when others => return False;
25899 end Is_Valid_Assertion_Kind
;
25901 -----------------------------------------
25902 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
25903 -----------------------------------------
25905 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
25906 Aspects
: constant List_Id
:= New_List
;
25907 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
25908 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
25910 Original_Aspects
: List_Id
;
25911 -- To capture global references, a copy of the created aspects must be
25912 -- inserted in the original tree.
25915 Prag_Arg_Ass
: Node_Id
;
25916 Prag_Id
: Pragma_Id
;
25919 -- Check for any PPC pragmas that appear within Decl
25921 Prag
:= Next
(Decl
);
25922 while Nkind
(Prag
) = N_Pragma
loop
25923 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
25926 when Pragma_Postcondition | Pragma_Precondition
=>
25927 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
25929 -- Make an aspect from any PPC pragma
25931 Append_To
(Aspects
,
25932 Make_Aspect_Specification
(Loc
,
25934 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
25936 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
25938 -- Generate the analysis information in the pragma expression
25939 -- and then set the pragma node analyzed to avoid any further
25942 Analyze
(Expression
(Prag_Arg_Ass
));
25943 Set_Analyzed
(Prag
, True);
25945 when others => null;
25951 -- Set all new aspects into the generic declaration node
25953 if Is_Non_Empty_List
(Aspects
) then
25955 -- Create the list of aspects to be inserted in the original tree
25957 Original_Aspects
:= Copy_Separate_List
(Aspects
);
25959 -- Check if Decl already has aspects
25961 -- Attach the new lists of aspects to both the generic copy and the
25964 if Has_Aspects
(Decl
) then
25965 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
25966 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
25969 Set_Parent
(Aspects
, Decl
);
25970 Set_Aspect_Specifications
(Decl
, Aspects
);
25971 Set_Parent
(Original_Aspects
, Or_Decl
);
25972 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
25975 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
25977 -------------------------
25978 -- Preanalyze_CTC_Args --
25979 -------------------------
25981 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
25983 -- Preanalyze the boolean expressions, we treat these as spec
25984 -- expressions (i.e. similar to a default expression).
25986 if Present
(Arg_Req
) then
25987 Preanalyze_Assert_Expression
25988 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
25990 -- In ASIS mode, for a pragma generated from a source aspect, also
25991 -- analyze the original aspect expression.
25993 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
25994 Preanalyze_Assert_Expression
25995 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
25999 if Present
(Arg_Ens
) then
26000 Preanalyze_Assert_Expression
26001 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
26003 -- In ASIS mode, for a pragma generated from a source aspect, also
26004 -- analyze the original aspect expression.
26006 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26007 Preanalyze_Assert_Expression
26008 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
26011 end Preanalyze_CTC_Args
;
26013 --------------------------------------
26014 -- Process_Compilation_Unit_Pragmas --
26015 --------------------------------------
26017 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26019 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26020 -- strange because it comes at the end of the unit. Rational has the
26021 -- same name for a pragma, but treats it as a program unit pragma, In
26022 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26023 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26024 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26025 -- the context clause to ensure the correct processing.
26027 if Has_Pragma_Suppress_All
(N
) then
26028 Prepend_To
(Context_Items
(N
),
26029 Make_Pragma
(Sloc
(N
),
26030 Chars
=> Name_Suppress
,
26031 Pragma_Argument_Associations
=> New_List
(
26032 Make_Pragma_Argument_Association
(Sloc
(N
),
26033 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26036 -- Nothing else to do at the current time
26038 end Process_Compilation_Unit_Pragmas
;
26040 ------------------------------------
26041 -- Record_Possible_Body_Reference --
26042 ------------------------------------
26044 procedure Record_Possible_Body_Reference
26045 (State_Id
: Entity_Id
;
26049 Spec_Id
: Entity_Id
;
26052 -- Ensure that we are dealing with a reference to a state
26054 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26056 -- Climb the tree starting from the reference looking for a package body
26057 -- whose spec declares the referenced state. This criteria automatically
26058 -- excludes references in package specs which are legal. Note that it is
26059 -- not wise to emit an error now as the package body may lack pragma
26060 -- Refined_State or the referenced state may not be mentioned in the
26061 -- refinement. This approach avoids the generation of misleading errors.
26064 while Present
(Context
) loop
26065 if Nkind
(Context
) = N_Package_Body
then
26066 Spec_Id
:= Corresponding_Spec
(Context
);
26068 if Present
(Abstract_States
(Spec_Id
))
26069 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26071 if No
(Body_References
(State_Id
)) then
26072 Set_Body_References
(State_Id
, New_Elmt_List
);
26075 Append_Elmt
(Ref
, Body_References
(State_Id
));
26080 Context
:= Parent
(Context
);
26082 end Record_Possible_Body_Reference
;
26084 ------------------------------
26085 -- Relocate_Pragmas_To_Body --
26086 ------------------------------
26088 procedure Relocate_Pragmas_To_Body
26089 (Subp_Body
: Node_Id
;
26090 Target_Body
: Node_Id
:= Empty
)
26092 procedure Relocate_Pragma
(Prag
: Node_Id
);
26093 -- Remove a single pragma from its current list and add it to the
26094 -- declarations of the proper body (either Subp_Body or Target_Body).
26096 ---------------------
26097 -- Relocate_Pragma --
26098 ---------------------
26100 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26105 -- When subprogram stubs or expression functions are involves, the
26106 -- destination declaration list belongs to the proper body.
26108 if Present
(Target_Body
) then
26109 Target
:= Target_Body
;
26111 Target
:= Subp_Body
;
26114 Decls
:= Declarations
(Target
);
26118 Set_Declarations
(Target
, Decls
);
26121 -- Unhook the pragma from its current list
26124 Prepend
(Prag
, Decls
);
26125 end Relocate_Pragma
;
26129 Body_Id
: constant Entity_Id
:=
26130 Defining_Unit_Name
(Specification
(Subp_Body
));
26131 Next_Stmt
: Node_Id
;
26134 -- Start of processing for Relocate_Pragmas_To_Body
26137 -- Do not process a body that comes from a separate unit as no construct
26138 -- can possibly follow it.
26140 if not Is_List_Member
(Subp_Body
) then
26143 -- Do not relocate pragmas that follow a stub if the stub does not have
26146 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26147 and then No
(Target_Body
)
26151 -- Do not process internally generated routine _Postconditions
26153 elsif Ekind
(Body_Id
) = E_Procedure
26154 and then Chars
(Body_Id
) = Name_uPostconditions
26159 -- Look at what is following the body. We are interested in certain kind
26160 -- of pragmas (either from source or byproducts of expansion) that can
26161 -- apply to a body [stub].
26163 Stmt
:= Next
(Subp_Body
);
26164 while Present
(Stmt
) loop
26166 -- Preserve the following statement for iteration purposes due to a
26167 -- possible relocation of a pragma.
26169 Next_Stmt
:= Next
(Stmt
);
26171 -- Move a candidate pragma following the body to the declarations of
26174 if Nkind
(Stmt
) = N_Pragma
26175 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26177 Relocate_Pragma
(Stmt
);
26179 -- Skip internally generated code
26181 elsif not Comes_From_Source
(Stmt
) then
26184 -- No candidate pragmas are available for relocation
26192 end Relocate_Pragmas_To_Body
;
26194 -------------------
26195 -- Resolve_State --
26196 -------------------
26198 procedure Resolve_State
(N
: Node_Id
) is
26203 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26204 Func
:= Entity
(N
);
26206 -- Handle overloading of state names by functions. Traverse the
26207 -- homonym chain looking for an abstract state.
26209 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26210 State
:= Homonym
(Func
);
26211 while Present
(State
) loop
26213 -- Resolve the overloading by setting the proper entity of the
26214 -- reference to that of the state.
26216 if Ekind
(State
) = E_Abstract_State
then
26217 Set_Etype
(N
, Standard_Void_Type
);
26218 Set_Entity
(N
, State
);
26219 Set_Associated_Node
(N
, State
);
26223 State
:= Homonym
(State
);
26226 -- A function can never act as a state. If the homonym chain does
26227 -- not contain a corresponding state, then something went wrong in
26228 -- the overloading mechanism.
26230 raise Program_Error
;
26235 ----------------------------
26236 -- Rewrite_Assertion_Kind --
26237 ----------------------------
26239 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26243 if Nkind
(N
) = N_Attribute_Reference
26244 and then Attribute_Name
(N
) = Name_Class
26245 and then Nkind
(Prefix
(N
)) = N_Identifier
26247 case Chars
(Prefix
(N
)) is
26252 when Name_Type_Invariant
=>
26253 Nam
:= Name_uType_Invariant
;
26254 when Name_Invariant
=>
26255 Nam
:= Name_uInvariant
;
26260 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26262 end Rewrite_Assertion_Kind
;
26273 --------------------------------
26274 -- Set_Encoded_Interface_Name --
26275 --------------------------------
26277 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26278 Str
: constant String_Id
:= Strval
(S
);
26279 Len
: constant Int
:= String_Length
(Str
);
26284 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26287 -- Stores encoded value of character code CC. The encoding we use an
26288 -- underscore followed by four lower case hex digits.
26294 procedure Encode
is
26296 Store_String_Char
(Get_Char_Code
('_'));
26298 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26300 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26302 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26304 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26307 -- Start of processing for Set_Encoded_Interface_Name
26310 -- If first character is asterisk, this is a link name, and we leave it
26311 -- completely unmodified. We also ignore null strings (the latter case
26312 -- happens only in error cases) and no encoding should occur for Java or
26313 -- AAMP interface names.
26316 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26317 or else VM_Target
/= No_VM
26318 or else AAMP_On_Target
26320 Set_Interface_Name
(E
, S
);
26325 CC
:= Get_String_Char
(Str
, J
);
26327 exit when not In_Character_Range
(CC
);
26329 C
:= Get_Character
(CC
);
26331 exit when C
/= '_' and then C
/= '$'
26332 and then C
not in '0' .. '9'
26333 and then C
not in 'a' .. 'z'
26334 and then C
not in 'A' .. 'Z';
26337 Set_Interface_Name
(E
, S
);
26345 -- Here we need to encode. The encoding we use as follows:
26346 -- three underscores + four hex digits (lower case)
26350 for J
in 1 .. String_Length
(Str
) loop
26351 CC
:= Get_String_Char
(Str
, J
);
26353 if not In_Character_Range
(CC
) then
26356 C
:= Get_Character
(CC
);
26358 if C
= '_' or else C
= '$'
26359 or else C
in '0' .. '9'
26360 or else C
in 'a' .. 'z'
26361 or else C
in 'A' .. 'Z'
26363 Store_String_Char
(CC
);
26370 Set_Interface_Name
(E
,
26371 Make_String_Literal
(Sloc
(S
),
26372 Strval
=> End_String
));
26374 end Set_Encoded_Interface_Name
;
26376 -------------------
26377 -- Set_Unit_Name --
26378 -------------------
26380 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26385 if Nkind
(N
) = N_Identifier
26386 and then Nkind
(With_Item
) = N_Identifier
26388 Set_Entity
(N
, Entity
(With_Item
));
26390 elsif Nkind
(N
) = N_Selected_Component
then
26391 Change_Selected_Component_To_Expanded_Name
(N
);
26392 Set_Entity
(N
, Entity
(With_Item
));
26393 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26395 Pref
:= Prefix
(N
);
26396 Scop
:= Scope
(Entity
(N
));
26397 while Nkind
(Pref
) = N_Selected_Component
loop
26398 Change_Selected_Component_To_Expanded_Name
(Pref
);
26399 Set_Entity
(Selector_Name
(Pref
), Scop
);
26400 Set_Entity
(Pref
, Scop
);
26401 Pref
:= Prefix
(Pref
);
26402 Scop
:= Scope
(Scop
);
26405 Set_Entity
(Pref
, Scop
);