1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Csets
; use Csets
;
37 with Debug
; use Debug
;
38 with Einfo
; use Einfo
;
39 with Elists
; use Elists
;
40 with Errout
; use Errout
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
45 with Lib
.Writ
; use Lib
.Writ
;
46 with Lib
.Xref
; use Lib
.Xref
;
47 with Namet
.Sp
; use Namet
.Sp
;
48 with Nlists
; use Nlists
;
49 with Nmake
; use Nmake
;
50 with Output
; use Output
;
51 with Par_SCO
; use Par_SCO
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch6
; use Sem_Ch6
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Ch12
; use Sem_Ch12
;
61 with Sem_Ch13
; use Sem_Ch13
;
62 with Sem_Disp
; use Sem_Disp
;
63 with Sem_Dist
; use Sem_Dist
;
64 with Sem_Elim
; use Sem_Elim
;
65 with Sem_Eval
; use Sem_Eval
;
66 with Sem_Intr
; use Sem_Intr
;
67 with Sem_Mech
; use Sem_Mech
;
68 with Sem_Res
; use Sem_Res
;
69 with Sem_Type
; use Sem_Type
;
70 with Sem_Util
; use Sem_Util
;
71 with Sem_Warn
; use Sem_Warn
;
72 with Stand
; use Stand
;
73 with Sinfo
; use Sinfo
;
74 with Sinfo
.CN
; use Sinfo
.CN
;
75 with Sinput
; use Sinput
;
76 with Stringt
; use Stringt
;
77 with Stylesw
; use Stylesw
;
79 with Targparm
; use Targparm
;
80 with Tbuild
; use Tbuild
;
82 with Uintp
; use Uintp
;
83 with Uname
; use Uname
;
84 with Urealp
; use Urealp
;
85 with Validsw
; use Validsw
;
86 with Warnsw
; use Warnsw
;
88 package body Sem_Prag
is
90 ----------------------------------------------
91 -- Common Handling of Import-Export Pragmas --
92 ----------------------------------------------
94 -- In the following section, a number of Import_xxx and Export_xxx pragmas
95 -- are defined by GNAT. These are compatible with the DEC pragmas of the
96 -- same name, and all have the following common form and processing:
99 -- [Internal =>] LOCAL_NAME
100 -- [, [External =>] EXTERNAL_SYMBOL]
101 -- [, other optional parameters ]);
104 -- [Internal =>] LOCAL_NAME
105 -- [, [External =>] EXTERNAL_SYMBOL]
106 -- [, other optional parameters ]);
108 -- EXTERNAL_SYMBOL ::=
110 -- | static_string_EXPRESSION
112 -- The internal LOCAL_NAME designates the entity that is imported or
113 -- exported, and must refer to an entity in the current declarative
114 -- part (as required by the rules for LOCAL_NAME).
116 -- The external linker name is designated by the External parameter if
117 -- given, or the Internal parameter if not (if there is no External
118 -- parameter, the External parameter is a copy of the Internal name).
120 -- If the External parameter is given as a string, then this string is
121 -- treated as an external name (exactly as though it had been given as an
122 -- External_Name parameter for a normal Import pragma).
124 -- If the External parameter is given as an identifier (or there is no
125 -- External parameter, so that the Internal identifier is used), then
126 -- the external name is the characters of the identifier, translated
127 -- to all lower case letters.
129 -- Note: the external name specified or implied by any of these special
130 -- Import_xxx or Export_xxx pragmas override an external or link name
131 -- specified in a previous Import or Export pragma.
133 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
134 -- named notation, following the standard rules for subprogram calls, i.e.
135 -- parameters can be given in any order if named notation is used, and
136 -- positional and named notation can be mixed, subject to the rule that all
137 -- positional parameters must appear first.
139 -- Note: All these pragmas are implemented exactly following the DEC design
140 -- and implementation and are intended to be fully compatible with the use
141 -- of these pragmas in the DEC Ada compiler.
143 --------------------------------------------
144 -- Checking for Duplicated External Names --
145 --------------------------------------------
147 -- It is suspicious if two separate Export pragmas use the same external
148 -- name. The following table is used to diagnose this situation so that
149 -- an appropriate warning can be issued.
151 -- The Node_Id stored is for the N_String_Literal node created to hold
152 -- the value of the external name. The Sloc of this node is used to
153 -- cross-reference the location of the duplication.
155 package Externals
is new Table
.Table
(
156 Table_Component_Type
=> Node_Id
,
157 Table_Index_Type
=> Int
,
158 Table_Low_Bound
=> 0,
159 Table_Initial
=> 100,
160 Table_Increment
=> 100,
161 Table_Name
=> "Name_Externals");
163 -------------------------------------
164 -- Local Subprograms and Variables --
165 -------------------------------------
167 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
);
168 -- Subsidiary routine to the analysis of pragmas Depends, Global and
169 -- Refined_State. Append an entity to a list. If the list is empty, create
172 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
173 -- This routine is used for possible casing adjustment of an explicit
174 -- external name supplied as a string literal (the node N), according to
175 -- the casing requirement of Opt.External_Name_Casing. If this is set to
176 -- As_Is, then the string literal is returned unchanged, but if it is set
177 -- to Uppercase or Lowercase, then a new string literal with appropriate
178 -- casing is constructed.
180 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
181 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
182 -- Query whether a particular item appears in a mixed list of nodes and
183 -- entities. It is assumed that all nodes in the list have entities.
185 function Check_Kind
(Nam
: Name_Id
) return Name_Id
;
186 -- This function is used in connection with pragmas Assert, Check,
187 -- and assertion aspects and pragmas, to determine if Check pragmas
188 -- (or corresponding assertion aspects or pragmas) are currently active
189 -- as determined by the presence of -gnata on the command line (which
190 -- sets the default), and the appearance of pragmas Check_Policy and
191 -- Assertion_Policy as configuration pragmas either in a configuration
192 -- pragma file, or at the start of the current unit, or locally given
193 -- Check_Policy and Assertion_Policy pragmas that are currently active.
195 -- The value returned is one of the names Check, Ignore, Disable (On
196 -- returns Check, and Off returns Ignore).
198 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
199 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
200 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
201 -- _Post, _Invariant, or _Type_Invariant, which are special names used
202 -- in identifiers to represent these attribute references.
204 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
);
205 -- In ASIS mode we need to analyze the original expression in the aspect
206 -- specification. For Initializes, Global, and related SPARK aspects, the
207 -- expression has a sui-generis syntax which may be a list, an expression,
210 procedure Check_State_And_Constituent_Use
214 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
215 -- Global and Initializes. Determine whether a state from list States and a
216 -- corresponding constituent from list Constits (if any) appear in the same
217 -- context denoted by Context. If this is the case, emit an error.
219 function Find_Related_Subprogram_Or_Body
221 Do_Checks
: Boolean := False) return Node_Id
;
222 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
223 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
224 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
225 -- Do_Checks is set, the routine reports duplicate pragmas and detects
226 -- improper use of refinement pragmas in stand alone expression functions.
227 -- The returned value depends on the related pragma as follows:
228 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
229 -- N_Subprogram_Declaration node or if the pragma applies to a stand
230 -- alone body, the N_Subprogram_Body node or Empty if illegal.
231 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
232 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
235 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
236 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
237 -- original one, following the renaming chain) is returned. Otherwise the
238 -- entity is returned unchanged. Should be in Einfo???
240 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
241 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
242 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
245 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
246 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
247 -- Determine whether dependency clause Clause is surrounded by extra
248 -- parentheses. If this is the case, issue an error message.
250 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
251 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
252 -- pragma Depends. Determine whether the type of dependency item Item is
253 -- tagged, unconstrained array, unconstrained record or a record with at
254 -- least one unconstrained component.
256 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
);
257 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
258 -- of a Test_Case pragma if present (possibly Empty). We treat these as
259 -- spec expressions (i.e. similar to a default expression).
261 procedure Record_Possible_Body_Reference
262 (State_Id
: Entity_Id
;
264 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
265 -- Global. Given an abstract state denoted by State_Id and a reference Ref
266 -- to it, determine whether the reference appears in a package body that
267 -- will eventually refine the state. If this is the case, record the
268 -- reference for future checks (see Analyze_Refined_State_In_Decls).
270 procedure Resolve_State
(N
: Node_Id
);
271 -- Handle the overloading of state names by functions. When N denotes a
272 -- function, this routine finds the corresponding state and sets the entity
273 -- of N to that of the state.
275 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
276 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
277 -- then it is rewritten as an identifier with the corresponding special
278 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
279 -- Check, Check_Policy.
281 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
282 -- Place semantic information on the argument of an Elaborate/Elaborate_All
283 -- pragma. Entity name for unit and its parents is taken from item in
284 -- previous with_clause that mentions the unit.
286 Dummy
: Integer := 0;
287 pragma Volatile
(Dummy
);
288 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
291 pragma No_Inline
(ip
);
292 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
293 -- is just to help debugging the front end. If a pragma Inspection_Point
294 -- is added to a source program, then breaking on ip will get you to that
295 -- point in the program.
298 pragma No_Inline
(rv
);
299 -- This is a dummy function called by the processing for pragma Reviewable.
300 -- It is there for assisting front end debugging. By placing a Reviewable
301 -- pragma in the source program, a breakpoint on rv catches this place in
302 -- the source, allowing convenient stepping to the point of interest.
308 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
310 Append_New_Elmt
(Item
, To
=> To_List
);
313 -------------------------------
314 -- Adjust_External_Name_Case --
315 -------------------------------
317 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
321 -- Adjust case of literal if required
323 if Opt
.External_Name_Exp_Casing
= As_Is
then
327 -- Copy existing string
333 for J
in 1 .. String_Length
(Strval
(N
)) loop
334 CC
:= Get_String_Char
(Strval
(N
), J
);
336 if Opt
.External_Name_Exp_Casing
= Uppercase
337 and then CC
>= Get_Char_Code
('a')
338 and then CC
<= Get_Char_Code
('z')
340 Store_String_Char
(CC
- 32);
342 elsif Opt
.External_Name_Exp_Casing
= Lowercase
343 and then CC
>= Get_Char_Code
('A')
344 and then CC
<= Get_Char_Code
('Z')
346 Store_String_Char
(CC
+ 32);
349 Store_String_Char
(CC
);
354 Make_String_Literal
(Sloc
(N
),
355 Strval
=> End_String
);
357 end Adjust_External_Name_Case
;
359 -----------------------------------------
360 -- Analyze_Contract_Cases_In_Decl_Part --
361 -----------------------------------------
363 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
364 Others_Seen
: Boolean := False;
366 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
367 -- Verify the legality of a single contract case
369 ---------------------------
370 -- Analyze_Contract_Case --
371 ---------------------------
373 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
374 Case_Guard
: Node_Id
;
376 Extra_Guard
: Node_Id
;
379 if Nkind
(CCase
) = N_Component_Association
then
380 Case_Guard
:= First
(Choices
(CCase
));
381 Conseq
:= Expression
(CCase
);
383 -- Each contract case must have exactly one case guard
385 Extra_Guard
:= Next
(Case_Guard
);
387 if Present
(Extra_Guard
) then
389 ("contract case must have exactly one case guard",
393 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
395 if Nkind
(Case_Guard
) = N_Others_Choice
then
398 ("only one others choice allowed in contract cases",
404 elsif Others_Seen
then
406 ("others must be the last choice in contract cases", N
);
409 -- Preanalyze the case guard and consequence
411 if Nkind
(Case_Guard
) /= N_Others_Choice
then
412 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
415 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
417 -- The contract case is malformed
420 Error_Msg_N
("wrong syntax in contract case", CCase
);
422 end Analyze_Contract_Case
;
431 Restore_Scope
: Boolean := False;
432 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
434 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
439 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
440 Subp_Id
:= Defining_Entity
(Subp_Decl
);
441 All_Cases
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
443 -- Single and multiple contract cases must appear in aggregate form. If
444 -- this is not the case, then either the parser of the analysis of the
445 -- pragma failed to produce an aggregate.
447 pragma Assert
(Nkind
(All_Cases
) = N_Aggregate
);
449 if No
(Component_Associations
(All_Cases
)) then
450 Error_Msg_N
("wrong syntax for constract cases", N
);
452 -- Individual contract cases appear as component associations
455 -- Ensure that the formal parameters are visible when analyzing all
456 -- clauses. This falls out of the general rule of aspects pertaining
457 -- to subprogram declarations. Skip the installation for subprogram
458 -- bodies because the formals are already visible.
460 if not In_Open_Scopes
(Subp_Id
) then
461 Restore_Scope
:= True;
462 Push_Scope
(Subp_Id
);
463 Install_Formals
(Subp_Id
);
466 CCase
:= First
(Component_Associations
(All_Cases
));
467 while Present
(CCase
) loop
468 Analyze_Contract_Case
(CCase
);
472 if Restore_Scope
then
476 end Analyze_Contract_Cases_In_Decl_Part
;
478 ----------------------------------
479 -- Analyze_Depends_In_Decl_Part --
480 ----------------------------------
482 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
483 Loc
: constant Source_Ptr
:= Sloc
(N
);
485 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
486 -- A list containing the entities of all the inputs processed so far.
487 -- The list is populated with unique entities because the same input
488 -- may appear in multiple input lists.
490 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
491 -- A list containing the entities of all the outputs processed so far.
492 -- The list is populated with unique entities because output items are
493 -- unique in a dependence relation.
495 Constits_Seen
: Elist_Id
:= No_Elist
;
496 -- A list containing the entities of all constituents processed so far.
497 -- It aids in detecting illegal usage of a state and a corresponding
498 -- constituent in pragma [Refinde_]Depends.
500 Global_Seen
: Boolean := False;
501 -- A flag set when pragma Global has been processed
503 Null_Output_Seen
: Boolean := False;
504 -- A flag used to track the legality of a null output
506 Result_Seen
: Boolean := False;
507 -- A flag set when Subp_Id'Result is processed
510 -- The entity of the subprogram subject to pragma [Refined_]Depends
512 States_Seen
: Elist_Id
:= No_Elist
;
513 -- A list containing the entities of all states processed so far. It
514 -- helps in detecting illegal usage of a state and a corresponding
515 -- constituent in pragma [Refined_]Depends.
518 -- The entity of the subprogram [body or stub] subject to pragma
519 -- [Refined_]Depends.
521 Subp_Inputs
: Elist_Id
:= No_Elist
;
522 Subp_Outputs
: Elist_Id
:= No_Elist
;
523 -- Two lists containing the full set of inputs and output of the related
524 -- subprograms. Note that these lists contain both nodes and entities.
526 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
527 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
528 -- to the name buffer. The individual kinds are as follows:
529 -- E_Abstract_State - "state"
530 -- E_In_Parameter - "parameter"
531 -- E_In_Out_Parameter - "parameter"
532 -- E_Out_Parameter - "parameter"
533 -- E_Variable - "global"
535 procedure Analyze_Dependency_Clause
538 -- Verify the legality of a single dependency clause. Flag Is_Last
539 -- denotes whether Clause is the last clause in the relation.
541 procedure Check_Function_Return
;
542 -- Verify that Funtion'Result appears as one of the outputs
543 -- (SPARK RM 6.1.5(10)).
550 -- Ensure that an item fulfils its designated input and/or output role
551 -- as specified by pragma Global (if any) or the enclosing context. If
552 -- this is not the case, emit an error. Item and Item_Id denote the
553 -- attributes of an item. Flag Is_Input should be set when item comes
554 -- from an input list. Flag Self_Ref should be set when the item is an
555 -- output and the dependency clause has operator "+".
557 procedure Check_Usage
558 (Subp_Items
: Elist_Id
;
559 Used_Items
: Elist_Id
;
561 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
562 -- error if this is not the case.
564 procedure Normalize_Clause
(Clause
: Node_Id
);
565 -- Remove a self-dependency "+" from the input list of a clause
567 -----------------------------
568 -- Add_Item_To_Name_Buffer --
569 -----------------------------
571 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
573 if Ekind
(Item_Id
) = E_Abstract_State
then
574 Add_Str_To_Name_Buffer
("state");
576 elsif Is_Formal
(Item_Id
) then
577 Add_Str_To_Name_Buffer
("parameter");
579 elsif Ekind
(Item_Id
) = E_Variable
then
580 Add_Str_To_Name_Buffer
("global");
582 -- The routine should not be called with non-SPARK items
587 end Add_Item_To_Name_Buffer
;
589 -------------------------------
590 -- Analyze_Dependency_Clause --
591 -------------------------------
593 procedure Analyze_Dependency_Clause
597 procedure Analyze_Input_List
(Inputs
: Node_Id
);
598 -- Verify the legality of a single input list
600 procedure Analyze_Input_Output
605 Seen
: in out Elist_Id
;
606 Null_Seen
: in out Boolean;
607 Non_Null_Seen
: in out Boolean);
608 -- Verify the legality of a single input or output item. Flag
609 -- Is_Input should be set whenever Item is an input, False when it
610 -- denotes an output. Flag Self_Ref should be set when the item is an
611 -- output and the dependency clause has a "+". Flag Top_Level should
612 -- be set whenever Item appears immediately within an input or output
613 -- list. Seen is a collection of all abstract states, variables and
614 -- formals processed so far. Flag Null_Seen denotes whether a null
615 -- input or output has been encountered. Flag Non_Null_Seen denotes
616 -- whether a non-null input or output has been encountered.
618 ------------------------
619 -- Analyze_Input_List --
620 ------------------------
622 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
623 Inputs_Seen
: Elist_Id
:= No_Elist
;
624 -- A list containing the entities of all inputs that appear in the
625 -- current input list.
627 Non_Null_Input_Seen
: Boolean := False;
628 Null_Input_Seen
: Boolean := False;
629 -- Flags used to check the legality of an input list
634 -- Multiple inputs appear as an aggregate
636 if Nkind
(Inputs
) = N_Aggregate
then
637 if Present
(Component_Associations
(Inputs
)) then
639 ("nested dependency relations not allowed", Inputs
);
641 elsif Present
(Expressions
(Inputs
)) then
642 Input
:= First
(Expressions
(Inputs
));
643 while Present
(Input
) loop
650 Null_Seen
=> Null_Input_Seen
,
651 Non_Null_Seen
=> Non_Null_Input_Seen
);
656 -- Syntax error, always report
659 Error_Msg_N
("malformed input dependency list", Inputs
);
662 -- Process a solitary input
671 Null_Seen
=> Null_Input_Seen
,
672 Non_Null_Seen
=> Non_Null_Input_Seen
);
675 -- Detect an illegal dependency clause of the form
679 if Null_Output_Seen
and then Null_Input_Seen
then
681 ("null dependency clause cannot have a null input list",
684 end Analyze_Input_List
;
686 --------------------------
687 -- Analyze_Input_Output --
688 --------------------------
690 procedure Analyze_Input_Output
695 Seen
: in out Elist_Id
;
696 Null_Seen
: in out Boolean;
697 Non_Null_Seen
: in out Boolean)
699 Is_Output
: constant Boolean := not Is_Input
;
704 -- Multiple input or output items appear as an aggregate
706 if Nkind
(Item
) = N_Aggregate
then
707 if not Top_Level
then
708 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
710 elsif Present
(Component_Associations
(Item
)) then
712 ("nested dependency relations not allowed", Item
);
714 -- Recursively analyze the grouped items
716 elsif Present
(Expressions
(Item
)) then
717 Grouped
:= First
(Expressions
(Item
));
718 while Present
(Grouped
) loop
721 Is_Input
=> Is_Input
,
722 Self_Ref
=> Self_Ref
,
725 Null_Seen
=> Null_Seen
,
726 Non_Null_Seen
=> Non_Null_Seen
);
731 -- Syntax error, always report
734 Error_Msg_N
("malformed dependency list", Item
);
737 -- Process Function'Result in the context of a dependency clause
739 elsif Is_Attribute_Result
(Item
) then
740 Non_Null_Seen
:= True;
742 -- It is sufficent to analyze the prefix of 'Result in order to
743 -- establish legality of the attribute.
745 Analyze
(Prefix
(Item
));
747 -- The prefix of 'Result must denote the function for which
748 -- pragma Depends applies (SPARK RM 6.1.5(11)).
750 if not Is_Entity_Name
(Prefix
(Item
))
751 or else Ekind
(Spec_Id
) /= E_Function
752 or else Entity
(Prefix
(Item
)) /= Spec_Id
754 Error_Msg_Name_1
:= Name_Result
;
756 ("prefix of attribute % must denote the enclosing "
759 -- Function'Result is allowed to appear on the output side of a
760 -- dependency clause (SPARK RM 6.1.5(6)).
763 SPARK_Msg_N
("function result cannot act as input", Item
);
767 ("cannot mix null and non-null dependency items", Item
);
773 -- Detect multiple uses of null in a single dependency list or
774 -- throughout the whole relation. Verify the placement of a null
775 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
777 elsif Nkind
(Item
) = N_Null
then
780 ("multiple null dependency relations not allowed", Item
);
782 elsif Non_Null_Seen
then
784 ("cannot mix null and non-null dependency items", Item
);
792 ("null output list must be the last clause in a "
793 & "dependency relation", Item
);
795 -- Catch a useless dependence of the form:
800 ("useless dependence, null depends on itself", Item
);
808 Non_Null_Seen
:= True;
811 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
815 Resolve_State
(Item
);
817 -- Find the entity of the item. If this is a renaming, climb
818 -- the renaming chain to reach the root object. Renamings of
819 -- non-entire objects do not yield an entity (Empty).
821 Item_Id
:= Entity_Of
(Item
);
823 if Present
(Item_Id
) then
824 if Ekind_In
(Item_Id
, E_Abstract_State
,
830 -- Ensure that the item fulfils its role as input and/or
831 -- output as specified by pragma Global or the enclosing
834 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
836 -- Detect multiple uses of the same state, variable or
837 -- formal parameter. If this is not the case, add the
838 -- item to the list of processed relations.
840 if Contains
(Seen
, Item_Id
) then
842 ("duplicate use of item &", Item
, Item_Id
);
844 Add_Item
(Item_Id
, Seen
);
847 -- Detect illegal use of an input related to a null
848 -- output. Such input items cannot appear in other
849 -- input lists (SPARK RM 6.1.5(13)).
852 and then Null_Output_Seen
853 and then Contains
(All_Inputs_Seen
, Item_Id
)
856 ("input of a null output list cannot appear in "
857 & "multiple input lists", Item
);
860 -- Add an input or a self-referential output to the list
861 -- of all processed inputs.
863 if Is_Input
or else Self_Ref
then
864 Add_Item
(Item_Id
, All_Inputs_Seen
);
867 -- State related checks (SPARK RM 6.1.5(3))
869 if Ekind
(Item_Id
) = E_Abstract_State
then
870 if Has_Visible_Refinement
(Item_Id
) then
872 ("cannot mention state & in global refinement",
875 ("\use its constituents instead", Item
);
878 -- If the reference to the abstract state appears in
879 -- an enclosing package body that will eventually
880 -- refine the state, record the reference for future
884 Record_Possible_Body_Reference
885 (State_Id
=> Item_Id
,
890 -- When the item renames an entire object, replace the
891 -- item with a reference to the object.
893 if Present
(Renamed_Object
(Entity
(Item
))) then
895 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
899 -- Add the entity of the current item to the list of
902 if Ekind
(Item_Id
) = E_Abstract_State
then
903 Add_Item
(Item_Id
, States_Seen
);
906 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
907 and then Present
(Encapsulating_State
(Item_Id
))
909 Add_Item
(Item_Id
, Constits_Seen
);
912 -- All other input/output items are illegal
913 -- (SPARK RM 6.1.5(1)).
917 ("item must denote parameter, variable, or state",
921 -- All other input/output items are illegal
922 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
926 ("item must denote parameter, variable, or state", Item
);
929 end Analyze_Input_Output
;
937 Non_Null_Output_Seen
: Boolean := False;
938 -- Flag used to check the legality of an output list
940 -- Start of processing for Analyze_Dependency_Clause
943 Inputs
:= Expression
(Clause
);
946 -- An input list with a self-dependency appears as operator "+" where
947 -- the actuals inputs are the right operand.
949 if Nkind
(Inputs
) = N_Op_Plus
then
950 Inputs
:= Right_Opnd
(Inputs
);
954 -- Process the output_list of a dependency_clause
956 Output
:= First
(Choices
(Clause
));
957 while Present
(Output
) loop
961 Self_Ref
=> Self_Ref
,
963 Seen
=> All_Outputs_Seen
,
964 Null_Seen
=> Null_Output_Seen
,
965 Non_Null_Seen
=> Non_Null_Output_Seen
);
970 -- Process the input_list of a dependency_clause
972 Analyze_Input_List
(Inputs
);
973 end Analyze_Dependency_Clause
;
975 ---------------------------
976 -- Check_Function_Return --
977 ---------------------------
979 procedure Check_Function_Return
is
981 if Ekind
(Spec_Id
) = E_Function
and then not Result_Seen
then
983 ("result of & must appear in exactly one output list",
986 end Check_Function_Return
;
999 (Item_Is_Input
: out Boolean;
1000 Item_Is_Output
: out Boolean);
1001 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1002 -- Item_Is_Output are set depending on the role.
1004 procedure Role_Error
1005 (Item_Is_Input
: Boolean;
1006 Item_Is_Output
: Boolean);
1007 -- Emit an error message concerning the incorrect use of Item in
1008 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1009 -- denote whether the item is an input and/or an output.
1016 (Item_Is_Input
: out Boolean;
1017 Item_Is_Output
: out Boolean)
1020 Item_Is_Input
:= False;
1021 Item_Is_Output
:= False;
1023 -- Abstract state cases
1025 if Ekind
(Item_Id
) = E_Abstract_State
then
1027 -- When pragma Global is present, the mode of the state may be
1028 -- further constrained by setting a more restrictive mode.
1031 if Appears_In
(Subp_Inputs
, Item_Id
) then
1032 Item_Is_Input
:= True;
1035 if Appears_In
(Subp_Outputs
, Item_Id
) then
1036 Item_Is_Output
:= True;
1039 -- Otherwise the state has a default IN OUT mode
1042 Item_Is_Input
:= True;
1043 Item_Is_Output
:= True;
1048 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1049 Item_Is_Input
:= True;
1051 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1052 Item_Is_Input
:= True;
1053 Item_Is_Output
:= True;
1055 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1056 if Scope
(Item_Id
) = Spec_Id
then
1058 -- An OUT parameter of the related subprogram has mode IN
1059 -- if its type is unconstrained or tagged because array
1060 -- bounds, discriminants or tags can be read.
1062 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1063 Item_Is_Input
:= True;
1066 Item_Is_Output
:= True;
1068 -- An OUT parameter of an enclosing subprogram behaves as a
1069 -- read-write variable in which case the mode is IN OUT.
1072 Item_Is_Input
:= True;
1073 Item_Is_Output
:= True;
1078 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1080 -- When pragma Global is present, the mode of the variable may
1081 -- be further constrained by setting a more restrictive mode.
1085 -- A variable has mode IN when its type is unconstrained or
1086 -- tagged because array bounds, discriminants or tags can be
1089 if Appears_In
(Subp_Inputs
, Item_Id
)
1090 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1092 Item_Is_Input
:= True;
1095 if Appears_In
(Subp_Outputs
, Item_Id
) then
1096 Item_Is_Output
:= True;
1099 -- Otherwise the variable has a default IN OUT mode
1102 Item_Is_Input
:= True;
1103 Item_Is_Output
:= True;
1112 procedure Role_Error
1113 (Item_Is_Input
: Boolean;
1114 Item_Is_Output
: Boolean)
1116 Error_Msg
: Name_Id
;
1121 -- When the item is not part of the input and the output set of
1122 -- the related subprogram, then it appears as extra in pragma
1123 -- [Refined_]Depends.
1125 if not Item_Is_Input
and then not Item_Is_Output
then
1126 Add_Item_To_Name_Buffer
(Item_Id
);
1127 Add_Str_To_Name_Buffer
1128 (" & cannot appear in dependence relation");
1130 Error_Msg
:= Name_Find
;
1131 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1133 Error_Msg_Name_1
:= Chars
(Subp_Id
);
1135 ("\& is not part of the input or output set of subprogram %",
1138 -- The mode of the item and its role in pragma [Refined_]Depends
1139 -- are in conflict. Construct a detailed message explaining the
1140 -- illegality (SPARK RM 6.1.5(5-6)).
1143 if Item_Is_Input
then
1144 Add_Str_To_Name_Buffer
("read-only");
1146 Add_Str_To_Name_Buffer
("write-only");
1149 Add_Char_To_Name_Buffer
(' ');
1150 Add_Item_To_Name_Buffer
(Item_Id
);
1151 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1153 if Item_Is_Input
then
1154 Add_Str_To_Name_Buffer
("output");
1156 Add_Str_To_Name_Buffer
("input");
1159 Add_Str_To_Name_Buffer
(" in dependence relation");
1160 Error_Msg
:= Name_Find
;
1161 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1167 Item_Is_Input
: Boolean;
1168 Item_Is_Output
: Boolean;
1170 -- Start of processing for Check_Role
1173 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1178 if not Item_Is_Input
then
1179 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1182 -- Self-referential item
1185 if not Item_Is_Input
or else not Item_Is_Output
then
1186 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1191 elsif not Item_Is_Output
then
1192 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1200 procedure Check_Usage
1201 (Subp_Items
: Elist_Id
;
1202 Used_Items
: Elist_Id
;
1205 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
1206 -- Emit an error concerning the illegal usage of an item
1212 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
1213 Error_Msg
: Name_Id
;
1220 -- Unconstrained and tagged items are not part of the explicit
1221 -- input set of the related subprogram, they do not have to be
1222 -- present in a dependence relation and should not be flagged
1223 -- (SPARK RM 6.1.5(8)).
1225 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1228 Add_Item_To_Name_Buffer
(Item_Id
);
1229 Add_Str_To_Name_Buffer
1230 (" & must appear in at least one input dependence list");
1232 Error_Msg
:= Name_Find
;
1233 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1236 -- Output case (SPARK RM 6.1.5(10))
1241 Add_Item_To_Name_Buffer
(Item_Id
);
1242 Add_Str_To_Name_Buffer
1243 (" & must appear in exactly one output dependence list");
1245 Error_Msg
:= Name_Find
;
1246 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1254 Item_Id
: Entity_Id
;
1256 -- Start of processing for Check_Usage
1259 if No
(Subp_Items
) then
1263 -- Each input or output of the subprogram must appear in a dependency
1266 Elmt
:= First_Elmt
(Subp_Items
);
1267 while Present
(Elmt
) loop
1268 Item
:= Node
(Elmt
);
1270 if Nkind
(Item
) = N_Defining_Identifier
then
1273 Item_Id
:= Entity_Of
(Item
);
1276 -- The item does not appear in a dependency
1278 if Present
(Item_Id
)
1279 and then not Contains
(Used_Items
, Item_Id
)
1281 if Is_Formal
(Item_Id
) then
1282 Usage_Error
(Item
, Item_Id
);
1284 -- States and global variables are not used properly only when
1285 -- the subprogram is subject to pragma Global.
1287 elsif Global_Seen
then
1288 Usage_Error
(Item
, Item_Id
);
1296 ----------------------
1297 -- Normalize_Clause --
1298 ----------------------
1300 procedure Normalize_Clause
(Clause
: Node_Id
) is
1301 procedure Create_Or_Modify_Clause
1307 Multiple
: Boolean);
1308 -- Create a brand new clause to represent the self-reference or
1309 -- modify the input and/or output lists of an existing clause. Output
1310 -- denotes a self-referencial output. Outputs is the output list of a
1311 -- clause. Inputs is the input list of a clause. After denotes the
1312 -- clause after which the new clause is to be inserted. Flag In_Place
1313 -- should be set when normalizing the last output of an output list.
1314 -- Flag Multiple should be set when Output comes from a list with
1317 -----------------------------
1318 -- Create_Or_Modify_Clause --
1319 -----------------------------
1321 procedure Create_Or_Modify_Clause
1329 procedure Propagate_Output
1332 -- Handle the various cases of output propagation to the input
1333 -- list. Output denotes a self-referencial output item. Inputs is
1334 -- the input list of a clause.
1336 ----------------------
1337 -- Propagate_Output --
1338 ----------------------
1340 procedure Propagate_Output
1344 function In_Input_List
1346 Inputs
: List_Id
) return Boolean;
1347 -- Determine whether a particulat item appears in the input
1348 -- list of a clause.
1354 function In_Input_List
1356 Inputs
: List_Id
) return Boolean
1361 Elmt
:= First
(Inputs
);
1362 while Present
(Elmt
) loop
1363 if Entity_Of
(Elmt
) = Item
then
1375 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1378 -- Start of processing for Propagate_Output
1381 -- The clause is of the form:
1383 -- (Output =>+ null)
1385 -- Remove null input and replace it with a copy of the output:
1387 -- (Output => Output)
1389 if Nkind
(Inputs
) = N_Null
then
1390 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1392 -- The clause is of the form:
1394 -- (Output =>+ (Input1, ..., InputN))
1396 -- Determine whether the output is not already mentioned in the
1397 -- input list and if not, add it to the list of inputs:
1399 -- (Output => (Output, Input1, ..., InputN))
1401 elsif Nkind
(Inputs
) = N_Aggregate
then
1402 Grouped
:= Expressions
(Inputs
);
1404 if not In_Input_List
1408 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1411 -- The clause is of the form:
1413 -- (Output =>+ Input)
1415 -- If the input does not mention the output, group the two
1418 -- (Output => (Output, Input))
1420 elsif Entity_Of
(Inputs
) /= Output_Id
then
1422 Make_Aggregate
(Loc
,
1423 Expressions
=> New_List
(
1424 New_Copy_Tree
(Output
),
1425 New_Copy_Tree
(Inputs
))));
1427 end Propagate_Output
;
1431 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1432 New_Clause
: Node_Id
;
1434 -- Start of processing for Create_Or_Modify_Clause
1437 -- A null output depending on itself does not require any
1440 if Nkind
(Output
) = N_Null
then
1443 -- A function result cannot depend on itself because it cannot
1444 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1446 elsif Is_Attribute_Result
(Output
) then
1447 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1451 -- When performing the transformation in place, simply add the
1452 -- output to the list of inputs (if not already there). This case
1453 -- arises when dealing with the last output of an output list -
1454 -- we perform the normalization in place to avoid generating a
1458 Propagate_Output
(Output
, Inputs
);
1460 -- A list with multiple outputs is slowly trimmed until only
1461 -- one element remains. When this happens, replace aggregate
1462 -- with the element itself.
1466 Rewrite
(Outputs
, Output
);
1472 -- Unchain the output from its output list as it will appear in
1473 -- a new clause. Note that we cannot simply rewrite the output
1474 -- as null because this will violate the semantics of pragma
1479 -- Generate a new clause of the form:
1480 -- (Output => Inputs)
1483 Make_Component_Association
(Loc
,
1484 Choices
=> New_List
(Output
),
1485 Expression
=> New_Copy_Tree
(Inputs
));
1487 -- The new clause contains replicated content that has already
1488 -- been analyzed. There is not need to reanalyze it or
1489 -- renormalize it again.
1491 Set_Analyzed
(New_Clause
);
1494 (Output
=> First
(Choices
(New_Clause
)),
1495 Inputs
=> Expression
(New_Clause
));
1497 Insert_After
(After
, New_Clause
);
1499 end Create_Or_Modify_Clause
;
1503 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1505 Last_Output
: Node_Id
;
1506 Next_Output
: Node_Id
;
1509 -- Start of processing for Normalize_Clause
1512 -- A self-dependency appears as operator "+". Remove the "+" from the
1513 -- tree by moving the real inputs to their proper place.
1515 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1516 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1517 Inputs
:= Expression
(Clause
);
1519 -- Multiple outputs appear as an aggregate
1521 if Nkind
(Outputs
) = N_Aggregate
then
1522 Last_Output
:= Last
(Expressions
(Outputs
));
1524 Output
:= First
(Expressions
(Outputs
));
1525 while Present
(Output
) loop
1527 -- Normalization may remove an output from its list,
1528 -- preserve the subsequent output now.
1530 Next_Output
:= Next
(Output
);
1532 Create_Or_Modify_Clause
1537 In_Place
=> Output
= Last_Output
,
1540 Output
:= Next_Output
;
1546 Create_Or_Modify_Clause
1555 end Normalize_Clause
;
1559 Deps
: constant Node_Id
:=
1561 (First
(Pragma_Argument_Associations
(N
)));
1564 Last_Clause
: Node_Id
;
1565 Subp_Decl
: Node_Id
;
1567 Restore_Scope
: Boolean := False;
1568 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1570 -- Start of processing for Analyze_Depends_In_Decl_Part
1575 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
1576 Subp_Id
:= Defining_Entity
(Subp_Decl
);
1578 -- The logic in this routine is used to analyze both pragma Depends and
1579 -- pragma Refined_Depends since they have the same syntax and base
1580 -- semantics. Find the entity of the corresponding spec when analyzing
1583 if Nkind
(Subp_Decl
) = N_Subprogram_Body
1584 and then Present
(Corresponding_Spec
(Subp_Decl
))
1586 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
1588 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
1589 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
1591 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
1597 -- Empty dependency list
1599 if Nkind
(Deps
) = N_Null
then
1601 -- Gather all states, variables and formal parameters that the
1602 -- subprogram may depend on. These items are obtained from the
1603 -- parameter profile or pragma [Refined_]Global (if available).
1605 Collect_Subprogram_Inputs_Outputs
1606 (Subp_Id
=> Subp_Id
,
1607 Subp_Inputs
=> Subp_Inputs
,
1608 Subp_Outputs
=> Subp_Outputs
,
1609 Global_Seen
=> Global_Seen
);
1611 -- Verify that every input or output of the subprogram appear in a
1614 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1615 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1616 Check_Function_Return
;
1618 -- Dependency clauses appear as component associations of an aggregate
1620 elsif Nkind
(Deps
) = N_Aggregate
then
1622 -- Do not attempt to perform analysis of a syntactically illegal
1623 -- clause as this will lead to misleading errors.
1625 if Has_Extra_Parentheses
(Deps
) then
1629 if Present
(Component_Associations
(Deps
)) then
1630 Last_Clause
:= Last
(Component_Associations
(Deps
));
1632 -- Gather all states, variables and formal parameters that the
1633 -- subprogram may depend on. These items are obtained from the
1634 -- parameter profile or pragma [Refined_]Global (if available).
1636 Collect_Subprogram_Inputs_Outputs
1637 (Subp_Id
=> Subp_Id
,
1638 Subp_Inputs
=> Subp_Inputs
,
1639 Subp_Outputs
=> Subp_Outputs
,
1640 Global_Seen
=> Global_Seen
);
1642 -- Ensure that the formal parameters are visible when analyzing
1643 -- all clauses. This falls out of the general rule of aspects
1644 -- pertaining to subprogram declarations. Skip the installation
1645 -- for subprogram bodies because the formals are already visible.
1647 if not In_Open_Scopes
(Spec_Id
) then
1648 Restore_Scope
:= True;
1649 Push_Scope
(Spec_Id
);
1650 Install_Formals
(Spec_Id
);
1653 Clause
:= First
(Component_Associations
(Deps
));
1654 while Present
(Clause
) loop
1655 Errors
:= Serious_Errors_Detected
;
1657 -- Normalization may create extra clauses that contain
1658 -- replicated input and output names. There is no need to
1661 if not Analyzed
(Clause
) then
1662 Set_Analyzed
(Clause
);
1664 Analyze_Dependency_Clause
1666 Is_Last
=> Clause
= Last_Clause
);
1669 -- Do not normalize a clause if errors were detected (count
1670 -- of Serious_Errors has increased) because the inputs and/or
1671 -- outputs may denote illegal items. Normalization is disabled
1672 -- in ASIS mode as it alters the tree by introducing new nodes
1673 -- similar to expansion.
1675 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1676 Normalize_Clause
(Clause
);
1682 if Restore_Scope
then
1686 -- Verify that every input or output of the subprogram appear in a
1689 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1690 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1691 Check_Function_Return
;
1693 -- The dependency list is malformed. This is a syntax error, always
1697 Error_Msg_N
("malformed dependency relation", Deps
);
1701 -- The top level dependency relation is malformed. This is a syntax
1702 -- error, always report.
1705 Error_Msg_N
("malformed dependency relation", Deps
);
1709 -- Ensure that a state and a corresponding constituent do not appear
1710 -- together in pragma [Refined_]Depends.
1712 Check_State_And_Constituent_Use
1713 (States
=> States_Seen
,
1714 Constits
=> Constits_Seen
,
1716 end Analyze_Depends_In_Decl_Part
;
1718 --------------------------------------------
1719 -- Analyze_External_Property_In_Decl_Part --
1720 --------------------------------------------
1722 procedure Analyze_External_Property_In_Decl_Part
1724 Expr_Val
: out Boolean)
1726 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1727 Obj_Id
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
1728 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Next
(Arg1
));
1731 Error_Msg_Name_1
:= Pragma_Name
(N
);
1733 -- An external property pragma must apply to an effectively volatile
1734 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1735 -- The check is performed at the end of the declarative region due to a
1736 -- possible out-of-order arrangement of pragmas:
1739 -- pragma Async_Readers (Obj);
1740 -- pragma Volatile (Obj);
1742 if not Is_Effectively_Volatile
(Obj_Id
) then
1744 ("external property % must apply to a volatile object", N
);
1747 -- Ensure that the Boolean expression (if present) is static. A missing
1748 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1752 if Present
(Expr
) then
1753 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
1755 if Is_OK_Static_Expression
(Expr
) then
1756 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1758 SPARK_Msg_N
("expression of % must be static", Expr
);
1761 end Analyze_External_Property_In_Decl_Part
;
1763 ---------------------------------
1764 -- Analyze_Global_In_Decl_Part --
1765 ---------------------------------
1767 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1768 Constits_Seen
: Elist_Id
:= No_Elist
;
1769 -- A list containing the entities of all constituents processed so far.
1770 -- It aids in detecting illegal usage of a state and a corresponding
1771 -- constituent in pragma [Refinde_]Global.
1773 Seen
: Elist_Id
:= No_Elist
;
1774 -- A list containing the entities of all the items processed so far. It
1775 -- plays a role in detecting distinct entities.
1777 Spec_Id
: Entity_Id
;
1778 -- The entity of the subprogram subject to pragma [Refined_]Global
1780 States_Seen
: Elist_Id
:= No_Elist
;
1781 -- A list containing the entities of all states processed so far. It
1782 -- helps in detecting illegal usage of a state and a corresponding
1783 -- constituent in pragma [Refined_]Global.
1785 Subp_Id
: Entity_Id
;
1786 -- The entity of the subprogram [body or stub] subject to pragma
1787 -- [Refined_]Global.
1789 In_Out_Seen
: Boolean := False;
1790 Input_Seen
: Boolean := False;
1791 Output_Seen
: Boolean := False;
1792 Proof_Seen
: Boolean := False;
1793 -- Flags used to verify the consistency of modes
1795 procedure Analyze_Global_List
1797 Global_Mode
: Name_Id
:= Name_Input
);
1798 -- Verify the legality of a single global list declaration. Global_Mode
1799 -- denotes the current mode in effect.
1801 -------------------------
1802 -- Analyze_Global_List --
1803 -------------------------
1805 procedure Analyze_Global_List
1807 Global_Mode
: Name_Id
:= Name_Input
)
1809 procedure Analyze_Global_Item
1811 Global_Mode
: Name_Id
);
1812 -- Verify the legality of a single global item declaration.
1813 -- Global_Mode denotes the current mode in effect.
1815 procedure Check_Duplicate_Mode
1817 Status
: in out Boolean);
1818 -- Flag Status denotes whether a particular mode has been seen while
1819 -- processing a global list. This routine verifies that Mode is not a
1820 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1822 procedure Check_Mode_Restriction_In_Enclosing_Context
1824 Item_Id
: Entity_Id
);
1825 -- Verify that an item of mode In_Out or Output does not appear as an
1826 -- input in the Global aspect of an enclosing subprogram. If this is
1827 -- the case, emit an error. Item and Item_Id are respectively the
1828 -- item and its entity.
1830 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1831 -- Mode denotes either In_Out or Output. Depending on the kind of the
1832 -- related subprogram, emit an error if those two modes apply to a
1833 -- function (SPARK RM 6.1.4(10)).
1835 -------------------------
1836 -- Analyze_Global_Item --
1837 -------------------------
1839 procedure Analyze_Global_Item
1841 Global_Mode
: Name_Id
)
1843 Item_Id
: Entity_Id
;
1846 -- Detect one of the following cases
1848 -- with Global => (null, Name)
1849 -- with Global => (Name_1, null, Name_2)
1850 -- with Global => (Name, null)
1852 if Nkind
(Item
) = N_Null
then
1853 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
1858 Resolve_State
(Item
);
1860 -- Find the entity of the item. If this is a renaming, climb the
1861 -- renaming chain to reach the root object. Renamings of non-
1862 -- entire objects do not yield an entity (Empty).
1864 Item_Id
:= Entity_Of
(Item
);
1866 if Present
(Item_Id
) then
1868 -- A global item may denote a formal parameter of an enclosing
1869 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1870 -- provide a better error diagnostic.
1872 if Is_Formal
(Item_Id
) then
1873 if Scope
(Item_Id
) = Spec_Id
then
1875 ("global item cannot reference parameter of subprogram",
1880 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1881 -- Do this check first to provide a better error diagnostic.
1883 elsif Ekind
(Item_Id
) = E_Constant
then
1884 SPARK_Msg_N
("global item cannot denote a constant", Item
);
1886 -- A formal object may act as a global item inside a generic
1888 elsif Is_Formal_Object
(Item_Id
) then
1891 -- The only legal references are those to abstract states and
1892 -- variables (SPARK RM 6.1.4(4)).
1894 elsif not Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
1896 ("global item must denote variable or state", Item
);
1900 -- State related checks
1902 if Ekind
(Item_Id
) = E_Abstract_State
then
1904 -- An abstract state with visible refinement cannot appear
1905 -- in pragma [Refined_]Global as its place must be taken by
1906 -- some of its constituents (SPARK RM 6.1.4(8)).
1908 if Has_Visible_Refinement
(Item_Id
) then
1910 ("cannot mention state & in global refinement",
1912 SPARK_Msg_N
("\use its constituents instead", Item
);
1915 -- If the reference to the abstract state appears in an
1916 -- enclosing package body that will eventually refine the
1917 -- state, record the reference for future checks.
1920 Record_Possible_Body_Reference
1921 (State_Id
=> Item_Id
,
1925 -- Variable related checks. These are only relevant when
1926 -- SPARK_Mode is on as they are not standard Ada legality
1929 elsif SPARK_Mode
= On
1930 and then Is_Effectively_Volatile
(Item_Id
)
1932 -- An effectively volatile object cannot appear as a global
1933 -- item of a function (SPARK RM 7.1.3(9)).
1935 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
1937 ("volatile object & cannot act as global item of a "
1938 & "function", Item
, Item_Id
);
1941 -- An effectively volatile object with external property
1942 -- Effective_Reads set to True must have mode Output or
1945 elsif Effective_Reads_Enabled
(Item_Id
)
1946 and then Global_Mode
= Name_Input
1949 ("volatile object & with property Effective_Reads must "
1950 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
1956 -- When the item renames an entire object, replace the item
1957 -- with a reference to the object.
1959 if Present
(Renamed_Object
(Entity
(Item
))) then
1960 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1964 -- Some form of illegal construct masquerading as a name
1965 -- (SPARK RM 6.1.4(4)).
1968 Error_Msg_N
("global item must denote variable or state", Item
);
1972 -- Verify that an output does not appear as an input in an
1973 -- enclosing subprogram.
1975 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
1976 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
1979 -- The same entity might be referenced through various way.
1980 -- Check the entity of the item rather than the item itself
1981 -- (SPARK RM 6.1.4(11)).
1983 if Contains
(Seen
, Item_Id
) then
1984 SPARK_Msg_N
("duplicate global item", Item
);
1986 -- Add the entity of the current item to the list of processed
1990 Add_Item
(Item_Id
, Seen
);
1992 if Ekind
(Item_Id
) = E_Abstract_State
then
1993 Add_Item
(Item_Id
, States_Seen
);
1996 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
1997 and then Present
(Encapsulating_State
(Item_Id
))
1999 Add_Item
(Item_Id
, Constits_Seen
);
2002 end Analyze_Global_Item
;
2004 --------------------------
2005 -- Check_Duplicate_Mode --
2006 --------------------------
2008 procedure Check_Duplicate_Mode
2010 Status
: in out Boolean)
2014 SPARK_Msg_N
("duplicate global mode", Mode
);
2018 end Check_Duplicate_Mode
;
2020 -------------------------------------------------
2021 -- Check_Mode_Restriction_In_Enclosing_Context --
2022 -------------------------------------------------
2024 procedure Check_Mode_Restriction_In_Enclosing_Context
2026 Item_Id
: Entity_Id
)
2028 Context
: Entity_Id
;
2030 Inputs
: Elist_Id
:= No_Elist
;
2031 Outputs
: Elist_Id
:= No_Elist
;
2034 -- Traverse the scope stack looking for enclosing subprograms
2035 -- subject to pragma [Refined_]Global.
2037 Context
:= Scope
(Subp_Id
);
2038 while Present
(Context
) and then Context
/= Standard_Standard
loop
2039 if Is_Subprogram
(Context
)
2041 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2043 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2045 Collect_Subprogram_Inputs_Outputs
2046 (Subp_Id
=> Context
,
2047 Subp_Inputs
=> Inputs
,
2048 Subp_Outputs
=> Outputs
,
2049 Global_Seen
=> Dummy
);
2051 -- The item is classified as In_Out or Output but appears as
2052 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2054 if Appears_In
(Inputs
, Item_Id
)
2055 and then not Appears_In
(Outputs
, Item_Id
)
2058 ("global item & cannot have mode In_Out or Output",
2061 ("\item already appears as input of subprogram &",
2064 -- Stop the traversal once an error has been detected
2070 Context
:= Scope
(Context
);
2072 end Check_Mode_Restriction_In_Enclosing_Context
;
2074 ----------------------------------------
2075 -- Check_Mode_Restriction_In_Function --
2076 ----------------------------------------
2078 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2080 if Ekind
(Spec_Id
) = E_Function
then
2082 ("global mode & is not applicable to functions", Mode
);
2084 end Check_Mode_Restriction_In_Function
;
2092 -- Start of processing for Analyze_Global_List
2095 if Nkind
(List
) = N_Null
then
2096 Set_Analyzed
(List
);
2098 -- Single global item declaration
2100 elsif Nkind_In
(List
, N_Expanded_Name
,
2102 N_Selected_Component
)
2104 Analyze_Global_Item
(List
, Global_Mode
);
2106 -- Simple global list or moded global list declaration
2108 elsif Nkind
(List
) = N_Aggregate
then
2109 Set_Analyzed
(List
);
2111 -- The declaration of a simple global list appear as a collection
2114 if Present
(Expressions
(List
)) then
2115 if Present
(Component_Associations
(List
)) then
2117 ("cannot mix moded and non-moded global lists", List
);
2120 Item
:= First
(Expressions
(List
));
2121 while Present
(Item
) loop
2122 Analyze_Global_Item
(Item
, Global_Mode
);
2127 -- The declaration of a moded global list appears as a collection
2128 -- of component associations where individual choices denote
2131 elsif Present
(Component_Associations
(List
)) then
2132 if Present
(Expressions
(List
)) then
2134 ("cannot mix moded and non-moded global lists", List
);
2137 Assoc
:= First
(Component_Associations
(List
));
2138 while Present
(Assoc
) loop
2139 Mode
:= First
(Choices
(Assoc
));
2141 if Nkind
(Mode
) = N_Identifier
then
2142 if Chars
(Mode
) = Name_In_Out
then
2143 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2144 Check_Mode_Restriction_In_Function
(Mode
);
2146 elsif Chars
(Mode
) = Name_Input
then
2147 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2149 elsif Chars
(Mode
) = Name_Output
then
2150 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2151 Check_Mode_Restriction_In_Function
(Mode
);
2153 elsif Chars
(Mode
) = Name_Proof_In
then
2154 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2157 SPARK_Msg_N
("invalid mode selector", Mode
);
2161 SPARK_Msg_N
("invalid mode selector", Mode
);
2164 -- Items in a moded list appear as a collection of
2165 -- expressions. Reuse the existing machinery to analyze
2169 (List
=> Expression
(Assoc
),
2170 Global_Mode
=> Chars
(Mode
));
2178 raise Program_Error
;
2181 -- Any other attempt to declare a global item is illegal. This is a
2182 -- syntax error, always report.
2185 Error_Msg_N
("malformed global list", List
);
2187 end Analyze_Global_List
;
2191 Items
: constant Node_Id
:=
2192 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2193 Subp_Decl
: Node_Id
;
2195 Restore_Scope
: Boolean := False;
2196 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2198 -- Start of processing for Analyze_Global_In_Decl_List
2202 Check_SPARK_Aspect_For_ASIS
(N
);
2204 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
2205 Subp_Id
:= Defining_Entity
(Subp_Decl
);
2207 -- The logic in this routine is used to analyze both pragma Global and
2208 -- pragma Refined_Global since they have the same syntax and base
2209 -- semantics. Find the entity of the corresponding spec when analyzing
2212 if Nkind
(Subp_Decl
) = N_Subprogram_Body
2213 and then Present
(Corresponding_Spec
(Subp_Decl
))
2215 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
2217 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
2218 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
2220 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
2226 -- There is nothing to be done for a null global list
2228 if Nkind
(Items
) = N_Null
then
2229 Set_Analyzed
(Items
);
2231 -- Analyze the various forms of global lists and items. Note that some
2232 -- of these may be malformed in which case the analysis emits error
2236 -- Ensure that the formal parameters are visible when processing an
2237 -- item. This falls out of the general rule of aspects pertaining to
2238 -- subprogram declarations.
2240 if not In_Open_Scopes
(Spec_Id
) then
2241 Restore_Scope
:= True;
2242 Push_Scope
(Spec_Id
);
2243 Install_Formals
(Spec_Id
);
2246 Analyze_Global_List
(Items
);
2248 if Restore_Scope
then
2253 -- Ensure that a state and a corresponding constituent do not appear
2254 -- together in pragma [Refined_]Global.
2256 Check_State_And_Constituent_Use
2257 (States
=> States_Seen
,
2258 Constits
=> Constits_Seen
,
2260 end Analyze_Global_In_Decl_Part
;
2262 --------------------------------------------
2263 -- Analyze_Initial_Condition_In_Decl_Part --
2264 --------------------------------------------
2266 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2267 Expr
: constant Node_Id
:=
2268 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2273 -- The expression is preanalyzed because it has not been moved to its
2274 -- final place yet. A direct analysis may generate side effects and this
2275 -- is not desired at this point.
2277 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2278 end Analyze_Initial_Condition_In_Decl_Part
;
2280 --------------------------------------
2281 -- Analyze_Initializes_In_Decl_Part --
2282 --------------------------------------
2284 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2285 Pack_Spec
: constant Node_Id
:= Parent
(N
);
2286 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Parent
(Pack_Spec
));
2288 Constits_Seen
: Elist_Id
:= No_Elist
;
2289 -- A list containing the entities of all constituents processed so far.
2290 -- It aids in detecting illegal usage of a state and a corresponding
2291 -- constituent in pragma Initializes.
2293 Items_Seen
: Elist_Id
:= No_Elist
;
2294 -- A list of all initialization items processed so far. This list is
2295 -- used to detect duplicate items.
2297 Non_Null_Seen
: Boolean := False;
2298 Null_Seen
: Boolean := False;
2299 -- Flags used to check the legality of a null initialization list
2301 States_And_Vars
: Elist_Id
:= No_Elist
;
2302 -- A list of all abstract states and variables declared in the visible
2303 -- declarations of the related package. This list is used to detect the
2304 -- legality of initialization items.
2306 States_Seen
: Elist_Id
:= No_Elist
;
2307 -- A list containing the entities of all states processed so far. It
2308 -- helps in detecting illegal usage of a state and a corresponding
2309 -- constituent in pragma Initializes.
2311 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2312 -- Verify the legality of a single initialization item
2314 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2315 -- Verify the legality of a single initialization item followed by a
2316 -- list of input items.
2318 procedure Collect_States_And_Variables
;
2319 -- Inspect the visible declarations of the related package and gather
2320 -- the entities of all abstract states and variables in States_And_Vars.
2322 ---------------------------------
2323 -- Analyze_Initialization_Item --
2324 ---------------------------------
2326 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2327 Item_Id
: Entity_Id
;
2330 -- Null initialization list
2332 if Nkind
(Item
) = N_Null
then
2334 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2336 elsif Non_Null_Seen
then
2338 ("cannot mix null and non-null initialization items", Item
);
2343 -- Initialization item
2346 Non_Null_Seen
:= True;
2350 ("cannot mix null and non-null initialization items", Item
);
2354 Resolve_State
(Item
);
2356 if Is_Entity_Name
(Item
) then
2357 Item_Id
:= Entity_Of
(Item
);
2359 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
2361 -- The state or variable must be declared in the visible
2362 -- declarations of the package (SPARK RM 7.1.5(7)).
2364 if not Contains
(States_And_Vars
, Item_Id
) then
2365 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2367 ("initialization item & must appear in the visible "
2368 & "declarations of package %", Item
, Item_Id
);
2370 -- Detect a duplicate use of the same initialization item
2371 -- (SPARK RM 7.1.5(5)).
2373 elsif Contains
(Items_Seen
, Item_Id
) then
2374 SPARK_Msg_N
("duplicate initialization item", Item
);
2376 -- The item is legal, add it to the list of processed states
2380 Add_Item
(Item_Id
, Items_Seen
);
2382 if Ekind
(Item_Id
) = E_Abstract_State
then
2383 Add_Item
(Item_Id
, States_Seen
);
2386 if Present
(Encapsulating_State
(Item_Id
)) then
2387 Add_Item
(Item_Id
, Constits_Seen
);
2391 -- The item references something that is not a state or a
2392 -- variable (SPARK RM 7.1.5(3)).
2396 ("initialization item must denote variable or state",
2400 -- Some form of illegal construct masquerading as a name
2401 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2405 ("initialization item must denote variable or state", Item
);
2408 end Analyze_Initialization_Item
;
2410 ---------------------------------------------
2411 -- Analyze_Initialization_Item_With_Inputs --
2412 ---------------------------------------------
2414 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2415 Inputs_Seen
: Elist_Id
:= No_Elist
;
2416 -- A list of all inputs processed so far. This list is used to detect
2417 -- duplicate uses of an input.
2419 Non_Null_Seen
: Boolean := False;
2420 Null_Seen
: Boolean := False;
2421 -- Flags used to check the legality of an input list
2423 procedure Analyze_Input_Item
(Input
: Node_Id
);
2424 -- Verify the legality of a single input item
2426 ------------------------
2427 -- Analyze_Input_Item --
2428 ------------------------
2430 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2431 Input_Id
: Entity_Id
;
2436 if Nkind
(Input
) = N_Null
then
2439 ("multiple null initializations not allowed", Item
);
2441 elsif Non_Null_Seen
then
2443 ("cannot mix null and non-null initialization item", Item
);
2451 Non_Null_Seen
:= True;
2455 ("cannot mix null and non-null initialization item", Item
);
2459 Resolve_State
(Input
);
2461 if Is_Entity_Name
(Input
) then
2462 Input_Id
:= Entity_Of
(Input
);
2464 if Ekind_In
(Input_Id
, E_Abstract_State
,
2470 -- The input cannot denote states or variables declared
2471 -- within the related package.
2473 if Within_Scope
(Input_Id
, Current_Scope
) then
2474 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2476 ("input item & cannot denote a visible variable or "
2477 & "state of package % (SPARK RM 7.1.5(4))",
2480 -- Detect a duplicate use of the same input item
2481 -- (SPARK RM 7.1.5(5)).
2483 elsif Contains
(Inputs_Seen
, Input_Id
) then
2484 SPARK_Msg_N
("duplicate input item", Input
);
2486 -- Input is legal, add it to the list of processed inputs
2489 Add_Item
(Input_Id
, Inputs_Seen
);
2491 if Ekind
(Input_Id
) = E_Abstract_State
then
2492 Add_Item
(Input_Id
, States_Seen
);
2495 if Ekind_In
(Input_Id
, E_Abstract_State
, E_Variable
)
2496 and then Present
(Encapsulating_State
(Input_Id
))
2498 Add_Item
(Input_Id
, Constits_Seen
);
2502 -- The input references something that is not a state or a
2503 -- variable (SPARK RM 7.1.5(3)).
2507 ("input item must denote variable or state", Input
);
2510 -- Some form of illegal construct masquerading as a name
2511 -- (SPARK RM 7.1.5(3)).
2515 ("input item must denote variable or state", Input
);
2518 end Analyze_Input_Item
;
2522 Inputs
: constant Node_Id
:= Expression
(Item
);
2526 Name_Seen
: Boolean := False;
2527 -- A flag used to detect multiple item names
2529 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2532 -- Inspect the name of an item with inputs
2534 Elmt
:= First
(Choices
(Item
));
2535 while Present
(Elmt
) loop
2537 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2540 Analyze_Initialization_Item
(Elmt
);
2546 -- Multiple input items appear as an aggregate
2548 if Nkind
(Inputs
) = N_Aggregate
then
2549 if Present
(Expressions
(Inputs
)) then
2550 Input
:= First
(Expressions
(Inputs
));
2551 while Present
(Input
) loop
2552 Analyze_Input_Item
(Input
);
2557 if Present
(Component_Associations
(Inputs
)) then
2559 ("inputs must appear in named association form", Inputs
);
2562 -- Single input item
2565 Analyze_Input_Item
(Inputs
);
2567 end Analyze_Initialization_Item_With_Inputs
;
2569 ----------------------------------
2570 -- Collect_States_And_Variables --
2571 ----------------------------------
2573 procedure Collect_States_And_Variables
is
2577 -- Collect the abstract states defined in the package (if any)
2579 if Present
(Abstract_States
(Pack_Id
)) then
2580 States_And_Vars
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2583 -- Collect all variables the appear in the visible declarations of
2584 -- the related package.
2586 if Present
(Visible_Declarations
(Pack_Spec
)) then
2587 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2588 while Present
(Decl
) loop
2589 if Nkind
(Decl
) = N_Object_Declaration
2590 and then Ekind
(Defining_Entity
(Decl
)) = E_Variable
2591 and then Comes_From_Source
(Decl
)
2593 Add_Item
(Defining_Entity
(Decl
), States_And_Vars
);
2599 end Collect_States_And_Variables
;
2603 Inits
: constant Node_Id
:=
2604 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2607 -- Start of processing for Analyze_Initializes_In_Decl_Part
2612 Check_SPARK_Aspect_For_ASIS
(N
);
2614 -- Nothing to do when the initialization list is empty
2616 if Nkind
(Inits
) = N_Null
then
2620 -- Single and multiple initialization clauses appear as an aggregate. If
2621 -- this is not the case, then either the parser or the analysis of the
2622 -- pragma failed to produce an aggregate.
2624 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2626 -- Initialize the various lists used during analysis
2628 Collect_States_And_Variables
;
2630 if Present
(Expressions
(Inits
)) then
2631 Init
:= First
(Expressions
(Inits
));
2632 while Present
(Init
) loop
2633 Analyze_Initialization_Item
(Init
);
2638 if Present
(Component_Associations
(Inits
)) then
2639 Init
:= First
(Component_Associations
(Inits
));
2640 while Present
(Init
) loop
2641 Analyze_Initialization_Item_With_Inputs
(Init
);
2646 -- Ensure that a state and a corresponding constituent do not appear
2647 -- together in pragma Initializes.
2649 Check_State_And_Constituent_Use
2650 (States
=> States_Seen
,
2651 Constits
=> Constits_Seen
,
2653 end Analyze_Initializes_In_Decl_Part
;
2655 --------------------
2656 -- Analyze_Pragma --
2657 --------------------
2659 procedure Analyze_Pragma
(N
: Node_Id
) is
2660 Loc
: constant Source_Ptr
:= Sloc
(N
);
2661 Prag_Id
: Pragma_Id
;
2664 -- Name of the source pragma, or name of the corresponding aspect for
2665 -- pragmas which originate in a source aspect. In the latter case, the
2666 -- name may be different from the pragma name.
2668 Pragma_Exit
: exception;
2669 -- This exception is used to exit pragma processing completely. It
2670 -- is used when an error is detected, and no further processing is
2671 -- required. It is also used if an earlier error has left the tree in
2672 -- a state where the pragma should not be processed.
2675 -- Number of pragma argument associations
2681 -- First four pragma arguments (pragma argument association nodes, or
2682 -- Empty if the corresponding argument does not exist).
2684 type Name_List
is array (Natural range <>) of Name_Id
;
2685 type Args_List
is array (Natural range <>) of Node_Id
;
2686 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2688 -----------------------
2689 -- Local Subprograms --
2690 -----------------------
2692 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
2693 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2694 -- get the given string argument, and place it in Name_Buffer, adding
2695 -- leading and trailing asterisks if they are not already present. The
2696 -- caller has already checked that Arg is a static string expression.
2698 procedure Ada_2005_Pragma
;
2699 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2700 -- Ada 95 mode, these are implementation defined pragmas, so should be
2701 -- caught by the No_Implementation_Pragmas restriction.
2703 procedure Ada_2012_Pragma
;
2704 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2705 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2706 -- should be caught by the No_Implementation_Pragmas restriction.
2708 procedure Analyze_Part_Of
2709 (Item_Id
: Entity_Id
;
2712 Legal
: out Boolean);
2713 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2714 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2715 -- an abstract state, variable or package instantiation. State is the
2716 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2717 -- set when the indicator is legal.
2719 procedure Analyze_Refined_Pragma
2720 (Spec_Id
: out Entity_Id
;
2721 Body_Id
: out Entity_Id
;
2722 Legal
: out Boolean);
2723 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2724 -- Refined_Global and Refined_Post. Check the placement and related
2725 -- context of the pragma. Spec_Id is the entity of the related
2726 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2727 -- Legal is set when the pragma is properly placed.
2729 procedure Check_Ada_83_Warning
;
2730 -- Issues a warning message for the current pragma if operating in Ada
2731 -- 83 mode (used for language pragmas that are not a standard part of
2732 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
2735 procedure Check_Arg_Count
(Required
: Nat
);
2736 -- Check argument count for pragma is equal to given parameter. If not,
2737 -- then issue an error message and raise Pragma_Exit.
2739 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2740 -- Arg which can either be a pragma argument association, in which case
2741 -- the check is applied to the expression of the association or an
2742 -- expression directly.
2744 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
2745 -- Check that an argument has the right form for an EXTERNAL_NAME
2746 -- parameter of an extended import/export pragma. The rule is that the
2747 -- name must be an identifier or string literal (in Ada 83 mode) or a
2748 -- static string expression (in Ada 95 mode).
2750 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
2751 -- Check the specified argument Arg to make sure that it is an
2752 -- identifier. If not give error and raise Pragma_Exit.
2754 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
2755 -- Check the specified argument Arg to make sure that it is an integer
2756 -- literal. If not give error and raise Pragma_Exit.
2758 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
2759 -- Check the specified argument Arg to make sure that it has the proper
2760 -- syntactic form for a local name and meets the semantic requirements
2761 -- for a local name. The local name is analyzed as part of the
2762 -- processing for this call. In addition, the local name is required
2763 -- to represent an entity at the library level.
2765 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
2766 -- Check the specified argument Arg to make sure that it has the proper
2767 -- syntactic form for a local name and meets the semantic requirements
2768 -- for a local name. The local name is analyzed as part of the
2769 -- processing for this call.
2771 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
2772 -- Check the specified argument Arg to make sure that it is a valid
2773 -- locking policy name. If not give error and raise Pragma_Exit.
2775 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
2776 -- Check the specified argument Arg to make sure that it is a valid
2777 -- elaboration policy name. If not give error and raise Pragma_Exit.
2779 procedure Check_Arg_Is_One_Of
2782 procedure Check_Arg_Is_One_Of
2784 N1
, N2
, N3
: Name_Id
);
2785 procedure Check_Arg_Is_One_Of
2787 N1
, N2
, N3
, N4
: Name_Id
);
2788 procedure Check_Arg_Is_One_Of
2790 N1
, N2
, N3
, N4
, N5
: Name_Id
);
2791 -- Check the specified argument Arg to make sure that it is an
2792 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2793 -- present). If not then give error and raise Pragma_Exit.
2795 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
2796 -- Check the specified argument Arg to make sure that it is a valid
2797 -- queuing policy name. If not give error and raise Pragma_Exit.
2799 procedure Check_Arg_Is_OK_Static_Expression
2801 Typ
: Entity_Id
:= Empty
);
2802 -- Check the specified argument Arg to make sure that it is a static
2803 -- expression of the given type (i.e. it will be analyzed and resolved
2804 -- using this type, which can be any valid argument to Resolve, e.g.
2805 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2806 -- Typ is left Empty, then any static expression is allowed. Includes
2807 -- checking that the argument does not raise Constraint_Error.
2809 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
2810 -- Check the specified argument Arg to make sure that it is a valid task
2811 -- dispatching policy name. If not give error and raise Pragma_Exit.
2813 procedure Check_Arg_Order
(Names
: Name_List
);
2814 -- Checks for an instance of two arguments with identifiers for the
2815 -- current pragma which are not in the sequence indicated by Names,
2816 -- and if so, generates a fatal message about bad order of arguments.
2818 procedure Check_At_Least_N_Arguments
(N
: Nat
);
2819 -- Check there are at least N arguments present
2821 procedure Check_At_Most_N_Arguments
(N
: Nat
);
2822 -- Check there are no more than N arguments present
2824 procedure Check_Component
2827 In_Variant_Part
: Boolean := False);
2828 -- Examine an Unchecked_Union component for correct use of per-object
2829 -- constrained subtypes, and for restrictions on finalizable components.
2830 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2831 -- should be set when Comp comes from a record variant.
2833 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
);
2834 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2835 -- Initial_Condition and Initializes. Determine whether pragma First
2836 -- appears before pragma Second. If this is not the case, emit an error.
2838 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
2839 -- Check if a rep item of the same name as the current pragma is already
2840 -- chained as a rep pragma to the given entity. If so give a message
2841 -- about the duplicate, and then raise Pragma_Exit so does not return.
2842 -- Note that if E is a type, then this routine avoids flagging a pragma
2843 -- which applies to a parent type from which E is derived.
2845 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
2846 -- Nam is an N_String_Literal node containing the external name set by
2847 -- an Import or Export pragma (or extended Import or Export pragma).
2848 -- This procedure checks for possible duplications if this is the export
2849 -- case, and if found, issues an appropriate error message.
2851 procedure Check_Expr_Is_OK_Static_Expression
2853 Typ
: Entity_Id
:= Empty
);
2854 -- Check the specified expression Expr to make sure that it is a static
2855 -- expression of the given type (i.e. it will be analyzed and resolved
2856 -- using this type, which can be any valid argument to Resolve, e.g.
2857 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2858 -- Typ is left Empty, then any static expression is allowed. Includes
2859 -- checking that the expression does not raise Constraint_Error.
2861 procedure Check_First_Subtype
(Arg
: Node_Id
);
2862 -- Checks that Arg, whose expression is an entity name, references a
2865 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2866 -- Checks that the given argument has an identifier, and if so, requires
2867 -- it to match the given identifier name. If there is no identifier, or
2868 -- a non-matching identifier, then an error message is given and
2869 -- Pragma_Exit is raised.
2871 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
2872 -- Checks that the given argument has an identifier, and if so, requires
2873 -- it to match one of the given identifier names. If there is no
2874 -- identifier, or a non-matching identifier, then an error message is
2875 -- given and Pragma_Exit is raised.
2877 procedure Check_In_Main_Program
;
2878 -- Common checks for pragmas that appear within a main program
2879 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2881 procedure Check_Interrupt_Or_Attach_Handler
;
2882 -- Common processing for first argument of pragma Interrupt_Handler or
2883 -- pragma Attach_Handler.
2885 procedure Check_Loop_Pragma_Placement
;
2886 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2887 -- appear immediately within a construct restricted to loops, and that
2888 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2890 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
2891 -- Check that pragma appears in a declarative part, or in a package
2892 -- specification, i.e. that it does not occur in a statement sequence
2895 procedure Check_No_Identifier
(Arg
: Node_Id
);
2896 -- Checks that the given argument does not have an identifier. If
2897 -- an identifier is present, then an error message is issued, and
2898 -- Pragma_Exit is raised.
2900 procedure Check_No_Identifiers
;
2901 -- Checks that none of the arguments to the pragma has an identifier.
2902 -- If any argument has an identifier, then an error message is issued,
2903 -- and Pragma_Exit is raised.
2905 procedure Check_No_Link_Name
;
2906 -- Checks that no link name is specified
2908 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2909 -- Checks if the given argument has an identifier, and if so, requires
2910 -- it to match the given identifier name. If there is a non-matching
2911 -- identifier, then an error message is given and Pragma_Exit is raised.
2913 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
2914 -- Checks if the given argument has an identifier, and if so, requires
2915 -- it to match the given identifier name. If there is a non-matching
2916 -- identifier, then an error message is given and Pragma_Exit is raised.
2917 -- In this version of the procedure, the identifier name is given as
2918 -- a string with lower case letters.
2920 procedure Check_Pre_Post
;
2921 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
2922 -- pragmas. These are processed by transformation to equivalent
2923 -- Precondition and Postcondition pragmas, but Pre and Post need an
2924 -- additional check that they are not used in a subprogram body when
2925 -- there is a separate spec present.
2927 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
2928 -- Called to process a precondition or postcondition pragma. There are
2931 -- The pragma appears after a subprogram spec
2933 -- If the corresponding check is not enabled, the pragma is analyzed
2934 -- but otherwise ignored and control returns with In_Body set False.
2936 -- If the check is enabled, then the first step is to analyze the
2937 -- pragma, but this is skipped if the subprogram spec appears within
2938 -- a package specification (because this is the case where we delay
2939 -- analysis till the end of the spec). Then (whether or not it was
2940 -- analyzed), the pragma is chained to the subprogram in question
2941 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
2942 -- to the caller with In_Body set False.
2944 -- The pragma appears at the start of subprogram body declarations
2946 -- In this case an immediate return to the caller is made with
2947 -- In_Body set True, and the pragma is NOT analyzed.
2949 -- In all other cases, an error message for bad placement is given
2951 procedure Check_Static_Constraint
(Constr
: Node_Id
);
2952 -- Constr is a constraint from an N_Subtype_Indication node from a
2953 -- component constraint in an Unchecked_Union type. This routine checks
2954 -- that the constraint is static as required by the restrictions for
2957 procedure Check_Test_Case
;
2958 -- Called to process a test-case pragma. It starts with checking pragma
2959 -- arguments, and the rest of the treatment is similar to the one for
2960 -- pre- and postcondition in Check_Precondition_Postcondition, except
2961 -- the placement rules for the test-case pragma are stricter. These
2962 -- pragmas may only occur after a subprogram spec declared directly
2963 -- in a package spec unit. In this case, the pragma is chained to the
2964 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
2965 -- and analysis of the pragma is delayed till the end of the spec. In
2966 -- all other cases, an error message for bad placement is given.
2968 procedure Check_Valid_Configuration_Pragma
;
2969 -- Legality checks for placement of a configuration pragma
2971 procedure Check_Valid_Library_Unit_Pragma
;
2972 -- Legality checks for library unit pragmas. A special case arises for
2973 -- pragmas in generic instances that come from copies of the original
2974 -- library unit pragmas in the generic templates. In the case of other
2975 -- than library level instantiations these can appear in contexts which
2976 -- would normally be invalid (they only apply to the original template
2977 -- and to library level instantiations), and they are simply ignored,
2978 -- which is implemented by rewriting them as null statements.
2980 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
2981 -- Check an Unchecked_Union variant for lack of nested variants and
2982 -- presence of at least one component. UU_Typ is the related Unchecked_
2985 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
2986 -- Subsidiary routine to the processing of pragmas Abstract_State,
2987 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
2988 -- Refined_Global and Refined_State. Transform argument Arg into an
2989 -- aggregate if not one already. N_Null is never transformed.
2991 procedure Error_Pragma
(Msg
: String);
2992 pragma No_Return
(Error_Pragma
);
2993 -- Outputs error message for current pragma. The message contains a %
2994 -- that will be replaced with the pragma name, and the flag is placed
2995 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2996 -- calls Fix_Error (see spec of that procedure for details).
2998 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
2999 pragma No_Return
(Error_Pragma_Arg
);
3000 -- Outputs error message for current pragma. The message may contain
3001 -- a % that will be replaced with the pragma name. The parameter Arg
3002 -- may either be a pragma argument association, in which case the flag
3003 -- is placed on the expression of this association, or an expression,
3004 -- in which case the flag is placed directly on the expression. The
3005 -- message is placed using Error_Msg_N, so the message may also contain
3006 -- an & insertion character which will reference the given Arg value.
3007 -- After placing the message, Pragma_Exit is raised. Note: this routine
3008 -- calls Fix_Error (see spec of that procedure for details).
3010 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3011 pragma No_Return
(Error_Pragma_Arg
);
3012 -- Similar to above form of Error_Pragma_Arg except that two messages
3013 -- are provided, the second is a continuation comment starting with \.
3015 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3016 pragma No_Return
(Error_Pragma_Arg_Ident
);
3017 -- Outputs error message for current pragma. The message may contain a %
3018 -- that will be replaced with the pragma name. The parameter Arg must be
3019 -- a pragma argument association with a non-empty identifier (i.e. its
3020 -- Chars field must be set), and the error message is placed on the
3021 -- identifier. The message is placed using Error_Msg_N so the message
3022 -- may also contain an & insertion character which will reference
3023 -- the identifier. After placing the message, Pragma_Exit is raised.
3024 -- Note: this routine calls Fix_Error (see spec of that procedure for
3027 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3028 pragma No_Return
(Error_Pragma_Ref
);
3029 -- Outputs error message for current pragma. The message may contain
3030 -- a % that will be replaced with the pragma name. The parameter Ref
3031 -- must be an entity whose name can be referenced by & and sloc by #.
3032 -- After placing the message, Pragma_Exit is raised. Note: this routine
3033 -- calls Fix_Error (see spec of that procedure for details).
3035 function Find_Lib_Unit_Name
return Entity_Id
;
3036 -- Used for a library unit pragma to find the entity to which the
3037 -- library unit pragma applies, returns the entity found.
3039 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3040 -- If the pragma is a compilation unit pragma, the id must denote the
3041 -- compilation unit in the same compilation, and the pragma must appear
3042 -- in the list of preceding or trailing pragmas. If it is a program
3043 -- unit pragma that is not a compilation unit pragma, then the
3044 -- identifier must be visible.
3046 function Find_Unique_Parameterless_Procedure
3048 Arg
: Node_Id
) return Entity_Id
;
3049 -- Used for a procedure pragma to find the unique parameterless
3050 -- procedure identified by Name, returns it if it exists, otherwise
3051 -- errors out and uses Arg as the pragma argument for the message.
3053 function Fix_Error
(Msg
: String) return String;
3054 -- This is called prior to issuing an error message. Msg is the normal
3055 -- error message issued in the pragma case. This routine checks for the
3056 -- case of a pragma coming from an aspect in the source, and returns a
3057 -- message suitable for the aspect case as follows:
3059 -- Each substring "pragma" is replaced by "aspect"
3061 -- If "argument of" is at the start of the error message text, it is
3062 -- replaced by "entity for".
3064 -- If "argument" is at the start of the error message text, it is
3065 -- replaced by "entity".
3067 -- So for example, "argument of pragma X must be discrete type"
3068 -- returns "entity for aspect X must be a discrete type".
3070 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3071 -- be different from the pragma name). If the current pragma results
3072 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3073 -- original pragma name.
3075 procedure Gather_Associations
3077 Args
: out Args_List
);
3078 -- This procedure is used to gather the arguments for a pragma that
3079 -- permits arbitrary ordering of parameters using the normal rules
3080 -- for named and positional parameters. The Names argument is a list
3081 -- of Name_Id values that corresponds to the allowed pragma argument
3082 -- association identifiers in order. The result returned in Args is
3083 -- a list of corresponding expressions that are the pragma arguments.
3084 -- Note that this is a list of expressions, not of pragma argument
3085 -- associations (Gather_Associations has completely checked all the
3086 -- optional identifiers when it returns). An entry in Args is Empty
3087 -- on return if the corresponding argument is not present.
3089 procedure GNAT_Pragma
;
3090 -- Called for all GNAT defined pragmas to check the relevant restriction
3091 -- (No_Implementation_Pragmas).
3093 function Is_Before_First_Decl
3094 (Pragma_Node
: Node_Id
;
3095 Decls
: List_Id
) return Boolean;
3096 -- Return True if Pragma_Node is before the first declarative item in
3097 -- Decls where Decls is the list of declarative items.
3099 function Is_Configuration_Pragma
return Boolean;
3100 -- Determines if the placement of the current pragma is appropriate
3101 -- for a configuration pragma.
3103 function Is_In_Context_Clause
return Boolean;
3104 -- Returns True if pragma appears within the context clause of a unit,
3105 -- and False for any other placement (does not generate any messages).
3107 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3108 -- Analyzes the argument, and determines if it is a static string
3109 -- expression, returns True if so, False if non-static or not String.
3110 -- A special case is that a string literal returns True in Ada 83 mode
3111 -- (which has no such thing as static string expressions).
3113 procedure Pragma_Misplaced
;
3114 pragma No_Return
(Pragma_Misplaced
);
3115 -- Issue fatal error message for misplaced pragma
3117 procedure Process_Atomic_Shared_Volatile
;
3118 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3119 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3120 -- in effect to pragma Atomic.
3122 procedure Process_Compile_Time_Warning_Or_Error
;
3123 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3125 procedure Process_Convention
3126 (C
: out Convention_Id
;
3127 Ent
: out Entity_Id
);
3128 -- Common processing for Convention, Interface, Import and Export.
3129 -- Checks first two arguments of pragma, and sets the appropriate
3130 -- convention value in the specified entity or entities. On return
3131 -- C is the convention, Ent is the referenced entity.
3133 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3134 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3135 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3137 procedure Process_Extended_Import_Export_Object_Pragma
3138 (Arg_Internal
: Node_Id
;
3139 Arg_External
: Node_Id
;
3140 Arg_Size
: Node_Id
);
3141 -- Common processing for the pragmas Import/Export_Object. The three
3142 -- arguments correspond to the three named parameters of the pragmas. An
3143 -- argument is empty if the corresponding parameter is not present in
3146 procedure Process_Extended_Import_Export_Internal_Arg
3147 (Arg_Internal
: Node_Id
:= Empty
);
3148 -- Common processing for all extended Import and Export pragmas. The
3149 -- argument is the pragma parameter for the Internal argument. If
3150 -- Arg_Internal is empty or inappropriate, an error message is posted.
3151 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3152 -- set to identify the referenced entity.
3154 procedure Process_Extended_Import_Export_Subprogram_Pragma
3155 (Arg_Internal
: Node_Id
;
3156 Arg_External
: Node_Id
;
3157 Arg_Parameter_Types
: Node_Id
;
3158 Arg_Result_Type
: Node_Id
:= Empty
;
3159 Arg_Mechanism
: Node_Id
;
3160 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3161 -- Common processing for all extended Import and Export pragmas applying
3162 -- to subprograms. The caller omits any arguments that do not apply to
3163 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3164 -- only in the Import_Function and Export_Function cases). The argument
3165 -- names correspond to the allowed pragma association identifiers.
3167 procedure Process_Generic_List
;
3168 -- Common processing for Share_Generic and Inline_Generic
3170 procedure Process_Import_Or_Interface
;
3171 -- Common processing for Import of Interface
3173 procedure Process_Import_Predefined_Type
;
3174 -- Processing for completing a type with pragma Import. This is used
3175 -- to declare types that match predefined C types, especially for cases
3176 -- without corresponding Ada predefined type.
3178 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3179 -- Inline status of a subprogram, indicated as follows:
3180 -- Suppressed: inlining is suppressed for the subprogram
3181 -- Disabled: no inlining is requested for the subprogram
3182 -- Enabled: inlining is requested/required for the subprogram
3184 procedure Process_Inline
(Status
: Inline_Status
);
3185 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3186 -- indicates the inline status specified by the pragma.
3188 procedure Process_Interface_Name
3189 (Subprogram_Def
: Entity_Id
;
3191 Link_Arg
: Node_Id
);
3192 -- Given the last two arguments of pragma Import, pragma Export, or
3193 -- pragma Interface_Name, performs validity checks and sets the
3194 -- Interface_Name field of the given subprogram entity to the
3195 -- appropriate external or link name, depending on the arguments given.
3196 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3197 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3198 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3199 -- nor Link_Arg is present, the interface name is set to the default
3200 -- from the subprogram name.
3202 procedure Process_Interrupt_Or_Attach_Handler
;
3203 -- Common processing for Interrupt and Attach_Handler pragmas
3205 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3206 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3207 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3208 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3209 -- is not set in the Restrictions case.
3211 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3212 -- Common processing for Suppress and Unsuppress. The boolean parameter
3213 -- Suppress_Case is True for the Suppress case, and False for the
3216 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3217 -- This procedure sets the Is_Exported flag for the given entity,
3218 -- checking that the entity was not previously imported. Arg is
3219 -- the argument that specified the entity. A check is also made
3220 -- for exporting inappropriate entities.
3222 procedure Set_Extended_Import_Export_External_Name
3223 (Internal_Ent
: Entity_Id
;
3224 Arg_External
: Node_Id
);
3225 -- Common processing for all extended import export pragmas. The first
3226 -- argument, Internal_Ent, is the internal entity, which has already
3227 -- been checked for validity by the caller. Arg_External is from the
3228 -- Import or Export pragma, and may be null if no External parameter
3229 -- was present. If Arg_External is present and is a non-null string
3230 -- (a null string is treated as the default), then the Interface_Name
3231 -- field of Internal_Ent is set appropriately.
3233 procedure Set_Imported
(E
: Entity_Id
);
3234 -- This procedure sets the Is_Imported flag for the given entity,
3235 -- checking that it is not previously exported or imported.
3237 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3238 -- Mech is a parameter passing mechanism (see Import_Function syntax
3239 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3240 -- has the right form, and if not issues an error message. If the
3241 -- argument has the right form then the Mechanism field of Ent is
3242 -- set appropriately.
3244 procedure Set_Rational_Profile
;
3245 -- Activate the set of configuration pragmas and permissions that make
3246 -- up the Rational profile.
3248 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3249 -- Activate the set of configuration pragmas and restrictions that make
3250 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3251 -- is used for error messages on any constructs violating the profile.
3253 ----------------------------------
3254 -- Acquire_Warning_Match_String --
3255 ----------------------------------
3257 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3259 String_To_Name_Buffer
3260 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3262 -- Add asterisk at start if not already there
3264 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3265 Name_Buffer
(2 .. Name_Len
+ 1) :=
3266 Name_Buffer
(1 .. Name_Len
);
3267 Name_Buffer
(1) := '*';
3268 Name_Len
:= Name_Len
+ 1;
3271 -- Add asterisk at end if not already there
3273 if Name_Buffer
(Name_Len
) /= '*' then
3274 Name_Len
:= Name_Len
+ 1;
3275 Name_Buffer
(Name_Len
) := '*';
3277 end Acquire_Warning_Match_String
;
3279 ---------------------
3280 -- Ada_2005_Pragma --
3281 ---------------------
3283 procedure Ada_2005_Pragma
is
3285 if Ada_Version
<= Ada_95
then
3286 Check_Restriction
(No_Implementation_Pragmas
, N
);
3288 end Ada_2005_Pragma
;
3290 ---------------------
3291 -- Ada_2012_Pragma --
3292 ---------------------
3294 procedure Ada_2012_Pragma
is
3296 if Ada_Version
<= Ada_2005
then
3297 Check_Restriction
(No_Implementation_Pragmas
, N
);
3299 end Ada_2012_Pragma
;
3301 ---------------------
3302 -- Analyze_Part_Of --
3303 ---------------------
3305 procedure Analyze_Part_Of
3306 (Item_Id
: Entity_Id
;
3309 Legal
: out Boolean)
3311 Pack_Id
: Entity_Id
;
3312 Placement
: State_Space_Kind
;
3313 Parent_Unit
: Entity_Id
;
3314 State_Id
: Entity_Id
;
3317 -- Assume that the pragma/option is illegal
3321 if Nkind_In
(State
, N_Expanded_Name
,
3323 N_Selected_Component
)
3326 Resolve_State
(State
);
3328 if Is_Entity_Name
(State
)
3329 and then Ekind
(Entity
(State
)) = E_Abstract_State
3331 State_Id
:= Entity
(State
);
3335 ("indicator Part_Of must denote an abstract state", State
);
3339 -- This is a syntax error, always report
3343 ("indicator Part_Of must denote an abstract state", State
);
3347 -- Determine where the state, variable or the package instantiation
3348 -- lives with respect to the enclosing packages or package bodies (if
3349 -- any). This placement dictates the legality of the encapsulating
3352 Find_Placement_In_State_Space
3353 (Item_Id
=> Item_Id
,
3354 Placement
=> Placement
,
3355 Pack_Id
=> Pack_Id
);
3357 -- The item appears in a non-package construct with a declarative
3358 -- part (subprogram, block, etc). As such, the item is not allowed
3359 -- to be a part of an encapsulating state because the item is not
3362 if Placement
= Not_In_Package
then
3364 ("indicator Part_Of cannot appear in this context "
3365 & "(SPARK RM 7.2.6(5))", Indic
);
3366 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3368 ("\& is not part of the hidden state of package %",
3371 -- The item appears in the visible state space of some package. In
3372 -- general this scenario does not warrant Part_Of except when the
3373 -- package is a private child unit and the encapsulating state is
3374 -- declared in a parent unit or a public descendant of that parent
3377 elsif Placement
= Visible_State_Space
then
3378 if Is_Child_Unit
(Pack_Id
)
3379 and then Is_Private_Descendant
(Pack_Id
)
3381 -- A variable or state abstraction which is part of the
3382 -- visible state of a private child unit (or one of its public
3383 -- descendants) must have its Part_Of indicator specified. The
3384 -- Part_Of indicator must denote a state abstraction declared
3385 -- by either the parent unit of the private unit or by a public
3386 -- descendant of that parent unit.
3388 -- Find nearest private ancestor (which can be the current unit
3391 Parent_Unit
:= Pack_Id
;
3392 while Present
(Parent_Unit
) loop
3393 exit when Private_Present
3394 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3395 Parent_Unit
:= Scope
(Parent_Unit
);
3398 Parent_Unit
:= Scope
(Parent_Unit
);
3400 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3402 ("indicator Part_Of must denote an abstract state of& "
3403 & "or public descendant (SPARK RM 7.2.6(3))",
3404 Indic
, Parent_Unit
);
3406 elsif Scope
(State_Id
) = Parent_Unit
3407 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3409 not Is_Private_Descendant
(Scope
(State_Id
)))
3415 ("indicator Part_Of must denote an abstract state of& "
3416 & "or public descendant (SPARK RM 7.2.6(3))",
3417 Indic
, Parent_Unit
);
3420 -- Indicator Part_Of is not needed when the related package is not
3421 -- a private child unit or a public descendant thereof.
3425 ("indicator Part_Of cannot appear in this context "
3426 & "(SPARK RM 7.2.6(5))", Indic
);
3427 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3429 ("\& is declared in the visible part of package %",
3433 -- When the item appears in the private state space of a package, the
3434 -- encapsulating state must be declared in the same package.
3436 elsif Placement
= Private_State_Space
then
3437 if Scope
(State_Id
) /= Pack_Id
then
3439 ("indicator Part_Of must designate an abstract state of "
3440 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3441 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3443 ("\& is declared in the private part of package %",
3447 -- Items declared in the body state space of a package do not need
3448 -- Part_Of indicators as the refinement has already been seen.
3452 ("indicator Part_Of cannot appear in this context "
3453 & "(SPARK RM 7.2.6(5))", Indic
);
3455 if Scope
(State_Id
) = Pack_Id
then
3456 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3458 ("\& is declared in the body of package %", Indic
, Item_Id
);
3463 end Analyze_Part_Of
;
3465 ----------------------------
3466 -- Analyze_Refined_Pragma --
3467 ----------------------------
3469 procedure Analyze_Refined_Pragma
3470 (Spec_Id
: out Entity_Id
;
3471 Body_Id
: out Entity_Id
;
3472 Legal
: out Boolean)
3474 Body_Decl
: Node_Id
;
3475 Spec_Decl
: Node_Id
;
3478 -- Assume that the pragma is illegal
3485 Check_Arg_Count
(1);
3486 Check_No_Identifiers
;
3488 if Nam_In
(Pname
, Name_Refined_Depends
,
3489 Name_Refined_Global
,
3492 Ensure_Aggregate_Form
(Arg1
);
3495 -- Verify the placement of the pragma and check for duplicates. The
3496 -- pragma must apply to a subprogram body [stub].
3498 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3500 -- Extract the entities of the spec and body
3502 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3503 Body_Id
:= Defining_Entity
(Body_Decl
);
3504 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3506 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3507 Body_Id
:= Defining_Entity
(Body_Decl
);
3508 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3515 -- The pragma must apply to the second declaration of a subprogram.
3516 -- In other words, the body [stub] cannot acts as a spec.
3518 if No
(Spec_Id
) then
3519 Error_Pragma
("pragma % cannot apply to a stand alone body");
3522 -- Catch the case where the subprogram body is a subunit and acts as
3523 -- the third declaration of the subprogram.
3525 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3526 Error_Pragma
("pragma % cannot apply to a subunit");
3530 -- The pragma can only apply to the body [stub] of a subprogram
3531 -- declared in the visible part of a package. Retrieve the context of
3532 -- the subprogram declaration.
3534 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3536 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3538 ("pragma % must apply to the body of a subprogram declared in a "
3539 & "package specification");
3543 -- If we get here, then the pragma is legal
3546 end Analyze_Refined_Pragma
;
3548 --------------------------
3549 -- Check_Ada_83_Warning --
3550 --------------------------
3552 procedure Check_Ada_83_Warning
is
3554 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3555 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3557 end Check_Ada_83_Warning
;
3559 ---------------------
3560 -- Check_Arg_Count --
3561 ---------------------
3563 procedure Check_Arg_Count
(Required
: Nat
) is
3565 if Arg_Count
/= Required
then
3566 Error_Pragma
("wrong number of arguments for pragma%");
3568 end Check_Arg_Count
;
3570 --------------------------------
3571 -- Check_Arg_Is_External_Name --
3572 --------------------------------
3574 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3575 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3578 if Nkind
(Argx
) = N_Identifier
then
3582 Analyze_And_Resolve
(Argx
, Standard_String
);
3584 if Is_OK_Static_Expression
(Argx
) then
3587 elsif Etype
(Argx
) = Any_Type
then
3590 -- An interesting special case, if we have a string literal and
3591 -- we are in Ada 83 mode, then we allow it even though it will
3592 -- not be flagged as static. This allows expected Ada 83 mode
3593 -- use of external names which are string literals, even though
3594 -- technically these are not static in Ada 83.
3596 elsif Ada_Version
= Ada_83
3597 and then Nkind
(Argx
) = N_String_Literal
3601 -- Static expression that raises Constraint_Error. This has
3602 -- already been flagged, so just exit from pragma processing.
3604 elsif Is_OK_Static_Expression
(Argx
) then
3607 -- Here we have a real error (non-static expression)
3610 Error_Msg_Name_1
:= Pname
;
3613 Msg
: constant String :=
3614 "argument for pragma% must be a identifier or "
3615 & "static string expression!";
3617 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3622 end Check_Arg_Is_External_Name
;
3624 -----------------------------
3625 -- Check_Arg_Is_Identifier --
3626 -----------------------------
3628 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3629 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3631 if Nkind
(Argx
) /= N_Identifier
then
3633 ("argument for pragma% must be identifier", Argx
);
3635 end Check_Arg_Is_Identifier
;
3637 ----------------------------------
3638 -- Check_Arg_Is_Integer_Literal --
3639 ----------------------------------
3641 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3642 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3644 if Nkind
(Argx
) /= N_Integer_Literal
then
3646 ("argument for pragma% must be integer literal", Argx
);
3648 end Check_Arg_Is_Integer_Literal
;
3650 -------------------------------------------
3651 -- Check_Arg_Is_Library_Level_Local_Name --
3652 -------------------------------------------
3656 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3657 -- | library_unit_NAME
3659 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3661 Check_Arg_Is_Local_Name
(Arg
);
3663 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3664 and then Comes_From_Source
(N
)
3667 ("argument for pragma% must be library level entity", Arg
);
3669 end Check_Arg_Is_Library_Level_Local_Name
;
3671 -----------------------------
3672 -- Check_Arg_Is_Local_Name --
3673 -----------------------------
3677 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3678 -- | library_unit_NAME
3680 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3681 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3686 if Nkind
(Argx
) not in N_Direct_Name
3687 and then (Nkind
(Argx
) /= N_Attribute_Reference
3688 or else Present
(Expressions
(Argx
))
3689 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3690 and then (not Is_Entity_Name
(Argx
)
3691 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3693 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3696 -- No further check required if not an entity name
3698 if not Is_Entity_Name
(Argx
) then
3704 Ent
: constant Entity_Id
:= Entity
(Argx
);
3705 Scop
: constant Entity_Id
:= Scope
(Ent
);
3708 -- Case of a pragma applied to a compilation unit: pragma must
3709 -- occur immediately after the program unit in the compilation.
3711 if Is_Compilation_Unit
(Ent
) then
3713 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3716 -- Case of pragma placed immediately after spec
3718 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3721 -- Case of pragma placed immediately after body
3723 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3724 and then Present
(Corresponding_Body
(Decl
))
3728 (Parent
(Unit_Declaration_Node
3729 (Corresponding_Body
(Decl
))));
3731 -- All other cases are illegal
3738 -- Special restricted placement rule from 10.2.1(11.8/2)
3740 elsif Is_Generic_Formal
(Ent
)
3741 and then Prag_Id
= Pragma_Preelaborable_Initialization
3743 OK
:= List_Containing
(N
) =
3744 Generic_Formal_Declarations
3745 (Unit_Declaration_Node
(Scop
));
3747 -- If this is an aspect applied to a subprogram body, the
3748 -- pragma is inserted in its declarative part.
3750 elsif From_Aspect_Specification
(N
)
3751 and then Ent
= Current_Scope
3753 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3757 -- If the aspect is a predicate (possibly others ???) and the
3758 -- context is a record type, this is a discriminant expression
3759 -- within a type declaration, that freezes the predicated
3762 elsif From_Aspect_Specification
(N
)
3763 and then Prag_Id
= Pragma_Predicate
3764 and then Ekind
(Current_Scope
) = E_Record_Type
3765 and then Scop
= Scope
(Current_Scope
)
3769 -- Default case, just check that the pragma occurs in the scope
3770 -- of the entity denoted by the name.
3773 OK
:= Current_Scope
= Scop
;
3778 ("pragma% argument must be in same declarative part", Arg
);
3782 end Check_Arg_Is_Local_Name
;
3784 ---------------------------------
3785 -- Check_Arg_Is_Locking_Policy --
3786 ---------------------------------
3788 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3789 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3792 Check_Arg_Is_Identifier
(Argx
);
3794 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3795 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3797 end Check_Arg_Is_Locking_Policy
;
3799 -----------------------------------------------
3800 -- Check_Arg_Is_Partition_Elaboration_Policy --
3801 -----------------------------------------------
3803 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3804 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3807 Check_Arg_Is_Identifier
(Argx
);
3809 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3811 ("& is not a valid partition elaboration policy name", Argx
);
3813 end Check_Arg_Is_Partition_Elaboration_Policy
;
3815 -------------------------
3816 -- Check_Arg_Is_One_Of --
3817 -------------------------
3819 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3820 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3823 Check_Arg_Is_Identifier
(Argx
);
3825 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3826 Error_Msg_Name_2
:= N1
;
3827 Error_Msg_Name_3
:= N2
;
3828 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3830 end Check_Arg_Is_One_Of
;
3832 procedure Check_Arg_Is_One_Of
3834 N1
, N2
, N3
: Name_Id
)
3836 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3839 Check_Arg_Is_Identifier
(Argx
);
3841 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3842 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3844 end Check_Arg_Is_One_Of
;
3846 procedure Check_Arg_Is_One_Of
3848 N1
, N2
, N3
, N4
: Name_Id
)
3850 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3853 Check_Arg_Is_Identifier
(Argx
);
3855 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3856 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3858 end Check_Arg_Is_One_Of
;
3860 procedure Check_Arg_Is_One_Of
3862 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3864 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3867 Check_Arg_Is_Identifier
(Argx
);
3869 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3870 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3872 end Check_Arg_Is_One_Of
;
3874 ---------------------------------
3875 -- Check_Arg_Is_Queuing_Policy --
3876 ---------------------------------
3878 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3879 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3882 Check_Arg_Is_Identifier
(Argx
);
3884 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3885 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3887 end Check_Arg_Is_Queuing_Policy
;
3889 ---------------------------------------
3890 -- Check_Arg_Is_OK_Static_Expression --
3891 ---------------------------------------
3893 procedure Check_Arg_Is_OK_Static_Expression
3895 Typ
: Entity_Id
:= Empty
)
3898 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
3899 end Check_Arg_Is_OK_Static_Expression
;
3901 ------------------------------------------
3902 -- Check_Arg_Is_Task_Dispatching_Policy --
3903 ------------------------------------------
3905 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
3906 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3909 Check_Arg_Is_Identifier
(Argx
);
3911 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
3913 ("& is not an allowed task dispatching policy name", Argx
);
3915 end Check_Arg_Is_Task_Dispatching_Policy
;
3917 ---------------------
3918 -- Check_Arg_Order --
3919 ---------------------
3921 procedure Check_Arg_Order
(Names
: Name_List
) is
3924 Highest_So_Far
: Natural := 0;
3925 -- Highest index in Names seen do far
3929 for J
in 1 .. Arg_Count
loop
3930 if Chars
(Arg
) /= No_Name
then
3931 for K
in Names
'Range loop
3932 if Chars
(Arg
) = Names
(K
) then
3933 if K
< Highest_So_Far
then
3934 Error_Msg_Name_1
:= Pname
;
3936 ("parameters out of order for pragma%", Arg
);
3937 Error_Msg_Name_1
:= Names
(K
);
3938 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
3939 Error_Msg_N
("\% must appear before %", Arg
);
3943 Highest_So_Far
:= K
;
3951 end Check_Arg_Order
;
3953 --------------------------------
3954 -- Check_At_Least_N_Arguments --
3955 --------------------------------
3957 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
3959 if Arg_Count
< N
then
3960 Error_Pragma
("too few arguments for pragma%");
3962 end Check_At_Least_N_Arguments
;
3964 -------------------------------
3965 -- Check_At_Most_N_Arguments --
3966 -------------------------------
3968 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
3971 if Arg_Count
> N
then
3973 for J
in 1 .. N
loop
3975 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
3978 end Check_At_Most_N_Arguments
;
3980 ---------------------
3981 -- Check_Component --
3982 ---------------------
3984 procedure Check_Component
3987 In_Variant_Part
: Boolean := False)
3989 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
3990 Sindic
: constant Node_Id
:=
3991 Subtype_Indication
(Component_Definition
(Comp
));
3992 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
3995 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
3996 -- object constraint, then the component type shall be an Unchecked_
3999 if Nkind
(Sindic
) = N_Subtype_Indication
4000 and then Has_Per_Object_Constraint
(Comp_Id
)
4001 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4004 ("component subtype subject to per-object constraint "
4005 & "must be an Unchecked_Union", Comp
);
4007 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4008 -- the body of a generic unit, or within the body of any of its
4009 -- descendant library units, no part of the type of a component
4010 -- declared in a variant_part of the unchecked union type shall be of
4011 -- a formal private type or formal private extension declared within
4012 -- the formal part of the generic unit.
4014 elsif Ada_Version
>= Ada_2012
4015 and then In_Generic_Body
(UU_Typ
)
4016 and then In_Variant_Part
4017 and then Is_Private_Type
(Typ
)
4018 and then Is_Generic_Type
(Typ
)
4021 ("component of unchecked union cannot be of generic type", Comp
);
4023 elsif Needs_Finalization
(Typ
) then
4025 ("component of unchecked union cannot be controlled", Comp
);
4027 elsif Has_Task
(Typ
) then
4029 ("component of unchecked union cannot have tasks", Comp
);
4031 end Check_Component
;
4033 -----------------------------
4034 -- Check_Declaration_Order --
4035 -----------------------------
4037 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4038 procedure Check_Aspect_Specification_Order
;
4039 -- Inspect the aspect specifications of the context to determine the
4042 --------------------------------------
4043 -- Check_Aspect_Specification_Order --
4044 --------------------------------------
4046 procedure Check_Aspect_Specification_Order
is
4047 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4048 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4052 -- Both aspects must be part of the same aspect specification list
4055 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4057 -- Try to reach Second starting from First in a left to right
4058 -- traversal of the aspect specifications.
4060 Asp
:= Next
(Asp_First
);
4061 while Present
(Asp
) loop
4063 -- The order is ok, First is followed by Second
4065 if Asp
= Asp_Second
then
4072 -- If we get here, then the aspects are out of order
4074 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4075 end Check_Aspect_Specification_Order
;
4081 -- Start of processing for Check_Declaration_Order
4084 -- Cannot check the order if one of the pragmas is missing
4086 if No
(First
) or else No
(Second
) then
4090 -- Set up the error names in case the order is incorrect
4092 Error_Msg_Name_1
:= Pragma_Name
(First
);
4093 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4095 if From_Aspect_Specification
(First
) then
4097 -- Both pragmas are actually aspects, check their declaration
4098 -- order in the associated aspect specification list. Otherwise
4099 -- First is an aspect and Second a source pragma.
4101 if From_Aspect_Specification
(Second
) then
4102 Check_Aspect_Specification_Order
;
4105 -- Abstract_States is a source pragma
4108 if From_Aspect_Specification
(Second
) then
4109 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4111 -- Both pragmas are source constructs. Try to reach First from
4112 -- Second by traversing the declarations backwards.
4115 Stmt
:= Prev
(Second
);
4116 while Present
(Stmt
) loop
4118 -- The order is ok, First is followed by Second
4120 if Stmt
= First
then
4127 -- If we get here, then the pragmas are out of order
4129 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4132 end Check_Declaration_Order
;
4134 ----------------------------
4135 -- Check_Duplicate_Pragma --
4136 ----------------------------
4138 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4139 Id
: Entity_Id
:= E
;
4143 -- Nothing to do if this pragma comes from an aspect specification,
4144 -- since we could not be duplicating a pragma, and we dealt with the
4145 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4147 if From_Aspect_Specification
(N
) then
4151 -- Otherwise current pragma may duplicate previous pragma or a
4152 -- previously given aspect specification or attribute definition
4153 -- clause for the same pragma.
4155 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4159 -- If the entity is a type, then we have to make sure that the
4160 -- ostensible duplicate is not for a parent type from which this
4164 if Nkind
(P
) = N_Pragma
then
4166 Args
: constant List_Id
:=
4167 Pragma_Argument_Associations
(P
);
4170 and then Is_Entity_Name
(Expression
(First
(Args
)))
4171 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4172 and then Entity
(Expression
(First
(Args
))) /= E
4178 elsif Nkind
(P
) = N_Aspect_Specification
4179 and then Is_Type
(Entity
(P
))
4180 and then Entity
(P
) /= E
4186 -- Here we have a definite duplicate
4188 Error_Msg_Name_1
:= Pragma_Name
(N
);
4189 Error_Msg_Sloc
:= Sloc
(P
);
4191 -- For a single protected or a single task object, the error is
4192 -- issued on the original entity.
4194 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4195 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4198 if Nkind
(P
) = N_Aspect_Specification
4199 or else From_Aspect_Specification
(P
)
4201 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4203 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4208 end Check_Duplicate_Pragma
;
4210 ----------------------------------
4211 -- Check_Duplicated_Export_Name --
4212 ----------------------------------
4214 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4215 String_Val
: constant String_Id
:= Strval
(Nam
);
4218 -- We are only interested in the export case, and in the case of
4219 -- generics, it is the instance, not the template, that is the
4220 -- problem (the template will generate a warning in any case).
4222 if not Inside_A_Generic
4223 and then (Prag_Id
= Pragma_Export
4225 Prag_Id
= Pragma_Export_Procedure
4227 Prag_Id
= Pragma_Export_Valued_Procedure
4229 Prag_Id
= Pragma_Export_Function
)
4231 for J
in Externals
.First
.. Externals
.Last
loop
4232 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4233 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4234 Error_Msg_N
("external name duplicates name given#", Nam
);
4239 Externals
.Append
(Nam
);
4241 end Check_Duplicated_Export_Name
;
4243 ----------------------------------------
4244 -- Check_Expr_Is_OK_Static_Expression --
4245 ----------------------------------------
4247 procedure Check_Expr_Is_OK_Static_Expression
4249 Typ
: Entity_Id
:= Empty
)
4252 if Present
(Typ
) then
4253 Analyze_And_Resolve
(Expr
, Typ
);
4255 Analyze_And_Resolve
(Expr
);
4258 if Is_OK_Static_Expression
(Expr
) then
4261 elsif Etype
(Expr
) = Any_Type
then
4264 -- An interesting special case, if we have a string literal and we
4265 -- are in Ada 83 mode, then we allow it even though it will not be
4266 -- flagged as static. This allows the use of Ada 95 pragmas like
4267 -- Import in Ada 83 mode. They will of course be flagged with
4268 -- warnings as usual, but will not cause errors.
4270 elsif Ada_Version
= Ada_83
4271 and then Nkind
(Expr
) = N_String_Literal
4275 -- Static expression that raises Constraint_Error. This has already
4276 -- been flagged, so just exit from pragma processing.
4278 elsif Is_OK_Static_Expression
(Expr
) then
4281 -- Finally, we have a real error
4284 Error_Msg_Name_1
:= Pname
;
4285 Flag_Non_Static_Expr
4286 (Fix_Error
("argument for pragma% must be a static expression!"),
4290 end Check_Expr_Is_OK_Static_Expression
;
4292 -------------------------
4293 -- Check_First_Subtype --
4294 -------------------------
4296 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4297 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4298 Ent
: constant Entity_Id
:= Entity
(Argx
);
4301 if Is_First_Subtype
(Ent
) then
4304 elsif Is_Type
(Ent
) then
4306 ("pragma% cannot apply to subtype", Argx
);
4308 elsif Is_Object
(Ent
) then
4310 ("pragma% cannot apply to object, requires a type", Argx
);
4314 ("pragma% cannot apply to&, requires a type", Argx
);
4316 end Check_First_Subtype
;
4318 ----------------------
4319 -- Check_Identifier --
4320 ----------------------
4322 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4325 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4327 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4328 Error_Msg_Name_1
:= Pname
;
4329 Error_Msg_Name_2
:= Id
;
4330 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4334 end Check_Identifier
;
4336 --------------------------------
4337 -- Check_Identifier_Is_One_Of --
4338 --------------------------------
4340 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4343 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4345 if Chars
(Arg
) = No_Name
then
4346 Error_Msg_Name_1
:= Pname
;
4347 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4350 elsif Chars
(Arg
) /= N1
4351 and then Chars
(Arg
) /= N2
4353 Error_Msg_Name_1
:= Pname
;
4354 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4358 end Check_Identifier_Is_One_Of
;
4360 ---------------------------
4361 -- Check_In_Main_Program --
4362 ---------------------------
4364 procedure Check_In_Main_Program
is
4365 P
: constant Node_Id
:= Parent
(N
);
4368 -- Must be at in subprogram body
4370 if Nkind
(P
) /= N_Subprogram_Body
then
4371 Error_Pragma
("% pragma allowed only in subprogram");
4373 -- Otherwise warn if obviously not main program
4375 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4376 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4378 Error_Msg_Name_1
:= Pname
;
4380 ("??pragma% is only effective in main program", N
);
4382 end Check_In_Main_Program
;
4384 ---------------------------------------
4385 -- Check_Interrupt_Or_Attach_Handler --
4386 ---------------------------------------
4388 procedure Check_Interrupt_Or_Attach_Handler
is
4389 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4390 Handler_Proc
, Proc_Scope
: Entity_Id
;
4395 if Prag_Id
= Pragma_Interrupt_Handler
then
4396 Check_Restriction
(No_Dynamic_Attachment
, N
);
4399 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4400 Proc_Scope
:= Scope
(Handler_Proc
);
4402 -- On AAMP only, a pragma Interrupt_Handler is supported for
4403 -- nonprotected parameterless procedures.
4405 if not AAMP_On_Target
4406 or else Prag_Id
= Pragma_Attach_Handler
4408 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4410 ("argument of pragma% must be protected procedure", Arg1
);
4413 -- For pragma case (as opposed to access case), check placement.
4414 -- We don't need to do that for aspects, because we have the
4415 -- check that they aspect applies an appropriate procedure.
4417 if not From_Aspect_Specification
(N
)
4418 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4420 Error_Pragma
("pragma% must be in protected definition");
4424 if not Is_Library_Level_Entity
(Proc_Scope
)
4425 or else (AAMP_On_Target
4426 and then not Is_Library_Level_Entity
(Handler_Proc
))
4429 ("argument for pragma% must be library level entity", Arg1
);
4432 -- AI05-0033: A pragma cannot appear within a generic body, because
4433 -- instance can be in a nested scope. The check that protected type
4434 -- is itself a library-level declaration is done elsewhere.
4436 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4437 -- handle code prior to AI-0033. Analysis tools typically are not
4438 -- interested in this pragma in any case, so no need to worry too
4439 -- much about its placement.
4441 if Inside_A_Generic
then
4442 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4443 and then In_Package_Body
(Scope
(Current_Scope
))
4444 and then not Relaxed_RM_Semantics
4446 Error_Pragma
("pragma% cannot be used inside a generic");
4449 end Check_Interrupt_Or_Attach_Handler
;
4451 ---------------------------------
4452 -- Check_Loop_Pragma_Placement --
4453 ---------------------------------
4455 procedure Check_Loop_Pragma_Placement
is
4456 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4457 -- Verify whether the current pragma is properly grouped with other
4458 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4459 -- related loop where the pragma appears.
4461 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4462 -- Determine whether an arbitrary statement Stmt denotes pragma
4463 -- Loop_Invariant or Loop_Variant.
4465 procedure Placement_Error
(Constr
: Node_Id
);
4466 pragma No_Return
(Placement_Error
);
4467 -- Node Constr denotes the last loop restricted construct before we
4468 -- encountered an illegal relation between enclosing constructs. Emit
4469 -- an error depending on what Constr was.
4471 --------------------------------
4472 -- Check_Loop_Pragma_Grouping --
4473 --------------------------------
4475 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4476 Stop_Search
: exception;
4477 -- This exception is used to terminate the recursive descent of
4478 -- routine Check_Grouping.
4480 procedure Check_Grouping
(L
: List_Id
);
4481 -- Find the first group of pragmas in list L and if successful,
4482 -- ensure that the current pragma is part of that group. The
4483 -- routine raises Stop_Search once such a check is performed to
4484 -- halt the recursive descent.
4486 procedure Grouping_Error
(Prag
: Node_Id
);
4487 pragma No_Return
(Grouping_Error
);
4488 -- Emit an error concerning the current pragma indicating that it
4489 -- should be placed after pragma Prag.
4491 --------------------
4492 -- Check_Grouping --
4493 --------------------
4495 procedure Check_Grouping
(L
: List_Id
) is
4501 -- Inspect the list of declarations or statements looking for
4502 -- the first grouping of pragmas:
4505 -- pragma Loop_Invariant ...;
4506 -- pragma Loop_Variant ...;
4508 -- pragma Loop_Variant ...; -- current pragma
4510 -- If the current pragma is not in the grouping, then it must
4511 -- either appear in a different declarative or statement list
4512 -- or the construct at (1) is separating the pragma from the
4516 while Present
(Stmt
) loop
4518 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4519 -- inside a loop or a block housed inside a loop. Inspect
4520 -- the declarations and statements of the block as they may
4521 -- contain the first grouping.
4523 if Nkind
(Stmt
) = N_Block_Statement
then
4524 HSS
:= Handled_Statement_Sequence
(Stmt
);
4526 Check_Grouping
(Declarations
(Stmt
));
4528 if Present
(HSS
) then
4529 Check_Grouping
(Statements
(HSS
));
4532 -- First pragma of the first topmost grouping has been found
4534 elsif Is_Loop_Pragma
(Stmt
) then
4536 -- The group and the current pragma are not in the same
4537 -- declarative or statement list.
4539 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4540 Grouping_Error
(Stmt
);
4542 -- Try to reach the current pragma from the first pragma
4543 -- of the grouping while skipping other members:
4545 -- pragma Loop_Invariant ...; -- first pragma
4546 -- pragma Loop_Variant ...; -- member
4548 -- pragma Loop_Variant ...; -- current pragma
4551 while Present
(Stmt
) loop
4553 -- The current pragma is either the first pragma
4554 -- of the group or is a member of the group. Stop
4555 -- the search as the placement is legal.
4560 -- Skip group members, but keep track of the last
4561 -- pragma in the group.
4563 elsif Is_Loop_Pragma
(Stmt
) then
4566 -- A non-pragma is separating the group from the
4567 -- current pragma, the placement is illegal.
4570 Grouping_Error
(Prag
);
4576 -- If the traversal did not reach the current pragma,
4577 -- then the list must be malformed.
4579 raise Program_Error
;
4587 --------------------
4588 -- Grouping_Error --
4589 --------------------
4591 procedure Grouping_Error
(Prag
: Node_Id
) is
4593 Error_Msg_Sloc
:= Sloc
(Prag
);
4594 Error_Pragma
("pragma% must appear next to pragma#");
4597 -- Start of processing for Check_Loop_Pragma_Grouping
4600 -- Inspect the statements of the loop or nested blocks housed
4601 -- within to determine whether the current pragma is part of the
4602 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4604 Check_Grouping
(Statements
(Loop_Stmt
));
4607 when Stop_Search
=> null;
4608 end Check_Loop_Pragma_Grouping
;
4610 --------------------
4611 -- Is_Loop_Pragma --
4612 --------------------
4614 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4616 -- Inspect the original node as Loop_Invariant and Loop_Variant
4617 -- pragmas are rewritten to null when assertions are disabled.
4619 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4621 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4622 Name_Loop_Invariant
,
4629 ---------------------
4630 -- Placement_Error --
4631 ---------------------
4633 procedure Placement_Error
(Constr
: Node_Id
) is
4634 LA
: constant String := " with Loop_Entry";
4637 if Prag_Id
= Pragma_Assert
then
4638 Error_Msg_String
(1 .. LA
'Length) := LA
;
4639 Error_Msg_Strlen
:= LA
'Length;
4641 Error_Msg_Strlen
:= 0;
4644 if Nkind
(Constr
) = N_Pragma
then
4646 ("pragma %~ must appear immediately within the statements "
4650 ("block containing pragma %~ must appear immediately within "
4651 & "the statements of a loop", Constr
);
4653 end Placement_Error
;
4655 -- Local declarations
4660 -- Start of processing for Check_Loop_Pragma_Placement
4663 -- Check that pragma appears immediately within a loop statement,
4664 -- ignoring intervening block statements.
4668 while Present
(Stmt
) loop
4670 -- The pragma or previous block must appear immediately within the
4671 -- current block's declarative or statement part.
4673 if Nkind
(Stmt
) = N_Block_Statement
then
4674 if (No
(Declarations
(Stmt
))
4675 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4677 List_Containing
(Prev
) /=
4678 Statements
(Handled_Statement_Sequence
(Stmt
))
4680 Placement_Error
(Prev
);
4683 -- Keep inspecting the parents because we are now within a
4684 -- chain of nested blocks.
4688 Stmt
:= Parent
(Stmt
);
4691 -- The pragma or previous block must appear immediately within the
4692 -- statements of the loop.
4694 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4695 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4696 Placement_Error
(Prev
);
4699 -- Stop the traversal because we reached the innermost loop
4700 -- regardless of whether we encountered an error or not.
4704 -- Ignore a handled statement sequence. Note that this node may
4705 -- be related to a subprogram body in which case we will emit an
4706 -- error on the next iteration of the search.
4708 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4709 Stmt
:= Parent
(Stmt
);
4711 -- Any other statement breaks the chain from the pragma to the
4715 Placement_Error
(Prev
);
4720 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4721 -- grouped together with other such pragmas.
4723 if Is_Loop_Pragma
(N
) then
4725 -- The previous check should have located the related loop
4727 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4728 Check_Loop_Pragma_Grouping
(Stmt
);
4730 end Check_Loop_Pragma_Placement
;
4732 -------------------------------------------
4733 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4734 -------------------------------------------
4736 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4745 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4748 elsif Nkind_In
(P
, N_Package_Specification
,
4753 -- Note: the following tests seem a little peculiar, because
4754 -- they test for bodies, but if we were in the statement part
4755 -- of the body, we would already have hit the handled statement
4756 -- sequence, so the only way we get here is by being in the
4757 -- declarative part of the body.
4759 elsif Nkind_In
(P
, N_Subprogram_Body
,
4770 Error_Pragma
("pragma% is not in declarative part or package spec");
4771 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4773 -------------------------
4774 -- Check_No_Identifier --
4775 -------------------------
4777 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4779 if Nkind
(Arg
) = N_Pragma_Argument_Association
4780 and then Chars
(Arg
) /= No_Name
4782 Error_Pragma_Arg_Ident
4783 ("pragma% does not permit identifier& here", Arg
);
4785 end Check_No_Identifier
;
4787 --------------------------
4788 -- Check_No_Identifiers --
4789 --------------------------
4791 procedure Check_No_Identifiers
is
4795 for J
in 1 .. Arg_Count
loop
4796 Check_No_Identifier
(Arg_Node
);
4799 end Check_No_Identifiers
;
4801 ------------------------
4802 -- Check_No_Link_Name --
4803 ------------------------
4805 procedure Check_No_Link_Name
is
4807 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4811 if Present
(Arg4
) then
4813 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4815 end Check_No_Link_Name
;
4817 -------------------------------
4818 -- Check_Optional_Identifier --
4819 -------------------------------
4821 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4824 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4825 and then Chars
(Arg
) /= No_Name
4827 if Chars
(Arg
) /= Id
then
4828 Error_Msg_Name_1
:= Pname
;
4829 Error_Msg_Name_2
:= Id
;
4830 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4834 end Check_Optional_Identifier
;
4836 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4838 Name_Buffer
(1 .. Id
'Length) := Id
;
4839 Name_Len
:= Id
'Length;
4840 Check_Optional_Identifier
(Arg
, Name_Find
);
4841 end Check_Optional_Identifier
;
4843 --------------------
4844 -- Check_Pre_Post --
4845 --------------------
4847 procedure Check_Pre_Post
is
4852 if not Is_List_Member
(N
) then
4856 -- If we are within an inlined body, the legality of the pragma
4857 -- has been checked already.
4859 if In_Inlined_Body
then
4863 -- Search prior declarations
4866 while Present
(Prev
(P
)) loop
4869 -- If the previous node is a generic subprogram, do not go to to
4870 -- the original node, which is the unanalyzed tree: we need to
4871 -- attach the pre/postconditions to the analyzed version at this
4872 -- point. They get propagated to the original tree when analyzing
4873 -- the corresponding body.
4875 if Nkind
(P
) not in N_Generic_Declaration
then
4876 PO
:= Original_Node
(P
);
4881 -- Skip past prior pragma
4883 if Nkind
(PO
) = N_Pragma
then
4886 -- Skip stuff not coming from source
4888 elsif not Comes_From_Source
(PO
) then
4890 -- The condition may apply to a subprogram instantiation
4892 if Nkind
(PO
) = N_Subprogram_Declaration
4893 and then Present
(Generic_Parent
(Specification
(PO
)))
4897 elsif Nkind
(PO
) = N_Subprogram_Declaration
4898 and then In_Instance
4902 -- For all other cases of non source code, do nothing
4908 -- Only remaining possibility is subprogram declaration
4915 -- If we fall through loop, pragma is at start of list, so see if it
4916 -- is at the start of declarations of a subprogram body.
4920 if Nkind
(PO
) = N_Subprogram_Body
4921 and then List_Containing
(N
) = Declarations
(PO
)
4923 -- This is only allowed if there is no separate specification
4925 if Present
(Corresponding_Spec
(PO
)) then
4927 ("pragma% must apply to subprogram specification");
4934 --------------------------------------
4935 -- Check_Precondition_Postcondition --
4936 --------------------------------------
4938 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
4942 procedure Chain_PPC
(PO
: Node_Id
);
4943 -- If PO is an entry or a [generic] subprogram declaration node, then
4944 -- the precondition/postcondition applies to this subprogram and the
4945 -- processing for the pragma is completed. Otherwise the pragma is
4952 procedure Chain_PPC
(PO
: Node_Id
) is
4956 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
4957 if not From_Aspect_Specification
(N
) then
4959 ("pragma% cannot be applied to abstract subprogram");
4961 elsif Class_Present
(N
) then
4966 ("aspect % requires ''Class for abstract subprogram");
4969 -- AI05-0230: The same restriction applies to null procedures. For
4970 -- compatibility with earlier uses of the Ada pragma, apply this
4971 -- rule only to aspect specifications.
4973 -- The above discrepency needs documentation. Robert is dubious
4974 -- about whether it is a good idea ???
4976 elsif Nkind
(PO
) = N_Subprogram_Declaration
4977 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
4978 and then Null_Present
(Specification
(PO
))
4979 and then From_Aspect_Specification
(N
)
4980 and then not Class_Present
(N
)
4983 ("aspect % requires ''Class for null procedure");
4985 -- Pre/postconditions are legal on a subprogram body if it is not
4986 -- a completion of a declaration. They are also legal on a stub
4987 -- with no previous declarations (this is checked when processing
4988 -- the corresponding aspects).
4990 elsif Nkind
(PO
) = N_Subprogram_Body
4991 and then Acts_As_Spec
(PO
)
4995 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
4998 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
4999 N_Expression_Function
,
5000 N_Generic_Subprogram_Declaration
,
5001 N_Entry_Declaration
)
5006 -- Here if we have [generic] subprogram or entry declaration
5008 if Nkind
(PO
) = N_Entry_Declaration
then
5009 S
:= Defining_Entity
(PO
);
5011 S
:= Defining_Unit_Name
(Specification
(PO
));
5013 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5014 S
:= Defining_Identifier
(S
);
5018 -- Note: we do not analyze the pragma at this point. Instead we
5019 -- delay this analysis until the end of the declarative part in
5020 -- which the pragma appears. This implements the required delay
5021 -- in this analysis, allowing forward references. The analysis
5022 -- happens at the end of Analyze_Declarations.
5024 -- Chain spec PPC pragma to list for subprogram
5026 Add_Contract_Item
(N
, S
);
5028 -- Return indicating spec case
5034 -- Start of processing for Check_Precondition_Postcondition
5037 if not Is_List_Member
(N
) then
5041 -- Preanalyze message argument if present. Visibility in this
5042 -- argument is established at the point of pragma occurrence.
5044 if Arg_Count
= 2 then
5045 Check_Optional_Identifier
(Arg2
, Name_Message
);
5046 Preanalyze_Spec_Expression
5047 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5050 -- For a pragma PPC in the extended main source unit, record enabled
5053 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5054 Set_SCO_Pragma_Enabled
(Loc
);
5057 -- If we are within an inlined body, the legality of the pragma
5058 -- has been checked already.
5060 if In_Inlined_Body
then
5065 -- Search prior declarations
5068 while Present
(Prev
(P
)) loop
5071 -- If the previous node is a generic subprogram, do not go to to
5072 -- the original node, which is the unanalyzed tree: we need to
5073 -- attach the pre/postconditions to the analyzed version at this
5074 -- point. They get propagated to the original tree when analyzing
5075 -- the corresponding body.
5077 if Nkind
(P
) not in N_Generic_Declaration
then
5078 PO
:= Original_Node
(P
);
5083 -- Skip past prior pragma
5085 if Nkind
(PO
) = N_Pragma
then
5088 -- Skip stuff not coming from source
5090 elsif not Comes_From_Source
(PO
) then
5092 -- The condition may apply to a subprogram instantiation
5094 if Nkind
(PO
) = N_Subprogram_Declaration
5095 and then Present
(Generic_Parent
(Specification
(PO
)))
5100 elsif Nkind
(PO
) = N_Subprogram_Declaration
5101 and then In_Instance
5106 -- For all other cases of non source code, do nothing
5112 -- Only remaining possibility is subprogram declaration
5120 -- If we fall through loop, pragma is at start of list, so see if it
5121 -- is at the start of declarations of a subprogram body.
5125 if Nkind
(PO
) = N_Subprogram_Body
5126 and then List_Containing
(N
) = Declarations
(PO
)
5128 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5130 -- Analyze pragma expression for correctness and for ASIS use
5132 Preanalyze_Assert_Expression
5133 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5135 -- In ASIS mode, for a pragma generated from a source aspect,
5136 -- also analyze the original aspect expression.
5138 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5139 Preanalyze_Assert_Expression
5140 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5144 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5145 -- The copy is needed because the pragma is expanded into other
5146 -- constructs which are not acceptable in the N_Contract node.
5148 if Acts_As_Spec
(PO
) and then GNATprove_Mode
then
5150 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5153 -- Preanalyze the pragma
5155 Preanalyze_Assert_Expression
5157 (First
(Pragma_Argument_Associations
(Prag
))),
5160 -- Preanalyze the corresponding aspect (if any)
5162 if Present
(Corresponding_Aspect
(Prag
)) then
5163 Preanalyze_Assert_Expression
5164 (Expression
(Corresponding_Aspect
(Prag
)),
5168 -- Chain the copy on the contract of the body
5171 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5178 -- See if it is in the pragmas after a library level subprogram
5180 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5182 -- In GNATprove mode, analyze pragma expression for correctness,
5183 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5184 -- no later point at which the aspect will be analyzed.
5186 if GNATprove_Mode
or ASIS_Mode
then
5187 Analyze_Pre_Post_Condition_In_Decl_Part
5188 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5191 Chain_PPC
(Unit
(Parent
(PO
)));
5195 -- If we fall through, pragma was misplaced
5198 end Check_Precondition_Postcondition
;
5200 -----------------------------
5201 -- Check_Static_Constraint --
5202 -----------------------------
5204 -- Note: for convenience in writing this procedure, in addition to
5205 -- the officially (i.e. by spec) allowed argument which is always a
5206 -- constraint, it also allows ranges and discriminant associations.
5207 -- Above is not clear ???
5209 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5211 procedure Require_Static
(E
: Node_Id
);
5212 -- Require given expression to be static expression
5214 --------------------
5215 -- Require_Static --
5216 --------------------
5218 procedure Require_Static
(E
: Node_Id
) is
5220 if not Is_OK_Static_Expression
(E
) then
5221 Flag_Non_Static_Expr
5222 ("non-static constraint not allowed in Unchecked_Union!", E
);
5227 -- Start of processing for Check_Static_Constraint
5230 case Nkind
(Constr
) is
5231 when N_Discriminant_Association
=>
5232 Require_Static
(Expression
(Constr
));
5235 Require_Static
(Low_Bound
(Constr
));
5236 Require_Static
(High_Bound
(Constr
));
5238 when N_Attribute_Reference
=>
5239 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5240 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5242 when N_Range_Constraint
=>
5243 Check_Static_Constraint
(Range_Expression
(Constr
));
5245 when N_Index_Or_Discriminant_Constraint
=>
5249 IDC
:= First
(Constraints
(Constr
));
5250 while Present
(IDC
) loop
5251 Check_Static_Constraint
(IDC
);
5259 end Check_Static_Constraint
;
5261 ---------------------
5262 -- Check_Test_Case --
5263 ---------------------
5265 procedure Check_Test_Case
is
5269 procedure Chain_CTC
(PO
: Node_Id
);
5270 -- If PO is a [generic] subprogram declaration node, then the
5271 -- test-case applies to this subprogram and the processing for
5272 -- the pragma is completed. Otherwise the pragma is misplaced.
5278 procedure Chain_CTC
(PO
: Node_Id
) is
5279 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5284 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5286 ("pragma% cannot be applied to abstract subprogram");
5288 elsif Nkind
(PO
) = N_Entry_Declaration
then
5289 Error_Pragma
("pragma% cannot be applied to entry");
5291 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5292 N_Generic_Subprogram_Declaration
)
5297 -- Here if we have [generic] subprogram declaration
5299 S
:= Defining_Unit_Name
(Specification
(PO
));
5301 -- Note: we do not analyze the pragma at this point. Instead we
5302 -- delay this analysis until the end of the declarative part in
5303 -- which the pragma appears. This implements the required delay
5304 -- in this analysis, allowing forward references. The analysis
5305 -- happens at the end of Analyze_Declarations.
5307 -- There should not be another test-case with the same name
5308 -- associated to this subprogram.
5310 CTC
:= Contract_Test_Cases
(Contract
(S
));
5311 while Present
(CTC
) loop
5313 -- Omit pragma Contract_Cases because it does not introduce
5314 -- a unique case name and it does not follow the syntax of
5317 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5320 elsif String_Equal
(Name
, Get_Name_From_CTC_Pragma
(CTC
)) then
5321 Error_Msg_Sloc
:= Sloc
(CTC
);
5322 Error_Pragma
("name for pragma% is already used#");
5325 CTC
:= Next_Pragma
(CTC
);
5328 -- Chain spec CTC pragma to list for subprogram
5330 Add_Contract_Item
(N
, S
);
5333 -- Start of processing for Check_Test_Case
5336 -- First check pragma arguments
5338 Check_At_Least_N_Arguments
(2);
5339 Check_At_Most_N_Arguments
(4);
5341 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5343 Check_Optional_Identifier
(Arg1
, Name_Name
);
5344 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
5346 -- In ASIS mode, for a pragma generated from a source aspect, also
5347 -- analyze the original aspect expression.
5349 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5350 Check_Expr_Is_OK_Static_Expression
5351 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5354 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5355 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5357 if Arg_Count
= 4 then
5358 Check_Identifier
(Arg3
, Name_Requires
);
5359 Check_Identifier
(Arg4
, Name_Ensures
);
5361 elsif Arg_Count
= 3 then
5362 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5365 -- Check pragma placement
5367 if not Is_List_Member
(N
) then
5371 -- Test-case should only appear in package spec unit
5373 if Get_Source_Unit
(N
) = No_Unit
5374 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Current_Sem_Unit
)),
5375 N_Package_Declaration
,
5376 N_Generic_Package_Declaration
)
5381 -- Search prior declarations
5384 while Present
(Prev
(P
)) loop
5387 -- If the previous node is a generic subprogram, do not go to to
5388 -- the original node, which is the unanalyzed tree: we need to
5389 -- attach the test-case to the analyzed version at this point.
5390 -- They get propagated to the original tree when analyzing the
5391 -- corresponding body.
5393 if Nkind
(P
) not in N_Generic_Declaration
then
5394 PO
:= Original_Node
(P
);
5399 -- Skip past prior pragma
5401 if Nkind
(PO
) = N_Pragma
then
5404 -- Skip stuff not coming from source
5406 elsif not Comes_From_Source
(PO
) then
5409 -- Only remaining possibility is subprogram declaration. First
5410 -- check that it is declared directly in a package declaration.
5411 -- This may be either the package declaration for the current unit
5412 -- being defined or a local package declaration.
5414 elsif not Present
(Parent
(Parent
(PO
)))
5415 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5416 or else not Nkind_In
(Parent
(Parent
(PO
)),
5417 N_Package_Declaration
,
5418 N_Generic_Package_Declaration
)
5428 -- If we fall through, pragma was misplaced
5431 end Check_Test_Case
;
5433 --------------------------------------
5434 -- Check_Valid_Configuration_Pragma --
5435 --------------------------------------
5437 -- A configuration pragma must appear in the context clause of a
5438 -- compilation unit, and only other pragmas may precede it. Note that
5439 -- the test also allows use in a configuration pragma file.
5441 procedure Check_Valid_Configuration_Pragma
is
5443 if not Is_Configuration_Pragma
then
5444 Error_Pragma
("incorrect placement for configuration pragma%");
5446 end Check_Valid_Configuration_Pragma
;
5448 -------------------------------------
5449 -- Check_Valid_Library_Unit_Pragma --
5450 -------------------------------------
5452 procedure Check_Valid_Library_Unit_Pragma
is
5454 Parent_Node
: Node_Id
;
5455 Unit_Name
: Entity_Id
;
5456 Unit_Kind
: Node_Kind
;
5457 Unit_Node
: Node_Id
;
5458 Sindex
: Source_File_Index
;
5461 if not Is_List_Member
(N
) then
5465 Plist
:= List_Containing
(N
);
5466 Parent_Node
:= Parent
(Plist
);
5468 if Parent_Node
= Empty
then
5471 -- Case of pragma appearing after a compilation unit. In this case
5472 -- it must have an argument with the corresponding name and must
5473 -- be part of the following pragmas of its parent.
5475 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5476 if Plist
/= Pragmas_After
(Parent_Node
) then
5479 elsif Arg_Count
= 0 then
5481 ("argument required if outside compilation unit");
5484 Check_No_Identifiers
;
5485 Check_Arg_Count
(1);
5486 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5487 Unit_Kind
:= Nkind
(Unit_Node
);
5489 Analyze
(Get_Pragma_Arg
(Arg1
));
5491 if Unit_Kind
= N_Generic_Subprogram_Declaration
5492 or else Unit_Kind
= N_Subprogram_Declaration
5494 Unit_Name
:= Defining_Entity
(Unit_Node
);
5496 elsif Unit_Kind
in N_Generic_Instantiation
then
5497 Unit_Name
:= Defining_Entity
(Unit_Node
);
5500 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5503 if Chars
(Unit_Name
) /=
5504 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5507 ("pragma% argument is not current unit name", Arg1
);
5510 if Ekind
(Unit_Name
) = E_Package
5511 and then Present
(Renamed_Entity
(Unit_Name
))
5513 Error_Pragma
("pragma% not allowed for renamed package");
5517 -- Pragma appears other than after a compilation unit
5520 -- Here we check for the generic instantiation case and also
5521 -- for the case of processing a generic formal package. We
5522 -- detect these cases by noting that the Sloc on the node
5523 -- does not belong to the current compilation unit.
5525 Sindex
:= Source_Index
(Current_Sem_Unit
);
5527 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5528 Rewrite
(N
, Make_Null_Statement
(Loc
));
5531 -- If before first declaration, the pragma applies to the
5532 -- enclosing unit, and the name if present must be this name.
5534 elsif Is_Before_First_Decl
(N
, Plist
) then
5535 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5536 Unit_Kind
:= Nkind
(Unit_Node
);
5538 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5541 elsif Unit_Kind
= N_Subprogram_Body
5542 and then not Acts_As_Spec
(Unit_Node
)
5546 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5549 elsif Nkind
(Parent_Node
) = N_Package_Specification
5550 and then Plist
= Private_Declarations
(Parent_Node
)
5554 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5555 or else Nkind
(Parent_Node
) =
5556 N_Generic_Subprogram_Declaration
)
5557 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5561 elsif Arg_Count
> 0 then
5562 Analyze
(Get_Pragma_Arg
(Arg1
));
5564 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5566 ("name in pragma% must be enclosing unit", Arg1
);
5569 -- It is legal to have no argument in this context
5575 -- Error if not before first declaration. This is because a
5576 -- library unit pragma argument must be the name of a library
5577 -- unit (RM 10.1.5(7)), but the only names permitted in this
5578 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5579 -- generic subprogram declarations or generic instantiations.
5583 ("pragma% misplaced, must be before first declaration");
5587 end Check_Valid_Library_Unit_Pragma
;
5593 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5594 Clist
: constant Node_Id
:= Component_List
(Variant
);
5598 Comp
:= First
(Component_Items
(Clist
));
5599 while Present
(Comp
) loop
5600 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5605 ---------------------------
5606 -- Ensure_Aggregate_Form --
5607 ---------------------------
5609 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5610 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5611 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5612 Nam
: constant Name_Id
:= Chars
(Arg
);
5613 Comps
: List_Id
:= No_List
;
5614 Exprs
: List_Id
:= No_List
;
5616 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5617 -- Used to restore Comes_From_Source_Default
5620 -- The argument is already in aggregate form, but the presence of a
5621 -- name causes this to be interpreted as a named association which in
5622 -- turn must be converted into an aggregate.
5624 -- pragma Global (In_Out => (A, B, C))
5628 -- pragma Global ((In_Out => (A, B, C)))
5630 -- aggregate aggregate
5632 if Nkind
(Expr
) = N_Aggregate
then
5633 if Nam
= No_Name
then
5637 -- Do not transform a null argument into an aggregate as N_Null has
5638 -- special meaning in formal verification pragmas.
5640 elsif Nkind
(Expr
) = N_Null
then
5644 -- Everything comes from source if the original comes from source
5646 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5648 -- Positional argument is transformed into an aggregate with an
5649 -- Expressions list.
5651 if Nam
= No_Name
then
5652 Exprs
:= New_List
(Relocate_Node
(Expr
));
5654 -- An associative argument is transformed into an aggregate with
5655 -- Component_Associations.
5659 Make_Component_Association
(Loc
,
5660 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5661 Expression
=> Relocate_Node
(Expr
)));
5664 -- Remove the pragma argument name as this information has been
5665 -- captured in the aggregate.
5667 Set_Chars
(Arg
, No_Name
);
5669 Set_Expression
(Arg
,
5670 Make_Aggregate
(Loc
,
5671 Component_Associations
=> Comps
,
5672 Expressions
=> Exprs
));
5674 -- Restore Comes_From_Source default
5676 Set_Comes_From_Source_Default
(CFSD
);
5677 end Ensure_Aggregate_Form
;
5683 procedure Error_Pragma
(Msg
: String) is
5685 Error_Msg_Name_1
:= Pname
;
5686 Error_Msg_N
(Fix_Error
(Msg
), N
);
5690 ----------------------
5691 -- Error_Pragma_Arg --
5692 ----------------------
5694 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5696 Error_Msg_Name_1
:= Pname
;
5697 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5699 end Error_Pragma_Arg
;
5701 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5703 Error_Msg_Name_1
:= Pname
;
5704 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5705 Error_Pragma_Arg
(Msg2
, Arg
);
5706 end Error_Pragma_Arg
;
5708 ----------------------------
5709 -- Error_Pragma_Arg_Ident --
5710 ----------------------------
5712 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5714 Error_Msg_Name_1
:= Pname
;
5715 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5717 end Error_Pragma_Arg_Ident
;
5719 ----------------------
5720 -- Error_Pragma_Ref --
5721 ----------------------
5723 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5725 Error_Msg_Name_1
:= Pname
;
5726 Error_Msg_Sloc
:= Sloc
(Ref
);
5727 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5729 end Error_Pragma_Ref
;
5731 ------------------------
5732 -- Find_Lib_Unit_Name --
5733 ------------------------
5735 function Find_Lib_Unit_Name
return Entity_Id
is
5737 -- Return inner compilation unit entity, for case of nested
5738 -- categorization pragmas. This happens in generic unit.
5740 if Nkind
(Parent
(N
)) = N_Package_Specification
5741 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5743 return Defining_Entity
(Parent
(N
));
5745 return Current_Scope
;
5747 end Find_Lib_Unit_Name
;
5749 ----------------------------
5750 -- Find_Program_Unit_Name --
5751 ----------------------------
5753 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5754 Unit_Name
: Entity_Id
;
5755 Unit_Kind
: Node_Kind
;
5756 P
: constant Node_Id
:= Parent
(N
);
5759 if Nkind
(P
) = N_Compilation_Unit
then
5760 Unit_Kind
:= Nkind
(Unit
(P
));
5762 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5763 N_Package_Declaration
)
5764 or else Unit_Kind
in N_Generic_Declaration
5766 Unit_Name
:= Defining_Entity
(Unit
(P
));
5768 if Chars
(Id
) = Chars
(Unit_Name
) then
5769 Set_Entity
(Id
, Unit_Name
);
5770 Set_Etype
(Id
, Etype
(Unit_Name
));
5772 Set_Etype
(Id
, Any_Type
);
5774 ("cannot find program unit referenced by pragma%");
5778 Set_Etype
(Id
, Any_Type
);
5779 Error_Pragma
("pragma% inapplicable to this unit");
5785 end Find_Program_Unit_Name
;
5787 -----------------------------------------
5788 -- Find_Unique_Parameterless_Procedure --
5789 -----------------------------------------
5791 function Find_Unique_Parameterless_Procedure
5793 Arg
: Node_Id
) return Entity_Id
5795 Proc
: Entity_Id
:= Empty
;
5798 -- The body of this procedure needs some comments ???
5800 if not Is_Entity_Name
(Name
) then
5802 ("argument of pragma% must be entity name", Arg
);
5804 elsif not Is_Overloaded
(Name
) then
5805 Proc
:= Entity
(Name
);
5807 if Ekind
(Proc
) /= E_Procedure
5808 or else Present
(First_Formal
(Proc
))
5811 ("argument of pragma% must be parameterless procedure", Arg
);
5816 Found
: Boolean := False;
5818 Index
: Interp_Index
;
5821 Get_First_Interp
(Name
, Index
, It
);
5822 while Present
(It
.Nam
) loop
5825 if Ekind
(Proc
) = E_Procedure
5826 and then No
(First_Formal
(Proc
))
5830 Set_Entity
(Name
, Proc
);
5831 Set_Is_Overloaded
(Name
, False);
5834 ("ambiguous handler name for pragma% ", Arg
);
5838 Get_Next_Interp
(Index
, It
);
5843 ("argument of pragma% must be parameterless procedure",
5846 Proc
:= Entity
(Name
);
5852 end Find_Unique_Parameterless_Procedure
;
5858 function Fix_Error
(Msg
: String) return String is
5859 Res
: String (Msg
'Range) := Msg
;
5860 Res_Last
: Natural := Msg
'Last;
5864 -- If we have a rewriting of another pragma, go to that pragma
5866 if Is_Rewrite_Substitution
(N
)
5867 and then Nkind
(Original_Node
(N
)) = N_Pragma
5869 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5872 -- Case where pragma comes from an aspect specification
5874 if From_Aspect_Specification
(N
) then
5876 -- Change appearence of "pragma" in message to "aspect"
5879 while J
<= Res_Last
- 5 loop
5880 if Res
(J
.. J
+ 5) = "pragma" then
5881 Res
(J
.. J
+ 5) := "aspect";
5889 -- Change "argument of" at start of message to "entity for"
5892 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5894 Res
(Res
'First .. Res
'First + 9) := "entity for";
5895 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5896 Res
(Res
'First + 11 .. Res_Last
);
5897 Res_Last
:= Res_Last
- 1;
5900 -- Change "argument" at start of message to "entity"
5903 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5905 Res
(Res
'First .. Res
'First + 5) := "entity";
5906 Res
(Res
'First + 6 .. Res_Last
- 2) :=
5907 Res
(Res
'First + 8 .. Res_Last
);
5908 Res_Last
:= Res_Last
- 2;
5911 -- Get name from corresponding aspect
5913 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
5916 -- Return possibly modified message
5918 return Res
(Res
'First .. Res_Last
);
5921 -------------------------
5922 -- Gather_Associations --
5923 -------------------------
5925 procedure Gather_Associations
5927 Args
: out Args_List
)
5932 -- Initialize all parameters to Empty
5934 for J
in Args
'Range loop
5938 -- That's all we have to do if there are no argument associations
5940 if No
(Pragma_Argument_Associations
(N
)) then
5944 -- Otherwise first deal with any positional parameters present
5946 Arg
:= First
(Pragma_Argument_Associations
(N
));
5947 for Index
in Args
'Range loop
5948 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
5949 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5953 -- Positional parameters all processed, if any left, then we
5954 -- have too many positional parameters.
5956 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
5958 ("too many positional associations for pragma%", Arg
);
5961 -- Process named parameters if any are present
5963 while Present
(Arg
) loop
5964 if Chars
(Arg
) = No_Name
then
5966 ("positional association cannot follow named association",
5970 for Index
in Names
'Range loop
5971 if Names
(Index
) = Chars
(Arg
) then
5972 if Present
(Args
(Index
)) then
5974 ("duplicate argument association for pragma%", Arg
);
5976 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5981 if Index
= Names
'Last then
5982 Error_Msg_Name_1
:= Pname
;
5983 Error_Msg_N
("pragma% does not allow & argument", Arg
);
5985 -- Check for possible misspelling
5987 for Index1
in Names
'Range loop
5988 if Is_Bad_Spelling_Of
5989 (Chars
(Arg
), Names
(Index1
))
5991 Error_Msg_Name_1
:= Names
(Index1
);
5992 Error_Msg_N
-- CODEFIX
5993 ("\possible misspelling of%", Arg
);
6005 end Gather_Associations
;
6011 procedure GNAT_Pragma
is
6013 -- We need to check the No_Implementation_Pragmas restriction for
6014 -- the case of a pragma from source. Note that the case of aspects
6015 -- generating corresponding pragmas marks these pragmas as not being
6016 -- from source, so this test also catches that case.
6018 if Comes_From_Source
(N
) then
6019 Check_Restriction
(No_Implementation_Pragmas
, N
);
6023 --------------------------
6024 -- Is_Before_First_Decl --
6025 --------------------------
6027 function Is_Before_First_Decl
6028 (Pragma_Node
: Node_Id
;
6029 Decls
: List_Id
) return Boolean
6031 Item
: Node_Id
:= First
(Decls
);
6034 -- Only other pragmas can come before this pragma
6037 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6040 elsif Item
= Pragma_Node
then
6046 end Is_Before_First_Decl
;
6048 -----------------------------
6049 -- Is_Configuration_Pragma --
6050 -----------------------------
6052 -- A configuration pragma must appear in the context clause of a
6053 -- compilation unit, and only other pragmas may precede it. Note that
6054 -- the test below also permits use in a configuration pragma file.
6056 function Is_Configuration_Pragma
return Boolean is
6057 Lis
: constant List_Id
:= List_Containing
(N
);
6058 Par
: constant Node_Id
:= Parent
(N
);
6062 -- If no parent, then we are in the configuration pragma file,
6063 -- so the placement is definitely appropriate.
6068 -- Otherwise we must be in the context clause of a compilation unit
6069 -- and the only thing allowed before us in the context list is more
6070 -- configuration pragmas.
6072 elsif Nkind
(Par
) = N_Compilation_Unit
6073 and then Context_Items
(Par
) = Lis
6080 elsif Nkind
(Prg
) /= N_Pragma
then
6090 end Is_Configuration_Pragma
;
6092 --------------------------
6093 -- Is_In_Context_Clause --
6094 --------------------------
6096 function Is_In_Context_Clause
return Boolean is
6098 Parent_Node
: Node_Id
;
6101 if not Is_List_Member
(N
) then
6105 Plist
:= List_Containing
(N
);
6106 Parent_Node
:= Parent
(Plist
);
6108 if Parent_Node
= Empty
6109 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6110 or else Context_Items
(Parent_Node
) /= Plist
6117 end Is_In_Context_Clause
;
6119 ---------------------------------
6120 -- Is_Static_String_Expression --
6121 ---------------------------------
6123 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6124 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6125 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6128 Analyze_And_Resolve
(Argx
);
6130 -- Special case Ada 83, where the expression will never be static,
6131 -- but we will return true if we had a string literal to start with.
6133 if Ada_Version
= Ada_83
then
6136 -- Normal case, true only if we end up with a string literal that
6137 -- is marked as being the result of evaluating a static expression.
6140 return Is_OK_Static_Expression
(Argx
)
6141 and then Nkind
(Argx
) = N_String_Literal
;
6144 end Is_Static_String_Expression
;
6146 ----------------------
6147 -- Pragma_Misplaced --
6148 ----------------------
6150 procedure Pragma_Misplaced
is
6152 Error_Pragma
("incorrect placement of pragma%");
6153 end Pragma_Misplaced
;
6155 ------------------------------------
6156 -- Process_Atomic_Shared_Volatile --
6157 ------------------------------------
6159 procedure Process_Atomic_Shared_Volatile
is
6166 procedure Set_Atomic
(E
: Entity_Id
);
6167 -- Set given type as atomic, and if no explicit alignment was given,
6168 -- set alignment to unknown, since back end knows what the alignment
6169 -- requirements are for atomic arrays. Note: this step is necessary
6170 -- for derived types.
6176 procedure Set_Atomic
(E
: Entity_Id
) is
6180 if not Has_Alignment_Clause
(E
) then
6181 Set_Alignment
(E
, Uint_0
);
6185 -- Start of processing for Process_Atomic_Shared_Volatile
6188 Check_Ada_83_Warning
;
6189 Check_No_Identifiers
;
6190 Check_Arg_Count
(1);
6191 Check_Arg_Is_Local_Name
(Arg1
);
6192 E_Id
:= Get_Pragma_Arg
(Arg1
);
6194 if Etype
(E_Id
) = Any_Type
then
6199 D
:= Declaration_Node
(E
);
6202 -- Check duplicate before we chain ourselves
6204 Check_Duplicate_Pragma
(E
);
6206 -- Now check appropriateness of the entity
6209 if Rep_Item_Too_Early
(E
, N
)
6211 Rep_Item_Too_Late
(E
, N
)
6215 Check_First_Subtype
(Arg1
);
6218 if Prag_Id
/= Pragma_Volatile
then
6220 Set_Atomic
(Underlying_Type
(E
));
6221 Set_Atomic
(Base_Type
(E
));
6224 -- Attribute belongs on the base type. If the view of the type is
6225 -- currently private, it also belongs on the underlying type.
6227 Set_Is_Volatile
(Base_Type
(E
));
6228 Set_Is_Volatile
(Underlying_Type
(E
));
6230 Set_Treat_As_Volatile
(E
);
6231 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6233 elsif K
= N_Object_Declaration
6234 or else (K
= N_Component_Declaration
6235 and then Original_Record_Component
(E
) = E
)
6237 if Rep_Item_Too_Late
(E
, N
) then
6241 if Prag_Id
/= Pragma_Volatile
then
6244 -- If the object declaration has an explicit initialization, a
6245 -- temporary may have to be created to hold the expression, to
6246 -- ensure that access to the object remain atomic.
6248 if Nkind
(Parent
(E
)) = N_Object_Declaration
6249 and then Present
(Expression
(Parent
(E
)))
6251 Set_Has_Delayed_Freeze
(E
);
6254 -- An interesting improvement here. If an object of composite
6255 -- type X is declared atomic, and the type X isn't, that's a
6256 -- pity, since it may not have appropriate alignment etc. We
6257 -- can rescue this in the special case where the object and
6258 -- type are in the same unit by just setting the type as
6259 -- atomic, so that the back end will process it as atomic.
6261 -- Note: we used to do this for elementary types as well,
6262 -- but that turns out to be a bad idea and can have unwanted
6263 -- effects, most notably if the type is elementary, the object
6264 -- a simple component within a record, and both are in a spec:
6265 -- every object of this type in the entire program will be
6266 -- treated as atomic, thus incurring a potentially costly
6267 -- synchronization operation for every access.
6269 -- Of course it would be best if the back end could just adjust
6270 -- the alignment etc for the specific object, but that's not
6271 -- something we are capable of doing at this point.
6273 Utyp
:= Underlying_Type
(Etype
(E
));
6276 and then Is_Composite_Type
(Utyp
)
6277 and then Sloc
(E
) > No_Location
6278 and then Sloc
(Utyp
) > No_Location
6280 Get_Source_File_Index
(Sloc
(E
)) =
6281 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6283 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6287 Set_Is_Volatile
(E
);
6288 Set_Treat_As_Volatile
(E
);
6291 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6294 -- The following check is only relevant when SPARK_Mode is on as
6295 -- this is not a standard Ada legality rule. Pragma Volatile can
6296 -- only apply to a full type declaration or an object declaration
6297 -- (SPARK RM C.6(1)).
6300 and then Prag_Id
= Pragma_Volatile
6301 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6302 N_Object_Declaration
)
6305 ("argument of pragma % must denote a full type or object "
6306 & "declaration", Arg1
);
6308 end Process_Atomic_Shared_Volatile
;
6310 -------------------------------------------
6311 -- Process_Compile_Time_Warning_Or_Error --
6312 -------------------------------------------
6314 procedure Process_Compile_Time_Warning_Or_Error
is
6315 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6318 Check_Arg_Count
(2);
6319 Check_No_Identifiers
;
6320 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6321 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6323 if Compile_Time_Known_Value
(Arg1x
) then
6324 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6326 Str
: constant String_Id
:=
6327 Strval
(Get_Pragma_Arg
(Arg2
));
6328 Len
: constant Int
:= String_Length
(Str
);
6333 Cent
: constant Entity_Id
:=
6334 Cunit_Entity
(Current_Sem_Unit
);
6336 Force
: constant Boolean :=
6337 Prag_Id
= Pragma_Compile_Time_Warning
6339 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6340 and then (Ekind
(Cent
) /= E_Package
6341 or else not In_Private_Part
(Cent
));
6342 -- Set True if this is the warning case, and we are in the
6343 -- visible part of a package spec, or in a subprogram spec,
6344 -- in which case we want to force the client to see the
6345 -- warning, even though it is not in the main unit.
6348 -- Loop through segments of message separated by line feeds.
6349 -- We output these segments as separate messages with
6350 -- continuation marks for all but the first.
6355 Error_Msg_Strlen
:= 0;
6357 -- Loop to copy characters from argument to error message
6361 exit when Ptr
> Len
;
6362 CC
:= Get_String_Char
(Str
, Ptr
);
6365 -- Ignore wide chars ??? else store character
6367 if In_Character_Range
(CC
) then
6368 C
:= Get_Character
(CC
);
6369 exit when C
= ASCII
.LF
;
6370 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6371 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6375 -- Here with one line ready to go
6377 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6379 -- If this is a warning in a spec, then we want clients
6380 -- to see the warning, so mark the message with the
6381 -- special sequence !! to force the warning. In the case
6382 -- of a package spec, we do not force this if we are in
6383 -- the private part of the spec.
6386 if Cont
= False then
6387 Error_Msg_N
("<<~!!", Arg1
);
6390 Error_Msg_N
("\<<~!!", Arg1
);
6393 -- Error, rather than warning, or in a body, so we do not
6394 -- need to force visibility for client (error will be
6395 -- output in any case, and this is the situation in which
6396 -- we do not want a client to get a warning, since the
6397 -- warning is in the body or the spec private part).
6400 if Cont
= False then
6401 Error_Msg_N
("<<~", Arg1
);
6404 Error_Msg_N
("\<<~", Arg1
);
6408 exit when Ptr
> Len
;
6413 end Process_Compile_Time_Warning_Or_Error
;
6415 ------------------------
6416 -- Process_Convention --
6417 ------------------------
6419 procedure Process_Convention
6420 (C
: out Convention_Id
;
6421 Ent
: out Entity_Id
)
6425 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6426 -- Called if we have more than one Export/Import/Convention pragma.
6427 -- This is generally illegal, but we have a special case of allowing
6428 -- Import and Interface to coexist if they specify the convention in
6429 -- a consistent manner. We are allowed to do this, since Interface is
6430 -- an implementation defined pragma, and we choose to do it since we
6431 -- know Rational allows this combination. S is the entity id of the
6432 -- subprogram in question. This procedure also sets the special flag
6433 -- Import_Interface_Present in both pragmas in the case where we do
6434 -- have matching Import and Interface pragmas.
6436 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6437 -- Set convention in entity E, and also flag that the entity has a
6438 -- convention pragma. If entity is for a private or incomplete type,
6439 -- also set convention and flag on underlying type. This procedure
6440 -- also deals with the special case of C_Pass_By_Copy convention,
6441 -- and error checks for inappropriate convention specification.
6443 -------------------------------
6444 -- Diagnose_Multiple_Pragmas --
6445 -------------------------------
6447 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6448 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6452 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6453 -- Decl is a pragma node. This function returns True if this
6454 -- pragma has a first argument that is an identifier with a
6455 -- Chars field corresponding to the Convention_Id C.
6457 function Same_Name
(Decl
: Node_Id
) return Boolean;
6458 -- Decl is a pragma node. This function returns True if this
6459 -- pragma has a second argument that is an identifier with a
6460 -- Chars field that matches the Chars of the current subprogram.
6462 ---------------------
6463 -- Same_Convention --
6464 ---------------------
6466 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6467 Arg1
: constant Node_Id
:=
6468 First
(Pragma_Argument_Associations
(Decl
));
6471 if Present
(Arg1
) then
6473 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6475 if Nkind
(Arg
) = N_Identifier
6476 and then Is_Convention_Name
(Chars
(Arg
))
6477 and then Get_Convention_Id
(Chars
(Arg
)) = C
6485 end Same_Convention
;
6491 function Same_Name
(Decl
: Node_Id
) return Boolean is
6492 Arg1
: constant Node_Id
:=
6493 First
(Pragma_Argument_Associations
(Decl
));
6501 Arg2
:= Next
(Arg1
);
6508 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6510 if Nkind
(Arg
) = N_Identifier
6511 and then Chars
(Arg
) = Chars
(S
)
6520 -- Start of processing for Diagnose_Multiple_Pragmas
6525 -- Definitely give message if we have Convention/Export here
6527 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6530 -- If we have an Import or Export, scan back from pragma to
6531 -- find any previous pragma applying to the same procedure.
6532 -- The scan will be terminated by the start of the list, or
6533 -- hitting the subprogram declaration. This won't allow one
6534 -- pragma to appear in the public part and one in the private
6535 -- part, but that seems very unlikely in practice.
6539 while Present
(Decl
) and then Decl
/= Pdec
loop
6541 -- Look for pragma with same name as us
6543 if Nkind
(Decl
) = N_Pragma
6544 and then Same_Name
(Decl
)
6546 -- Give error if same as our pragma or Export/Convention
6548 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6554 -- Case of Import/Interface or the other way round
6556 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6559 -- Here we know that we have Import and Interface. It
6560 -- doesn't matter which way round they are. See if
6561 -- they specify the same convention. If so, all OK,
6562 -- and set special flags to stop other messages
6564 if Same_Convention
(Decl
) then
6565 Set_Import_Interface_Present
(N
);
6566 Set_Import_Interface_Present
(Decl
);
6569 -- If different conventions, special message
6572 Error_Msg_Sloc
:= Sloc
(Decl
);
6574 ("convention differs from that given#", Arg1
);
6584 -- Give message if needed if we fall through those tests
6585 -- except on Relaxed_RM_Semantics where we let go: either this
6586 -- is a case accepted/ignored by other Ada compilers (e.g.
6587 -- a mix of Convention and Import), or another error will be
6588 -- generated later (e.g. using both Import and Export).
6590 if Err
and not Relaxed_RM_Semantics
then
6592 ("at most one Convention/Export/Import pragma is allowed",
6595 end Diagnose_Multiple_Pragmas
;
6597 --------------------------------
6598 -- Set_Convention_From_Pragma --
6599 --------------------------------
6601 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6603 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6604 -- for an overridden dispatching operation. Technically this is
6605 -- an amendment and should only be done in Ada 2005 mode. However,
6606 -- this is clearly a mistake, since the problem that is addressed
6607 -- by this AI is that there is a clear gap in the RM.
6609 if Is_Dispatching_Operation
(E
)
6610 and then Present
(Overridden_Operation
(E
))
6611 and then C
/= Convention
(Overridden_Operation
(E
))
6614 ("cannot change convention for overridden dispatching "
6615 & "operation", Arg1
);
6618 -- Special checks for Convention_Stdcall
6620 if C
= Convention_Stdcall
then
6622 -- A dispatching call is not allowed. A dispatching subprogram
6623 -- cannot be used to interface to the Win32 API, so in fact
6624 -- this check does not impose any effective restriction.
6626 if Is_Dispatching_Operation
(E
) then
6627 Error_Msg_Sloc
:= Sloc
(E
);
6629 -- Note: make this unconditional so that if there is more
6630 -- than one call to which the pragma applies, we get a
6631 -- message for each call. Also don't use Error_Pragma,
6632 -- so that we get multiple messages.
6635 ("dispatching subprogram# cannot use Stdcall convention!",
6638 -- Subprograms are not allowed
6640 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6644 and then Ekind
(E
) /= E_Variable
6646 -- An access to subprogram is also allowed
6650 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6652 -- Allow internal call to set convention of subprogram type
6654 and then not (Ekind
(E
) = E_Subprogram_Type
)
6657 ("second argument of pragma% must be subprogram (type)",
6662 -- Set the convention
6664 Set_Convention
(E
, C
);
6665 Set_Has_Convention_Pragma
(E
);
6667 -- For the case of a record base type, also set the convention of
6668 -- any anonymous access types declared in the record which do not
6669 -- currently have a specified convention.
6671 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6676 Comp
:= First_Component
(E
);
6677 while Present
(Comp
) loop
6678 if Present
(Etype
(Comp
))
6679 and then Ekind_In
(Etype
(Comp
),
6680 E_Anonymous_Access_Type
,
6681 E_Anonymous_Access_Subprogram_Type
)
6682 and then not Has_Convention_Pragma
(Comp
)
6684 Set_Convention
(Comp
, C
);
6687 Next_Component
(Comp
);
6692 -- Deal with incomplete/private type case, where underlying type
6693 -- is available, so set convention of that underlying type.
6695 if Is_Incomplete_Or_Private_Type
(E
)
6696 and then Present
(Underlying_Type
(E
))
6698 Set_Convention
(Underlying_Type
(E
), C
);
6699 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6702 -- A class-wide type should inherit the convention of the specific
6703 -- root type (although this isn't specified clearly by the RM).
6705 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6706 Set_Convention
(Class_Wide_Type
(E
), C
);
6709 -- If the entity is a record type, then check for special case of
6710 -- C_Pass_By_Copy, which is treated the same as C except that the
6711 -- special record flag is set. This convention is only permitted
6712 -- on record types (see AI95-00131).
6714 if Cname
= Name_C_Pass_By_Copy
then
6715 if Is_Record_Type
(E
) then
6716 Set_C_Pass_By_Copy
(Base_Type
(E
));
6717 elsif Is_Incomplete_Or_Private_Type
(E
)
6718 and then Is_Record_Type
(Underlying_Type
(E
))
6720 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6723 ("C_Pass_By_Copy convention allowed only for record type",
6728 -- If the entity is a derived boolean type, check for the special
6729 -- case of convention C, C++, or Fortran, where we consider any
6730 -- nonzero value to represent true.
6732 if Is_Discrete_Type
(E
)
6733 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6739 C
= Convention_Fortran
)
6741 Set_Nonzero_Is_True
(Base_Type
(E
));
6743 end Set_Convention_From_Pragma
;
6747 Comp_Unit
: Unit_Number_Type
;
6752 -- Start of processing for Process_Convention
6755 Check_At_Least_N_Arguments
(2);
6756 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6757 Check_Arg_Is_Identifier
(Arg1
);
6758 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6760 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6761 -- tested again below to set the critical flag).
6763 if Cname
= Name_C_Pass_By_Copy
then
6766 -- Otherwise we must have something in the standard convention list
6768 elsif Is_Convention_Name
(Cname
) then
6769 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6771 -- Otherwise warn on unrecognized convention
6774 if Warn_On_Export_Import
then
6776 ("??unrecognized convention name, C assumed",
6777 Get_Pragma_Arg
(Arg1
));
6783 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6784 Check_Arg_Is_Local_Name
(Arg2
);
6786 Id
:= Get_Pragma_Arg
(Arg2
);
6789 if not Is_Entity_Name
(Id
) then
6790 Error_Pragma_Arg
("entity name required", Arg2
);
6795 -- Set entity to return
6799 -- Ada_Pass_By_Copy special checking
6801 if C
= Convention_Ada_Pass_By_Copy
then
6802 if not Is_First_Subtype
(E
) then
6804 ("convention `Ada_Pass_By_Copy` only allowed for types",
6808 if Is_By_Reference_Type
(E
) then
6810 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6814 -- Ada_Pass_By_Reference special checking
6816 elsif C
= Convention_Ada_Pass_By_Reference
then
6817 if not Is_First_Subtype
(E
) then
6819 ("convention `Ada_Pass_By_Reference` only allowed for types",
6823 if Is_By_Copy_Type
(E
) then
6825 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6830 -- Go to renamed subprogram if present, since convention applies to
6831 -- the actual renamed entity, not to the renaming entity. If the
6832 -- subprogram is inherited, go to parent subprogram.
6834 if Is_Subprogram
(E
)
6835 and then Present
(Alias
(E
))
6837 if Nkind
(Parent
(Declaration_Node
(E
))) =
6838 N_Subprogram_Renaming_Declaration
6840 if Scope
(E
) /= Scope
(Alias
(E
)) then
6842 ("cannot apply pragma% to non-local entity&#", E
);
6847 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6848 N_Private_Extension_Declaration
)
6849 and then Scope
(E
) = Scope
(Alias
(E
))
6853 -- Return the parent subprogram the entity was inherited from
6859 -- Check that we are not applying this to a specless body. Relax this
6860 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6862 if Is_Subprogram
(E
)
6863 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6864 and then not Relaxed_RM_Semantics
6867 ("pragma% requires separate spec and must come before body");
6870 -- Check that we are not applying this to a named constant
6872 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6873 Error_Msg_Name_1
:= Pname
;
6875 ("cannot apply pragma% to named constant!",
6876 Get_Pragma_Arg
(Arg2
));
6878 ("\supply appropriate type for&!", Arg2
);
6881 if Ekind
(E
) = E_Enumeration_Literal
then
6882 Error_Pragma
("enumeration literal not allowed for pragma%");
6885 -- Check for rep item appearing too early or too late
6887 if Etype
(E
) = Any_Type
6888 or else Rep_Item_Too_Early
(E
, N
)
6892 elsif Present
(Underlying_Type
(E
)) then
6893 E
:= Underlying_Type
(E
);
6896 if Rep_Item_Too_Late
(E
, N
) then
6900 if Has_Convention_Pragma
(E
) then
6901 Diagnose_Multiple_Pragmas
(E
);
6903 elsif Convention
(E
) = Convention_Protected
6904 or else Ekind
(Scope
(E
)) = E_Protected_Type
6907 ("a protected operation cannot be given a different convention",
6911 -- For Intrinsic, a subprogram is required
6913 if C
= Convention_Intrinsic
6914 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
6917 ("second argument of pragma% must be a subprogram", Arg2
);
6920 -- Deal with non-subprogram cases
6922 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
6923 Set_Convention_From_Pragma
(E
);
6926 Check_First_Subtype
(Arg2
);
6927 Set_Convention_From_Pragma
(Base_Type
(E
));
6929 -- For access subprograms, we must set the convention on the
6930 -- internally generated directly designated type as well.
6932 if Ekind
(E
) = E_Access_Subprogram_Type
then
6933 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
6937 -- For the subprogram case, set proper convention for all homonyms
6938 -- in same scope and the same declarative part, i.e. the same
6939 -- compilation unit.
6942 Comp_Unit
:= Get_Source_Unit
(E
);
6943 Set_Convention_From_Pragma
(E
);
6945 -- Treat a pragma Import as an implicit body, and pragma import
6946 -- as implicit reference (for navigation in GPS).
6948 if Prag_Id
= Pragma_Import
then
6949 Generate_Reference
(E
, Id
, 'b');
6951 -- For exported entities we restrict the generation of references
6952 -- to entities exported to foreign languages since entities
6953 -- exported to Ada do not provide further information to GPS and
6954 -- add undesired references to the output of the gnatxref tool.
6956 elsif Prag_Id
= Pragma_Export
6957 and then Convention
(E
) /= Convention_Ada
6959 Generate_Reference
(E
, Id
, 'i');
6962 -- If the pragma comes from from an aspect, it only applies to the
6963 -- given entity, not its homonyms.
6965 if From_Aspect_Specification
(N
) then
6969 -- Otherwise Loop through the homonyms of the pragma argument's
6970 -- entity, an apply convention to those in the current scope.
6976 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
6978 -- Ignore entry for which convention is already set
6980 if Has_Convention_Pragma
(E1
) then
6984 -- Do not set the pragma on inherited operations or on formal
6987 if Comes_From_Source
(E1
)
6988 and then Comp_Unit
= Get_Source_Unit
(E1
)
6989 and then not Is_Formal_Subprogram
(E1
)
6990 and then Nkind
(Original_Node
(Parent
(E1
))) /=
6991 N_Full_Type_Declaration
6993 if Present
(Alias
(E1
))
6994 and then Scope
(E1
) /= Scope
(Alias
(E1
))
6997 ("cannot apply pragma% to non-local entity& declared#",
7001 Set_Convention_From_Pragma
(E1
);
7003 if Prag_Id
= Pragma_Import
then
7004 Generate_Reference
(E1
, Id
, 'b');
7012 end Process_Convention
;
7014 ----------------------------------------
7015 -- Process_Disable_Enable_Atomic_Sync --
7016 ----------------------------------------
7018 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7020 Check_No_Identifiers
;
7021 Check_At_Most_N_Arguments
(1);
7023 -- Modeled internally as
7024 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7028 Pragma_Identifier
=>
7029 Make_Identifier
(Loc
, Nam
),
7030 Pragma_Argument_Associations
=> New_List
(
7031 Make_Pragma_Argument_Association
(Loc
,
7033 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7035 if Present
(Arg1
) then
7036 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7040 end Process_Disable_Enable_Atomic_Sync
;
7042 -------------------------------------------------
7043 -- Process_Extended_Import_Export_Internal_Arg --
7044 -------------------------------------------------
7046 procedure Process_Extended_Import_Export_Internal_Arg
7047 (Arg_Internal
: Node_Id
:= Empty
)
7050 if No
(Arg_Internal
) then
7051 Error_Pragma
("Internal parameter required for pragma%");
7054 if Nkind
(Arg_Internal
) = N_Identifier
then
7057 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7058 and then (Prag_Id
= Pragma_Import_Function
7060 Prag_Id
= Pragma_Export_Function
)
7066 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7069 Check_Arg_Is_Local_Name
(Arg_Internal
);
7070 end Process_Extended_Import_Export_Internal_Arg
;
7072 --------------------------------------------------
7073 -- Process_Extended_Import_Export_Object_Pragma --
7074 --------------------------------------------------
7076 procedure Process_Extended_Import_Export_Object_Pragma
7077 (Arg_Internal
: Node_Id
;
7078 Arg_External
: Node_Id
;
7084 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7085 Def_Id
:= Entity
(Arg_Internal
);
7087 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7089 ("pragma% must designate an object", Arg_Internal
);
7092 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7094 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7097 ("previous Common/Psect_Object applies, pragma % not permitted",
7101 if Rep_Item_Too_Late
(Def_Id
, N
) then
7105 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7107 if Present
(Arg_Size
) then
7108 Check_Arg_Is_External_Name
(Arg_Size
);
7111 -- Export_Object case
7113 if Prag_Id
= Pragma_Export_Object
then
7114 if not Is_Library_Level_Entity
(Def_Id
) then
7116 ("argument for pragma% must be library level entity",
7120 if Ekind
(Current_Scope
) = E_Generic_Package
then
7121 Error_Pragma
("pragma& cannot appear in a generic unit");
7124 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7126 ("exported object must have compile time known size",
7130 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7131 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7133 Set_Exported
(Def_Id
, Arg_Internal
);
7136 -- Import_Object case
7139 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7141 ("cannot use pragma% for task/protected object",
7145 if Ekind
(Def_Id
) = E_Constant
then
7147 ("cannot import a constant", Arg_Internal
);
7150 if Warn_On_Export_Import
7151 and then Has_Discriminants
(Etype
(Def_Id
))
7154 ("imported value must be initialized??", Arg_Internal
);
7157 if Warn_On_Export_Import
7158 and then Is_Access_Type
(Etype
(Def_Id
))
7161 ("cannot import object of an access type??", Arg_Internal
);
7164 if Warn_On_Export_Import
7165 and then Is_Imported
(Def_Id
)
7167 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7169 -- Check for explicit initialization present. Note that an
7170 -- initialization generated by the code generator, e.g. for an
7171 -- access type, does not count here.
7173 elsif Present
(Expression
(Parent
(Def_Id
)))
7176 (Original_Node
(Expression
(Parent
(Def_Id
))))
7178 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7180 ("imported entities cannot be initialized (RM B.1(24))",
7181 "\no initialization allowed for & declared#", Arg1
);
7183 Set_Imported
(Def_Id
);
7184 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7187 end Process_Extended_Import_Export_Object_Pragma
;
7189 ------------------------------------------------------
7190 -- Process_Extended_Import_Export_Subprogram_Pragma --
7191 ------------------------------------------------------
7193 procedure Process_Extended_Import_Export_Subprogram_Pragma
7194 (Arg_Internal
: Node_Id
;
7195 Arg_External
: Node_Id
;
7196 Arg_Parameter_Types
: Node_Id
;
7197 Arg_Result_Type
: Node_Id
:= Empty
;
7198 Arg_Mechanism
: Node_Id
;
7199 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7205 Ambiguous
: Boolean;
7208 function Same_Base_Type
7210 Formal
: Entity_Id
) return Boolean;
7211 -- Determines if Ptype references the type of Formal. Note that only
7212 -- the base types need to match according to the spec. Ptype here is
7213 -- the argument from the pragma, which is either a type name, or an
7214 -- access attribute.
7216 --------------------
7217 -- Same_Base_Type --
7218 --------------------
7220 function Same_Base_Type
7222 Formal
: Entity_Id
) return Boolean
7224 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7228 -- Case where pragma argument is typ'Access
7230 if Nkind
(Ptype
) = N_Attribute_Reference
7231 and then Attribute_Name
(Ptype
) = Name_Access
7233 Pref
:= Prefix
(Ptype
);
7236 if not Is_Entity_Name
(Pref
)
7237 or else Entity
(Pref
) = Any_Type
7242 -- We have a match if the corresponding argument is of an
7243 -- anonymous access type, and its designated type matches the
7244 -- type of the prefix of the access attribute
7246 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7247 and then Base_Type
(Entity
(Pref
)) =
7248 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7250 -- Case where pragma argument is a type name
7255 if not Is_Entity_Name
(Ptype
)
7256 or else Entity
(Ptype
) = Any_Type
7261 -- We have a match if the corresponding argument is of the type
7262 -- given in the pragma (comparing base types)
7264 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7268 -- Start of processing for
7269 -- Process_Extended_Import_Export_Subprogram_Pragma
7272 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7276 -- Loop through homonyms (overloadings) of the entity
7278 Hom_Id
:= Entity
(Arg_Internal
);
7279 while Present
(Hom_Id
) loop
7280 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7282 -- We need a subprogram in the current scope
7284 if not Is_Subprogram
(Def_Id
)
7285 or else Scope
(Def_Id
) /= Current_Scope
7292 -- Pragma cannot apply to subprogram body
7294 if Is_Subprogram
(Def_Id
)
7295 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7299 ("pragma% requires separate spec"
7300 & " and must come before body");
7303 -- Test result type if given, note that the result type
7304 -- parameter can only be present for the function cases.
7306 if Present
(Arg_Result_Type
)
7307 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7311 elsif Etype
(Def_Id
) /= Standard_Void_Type
7313 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7317 -- Test parameter types if given. Note that this parameter
7318 -- has not been analyzed (and must not be, since it is
7319 -- semantic nonsense), so we get it as the parser left it.
7321 elsif Present
(Arg_Parameter_Types
) then
7322 Check_Matching_Types
: declare
7327 Formal
:= First_Formal
(Def_Id
);
7329 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7330 if Present
(Formal
) then
7334 -- A list of one type, e.g. (List) is parsed as
7335 -- a parenthesized expression.
7337 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7338 and then Paren_Count
(Arg_Parameter_Types
) = 1
7341 or else Present
(Next_Formal
(Formal
))
7346 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7349 -- A list of more than one type is parsed as a aggregate
7351 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7352 and then Paren_Count
(Arg_Parameter_Types
) = 0
7354 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7355 while Present
(Ptype
) or else Present
(Formal
) loop
7358 or else not Same_Base_Type
(Ptype
, Formal
)
7363 Next_Formal
(Formal
);
7368 -- Anything else is of the wrong form
7372 ("wrong form for Parameter_Types parameter",
7373 Arg_Parameter_Types
);
7375 end Check_Matching_Types
;
7378 -- Match is now False if the entry we found did not match
7379 -- either a supplied Parameter_Types or Result_Types argument
7385 -- Ambiguous case, the flag Ambiguous shows if we already
7386 -- detected this and output the initial messages.
7389 if not Ambiguous
then
7391 Error_Msg_Name_1
:= Pname
;
7393 ("pragma% does not uniquely identify subprogram!",
7395 Error_Msg_Sloc
:= Sloc
(Ent
);
7396 Error_Msg_N
("matching subprogram #!", N
);
7400 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7401 Error_Msg_N
("matching subprogram #!", N
);
7406 Hom_Id
:= Homonym
(Hom_Id
);
7409 -- See if we found an entry
7412 if not Ambiguous
then
7413 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7415 ("pragma% cannot be given for generic subprogram");
7418 ("pragma% does not identify local subprogram");
7425 -- Import pragmas must be for imported entities
7427 if Prag_Id
= Pragma_Import_Function
7429 Prag_Id
= Pragma_Import_Procedure
7431 Prag_Id
= Pragma_Import_Valued_Procedure
7433 if not Is_Imported
(Ent
) then
7435 ("pragma Import or Interface must precede pragma%");
7438 -- Here we have the Export case which can set the entity as exported
7440 -- But does not do so if the specified external name is null, since
7441 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7442 -- compatible) to request no external name.
7444 elsif Nkind
(Arg_External
) = N_String_Literal
7445 and then String_Length
(Strval
(Arg_External
)) = 0
7449 -- In all other cases, set entity as exported
7452 Set_Exported
(Ent
, Arg_Internal
);
7455 -- Special processing for Valued_Procedure cases
7457 if Prag_Id
= Pragma_Import_Valued_Procedure
7459 Prag_Id
= Pragma_Export_Valued_Procedure
7461 Formal
:= First_Formal
(Ent
);
7464 Error_Pragma
("at least one parameter required for pragma%");
7466 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7467 Error_Pragma
("first parameter must have mode out for pragma%");
7470 Set_Is_Valued_Procedure
(Ent
);
7474 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7476 -- Process Result_Mechanism argument if present. We have already
7477 -- checked that this is only allowed for the function case.
7479 if Present
(Arg_Result_Mechanism
) then
7480 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7483 -- Process Mechanism parameter if present. Note that this parameter
7484 -- is not analyzed, and must not be analyzed since it is semantic
7485 -- nonsense, so we get it in exactly as the parser left it.
7487 if Present
(Arg_Mechanism
) then
7495 -- A single mechanism association without a formal parameter
7496 -- name is parsed as a parenthesized expression. All other
7497 -- cases are parsed as aggregates, so we rewrite the single
7498 -- parameter case as an aggregate for consistency.
7500 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7501 and then Paren_Count
(Arg_Mechanism
) = 1
7503 Rewrite
(Arg_Mechanism
,
7504 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7505 Expressions
=> New_List
(
7506 Relocate_Node
(Arg_Mechanism
))));
7509 -- Case of only mechanism name given, applies to all formals
7511 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7512 Formal
:= First_Formal
(Ent
);
7513 while Present
(Formal
) loop
7514 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7515 Next_Formal
(Formal
);
7518 -- Case of list of mechanism associations given
7521 if Null_Record_Present
(Arg_Mechanism
) then
7523 ("inappropriate form for Mechanism parameter",
7527 -- Deal with positional ones first
7529 Formal
:= First_Formal
(Ent
);
7531 if Present
(Expressions
(Arg_Mechanism
)) then
7532 Mname
:= First
(Expressions
(Arg_Mechanism
));
7533 while Present
(Mname
) loop
7536 ("too many mechanism associations", Mname
);
7539 Set_Mechanism_Value
(Formal
, Mname
);
7540 Next_Formal
(Formal
);
7545 -- Deal with named entries
7547 if Present
(Component_Associations
(Arg_Mechanism
)) then
7548 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7549 while Present
(Massoc
) loop
7550 Choice
:= First
(Choices
(Massoc
));
7552 if Nkind
(Choice
) /= N_Identifier
7553 or else Present
(Next
(Choice
))
7556 ("incorrect form for mechanism association",
7560 Formal
:= First_Formal
(Ent
);
7564 ("parameter name & not present", Choice
);
7567 if Chars
(Choice
) = Chars
(Formal
) then
7569 (Formal
, Expression
(Massoc
));
7571 -- Set entity on identifier (needed by ASIS)
7573 Set_Entity
(Choice
, Formal
);
7578 Next_Formal
(Formal
);
7587 end Process_Extended_Import_Export_Subprogram_Pragma
;
7589 --------------------------
7590 -- Process_Generic_List --
7591 --------------------------
7593 procedure Process_Generic_List
is
7598 Check_No_Identifiers
;
7599 Check_At_Least_N_Arguments
(1);
7601 -- Check all arguments are names of generic units or instances
7604 while Present
(Arg
) loop
7605 Exp
:= Get_Pragma_Arg
(Arg
);
7608 if not Is_Entity_Name
(Exp
)
7610 (not Is_Generic_Instance
(Entity
(Exp
))
7612 not Is_Generic_Unit
(Entity
(Exp
)))
7615 ("pragma% argument must be name of generic unit/instance",
7621 end Process_Generic_List
;
7623 ------------------------------------
7624 -- Process_Import_Predefined_Type --
7625 ------------------------------------
7627 procedure Process_Import_Predefined_Type
is
7628 Loc
: constant Source_Ptr
:= Sloc
(N
);
7630 Ftyp
: Node_Id
:= Empty
;
7636 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7639 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7640 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7644 Ftyp
:= Node
(Elmt
);
7646 if Present
(Ftyp
) then
7648 -- Don't build a derived type declaration, because predefined C
7649 -- types have no declaration anywhere, so cannot really be named.
7650 -- Instead build a full type declaration, starting with an
7651 -- appropriate type definition is built
7653 if Is_Floating_Point_Type
(Ftyp
) then
7654 Def
:= Make_Floating_Point_Definition
(Loc
,
7655 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7656 Make_Real_Range_Specification
(Loc
,
7657 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7658 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7660 -- Should never have a predefined type we cannot handle
7663 raise Program_Error
;
7666 -- Build and insert a Full_Type_Declaration, which will be
7667 -- analyzed as soon as this list entry has been analyzed.
7669 Decl
:= Make_Full_Type_Declaration
(Loc
,
7670 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7671 Type_Definition
=> Def
);
7673 Insert_After
(N
, Decl
);
7674 Mark_Rewrite_Insertion
(Decl
);
7677 Error_Pragma_Arg
("no matching type found for pragma%",
7680 end Process_Import_Predefined_Type
;
7682 ---------------------------------
7683 -- Process_Import_Or_Interface --
7684 ---------------------------------
7686 procedure Process_Import_Or_Interface
is
7692 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7693 -- pragma Import (Entity, "external name");
7695 if Relaxed_RM_Semantics
7696 and then Arg_Count
= 2
7697 and then Prag_Id
= Pragma_Import
7698 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7701 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7704 if not Is_Entity_Name
(Def_Id
) then
7705 Error_Pragma_Arg
("entity name required", Arg1
);
7708 Def_Id
:= Entity
(Def_Id
);
7709 Kill_Size_Check_Code
(Def_Id
);
7710 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7713 Process_Convention
(C
, Def_Id
);
7714 Kill_Size_Check_Code
(Def_Id
);
7715 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7718 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7720 -- We do not permit Import to apply to a renaming declaration
7722 if Present
(Renamed_Object
(Def_Id
)) then
7724 ("pragma% not allowed for object renaming", Arg2
);
7726 -- User initialization is not allowed for imported object, but
7727 -- the object declaration may contain a default initialization,
7728 -- that will be discarded. Note that an explicit initialization
7729 -- only counts if it comes from source, otherwise it is simply
7730 -- the code generator making an implicit initialization explicit.
7732 elsif Present
(Expression
(Parent
(Def_Id
)))
7733 and then Comes_From_Source
7734 (Original_Node
(Expression
(Parent
(Def_Id
))))
7736 -- Set imported flag to prevent cascaded errors
7738 Set_Is_Imported
(Def_Id
);
7740 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7742 ("no initialization allowed for declaration of& #",
7743 "\imported entities cannot be initialized (RM B.1(24))",
7747 -- If the pragma comes from an aspect specification the
7748 -- Is_Imported flag has already been set.
7750 if not From_Aspect_Specification
(N
) then
7751 Set_Imported
(Def_Id
);
7754 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7756 -- Note that we do not set Is_Public here. That's because we
7757 -- only want to set it if there is no address clause, and we
7758 -- don't know that yet, so we delay that processing till
7761 -- pragma Import completes deferred constants
7763 if Ekind
(Def_Id
) = E_Constant
then
7764 Set_Has_Completion
(Def_Id
);
7767 -- It is not possible to import a constant of an unconstrained
7768 -- array type (e.g. string) because there is no simple way to
7769 -- write a meaningful subtype for it.
7771 if Is_Array_Type
(Etype
(Def_Id
))
7772 and then not Is_Constrained
(Etype
(Def_Id
))
7775 ("imported constant& must have a constrained subtype",
7780 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7782 -- If the name is overloaded, pragma applies to all of the denoted
7783 -- entities in the same declarative part, unless the pragma comes
7784 -- from an aspect specification or was generated by the compiler
7785 -- (such as for pragma Provide_Shift_Operators).
7788 while Present
(Hom_Id
) loop
7790 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7792 -- Ignore inherited subprograms because the pragma will apply
7793 -- to the parent operation, which is the one called.
7795 if Is_Overloadable
(Def_Id
)
7796 and then Present
(Alias
(Def_Id
))
7800 -- If it is not a subprogram, it must be in an outer scope and
7801 -- pragma does not apply.
7803 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7806 -- The pragma does not apply to primitives of interfaces
7808 elsif Is_Dispatching_Operation
(Def_Id
)
7809 and then Present
(Find_Dispatching_Type
(Def_Id
))
7810 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7814 -- Verify that the homonym is in the same declarative part (not
7815 -- just the same scope). If the pragma comes from an aspect
7816 -- specification we know that it is part of the declaration.
7818 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7819 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7820 and then not From_Aspect_Specification
(N
)
7825 -- If the pragma comes from an aspect specification the
7826 -- Is_Imported flag has already been set.
7828 if not From_Aspect_Specification
(N
) then
7829 Set_Imported
(Def_Id
);
7832 -- Reject an Import applied to an abstract subprogram
7834 if Is_Subprogram
(Def_Id
)
7835 and then Is_Abstract_Subprogram
(Def_Id
)
7837 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7839 ("cannot import abstract subprogram& declared#",
7843 -- Special processing for Convention_Intrinsic
7845 if C
= Convention_Intrinsic
then
7847 -- Link_Name argument not allowed for intrinsic
7851 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7853 -- If no external name is present, then check that this
7854 -- is a valid intrinsic subprogram. If an external name
7855 -- is present, then this is handled by the back end.
7858 Check_Intrinsic_Subprogram
7859 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7863 -- Verify that the subprogram does not have a completion
7864 -- through a renaming declaration. For other completions the
7865 -- pragma appears as a too late representation.
7868 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7872 and then Nkind
(Decl
) = N_Subprogram_Declaration
7873 and then Present
(Corresponding_Body
(Decl
))
7874 and then Nkind
(Unit_Declaration_Node
7875 (Corresponding_Body
(Decl
))) =
7876 N_Subprogram_Renaming_Declaration
7878 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7880 ("cannot import&, renaming already provided for "
7881 & "declaration #", N
, Def_Id
);
7885 -- If the pragma comes from an aspect specification, there
7886 -- must be an Import aspect specified as well. In the rare
7887 -- case where Import is set to False, the suprogram needs to
7888 -- have a local completion.
7891 Imp_Aspect
: constant Node_Id
:=
7892 Find_Aspect
(Def_Id
, Aspect_Import
);
7896 if Present
(Imp_Aspect
)
7897 and then Present
(Expression
(Imp_Aspect
))
7899 Expr
:= Expression
(Imp_Aspect
);
7900 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7902 if Is_Entity_Name
(Expr
)
7903 and then Entity
(Expr
) = Standard_True
7905 Set_Has_Completion
(Def_Id
);
7908 -- If there is no expression, the default is True, as for
7909 -- all boolean aspects. Same for the older pragma.
7912 Set_Has_Completion
(Def_Id
);
7916 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7919 if Is_Compilation_Unit
(Hom_Id
) then
7921 -- Its possible homonyms are not affected by the pragma.
7922 -- Such homonyms might be present in the context of other
7923 -- units being compiled.
7927 elsif From_Aspect_Specification
(N
) then
7930 -- If the pragma was created by the compiler, then we don't
7931 -- want it to apply to other homonyms. This kind of case can
7932 -- occur when using pragma Provide_Shift_Operators, which
7933 -- generates implicit shift and rotate operators with Import
7934 -- pragmas that might apply to earlier explicit or implicit
7935 -- declarations marked with Import (for example, coming from
7936 -- an earlier pragma Provide_Shift_Operators for another type),
7937 -- and we don't generally want other homonyms being treated
7938 -- as imported or the pragma flagged as an illegal duplicate.
7940 elsif not Comes_From_Source
(N
) then
7944 Hom_Id
:= Homonym
(Hom_Id
);
7948 -- When the convention is Java or CIL, we also allow Import to
7949 -- be given for packages, generic packages, exceptions, record
7950 -- components, and access to subprograms.
7952 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
7954 (Is_Package_Or_Generic_Package
(Def_Id
)
7955 or else Ekind
(Def_Id
) = E_Exception
7956 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
7957 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
7959 Set_Imported
(Def_Id
);
7960 Set_Is_Public
(Def_Id
);
7961 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7963 -- Import a CPP class
7965 elsif C
= Convention_CPP
7966 and then (Is_Record_Type
(Def_Id
)
7967 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
7969 if Ekind
(Def_Id
) = E_Incomplete_Type
then
7970 if Present
(Full_View
(Def_Id
)) then
7971 Def_Id
:= Full_View
(Def_Id
);
7975 ("cannot import 'C'P'P type before full declaration seen",
7976 Get_Pragma_Arg
(Arg2
));
7978 -- Although we have reported the error we decorate it as
7979 -- CPP_Class to avoid reporting spurious errors
7981 Set_Is_CPP_Class
(Def_Id
);
7986 -- Types treated as CPP classes must be declared limited (note:
7987 -- this used to be a warning but there is no real benefit to it
7988 -- since we did effectively intend to treat the type as limited
7991 if not Is_Limited_Type
(Def_Id
) then
7993 ("imported 'C'P'P type must be limited",
7994 Get_Pragma_Arg
(Arg2
));
7997 if Etype
(Def_Id
) /= Def_Id
7998 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8000 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8003 Set_Is_CPP_Class
(Def_Id
);
8005 -- Imported CPP types must not have discriminants (because C++
8006 -- classes do not have discriminants).
8008 if Has_Discriminants
(Def_Id
) then
8010 ("imported 'C'P'P type cannot have discriminants",
8011 First
(Discriminant_Specifications
8012 (Declaration_Node
(Def_Id
))));
8015 -- Check that components of imported CPP types do not have default
8016 -- expressions. For private types this check is performed when the
8017 -- full view is analyzed (see Process_Full_View).
8019 if not Is_Private_Type
(Def_Id
) then
8020 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8023 -- Import a CPP exception
8025 elsif C
= Convention_CPP
8026 and then Ekind
(Def_Id
) = E_Exception
8030 ("'External_'Name arguments is required for 'Cpp exception",
8033 -- As only a string is allowed, Check_Arg_Is_External_Name
8036 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8039 if Present
(Arg4
) then
8041 ("Link_Name argument not allowed for imported Cpp exception",
8045 -- Do not call Set_Interface_Name as the name of the exception
8046 -- shouldn't be modified (and in particular it shouldn't be
8047 -- the External_Name). For exceptions, the External_Name is the
8048 -- name of the RTTI structure.
8050 -- ??? Emit an error if pragma Import/Export_Exception is present
8052 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8054 Check_Arg_Count
(3);
8055 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8057 Process_Import_Predefined_Type
;
8061 ("second argument of pragma% must be object, subprogram "
8062 & "or incomplete type",
8066 -- If this pragma applies to a compilation unit, then the unit, which
8067 -- is a subprogram, does not require (or allow) a body. We also do
8068 -- not need to elaborate imported procedures.
8070 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8072 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8074 Set_Body_Required
(Cunit
, False);
8077 end Process_Import_Or_Interface
;
8079 --------------------
8080 -- Process_Inline --
8081 --------------------
8083 procedure Process_Inline
(Status
: Inline_Status
) is
8090 Effective
: Boolean := False;
8091 -- Set True if inline has some effect, i.e. if there is at least one
8092 -- subprogram set as inlined as a result of the use of the pragma.
8094 procedure Make_Inline
(Subp
: Entity_Id
);
8095 -- Subp is the defining unit name of the subprogram declaration. Set
8096 -- the flag, as well as the flag in the corresponding body, if there
8099 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8100 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8101 -- Has_Pragma_Inline_Always for the Inline_Always case.
8103 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8104 -- Returns True if it can be determined at this stage that inlining
8105 -- is not possible, for example if the body is available and contains
8106 -- exception handlers, we prevent inlining, since otherwise we can
8107 -- get undefined symbols at link time. This function also emits a
8108 -- warning if front-end inlining is enabled and the pragma appears
8111 -- ??? is business with link symbols still valid, or does it relate
8112 -- to front end ZCX which is being phased out ???
8114 ---------------------------
8115 -- Inlining_Not_Possible --
8116 ---------------------------
8118 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8119 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8123 if Nkind
(Decl
) = N_Subprogram_Body
then
8124 Stats
:= Handled_Statement_Sequence
(Decl
);
8125 return Present
(Exception_Handlers
(Stats
))
8126 or else Present
(At_End_Proc
(Stats
));
8128 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8129 and then Present
(Corresponding_Body
(Decl
))
8131 if Front_End_Inlining
8132 and then Analyzed
(Corresponding_Body
(Decl
))
8134 Error_Msg_N
("pragma appears too late, ignored??", N
);
8137 -- If the subprogram is a renaming as body, the body is just a
8138 -- call to the renamed subprogram, and inlining is trivially
8142 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8143 N_Subprogram_Renaming_Declaration
8149 Handled_Statement_Sequence
8150 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8153 Present
(Exception_Handlers
(Stats
))
8154 or else Present
(At_End_Proc
(Stats
));
8158 -- If body is not available, assume the best, the check is
8159 -- performed again when compiling enclosing package bodies.
8163 end Inlining_Not_Possible
;
8169 procedure Make_Inline
(Subp
: Entity_Id
) is
8170 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8171 Inner_Subp
: Entity_Id
:= Subp
;
8174 -- Ignore if bad type, avoid cascaded error
8176 if Etype
(Subp
) = Any_Type
then
8180 -- Ignore if all inlining is suppressed
8182 elsif Suppress_All_Inlining
then
8186 -- If inlining is not possible, for now do not treat as an error
8188 elsif Status
/= Suppressed
8189 and then Inlining_Not_Possible
(Subp
)
8194 -- Here we have a candidate for inlining, but we must exclude
8195 -- derived operations. Otherwise we would end up trying to inline
8196 -- a phantom declaration, and the result would be to drag in a
8197 -- body which has no direct inlining associated with it. That
8198 -- would not only be inefficient but would also result in the
8199 -- backend doing cross-unit inlining in cases where it was
8200 -- definitely inappropriate to do so.
8202 -- However, a simple Comes_From_Source test is insufficient, since
8203 -- we do want to allow inlining of generic instances which also do
8204 -- not come from source. We also need to recognize specs generated
8205 -- by the front-end for bodies that carry the pragma. Finally,
8206 -- predefined operators do not come from source but are not
8207 -- inlineable either.
8209 elsif Is_Generic_Instance
(Subp
)
8210 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8214 elsif not Comes_From_Source
(Subp
)
8215 and then Scope
(Subp
) /= Standard_Standard
8221 -- The referenced entity must either be the enclosing entity, or
8222 -- an entity declared within the current open scope.
8224 if Present
(Scope
(Subp
))
8225 and then Scope
(Subp
) /= Current_Scope
8226 and then Subp
/= Current_Scope
8229 ("argument of% must be entity in current scope", Assoc
);
8233 -- Processing for procedure, operator or function. If subprogram
8234 -- is aliased (as for an instance) indicate that the renamed
8235 -- entity (if declared in the same unit) is inlined.
8237 if Is_Subprogram
(Subp
) then
8238 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8240 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8241 Set_Inline_Flags
(Inner_Subp
);
8243 Decl
:= Parent
(Parent
(Inner_Subp
));
8245 if Nkind
(Decl
) = N_Subprogram_Declaration
8246 and then Present
(Corresponding_Body
(Decl
))
8248 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8250 elsif Is_Generic_Instance
(Subp
) then
8252 -- Indicate that the body needs to be created for
8253 -- inlining subsequent calls. The instantiation node
8254 -- follows the declaration of the wrapper package
8257 if Scope
(Subp
) /= Standard_Standard
8259 Need_Subprogram_Instance_Body
8260 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8266 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8267 -- appear in a formal part to apply to a formal subprogram.
8268 -- Do not apply check within an instance or a formal package
8269 -- the test will have been applied to the original generic.
8271 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8272 and then List_Containing
(Decl
) = List_Containing
(N
)
8273 and then not In_Instance
8276 ("Inline cannot apply to a formal subprogram", N
);
8278 -- If Subp is a renaming, it is the renamed entity that
8279 -- will appear in any call, and be inlined. However, for
8280 -- ASIS uses it is convenient to indicate that the renaming
8281 -- itself is an inlined subprogram, so that some gnatcheck
8282 -- rules can be applied in the absence of expansion.
8284 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8285 Set_Inline_Flags
(Subp
);
8291 -- For a generic subprogram set flag as well, for use at the point
8292 -- of instantiation, to determine whether the body should be
8295 elsif Is_Generic_Subprogram
(Subp
) then
8296 Set_Inline_Flags
(Subp
);
8299 -- Literals are by definition inlined
8301 elsif Kind
= E_Enumeration_Literal
then
8304 -- Anything else is an error
8308 ("expect subprogram name for pragma%", Assoc
);
8312 ----------------------
8313 -- Set_Inline_Flags --
8314 ----------------------
8316 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8318 -- First set the Has_Pragma_XXX flags and issue the appropriate
8319 -- errors and warnings for suspicious combinations.
8321 if Prag_Id
= Pragma_No_Inline
then
8322 if Has_Pragma_Inline_Always
(Subp
) then
8324 ("Inline_Always and No_Inline are mutually exclusive", N
);
8325 elsif Has_Pragma_Inline
(Subp
) then
8327 ("Inline and No_Inline both specified for& ??",
8328 N
, Entity
(Subp_Id
));
8331 Set_Has_Pragma_No_Inline
(Subp
);
8333 if Prag_Id
= Pragma_Inline_Always
then
8334 if Has_Pragma_No_Inline
(Subp
) then
8336 ("Inline_Always and No_Inline are mutually exclusive",
8340 Set_Has_Pragma_Inline_Always
(Subp
);
8342 if Has_Pragma_No_Inline
(Subp
) then
8344 ("Inline and No_Inline both specified for& ??",
8345 N
, Entity
(Subp_Id
));
8349 if not Has_Pragma_Inline
(Subp
) then
8350 Set_Has_Pragma_Inline
(Subp
);
8355 -- Then adjust the Is_Inlined flag. It can never be set if the
8356 -- subprogram is subject to pragma No_Inline.
8360 Set_Is_Inlined
(Subp
, False);
8364 if not Has_Pragma_No_Inline
(Subp
) then
8365 Set_Is_Inlined
(Subp
, True);
8368 end Set_Inline_Flags
;
8370 -- Start of processing for Process_Inline
8373 Check_No_Identifiers
;
8374 Check_At_Least_N_Arguments
(1);
8376 if Status
= Enabled
then
8377 Inline_Processing_Required
:= True;
8381 while Present
(Assoc
) loop
8382 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8386 if Is_Entity_Name
(Subp_Id
) then
8387 Subp
:= Entity
(Subp_Id
);
8389 if Subp
= Any_Id
then
8391 -- If previous error, avoid cascaded errors
8393 Check_Error_Detected
;
8400 -- For the pragma case, climb homonym chain. This is
8401 -- what implements allowing the pragma in the renaming
8402 -- case, with the result applying to the ancestors, and
8403 -- also allows Inline to apply to all previous homonyms.
8405 if not From_Aspect_Specification
(N
) then
8406 while Present
(Homonym
(Subp
))
8407 and then Scope
(Homonym
(Subp
)) = Current_Scope
8409 Make_Inline
(Homonym
(Subp
));
8410 Subp
:= Homonym
(Subp
);
8418 ("inappropriate argument for pragma%", Assoc
);
8421 and then Warn_On_Redundant_Constructs
8422 and then not (Status
= Suppressed
or else Suppress_All_Inlining
)
8424 if Inlining_Not_Possible
(Subp
) then
8426 ("pragma Inline for& is ignored?r?",
8427 N
, Entity
(Subp_Id
));
8430 ("pragma Inline for& is redundant?r?",
8431 N
, Entity
(Subp_Id
));
8439 ----------------------------
8440 -- Process_Interface_Name --
8441 ----------------------------
8443 procedure Process_Interface_Name
8444 (Subprogram_Def
: Entity_Id
;
8450 String_Val
: String_Id
;
8452 procedure Check_Form_Of_Interface_Name
8454 Ext_Name_Case
: Boolean);
8455 -- SN is a string literal node for an interface name. This routine
8456 -- performs some minimal checks that the name is reasonable. In
8457 -- particular that no spaces or other obviously incorrect characters
8458 -- appear. This is only a warning, since any characters are allowed.
8459 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8461 ----------------------------------
8462 -- Check_Form_Of_Interface_Name --
8463 ----------------------------------
8465 procedure Check_Form_Of_Interface_Name
8467 Ext_Name_Case
: Boolean)
8469 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8470 SL
: constant Nat
:= String_Length
(S
);
8475 Error_Msg_N
("interface name cannot be null string", SN
);
8478 for J
in 1 .. SL
loop
8479 C
:= Get_String_Char
(S
, J
);
8481 -- Look for dubious character and issue unconditional warning.
8482 -- Definitely dubious if not in character range.
8484 if not In_Character_Range
(C
)
8486 -- For all cases except CLI target,
8487 -- commas, spaces and slashes are dubious (in CLI, we use
8488 -- commas and backslashes in external names to specify
8489 -- assembly version and public key, while slashes and spaces
8490 -- can be used in names to mark nested classes and
8493 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8494 and then (Get_Character
(C
) = ','
8496 Get_Character
(C
) = '\'))
8497 or else (VM_Target
/= CLI_Target
8498 and then (Get_Character
(C
) = ' '
8500 Get_Character
(C
) = '/'))
8503 ("??interface name contains illegal character",
8504 Sloc
(SN
) + Source_Ptr
(J
));
8507 end Check_Form_Of_Interface_Name
;
8509 -- Start of processing for Process_Interface_Name
8512 if No
(Link_Arg
) then
8513 if No
(Ext_Arg
) then
8514 if VM_Target
= CLI_Target
8515 and then Ekind
(Subprogram_Def
) = E_Package
8516 and then Nkind
(Parent
(Subprogram_Def
)) =
8517 N_Package_Specification
8518 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8523 (Generic_Parent
(Parent
(Subprogram_Def
))));
8528 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8530 Link_Nam
:= Expression
(Ext_Arg
);
8533 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8534 Ext_Nam
:= Expression
(Ext_Arg
);
8539 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8540 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8541 Ext_Nam
:= Expression
(Ext_Arg
);
8542 Link_Nam
:= Expression
(Link_Arg
);
8545 -- Check expressions for external name and link name are static
8547 if Present
(Ext_Nam
) then
8548 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8549 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8551 -- Verify that external name is not the name of a local entity,
8552 -- which would hide the imported one and could lead to run-time
8553 -- surprises. The problem can only arise for entities declared in
8554 -- a package body (otherwise the external name is fully qualified
8555 -- and will not conflict).
8563 if Prag_Id
= Pragma_Import
then
8564 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8566 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8568 if Nam
/= Chars
(Subprogram_Def
)
8569 and then Present
(E
)
8570 and then not Is_Overloadable
(E
)
8571 and then Is_Immediately_Visible
(E
)
8572 and then not Is_Imported
(E
)
8573 and then Ekind
(Scope
(E
)) = E_Package
8576 while Present
(Par
) loop
8577 if Nkind
(Par
) = N_Package_Body
then
8578 Error_Msg_Sloc
:= Sloc
(E
);
8580 ("imported entity is hidden by & declared#",
8585 Par
:= Parent
(Par
);
8592 if Present
(Link_Nam
) then
8593 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8594 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8597 -- If there is no link name, just set the external name
8599 if No
(Link_Nam
) then
8600 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8602 -- For the Link_Name case, the given literal is preceded by an
8603 -- asterisk, which indicates to GCC that the given name should be
8604 -- taken literally, and in particular that no prepending of
8605 -- underlines should occur, even in systems where this is the
8611 if VM_Target
= No_VM
then
8612 Store_String_Char
(Get_Char_Code
('*'));
8615 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8616 Store_String_Chars
(String_Val
);
8618 Make_String_Literal
(Sloc
(Link_Nam
),
8619 Strval
=> End_String
);
8622 -- Set the interface name. If the entity is a generic instance, use
8623 -- its alias, which is the callable entity.
8625 if Is_Generic_Instance
(Subprogram_Def
) then
8626 Set_Encoded_Interface_Name
8627 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8629 Set_Encoded_Interface_Name
8630 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8633 -- We allow duplicated export names in CIL/Java, as they are always
8634 -- enclosed in a namespace that differentiates them, and overloaded
8635 -- entities are supported by the VM.
8637 if Convention
(Subprogram_Def
) /= Convention_CIL
8639 Convention
(Subprogram_Def
) /= Convention_Java
8641 Check_Duplicated_Export_Name
(Link_Nam
);
8643 end Process_Interface_Name
;
8645 -----------------------------------------
8646 -- Process_Interrupt_Or_Attach_Handler --
8647 -----------------------------------------
8649 procedure Process_Interrupt_Or_Attach_Handler
is
8650 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8651 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8652 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8655 Set_Is_Interrupt_Handler
(Handler_Proc
);
8657 -- If the pragma is not associated with a handler procedure within a
8658 -- protected type, then it must be for a nonprotected procedure for
8659 -- the AAMP target, in which case we don't associate a representation
8660 -- item with the procedure's scope.
8662 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8663 if Prag_Id
= Pragma_Interrupt_Handler
8665 Prag_Id
= Pragma_Attach_Handler
8667 Record_Rep_Item
(Proc_Scope
, N
);
8670 end Process_Interrupt_Or_Attach_Handler
;
8672 --------------------------------------------------
8673 -- Process_Restrictions_Or_Restriction_Warnings --
8674 --------------------------------------------------
8676 -- Note: some of the simple identifier cases were handled in par-prag,
8677 -- but it is harmless (and more straightforward) to simply handle all
8678 -- cases here, even if it means we repeat a bit of work in some cases.
8680 procedure Process_Restrictions_Or_Restriction_Warnings
8684 R_Id
: Restriction_Id
;
8690 -- Ignore all Restrictions pragmas in CodePeer mode
8692 if CodePeer_Mode
then
8696 Check_Ada_83_Warning
;
8697 Check_At_Least_N_Arguments
(1);
8698 Check_Valid_Configuration_Pragma
;
8701 while Present
(Arg
) loop
8703 Expr
:= Get_Pragma_Arg
(Arg
);
8705 -- Case of no restriction identifier present
8707 if Id
= No_Name
then
8708 if Nkind
(Expr
) /= N_Identifier
then
8710 ("invalid form for restriction", Arg
);
8715 (Process_Restriction_Synonyms
(Expr
));
8717 if R_Id
not in All_Boolean_Restrictions
then
8718 Error_Msg_Name_1
:= Pname
;
8720 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8722 -- Check for possible misspelling
8724 for J
in Restriction_Id
loop
8726 Rnm
: constant String := Restriction_Id
'Image (J
);
8729 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8730 Name_Len
:= Rnm
'Length;
8731 Set_Casing
(All_Lower_Case
);
8733 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8735 (Identifier_Casing
(Current_Source_File
));
8736 Error_Msg_String
(1 .. Rnm
'Length) :=
8737 Name_Buffer
(1 .. Name_Len
);
8738 Error_Msg_Strlen
:= Rnm
'Length;
8739 Error_Msg_N
-- CODEFIX
8740 ("\possible misspelling of ""~""",
8741 Get_Pragma_Arg
(Arg
));
8750 if Implementation_Restriction
(R_Id
) then
8751 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8754 -- Special processing for No_Elaboration_Code restriction
8756 if R_Id
= No_Elaboration_Code
then
8758 -- Restriction is only recognized within a configuration
8759 -- pragma file, or within a unit of the main extended
8760 -- program. Note: the test for Main_Unit is needed to
8761 -- properly include the case of configuration pragma files.
8763 if not (Current_Sem_Unit
= Main_Unit
8764 or else In_Extended_Main_Source_Unit
(N
))
8768 -- Don't allow in a subunit unless already specified in
8771 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8772 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8773 and then not Restriction_Active
(No_Elaboration_Code
)
8776 ("invalid specification of ""No_Elaboration_Code""",
8779 ("\restriction cannot be specified in a subunit", N
);
8781 ("\unless also specified in body or spec", N
);
8784 -- If we accept a No_Elaboration_Code restriction, then it
8785 -- needs to be added to the configuration restriction set so
8786 -- that we get proper application to other units in the main
8787 -- extended source as required.
8790 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8794 -- If this is a warning, then set the warning unless we already
8795 -- have a real restriction active (we never want a warning to
8796 -- override a real restriction).
8799 if not Restriction_Active
(R_Id
) then
8800 Set_Restriction
(R_Id
, N
);
8801 Restriction_Warnings
(R_Id
) := True;
8804 -- If real restriction case, then set it and make sure that the
8805 -- restriction warning flag is off, since a real restriction
8806 -- always overrides a warning.
8809 Set_Restriction
(R_Id
, N
);
8810 Restriction_Warnings
(R_Id
) := False;
8813 -- Check for obsolescent restrictions in Ada 2005 mode
8816 and then Ada_Version
>= Ada_2005
8817 and then (R_Id
= No_Asynchronous_Control
8819 R_Id
= No_Unchecked_Deallocation
8821 R_Id
= No_Unchecked_Conversion
)
8823 Check_Restriction
(No_Obsolescent_Features
, N
);
8826 -- A very special case that must be processed here: pragma
8827 -- Restrictions (No_Exceptions) turns off all run-time
8828 -- checking. This is a bit dubious in terms of the formal
8829 -- language definition, but it is what is intended by RM
8830 -- H.4(12). Restriction_Warnings never affects generated code
8831 -- so this is done only in the real restriction case.
8833 -- Atomic_Synchronization is not a real check, so it is not
8834 -- affected by this processing).
8836 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8837 -- run-time checks in CodePeer and GNATprove modes: we want to
8838 -- generate checks for analysis purposes, as set respectively
8839 -- by -gnatC and -gnatd.F
8842 and then not (CodePeer_Mode
or GNATprove_Mode
)
8843 and then R_Id
= No_Exceptions
8845 for J
in Scope_Suppress
.Suppress
'Range loop
8846 if J
/= Atomic_Synchronization
then
8847 Scope_Suppress
.Suppress
(J
) := True;
8852 -- Case of No_Dependence => unit-name. Note that the parser
8853 -- already made the necessary entry in the No_Dependence table.
8855 elsif Id
= Name_No_Dependence
then
8856 if not OK_No_Dependence_Unit_Name
(Expr
) then
8860 -- Case of No_Specification_Of_Aspect => aspect-identifier
8862 elsif Id
= Name_No_Specification_Of_Aspect
then
8867 if Nkind
(Expr
) /= N_Identifier
then
8870 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8873 if A_Id
= No_Aspect
then
8874 Error_Pragma_Arg
("invalid restriction name", Arg
);
8876 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8880 -- Case of No_Use_Of_Attribute => attribute-identifier
8882 elsif Id
= Name_No_Use_Of_Attribute
then
8883 if Nkind
(Expr
) /= N_Identifier
8884 or else not Is_Attribute_Name
(Chars
(Expr
))
8886 Error_Msg_N
("unknown attribute name??", Expr
);
8889 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8892 -- Case of No_Use_Of_Entity => fully-qualified-name. Note that the
8893 -- parser already processed this case commpletely, including error
8894 -- checking and making an entry in the No_Use_Of_Entity table.
8896 elsif Id
= Name_No_Use_Of_Entity
then
8899 -- Case of No_Use_Of_Pragma => pragma-identifier
8901 elsif Id
= Name_No_Use_Of_Pragma
then
8902 if Nkind
(Expr
) /= N_Identifier
8903 or else not Is_Pragma_Name
(Chars
(Expr
))
8905 Error_Msg_N
("unknown pragma name??", Expr
);
8908 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8911 -- All other cases of restriction identifier present
8914 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8915 Analyze_And_Resolve
(Expr
, Any_Integer
);
8917 if R_Id
not in All_Parameter_Restrictions
then
8919 ("invalid restriction parameter identifier", Arg
);
8921 elsif not Is_OK_Static_Expression
(Expr
) then
8922 Flag_Non_Static_Expr
8923 ("value must be static expression!", Expr
);
8926 elsif not Is_Integer_Type
(Etype
(Expr
))
8927 or else Expr_Value
(Expr
) < 0
8930 ("value must be non-negative integer", Arg
);
8933 -- Restriction pragma is active
8935 Val
:= Expr_Value
(Expr
);
8937 if not UI_Is_In_Int_Range
(Val
) then
8939 ("pragma ignored, value too large??", Arg
);
8942 -- Warning case. If the real restriction is active, then we
8943 -- ignore the request, since warning never overrides a real
8944 -- restriction. Otherwise we set the proper warning. Note that
8945 -- this circuit sets the warning again if it is already set,
8946 -- which is what we want, since the constant may have changed.
8949 if not Restriction_Active
(R_Id
) then
8951 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
8952 Restriction_Warnings
(R_Id
) := True;
8955 -- Real restriction case, set restriction and make sure warning
8956 -- flag is off since real restriction always overrides warning.
8959 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
8960 Restriction_Warnings
(R_Id
) := False;
8966 end Process_Restrictions_Or_Restriction_Warnings
;
8968 ---------------------------------
8969 -- Process_Suppress_Unsuppress --
8970 ---------------------------------
8972 -- Note: this procedure makes entries in the check suppress data
8973 -- structures managed by Sem. See spec of package Sem for full
8974 -- details on how we handle recording of check suppression.
8976 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
8981 In_Package_Spec
: constant Boolean :=
8982 Is_Package_Or_Generic_Package
(Current_Scope
)
8983 and then not In_Package_Body
(Current_Scope
);
8985 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
8986 -- Used to suppress a single check on the given entity
8988 --------------------------------
8989 -- Suppress_Unsuppress_Echeck --
8990 --------------------------------
8992 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
8994 -- Check for error of trying to set atomic synchronization for
8995 -- a non-atomic variable.
8997 if C
= Atomic_Synchronization
8998 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9001 ("pragma & requires atomic type or variable",
9002 Pragma_Identifier
(Original_Node
(N
)));
9005 Set_Checks_May_Be_Suppressed
(E
);
9007 if In_Package_Spec
then
9008 Push_Global_Suppress_Stack_Entry
9011 Suppress
=> Suppress_Case
);
9013 Push_Local_Suppress_Stack_Entry
9016 Suppress
=> Suppress_Case
);
9019 -- If this is a first subtype, and the base type is distinct,
9020 -- then also set the suppress flags on the base type.
9022 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9023 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9025 end Suppress_Unsuppress_Echeck
;
9027 -- Start of processing for Process_Suppress_Unsuppress
9030 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9031 -- on user code: we want to generate checks for analysis purposes, as
9032 -- set respectively by -gnatC and -gnatd.F
9034 if (CodePeer_Mode
or GNATprove_Mode
)
9035 and then Comes_From_Source
(N
)
9040 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9041 -- declarative part or a package spec (RM 11.5(5)).
9043 if not Is_Configuration_Pragma
then
9044 Check_Is_In_Decl_Part_Or_Package_Spec
;
9047 Check_At_Least_N_Arguments
(1);
9048 Check_At_Most_N_Arguments
(2);
9049 Check_No_Identifier
(Arg1
);
9050 Check_Arg_Is_Identifier
(Arg1
);
9052 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9054 if C
= No_Check_Id
then
9056 ("argument of pragma% is not valid check name", Arg1
);
9059 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9061 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9063 ("Suppress of Elaboration_Check ignored in SPARK??",
9064 "\elaboration checking rules are statically enforced "
9065 & "(SPARK RM 7.7)", Arg1
);
9068 -- One-argument case
9070 if Arg_Count
= 1 then
9072 -- Make an entry in the local scope suppress table. This is the
9073 -- table that directly shows the current value of the scope
9074 -- suppress check for any check id value.
9076 if C
= All_Checks
then
9078 -- For All_Checks, we set all specific predefined checks with
9079 -- the exception of Elaboration_Check, which is handled
9080 -- specially because of not wanting All_Checks to have the
9081 -- effect of deactivating static elaboration order processing.
9082 -- Atomic_Synchronization is also not affected, since this is
9083 -- not a real check.
9085 for J
in Scope_Suppress
.Suppress
'Range loop
9086 if J
/= Elaboration_Check
9088 J
/= Atomic_Synchronization
9090 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9094 -- If not All_Checks, and predefined check, then set appropriate
9095 -- scope entry. Note that we will set Elaboration_Check if this
9096 -- is explicitly specified. Atomic_Synchronization is allowed
9097 -- only if internally generated and entity is atomic.
9099 elsif C
in Predefined_Check_Id
9100 and then (not Comes_From_Source
(N
)
9101 or else C
/= Atomic_Synchronization
)
9103 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9106 -- Also make an entry in the Local_Entity_Suppress table
9108 Push_Local_Suppress_Stack_Entry
9111 Suppress
=> Suppress_Case
);
9113 -- Case of two arguments present, where the check is suppressed for
9114 -- a specified entity (given as the second argument of the pragma)
9117 -- This is obsolescent in Ada 2005 mode
9119 if Ada_Version
>= Ada_2005
then
9120 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9123 Check_Optional_Identifier
(Arg2
, Name_On
);
9124 E_Id
:= Get_Pragma_Arg
(Arg2
);
9127 if not Is_Entity_Name
(E_Id
) then
9129 ("second argument of pragma% must be entity name", Arg2
);
9138 -- Enforce RM 11.5(7) which requires that for a pragma that
9139 -- appears within a package spec, the named entity must be
9140 -- within the package spec. We allow the package name itself
9141 -- to be mentioned since that makes sense, although it is not
9142 -- strictly allowed by 11.5(7).
9145 and then E
/= Current_Scope
9146 and then Scope
(E
) /= Current_Scope
9149 ("entity in pragma% is not in package spec (RM 11.5(7))",
9153 -- Loop through homonyms. As noted below, in the case of a package
9154 -- spec, only homonyms within the package spec are considered.
9157 Suppress_Unsuppress_Echeck
(E
, C
);
9159 if Is_Generic_Instance
(E
)
9160 and then Is_Subprogram
(E
)
9161 and then Present
(Alias
(E
))
9163 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9166 -- Move to next homonym if not aspect spec case
9168 exit when From_Aspect_Specification
(N
);
9172 -- If we are within a package specification, the pragma only
9173 -- applies to homonyms in the same scope.
9175 exit when In_Package_Spec
9176 and then Scope
(E
) /= Current_Scope
;
9179 end Process_Suppress_Unsuppress
;
9185 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9187 if Is_Imported
(E
) then
9189 ("cannot export entity& that was previously imported", Arg
);
9191 elsif Present
(Address_Clause
(E
))
9192 and then not Relaxed_RM_Semantics
9195 ("cannot export entity& that has an address clause", Arg
);
9198 Set_Is_Exported
(E
);
9200 -- Generate a reference for entity explicitly, because the
9201 -- identifier may be overloaded and name resolution will not
9204 Generate_Reference
(E
, Arg
);
9206 -- Deal with exporting non-library level entity
9208 if not Is_Library_Level_Entity
(E
) then
9210 -- Not allowed at all for subprograms
9212 if Is_Subprogram
(E
) then
9213 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9215 -- Otherwise set public and statically allocated
9219 Set_Is_Statically_Allocated
(E
);
9221 -- Warn if the corresponding W flag is set
9223 if Warn_On_Export_Import
9225 -- Only do this for something that was in the source. Not
9226 -- clear if this can be False now (there used for sure to be
9227 -- cases on some systems where it was False), but anyway the
9228 -- test is harmless if not needed, so it is retained.
9230 and then Comes_From_Source
(Arg
)
9233 ("?x?& has been made static as a result of Export",
9236 ("\?x?this usage is non-standard and non-portable",
9242 if Warn_On_Export_Import
and then Is_Type
(E
) then
9243 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9246 if Warn_On_Export_Import
and Inside_A_Generic
then
9248 ("all instances of& will have the same external name?x?",
9253 ----------------------------------------------
9254 -- Set_Extended_Import_Export_External_Name --
9255 ----------------------------------------------
9257 procedure Set_Extended_Import_Export_External_Name
9258 (Internal_Ent
: Entity_Id
;
9259 Arg_External
: Node_Id
)
9261 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9265 if No
(Arg_External
) then
9269 Check_Arg_Is_External_Name
(Arg_External
);
9271 if Nkind
(Arg_External
) = N_String_Literal
then
9272 if String_Length
(Strval
(Arg_External
)) = 0 then
9275 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9278 elsif Nkind
(Arg_External
) = N_Identifier
then
9279 New_Name
:= Get_Default_External_Name
(Arg_External
);
9281 -- Check_Arg_Is_External_Name should let through only identifiers and
9282 -- string literals or static string expressions (which are folded to
9283 -- string literals).
9286 raise Program_Error
;
9289 -- If we already have an external name set (by a prior normal Import
9290 -- or Export pragma), then the external names must match
9292 if Present
(Interface_Name
(Internal_Ent
)) then
9294 -- Ignore mismatching names in CodePeer mode, to support some
9295 -- old compilers which would export the same procedure under
9296 -- different names, e.g:
9298 -- pragma Export_Procedure (P, "a");
9299 -- pragma Export_Procedure (P, "b");
9301 if CodePeer_Mode
then
9305 Check_Matching_Internal_Names
: declare
9306 S1
: constant String_Id
:= Strval
(Old_Name
);
9307 S2
: constant String_Id
:= Strval
(New_Name
);
9310 pragma No_Return
(Mismatch
);
9311 -- Called if names do not match
9317 procedure Mismatch
is
9319 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9321 ("external name does not match that given #",
9325 -- Start of processing for Check_Matching_Internal_Names
9328 if String_Length
(S1
) /= String_Length
(S2
) then
9332 for J
in 1 .. String_Length
(S1
) loop
9333 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9338 end Check_Matching_Internal_Names
;
9340 -- Otherwise set the given name
9343 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9344 Check_Duplicated_Export_Name
(New_Name
);
9346 end Set_Extended_Import_Export_External_Name
;
9352 procedure Set_Imported
(E
: Entity_Id
) is
9354 -- Error message if already imported or exported
9356 if Is_Exported
(E
) or else Is_Imported
(E
) then
9358 -- Error if being set Exported twice
9360 if Is_Exported
(E
) then
9361 Error_Msg_NE
("entity& was previously exported", N
, E
);
9363 -- Ignore error in CodePeer mode where we treat all imported
9364 -- subprograms as unknown.
9366 elsif CodePeer_Mode
then
9369 -- OK if Import/Interface case
9371 elsif Import_Interface_Present
(N
) then
9374 -- Error if being set Imported twice
9377 Error_Msg_NE
("entity& was previously imported", N
, E
);
9380 Error_Msg_Name_1
:= Pname
;
9382 ("\(pragma% applies to all previous entities)", N
);
9384 Error_Msg_Sloc
:= Sloc
(E
);
9385 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9387 -- Here if not previously imported or exported, OK to import
9390 Set_Is_Imported
(E
);
9392 -- For subprogram, set Import_Pragma field
9394 if Is_Subprogram
(E
) then
9395 Set_Import_Pragma
(E
, N
);
9398 -- If the entity is an object that is not at the library level,
9399 -- then it is statically allocated. We do not worry about objects
9400 -- with address clauses in this context since they are not really
9401 -- imported in the linker sense.
9404 and then not Is_Library_Level_Entity
(E
)
9405 and then No
(Address_Clause
(E
))
9407 Set_Is_Statically_Allocated
(E
);
9414 -------------------------
9415 -- Set_Mechanism_Value --
9416 -------------------------
9418 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9419 -- analyzed, since it is semantic nonsense), so we get it in the exact
9420 -- form created by the parser.
9422 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9423 procedure Bad_Mechanism
;
9424 pragma No_Return
(Bad_Mechanism
);
9425 -- Signal bad mechanism name
9427 -------------------------
9428 -- Bad_Mechanism_Value --
9429 -------------------------
9431 procedure Bad_Mechanism
is
9433 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9436 -- Start of processing for Set_Mechanism_Value
9439 if Mechanism
(Ent
) /= Default_Mechanism
then
9441 ("mechanism for & has already been set", Mech_Name
, Ent
);
9444 -- MECHANISM_NAME ::= value | reference
9446 if Nkind
(Mech_Name
) = N_Identifier
then
9447 if Chars
(Mech_Name
) = Name_Value
then
9448 Set_Mechanism
(Ent
, By_Copy
);
9451 elsif Chars
(Mech_Name
) = Name_Reference
then
9452 Set_Mechanism
(Ent
, By_Reference
);
9455 elsif Chars
(Mech_Name
) = Name_Copy
then
9457 ("bad mechanism name, Value assumed", Mech_Name
);
9466 end Set_Mechanism_Value
;
9468 --------------------------
9469 -- Set_Rational_Profile --
9470 --------------------------
9472 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9473 -- and extension to the semantics of renaming declarations.
9475 procedure Set_Rational_Profile
is
9477 Implicit_Packing
:= True;
9478 Overriding_Renamings
:= True;
9479 Use_VADS_Size
:= True;
9480 end Set_Rational_Profile
;
9482 ---------------------------
9483 -- Set_Ravenscar_Profile --
9484 ---------------------------
9486 -- The tasks to be done here are
9488 -- Set required policies
9490 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9491 -- pragma Locking_Policy (Ceiling_Locking)
9493 -- Set Detect_Blocking mode
9495 -- Set required restrictions (see System.Rident for detailed list)
9497 -- Set the No_Dependence rules
9498 -- No_Dependence => Ada.Asynchronous_Task_Control
9499 -- No_Dependence => Ada.Calendar
9500 -- No_Dependence => Ada.Execution_Time.Group_Budget
9501 -- No_Dependence => Ada.Execution_Time.Timers
9502 -- No_Dependence => Ada.Task_Attributes
9503 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9505 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9506 Prefix_Entity
: Entity_Id
;
9507 Selector_Entity
: Entity_Id
;
9508 Prefix_Node
: Node_Id
;
9512 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9514 if Task_Dispatching_Policy
/= ' '
9515 and then Task_Dispatching_Policy
/= 'F'
9517 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9518 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9520 -- Set the FIFO_Within_Priorities policy, but always preserve
9521 -- System_Location since we like the error message with the run time
9525 Task_Dispatching_Policy
:= 'F';
9527 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9528 Task_Dispatching_Policy_Sloc
:= Loc
;
9532 -- pragma Locking_Policy (Ceiling_Locking)
9534 if Locking_Policy
/= ' '
9535 and then Locking_Policy
/= 'C'
9537 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9538 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9540 -- Set the Ceiling_Locking policy, but preserve System_Location since
9541 -- we like the error message with the run time name.
9544 Locking_Policy
:= 'C';
9546 if Locking_Policy_Sloc
/= System_Location
then
9547 Locking_Policy_Sloc
:= Loc
;
9551 -- pragma Detect_Blocking
9553 Detect_Blocking
:= True;
9555 -- Set the corresponding restrictions
9557 Set_Profile_Restrictions
9558 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9560 -- Set the No_Dependence restrictions
9562 -- The following No_Dependence restrictions:
9563 -- No_Dependence => Ada.Asynchronous_Task_Control
9564 -- No_Dependence => Ada.Calendar
9565 -- No_Dependence => Ada.Task_Attributes
9566 -- are already set by previous call to Set_Profile_Restrictions.
9568 -- Set the following restrictions which were added to Ada 2005:
9569 -- No_Dependence => Ada.Execution_Time.Group_Budget
9570 -- No_Dependence => Ada.Execution_Time.Timers
9572 if Ada_Version
>= Ada_2005
then
9573 Name_Buffer
(1 .. 3) := "ada";
9576 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9578 Name_Buffer
(1 .. 14) := "execution_time";
9581 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9584 Make_Selected_Component
9586 Prefix
=> Prefix_Entity
,
9587 Selector_Name
=> Selector_Entity
);
9589 Name_Buffer
(1 .. 13) := "group_budgets";
9592 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9595 Make_Selected_Component
9597 Prefix
=> Prefix_Node
,
9598 Selector_Name
=> Selector_Entity
);
9600 Set_Restriction_No_Dependence
9602 Warn
=> Treat_Restrictions_As_Warnings
,
9603 Profile
=> Ravenscar
);
9605 Name_Buffer
(1 .. 6) := "timers";
9608 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9611 Make_Selected_Component
9613 Prefix
=> Prefix_Node
,
9614 Selector_Name
=> Selector_Entity
);
9616 Set_Restriction_No_Dependence
9618 Warn
=> Treat_Restrictions_As_Warnings
,
9619 Profile
=> Ravenscar
);
9622 -- Set the following restrictions which was added to Ada 2012 (see
9624 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9626 if Ada_Version
>= Ada_2012
then
9627 Name_Buffer
(1 .. 6) := "system";
9630 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9632 Name_Buffer
(1 .. 15) := "multiprocessors";
9635 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9638 Make_Selected_Component
9640 Prefix
=> Prefix_Entity
,
9641 Selector_Name
=> Selector_Entity
);
9643 Name_Buffer
(1 .. 19) := "dispatching_domains";
9646 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9649 Make_Selected_Component
9651 Prefix
=> Prefix_Node
,
9652 Selector_Name
=> Selector_Entity
);
9654 Set_Restriction_No_Dependence
9656 Warn
=> Treat_Restrictions_As_Warnings
,
9657 Profile
=> Ravenscar
);
9659 end Set_Ravenscar_Profile
;
9661 -- Start of processing for Analyze_Pragma
9664 -- The following code is a defense against recursion. Not clear that
9665 -- this can happen legitimately, but perhaps some error situations
9666 -- can cause it, and we did see this recursion during testing.
9668 if Analyzed
(N
) then
9671 Set_Analyzed
(N
, True);
9674 -- Deal with unrecognized pragma
9676 Pname
:= Pragma_Name
(N
);
9678 if not Is_Pragma_Name
(Pname
) then
9679 if Warn_On_Unrecognized_Pragma
then
9680 Error_Msg_Name_1
:= Pname
;
9681 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9683 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9684 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9685 Error_Msg_Name_1
:= PN
;
9686 Error_Msg_N
-- CODEFIX
9687 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9696 -- Here to start processing for recognized pragma
9698 Prag_Id
:= Get_Pragma_Id
(Pname
);
9699 Pname
:= Original_Aspect_Name
(N
);
9701 -- Capture setting of Opt.Uneval_Old
9703 case Opt
.Uneval_Old
is
9705 Set_Uneval_Old_Accept
(N
);
9709 Set_Uneval_Old_Warn
(N
);
9711 raise Program_Error
;
9714 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9715 -- is already set, indicating that we have already checked the policy
9716 -- at the right point. This happens for example in the case of a pragma
9717 -- that is derived from an Aspect.
9719 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9722 -- For a pragma that is a rewriting of another pragma, copy the
9723 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9725 elsif Is_Rewrite_Substitution
(N
)
9726 and then Nkind
(Original_Node
(N
)) = N_Pragma
9727 and then Original_Node
(N
) /= N
9729 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9730 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9732 -- Otherwise query the applicable policy at this point
9735 Check_Applicable_Policy
(N
);
9737 -- If pragma is disabled, rewrite as NULL and skip analysis
9739 if Is_Disabled
(N
) then
9740 Rewrite
(N
, Make_Null_Statement
(Loc
));
9754 if Present
(Pragma_Argument_Associations
(N
)) then
9755 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9756 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9758 if Present
(Arg1
) then
9759 Arg2
:= Next
(Arg1
);
9761 if Present
(Arg2
) then
9762 Arg3
:= Next
(Arg2
);
9764 if Present
(Arg3
) then
9765 Arg4
:= Next
(Arg3
);
9771 Check_Restriction_No_Use_Of_Pragma
(N
);
9773 -- An enumeration type defines the pragmas that are supported by the
9774 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9775 -- into the corresponding enumeration value for the following case.
9783 -- pragma Abort_Defer;
9785 when Pragma_Abort_Defer
=>
9787 Check_Arg_Count
(0);
9789 -- The only required semantic processing is to check the
9790 -- placement. This pragma must appear at the start of the
9791 -- statement sequence of a handled sequence of statements.
9793 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9794 or else N
/= First
(Statements
(Parent
(N
)))
9799 --------------------
9800 -- Abstract_State --
9801 --------------------
9803 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9805 -- ABSTRACT_STATE_LIST ::=
9807 -- | STATE_NAME_WITH_OPTIONS
9808 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9810 -- STATE_NAME_WITH_OPTIONS ::=
9812 -- | (STATE_NAME with OPTION_LIST)
9814 -- OPTION_LIST ::= OPTION {, OPTION}
9818 -- | NAME_VALUE_OPTION
9820 -- SIMPLE_OPTION ::= Ghost
9822 -- NAME_VALUE_OPTION ::=
9823 -- Part_Of => ABSTRACT_STATE
9824 -- | External [=> EXTERNAL_PROPERTY_LIST]
9826 -- EXTERNAL_PROPERTY_LIST ::=
9827 -- EXTERNAL_PROPERTY
9828 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9830 -- EXTERNAL_PROPERTY ::=
9831 -- Async_Readers [=> boolean_EXPRESSION]
9832 -- | Async_Writers [=> boolean_EXPRESSION]
9833 -- | Effective_Reads [=> boolean_EXPRESSION]
9834 -- | Effective_Writes [=> boolean_EXPRESSION]
9835 -- others => boolean_EXPRESSION
9837 -- STATE_NAME ::= defining_identifier
9839 -- ABSTRACT_STATE ::= name
9841 when Pragma_Abstract_State
=> Abstract_State
: declare
9842 Missing_Parentheses
: Boolean := False;
9843 -- Flag set when a state declaration with options is not properly
9846 -- Flags used to verify the consistency of states
9848 Non_Null_Seen
: Boolean := False;
9849 Null_Seen
: Boolean := False;
9851 procedure Analyze_Abstract_State
9853 Pack_Id
: Entity_Id
);
9854 -- Verify the legality of a single state declaration. Create and
9855 -- decorate a state abstraction entity and introduce it into the
9856 -- visibility chain. Pack_Id denotes the entity or the related
9857 -- package where pragma Abstract_State appears.
9859 ----------------------------
9860 -- Analyze_Abstract_State --
9861 ----------------------------
9863 procedure Analyze_Abstract_State
9865 Pack_Id
: Entity_Id
)
9867 -- Flags used to verify the consistency of options
9869 AR_Seen
: Boolean := False;
9870 AW_Seen
: Boolean := False;
9871 ER_Seen
: Boolean := False;
9872 EW_Seen
: Boolean := False;
9873 External_Seen
: Boolean := False;
9874 Others_Seen
: Boolean := False;
9875 Part_Of_Seen
: Boolean := False;
9877 -- Flags used to store the static value of all external states'
9880 AR_Val
: Boolean := False;
9881 AW_Val
: Boolean := False;
9882 ER_Val
: Boolean := False;
9883 EW_Val
: Boolean := False;
9885 State_Id
: Entity_Id
:= Empty
;
9886 -- The entity to be generated for the current state declaration
9888 procedure Analyze_External_Option
(Opt
: Node_Id
);
9889 -- Verify the legality of option External
9891 procedure Analyze_External_Property
9893 Expr
: Node_Id
:= Empty
);
9894 -- Verify the legailty of a single external property. Prop
9895 -- denotes the external property. Expr is the expression used
9896 -- to set the property.
9898 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9899 -- Verify the legality of option Part_Of
9901 procedure Check_Duplicate_Option
9903 Status
: in out Boolean);
9904 -- Flag Status denotes whether a particular option has been
9905 -- seen while processing a state. This routine verifies that
9906 -- Opt is not a duplicate option and sets the flag Status
9907 -- (SPARK RM 7.1.4(1)).
9909 procedure Check_Duplicate_Property
9911 Status
: in out Boolean);
9912 -- Flag Status denotes whether a particular property has been
9913 -- seen while processing option External. This routine verifies
9914 -- that Prop is not a duplicate property and sets flag Status.
9915 -- Opt is not a duplicate property and sets the flag Status.
9916 -- (SPARK RM 7.1.4(2))
9918 procedure Create_Abstract_State
9923 -- Generate an abstract state entity with name Nam and enter it
9924 -- into visibility. Decl is the "declaration" of the state as
9925 -- it appears in pragma Abstract_State. Loc is the location of
9926 -- the related state "declaration". Flag Is_Null should be set
9927 -- when the associated Abstract_State pragma defines a null
9930 -----------------------------
9931 -- Analyze_External_Option --
9932 -----------------------------
9934 procedure Analyze_External_Option
(Opt
: Node_Id
) is
9935 Errors
: constant Nat
:= Serious_Errors_Detected
;
9937 Props
: Node_Id
:= Empty
;
9940 Check_Duplicate_Option
(Opt
, External_Seen
);
9942 if Nkind
(Opt
) = N_Component_Association
then
9943 Props
:= Expression
(Opt
);
9946 -- External state with properties
9948 if Present
(Props
) then
9950 -- Multiple properties appear as an aggregate
9952 if Nkind
(Props
) = N_Aggregate
then
9954 -- Simple property form
9956 Prop
:= First
(Expressions
(Props
));
9957 while Present
(Prop
) loop
9958 Analyze_External_Property
(Prop
);
9962 -- Property with expression form
9964 Prop
:= First
(Component_Associations
(Props
));
9965 while Present
(Prop
) loop
9966 Analyze_External_Property
9967 (Prop
=> First
(Choices
(Prop
)),
9968 Expr
=> Expression
(Prop
));
9976 Analyze_External_Property
(Props
);
9979 -- An external state defined without any properties defaults
9980 -- all properties to True.
9989 -- Once all external properties have been processed, verify
9990 -- their mutual interaction. Do not perform the check when
9991 -- at least one of the properties is illegal as this will
9992 -- produce a bogus error.
9994 if Errors
= Serious_Errors_Detected
then
9995 Check_External_Properties
9996 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
9998 end Analyze_External_Option
;
10000 -------------------------------
10001 -- Analyze_External_Property --
10002 -------------------------------
10004 procedure Analyze_External_Property
10006 Expr
: Node_Id
:= Empty
)
10008 Expr_Val
: Boolean;
10011 -- Check the placement of "others" (if available)
10013 if Nkind
(Prop
) = N_Others_Choice
then
10014 if Others_Seen
then
10016 ("only one others choice allowed in option External",
10019 Others_Seen
:= True;
10022 elsif Others_Seen
then
10024 ("others must be the last property in option External",
10027 -- The only remaining legal options are the four predefined
10028 -- external properties.
10030 elsif Nkind
(Prop
) = N_Identifier
10031 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10032 Name_Async_Writers
,
10033 Name_Effective_Reads
,
10034 Name_Effective_Writes
)
10038 -- Otherwise the construct is not a valid property
10041 SPARK_Msg_N
("invalid external state property", Prop
);
10045 -- Ensure that the expression of the external state property
10046 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10048 if Present
(Expr
) then
10049 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10051 if Is_OK_Static_Expression
(Expr
) then
10052 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10055 ("expression of external state property must be "
10059 -- The lack of expression defaults the property to True
10065 -- Named properties
10067 if Nkind
(Prop
) = N_Identifier
then
10068 if Chars
(Prop
) = Name_Async_Readers
then
10069 Check_Duplicate_Property
(Prop
, AR_Seen
);
10070 AR_Val
:= Expr_Val
;
10072 elsif Chars
(Prop
) = Name_Async_Writers
then
10073 Check_Duplicate_Property
(Prop
, AW_Seen
);
10074 AW_Val
:= Expr_Val
;
10076 elsif Chars
(Prop
) = Name_Effective_Reads
then
10077 Check_Duplicate_Property
(Prop
, ER_Seen
);
10078 ER_Val
:= Expr_Val
;
10081 Check_Duplicate_Property
(Prop
, EW_Seen
);
10082 EW_Val
:= Expr_Val
;
10085 -- The handling of property "others" must take into account
10086 -- all other named properties that have been encountered so
10087 -- far. Only those that have not been seen are affected by
10091 if not AR_Seen
then
10092 AR_Val
:= Expr_Val
;
10095 if not AW_Seen
then
10096 AW_Val
:= Expr_Val
;
10099 if not ER_Seen
then
10100 ER_Val
:= Expr_Val
;
10103 if not EW_Seen
then
10104 EW_Val
:= Expr_Val
;
10107 end Analyze_External_Property
;
10109 ----------------------------
10110 -- Analyze_Part_Of_Option --
10111 ----------------------------
10113 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10114 Encaps
: constant Node_Id
:= Expression
(Opt
);
10115 Encaps_Id
: Entity_Id
;
10119 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10122 (Item_Id
=> State_Id
,
10124 Indic
=> First
(Choices
(Opt
)),
10127 -- The Part_Of indicator turns an abstract state into a
10128 -- constituent of the encapsulating state.
10131 Encaps_Id
:= Entity
(Encaps
);
10133 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10134 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10136 end Analyze_Part_Of_Option
;
10138 ----------------------------
10139 -- Check_Duplicate_Option --
10140 ----------------------------
10142 procedure Check_Duplicate_Option
10144 Status
: in out Boolean)
10148 SPARK_Msg_N
("duplicate state option", Opt
);
10152 end Check_Duplicate_Option
;
10154 ------------------------------
10155 -- Check_Duplicate_Property --
10156 ------------------------------
10158 procedure Check_Duplicate_Property
10160 Status
: in out Boolean)
10164 SPARK_Msg_N
("duplicate external property", Prop
);
10168 end Check_Duplicate_Property
;
10170 ---------------------------
10171 -- Create_Abstract_State --
10172 ---------------------------
10174 procedure Create_Abstract_State
10181 -- The abstract state may be semi-declared when the related
10182 -- package was withed through a limited with clause. In that
10183 -- case reuse the entity to fully declare the state.
10185 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10186 State_Id
:= Entity
(Decl
);
10188 -- Otherwise the elaboration of pragma Abstract_State
10189 -- declares the state.
10192 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10194 if Present
(Decl
) then
10195 Set_Entity
(Decl
, State_Id
);
10199 -- Null states never come from source
10201 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10202 Set_Parent
(State_Id
, State
);
10203 Set_Ekind
(State_Id
, E_Abstract_State
);
10204 Set_Etype
(State_Id
, Standard_Void_Type
);
10205 Set_Encapsulating_State
(State_Id
, Empty
);
10206 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10207 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10209 -- An abstract state declared within a Ghost scope becomes
10210 -- Ghost (SPARK RM 6.9(2)).
10212 if Within_Ghost_Scope
then
10213 Set_Is_Ghost_Entity
(State_Id
);
10216 -- Establish a link between the state declaration and the
10217 -- abstract state entity. Note that a null state remains as
10218 -- N_Null and does not carry any linkages.
10220 if not Is_Null
then
10221 if Present
(Decl
) then
10222 Set_Entity
(Decl
, State_Id
);
10223 Set_Etype
(Decl
, Standard_Void_Type
);
10226 -- Every non-null state must be defined, nameable and
10229 Push_Scope
(Pack_Id
);
10230 Generate_Definition
(State_Id
);
10231 Enter_Name
(State_Id
);
10234 end Create_Abstract_State
;
10241 -- Start of processing for Analyze_Abstract_State
10244 -- A package with a null abstract state is not allowed to
10245 -- declare additional states.
10249 ("package & has null abstract state", State
, Pack_Id
);
10251 -- Null states appear as internally generated entities
10253 elsif Nkind
(State
) = N_Null
then
10254 Create_Abstract_State
10255 (Nam
=> New_Internal_Name
('S'),
10257 Loc
=> Sloc
(State
),
10261 -- Catch a case where a null state appears in a list of
10262 -- non-null states.
10264 if Non_Null_Seen
then
10266 ("package & has non-null abstract state",
10270 -- Simple state declaration
10272 elsif Nkind
(State
) = N_Identifier
then
10273 Create_Abstract_State
10274 (Nam
=> Chars
(State
),
10276 Loc
=> Sloc
(State
),
10278 Non_Null_Seen
:= True;
10280 -- State declaration with various options. This construct
10281 -- appears as an extension aggregate in the tree.
10283 elsif Nkind
(State
) = N_Extension_Aggregate
then
10284 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10285 Create_Abstract_State
10286 (Nam
=> Chars
(Ancestor_Part
(State
)),
10287 Decl
=> Ancestor_Part
(State
),
10288 Loc
=> Sloc
(Ancestor_Part
(State
)),
10290 Non_Null_Seen
:= True;
10293 ("state name must be an identifier",
10294 Ancestor_Part
(State
));
10297 -- Options External and Ghost appear as expressions
10299 Opt
:= First
(Expressions
(State
));
10300 while Present
(Opt
) loop
10301 if Nkind
(Opt
) = N_Identifier
then
10302 if Chars
(Opt
) = Name_External
then
10303 Analyze_External_Option
(Opt
);
10305 elsif Chars
(Opt
) = Name_Ghost
then
10306 if Present
(State_Id
) then
10307 Set_Is_Ghost_Entity
(State_Id
);
10310 -- Option Part_Of without an encapsulating state is
10311 -- illegal. (SPARK RM 7.1.4(9)).
10313 elsif Chars
(Opt
) = Name_Part_Of
then
10315 ("indicator Part_Of must denote an abstract "
10318 -- Do not emit an error message when a previous state
10319 -- declaration with options was not parenthesized as
10320 -- the option is actually another state declaration.
10322 -- with Abstract_State
10323 -- (State_1 with ..., -- missing parentheses
10324 -- (State_2 with ...),
10325 -- State_3) -- ok state declaration
10327 elsif Missing_Parentheses
then
10330 -- Otherwise the option is not allowed. Note that it
10331 -- is not possible to distinguish between an option
10332 -- and a state declaration when a previous state with
10333 -- options not properly parentheses.
10335 -- with Abstract_State
10336 -- (State_1 with ..., -- missing parentheses
10337 -- State_2); -- could be an option
10341 ("simple option not allowed in state declaration",
10345 -- Catch a case where missing parentheses around a state
10346 -- declaration with options cause a subsequent state
10347 -- declaration with options to be treated as an option.
10349 -- with Abstract_State
10350 -- (State_1 with ..., -- missing parentheses
10351 -- (State_2 with ...))
10353 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10354 Missing_Parentheses
:= True;
10356 ("state declaration must be parenthesized",
10357 Ancestor_Part
(State
));
10359 -- Otherwise the option is malformed
10362 SPARK_Msg_N
("malformed option", Opt
);
10368 -- Options External and Part_Of appear as component
10371 Opt
:= First
(Component_Associations
(State
));
10372 while Present
(Opt
) loop
10373 Opt_Nam
:= First
(Choices
(Opt
));
10375 if Nkind
(Opt_Nam
) = N_Identifier
then
10376 if Chars
(Opt_Nam
) = Name_External
then
10377 Analyze_External_Option
(Opt
);
10379 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10380 Analyze_Part_Of_Option
(Opt
);
10383 SPARK_Msg_N
("invalid state option", Opt
);
10386 SPARK_Msg_N
("invalid state option", Opt
);
10392 -- Any other attempt to declare a state is illegal. This is a
10393 -- syntax error, always report.
10396 Error_Msg_N
("malformed abstract state declaration", State
);
10400 -- Guard against a junk state. In such cases no entity is
10401 -- generated and the subsequent checks cannot be applied.
10403 if Present
(State_Id
) then
10405 -- Verify whether the state does not introduce an illegal
10406 -- hidden state within a package subject to a null abstract
10409 Check_No_Hidden_State
(State_Id
);
10411 -- Check whether the lack of option Part_Of agrees with the
10412 -- placement of the abstract state with respect to the state
10415 if not Part_Of_Seen
then
10416 Check_Missing_Part_Of
(State_Id
);
10419 -- Associate the state with its related package
10421 if No
(Abstract_States
(Pack_Id
)) then
10422 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10425 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10427 end Analyze_Abstract_State
;
10431 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10432 Pack_Id
: Entity_Id
;
10435 -- Start of processing for Abstract_State
10439 Check_No_Identifiers
;
10440 Check_Arg_Count
(1);
10441 Ensure_Aggregate_Form
(Arg1
);
10443 -- Ensure the proper placement of the pragma. Abstract states must
10444 -- be associated with a package declaration.
10446 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10447 N_Package_Declaration
)
10453 State
:= Expression
(Arg1
);
10454 Pack_Id
:= Defining_Entity
(Context
);
10456 -- Mark the associated package as Ghost if it is subject to aspect
10457 -- or pragma Ghost as this affects the declaration of an abstract
10460 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10461 Set_Is_Ghost_Entity
(Pack_Id
);
10464 -- Multiple non-null abstract states appear as an aggregate
10466 if Nkind
(State
) = N_Aggregate
then
10467 State
:= First
(Expressions
(State
));
10468 while Present
(State
) loop
10469 Analyze_Abstract_State
(State
, Pack_Id
);
10473 -- Various forms of a single abstract state. Note that these may
10474 -- include malformed state declarations.
10477 Analyze_Abstract_State
(State
, Pack_Id
);
10480 -- Save the pragma for retrieval by other tools
10482 Add_Contract_Item
(N
, Pack_Id
);
10484 -- Verify the declaration order of pragmas Abstract_State and
10487 Check_Declaration_Order
10489 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10490 end Abstract_State
;
10498 -- Note: this pragma also has some specific processing in Par.Prag
10499 -- because we want to set the Ada version mode during parsing.
10501 when Pragma_Ada_83
=>
10503 Check_Arg_Count
(0);
10505 -- We really should check unconditionally for proper configuration
10506 -- pragma placement, since we really don't want mixed Ada modes
10507 -- within a single unit, and the GNAT reference manual has always
10508 -- said this was a configuration pragma, but we did not check and
10509 -- are hesitant to add the check now.
10511 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10512 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10513 -- or Ada 2012 mode.
10515 if Ada_Version
>= Ada_2005
then
10516 Check_Valid_Configuration_Pragma
;
10519 -- Now set Ada 83 mode
10521 Ada_Version
:= Ada_83
;
10522 Ada_Version_Explicit
:= Ada_83
;
10523 Ada_Version_Pragma
:= N
;
10531 -- Note: this pragma also has some specific processing in Par.Prag
10532 -- because we want to set the Ada 83 version mode during parsing.
10534 when Pragma_Ada_95
=>
10536 Check_Arg_Count
(0);
10538 -- We really should check unconditionally for proper configuration
10539 -- pragma placement, since we really don't want mixed Ada modes
10540 -- within a single unit, and the GNAT reference manual has always
10541 -- said this was a configuration pragma, but we did not check and
10542 -- are hesitant to add the check now.
10544 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10545 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10547 if Ada_Version
>= Ada_2005
then
10548 Check_Valid_Configuration_Pragma
;
10551 -- Now set Ada 95 mode
10553 Ada_Version
:= Ada_95
;
10554 Ada_Version_Explicit
:= Ada_95
;
10555 Ada_Version_Pragma
:= N
;
10557 ---------------------
10558 -- Ada_05/Ada_2005 --
10559 ---------------------
10562 -- pragma Ada_05 (LOCAL_NAME);
10564 -- pragma Ada_2005;
10565 -- pragma Ada_2005 (LOCAL_NAME):
10567 -- Note: these pragmas also have some specific processing in Par.Prag
10568 -- because we want to set the Ada 2005 version mode during parsing.
10570 -- The one argument form is used for managing the transition from
10571 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10572 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10573 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10574 -- mode, a preference rule is established which does not choose
10575 -- such an entity unless it is unambiguously specified. This avoids
10576 -- extra subprograms marked this way from generating ambiguities in
10577 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10578 -- intended for exclusive use in the GNAT run-time library.
10580 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10586 if Arg_Count
= 1 then
10587 Check_Arg_Is_Local_Name
(Arg1
);
10588 E_Id
:= Get_Pragma_Arg
(Arg1
);
10590 if Etype
(E_Id
) = Any_Type
then
10594 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10595 Record_Rep_Item
(Entity
(E_Id
), N
);
10598 Check_Arg_Count
(0);
10600 -- For Ada_2005 we unconditionally enforce the documented
10601 -- configuration pragma placement, since we do not want to
10602 -- tolerate mixed modes in a unit involving Ada 2005. That
10603 -- would cause real difficulties for those cases where there
10604 -- are incompatibilities between Ada 95 and Ada 2005.
10606 Check_Valid_Configuration_Pragma
;
10608 -- Now set appropriate Ada mode
10610 Ada_Version
:= Ada_2005
;
10611 Ada_Version_Explicit
:= Ada_2005
;
10612 Ada_Version_Pragma
:= N
;
10616 ---------------------
10617 -- Ada_12/Ada_2012 --
10618 ---------------------
10621 -- pragma Ada_12 (LOCAL_NAME);
10623 -- pragma Ada_2012;
10624 -- pragma Ada_2012 (LOCAL_NAME):
10626 -- Note: these pragmas also have some specific processing in Par.Prag
10627 -- because we want to set the Ada 2012 version mode during parsing.
10629 -- The one argument form is used for managing the transition from Ada
10630 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10631 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10632 -- mode will generate a warning. In addition, in any pre-Ada_2012
10633 -- mode, a preference rule is established which does not choose
10634 -- such an entity unless it is unambiguously specified. This avoids
10635 -- extra subprograms marked this way from generating ambiguities in
10636 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10637 -- intended for exclusive use in the GNAT run-time library.
10639 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10645 if Arg_Count
= 1 then
10646 Check_Arg_Is_Local_Name
(Arg1
);
10647 E_Id
:= Get_Pragma_Arg
(Arg1
);
10649 if Etype
(E_Id
) = Any_Type
then
10653 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10654 Record_Rep_Item
(Entity
(E_Id
), N
);
10657 Check_Arg_Count
(0);
10659 -- For Ada_2012 we unconditionally enforce the documented
10660 -- configuration pragma placement, since we do not want to
10661 -- tolerate mixed modes in a unit involving Ada 2012. That
10662 -- would cause real difficulties for those cases where there
10663 -- are incompatibilities between Ada 95 and Ada 2012. We could
10664 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10666 Check_Valid_Configuration_Pragma
;
10668 -- Now set appropriate Ada mode
10670 Ada_Version
:= Ada_2012
;
10671 Ada_Version_Explicit
:= Ada_2012
;
10672 Ada_Version_Pragma
:= N
;
10676 ----------------------
10677 -- All_Calls_Remote --
10678 ----------------------
10680 -- pragma All_Calls_Remote [(library_package_NAME)];
10682 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10683 Lib_Entity
: Entity_Id
;
10686 Check_Ada_83_Warning
;
10687 Check_Valid_Library_Unit_Pragma
;
10689 if Nkind
(N
) = N_Null_Statement
then
10693 Lib_Entity
:= Find_Lib_Unit_Name
;
10695 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10697 if Present
(Lib_Entity
)
10698 and then not Debug_Flag_U
10700 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10701 Error_Pragma
("pragma% only apply to rci unit");
10703 -- Set flag for entity of the library unit
10706 Set_Has_All_Calls_Remote
(Lib_Entity
);
10710 end All_Calls_Remote
;
10712 ---------------------------
10713 -- Allow_Integer_Address --
10714 ---------------------------
10716 -- pragma Allow_Integer_Address;
10718 when Pragma_Allow_Integer_Address
=>
10720 Check_Valid_Configuration_Pragma
;
10721 Check_Arg_Count
(0);
10723 -- If Address is a private type, then set the flag to allow
10724 -- integer address values. If Address is not private, then this
10725 -- pragma has no purpose, so it is simply ignored. Not clear if
10726 -- there are any such targets now.
10728 if Opt
.Address_Is_Private
then
10729 Opt
.Allow_Integer_Address
:= True;
10737 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10738 -- ARG ::= NAME | EXPRESSION
10740 -- The first two arguments are by convention intended to refer to an
10741 -- external tool and a tool-specific function. These arguments are
10744 when Pragma_Annotate
=> Annotate
: declare
10750 Check_At_Least_N_Arguments
(1);
10752 -- See if last argument is Entity => local_Name, and if so process
10753 -- and then remove it for remaining processing.
10756 Last_Arg
: constant Node_Id
:=
10757 Last
(Pragma_Argument_Associations
(N
));
10760 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10761 and then Chars
(Last_Arg
) = Name_Entity
10763 Check_Arg_Is_Local_Name
(Last_Arg
);
10764 Arg_Count
:= Arg_Count
- 1;
10766 -- Not allowed in compiler units (bootstrap issues)
10768 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10772 -- Continue processing with last argument removed for now
10774 Check_Arg_Is_Identifier
(Arg1
);
10775 Check_No_Identifiers
;
10778 -- Second parameter is optional, it is never analyzed
10783 -- Here if we have a second parameter
10786 -- Second parameter must be identifier
10788 Check_Arg_Is_Identifier
(Arg2
);
10790 -- Process remaining parameters if any
10792 Arg
:= Next
(Arg2
);
10793 while Present
(Arg
) loop
10794 Exp
:= Get_Pragma_Arg
(Arg
);
10797 if Is_Entity_Name
(Exp
) then
10800 -- For string literals, we assume Standard_String as the
10801 -- type, unless the string contains wide or wide_wide
10804 elsif Nkind
(Exp
) = N_String_Literal
then
10805 if Has_Wide_Wide_Character
(Exp
) then
10806 Resolve
(Exp
, Standard_Wide_Wide_String
);
10807 elsif Has_Wide_Character
(Exp
) then
10808 Resolve
(Exp
, Standard_Wide_String
);
10810 Resolve
(Exp
, Standard_String
);
10813 elsif Is_Overloaded
(Exp
) then
10815 ("ambiguous argument for pragma%", Exp
);
10826 -------------------------------------------------
10827 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10828 -------------------------------------------------
10831 -- ( [Check => ] Boolean_EXPRESSION
10832 -- [, [Message =>] Static_String_EXPRESSION]);
10834 -- pragma Assert_And_Cut
10835 -- ( [Check => ] Boolean_EXPRESSION
10836 -- [, [Message =>] Static_String_EXPRESSION]);
10839 -- ( [Check => ] Boolean_EXPRESSION
10840 -- [, [Message =>] Static_String_EXPRESSION]);
10842 -- pragma Loop_Invariant
10843 -- ( [Check => ] Boolean_EXPRESSION
10844 -- [, [Message =>] Static_String_EXPRESSION]);
10846 when Pragma_Assert |
10847 Pragma_Assert_And_Cut |
10849 Pragma_Loop_Invariant
=>
10851 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10852 -- Determine whether expression Expr contains a Loop_Entry
10853 -- attribute reference.
10855 -------------------------
10856 -- Contains_Loop_Entry --
10857 -------------------------
10859 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10860 Has_Loop_Entry
: Boolean := False;
10862 function Process
(N
: Node_Id
) return Traverse_Result
;
10863 -- Process function for traversal to look for Loop_Entry
10869 function Process
(N
: Node_Id
) return Traverse_Result
is
10871 if Nkind
(N
) = N_Attribute_Reference
10872 and then Attribute_Name
(N
) = Name_Loop_Entry
10874 Has_Loop_Entry
:= True;
10881 procedure Traverse
is new Traverse_Proc
(Process
);
10883 -- Start of processing for Contains_Loop_Entry
10887 return Has_Loop_Entry
;
10888 end Contains_Loop_Entry
;
10895 -- Start of processing for Assert
10898 -- Assert is an Ada 2005 RM-defined pragma
10900 if Prag_Id
= Pragma_Assert
then
10903 -- The remaining ones are GNAT pragmas
10909 Check_At_Least_N_Arguments
(1);
10910 Check_At_Most_N_Arguments
(2);
10911 Check_Arg_Order
((Name_Check
, Name_Message
));
10912 Check_Optional_Identifier
(Arg1
, Name_Check
);
10913 Expr
:= Get_Pragma_Arg
(Arg1
);
10915 -- Special processing for Loop_Invariant, Loop_Variant or for
10916 -- other cases where a Loop_Entry attribute is present. If the
10917 -- assertion pragma contains attribute Loop_Entry, ensure that
10918 -- the related pragma is within a loop.
10920 if Prag_Id
= Pragma_Loop_Invariant
10921 or else Prag_Id
= Pragma_Loop_Variant
10922 or else Contains_Loop_Entry
(Expr
)
10924 Check_Loop_Pragma_Placement
;
10926 -- Perform preanalysis to deal with embedded Loop_Entry
10929 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10932 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10933 -- a corresponding Check pragma:
10935 -- pragma Check (name, condition [, msg]);
10937 -- Where name is the identifier matching the pragma name. So
10938 -- rewrite pragma in this manner, transfer the message argument
10939 -- if present, and analyze the result
10941 -- Note: When dealing with a semantically analyzed tree, the
10942 -- information that a Check node N corresponds to a source Assert,
10943 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10944 -- pragma kind of Original_Node(N).
10947 Make_Pragma_Argument_Association
(Loc
,
10948 Expression
=> Make_Identifier
(Loc
, Pname
)),
10949 Make_Pragma_Argument_Association
(Sloc
(Expr
),
10950 Expression
=> Expr
));
10952 if Arg_Count
> 1 then
10953 Check_Optional_Identifier
(Arg2
, Name_Message
);
10955 -- Provide semantic annnotations for optional argument, for
10956 -- ASIS use, before rewriting.
10958 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
10959 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
10962 -- Rewrite as Check pragma
10966 Chars
=> Name_Check
,
10967 Pragma_Argument_Associations
=> Newa
));
10971 ----------------------
10972 -- Assertion_Policy --
10973 ----------------------
10975 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10977 -- The following form is Ada 2012 only, but we allow it in all modes
10979 -- Pragma Assertion_Policy (
10980 -- ASSERTION_KIND => POLICY_IDENTIFIER
10981 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
10983 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
10985 -- RM_ASSERTION_KIND ::= Assert |
10986 -- Static_Predicate |
10987 -- Dynamic_Predicate |
10992 -- Type_Invariant |
10993 -- Type_Invariant'Class
10995 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
10997 -- Contract_Cases |
10999 -- Default_Initial_Condition |
11001 -- Initial_Condition |
11002 -- Loop_Invariant |
11008 -- Statement_Assertions
11010 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11011 -- ID_ASSERTION_KIND list contains implementation-defined additions
11012 -- recognized by GNAT. The effect is to control the behavior of
11013 -- identically named aspects and pragmas, depending on the specified
11014 -- policy identifier:
11016 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11018 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11019 -- implementation defined addition that results in totally ignoring
11020 -- the corresponding assertion. If Disable is specified, then the
11021 -- argument of the assertion is not even analyzed. This is useful
11022 -- when the aspect/pragma argument references entities in a with'ed
11023 -- package that is replaced by a dummy package in the final build.
11025 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11026 -- and Type_Invariant'Class were recognized by the parser and
11027 -- transformed into references to the special internal identifiers
11028 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11029 -- processing is required here.
11031 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11040 -- This can always appear as a configuration pragma
11042 if Is_Configuration_Pragma
then
11045 -- It can also appear in a declarative part or package spec in Ada
11046 -- 2012 mode. We allow this in other modes, but in that case we
11047 -- consider that we have an Ada 2012 pragma on our hands.
11050 Check_Is_In_Decl_Part_Or_Package_Spec
;
11054 -- One argument case with no identifier (first form above)
11057 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11058 or else Chars
(Arg1
) = No_Name
)
11060 Check_Arg_Is_One_Of
11061 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11063 -- Treat one argument Assertion_Policy as equivalent to:
11065 -- pragma Check_Policy (Assertion, policy)
11067 -- So rewrite pragma in that manner and link on to the chain
11068 -- of Check_Policy pragmas, marking the pragma as analyzed.
11070 Policy
:= Get_Pragma_Arg
(Arg1
);
11074 Chars
=> Name_Check_Policy
,
11075 Pragma_Argument_Associations
=> New_List
(
11076 Make_Pragma_Argument_Association
(Loc
,
11077 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11079 Make_Pragma_Argument_Association
(Loc
,
11081 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11084 -- Here if we have two or more arguments
11087 Check_At_Least_N_Arguments
(1);
11090 -- Loop through arguments
11093 while Present
(Arg
) loop
11094 LocP
:= Sloc
(Arg
);
11096 -- Kind must be specified
11098 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11099 or else Chars
(Arg
) = No_Name
11102 ("missing assertion kind for pragma%", Arg
);
11105 -- Check Kind and Policy have allowed forms
11107 Kind
:= Chars
(Arg
);
11109 if not Is_Valid_Assertion_Kind
(Kind
) then
11111 ("invalid assertion kind for pragma%", Arg
);
11114 Check_Arg_Is_One_Of
11115 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11117 -- Rewrite the Assertion_Policy pragma as a series of
11118 -- Check_Policy pragmas of the form:
11120 -- Check_Policy (Kind, Policy);
11122 -- Note: the insertion of the pragmas cannot be done with
11123 -- Insert_Action because in the configuration case, there
11124 -- are no scopes on the scope stack and the mechanism will
11127 Insert_Before_And_Analyze
(N
,
11129 Chars
=> Name_Check_Policy
,
11130 Pragma_Argument_Associations
=> New_List
(
11131 Make_Pragma_Argument_Association
(LocP
,
11132 Expression
=> Make_Identifier
(LocP
, Kind
)),
11133 Make_Pragma_Argument_Association
(LocP
,
11134 Expression
=> Get_Pragma_Arg
(Arg
)))));
11139 -- Rewrite the Assertion_Policy pragma as null since we have
11140 -- now inserted all the equivalent Check pragmas.
11142 Rewrite
(N
, Make_Null_Statement
(Loc
));
11145 end Assertion_Policy
;
11147 ------------------------------
11148 -- Assume_No_Invalid_Values --
11149 ------------------------------
11151 -- pragma Assume_No_Invalid_Values (On | Off);
11153 when Pragma_Assume_No_Invalid_Values
=>
11155 Check_Valid_Configuration_Pragma
;
11156 Check_Arg_Count
(1);
11157 Check_No_Identifiers
;
11158 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11160 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11161 Assume_No_Invalid_Values
:= True;
11163 Assume_No_Invalid_Values
:= False;
11166 --------------------------
11167 -- Attribute_Definition --
11168 --------------------------
11170 -- pragma Attribute_Definition
11171 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11172 -- [Entity =>] LOCAL_NAME,
11173 -- [Expression =>] EXPRESSION | NAME);
11175 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11176 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11181 Check_Arg_Count
(3);
11182 Check_Optional_Identifier
(Arg1
, "attribute");
11183 Check_Optional_Identifier
(Arg2
, "entity");
11184 Check_Optional_Identifier
(Arg3
, "expression");
11186 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11187 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11191 Check_Arg_Is_Local_Name
(Arg2
);
11193 -- If the attribute is not recognized, then issue a warning (not
11194 -- an error), and ignore the pragma.
11196 Aname
:= Chars
(Attribute_Designator
);
11198 if not Is_Attribute_Name
(Aname
) then
11199 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11203 -- Otherwise, rewrite the pragma as an attribute definition clause
11206 Make_Attribute_Definition_Clause
(Loc
,
11207 Name
=> Get_Pragma_Arg
(Arg2
),
11209 Expression
=> Get_Pragma_Arg
(Arg3
)));
11211 end Attribute_Definition
;
11213 ------------------------------------------------------------------
11214 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11215 ------------------------------------------------------------------
11217 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11218 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11219 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11220 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11222 -- FLAG ::= boolean_EXPRESSION
11224 when Pragma_Async_Readers |
11225 Pragma_Async_Writers |
11226 Pragma_Effective_Reads |
11227 Pragma_Effective_Writes
=>
11228 Async_Effective
: declare
11232 Obj_Id
: Entity_Id
;
11236 Check_No_Identifiers
;
11237 Check_At_Least_N_Arguments
(1);
11238 Check_At_Most_N_Arguments
(2);
11239 Check_Arg_Is_Local_Name
(Arg1
);
11240 Error_Msg_Name_1
:= Pname
;
11242 Obj
:= Get_Pragma_Arg
(Arg1
);
11243 Expr
:= Get_Pragma_Arg
(Arg2
);
11245 -- Perform minimal verification to ensure that the argument is at
11246 -- least a variable. Subsequent finer grained checks will be done
11247 -- at the end of the declarative region the contains the pragma.
11249 if Is_Entity_Name
(Obj
)
11250 and then Present
(Entity
(Obj
))
11251 and then Ekind
(Entity
(Obj
)) = E_Variable
11253 Obj_Id
:= Entity
(Obj
);
11255 -- Detect a duplicate pragma. Note that it is not efficient to
11256 -- examine preceding statements as Boolean aspects may appear
11257 -- anywhere between the related object declaration and its
11258 -- freeze point. As an alternative, inspect the contents of the
11259 -- variable contract.
11261 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11263 if Present
(Duplic
) then
11264 Error_Msg_Sloc
:= Sloc
(Duplic
);
11265 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11267 -- No duplicate detected
11270 if Present
(Expr
) then
11271 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11274 -- Chain the pragma on the contract for further processing
11276 Add_Contract_Item
(N
, Obj_Id
);
11279 Error_Pragma
("pragma % must apply to a volatile object");
11281 end Async_Effective
;
11287 -- pragma Asynchronous (LOCAL_NAME);
11289 when Pragma_Asynchronous
=> Asynchronous
: declare
11295 Formal
: Entity_Id
;
11297 procedure Process_Async_Pragma
;
11298 -- Common processing for procedure and access-to-procedure case
11300 --------------------------
11301 -- Process_Async_Pragma --
11302 --------------------------
11304 procedure Process_Async_Pragma
is
11307 Set_Is_Asynchronous
(Nm
);
11311 -- The formals should be of mode IN (RM E.4.1(6))
11314 while Present
(S
) loop
11315 Formal
:= Defining_Identifier
(S
);
11317 if Nkind
(Formal
) = N_Defining_Identifier
11318 and then Ekind
(Formal
) /= E_In_Parameter
11321 ("pragma% procedure can only have IN parameter",
11328 Set_Is_Asynchronous
(Nm
);
11329 end Process_Async_Pragma
;
11331 -- Start of processing for pragma Asynchronous
11334 Check_Ada_83_Warning
;
11335 Check_No_Identifiers
;
11336 Check_Arg_Count
(1);
11337 Check_Arg_Is_Local_Name
(Arg1
);
11339 if Debug_Flag_U
then
11343 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11344 Analyze
(Get_Pragma_Arg
(Arg1
));
11345 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11347 if not Is_Remote_Call_Interface
(C_Ent
)
11348 and then not Is_Remote_Types
(C_Ent
)
11350 -- This pragma should only appear in an RCI or Remote Types
11351 -- unit (RM E.4.1(4)).
11354 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11357 if Ekind
(Nm
) = E_Procedure
11358 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11360 if not Is_Remote_Call_Interface
(Nm
) then
11362 ("pragma% cannot be applied on non-remote procedure",
11366 L
:= Parameter_Specifications
(Parent
(Nm
));
11367 Process_Async_Pragma
;
11370 elsif Ekind
(Nm
) = E_Function
then
11372 ("pragma% cannot be applied to function", Arg1
);
11374 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11375 if Is_Record_Type
(Nm
) then
11377 -- A record type that is the Equivalent_Type for a remote
11378 -- access-to-subprogram type.
11380 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11383 -- A non-expanded RAS type (distribution is not enabled)
11385 N
:= Declaration_Node
(Nm
);
11388 if Nkind
(N
) = N_Full_Type_Declaration
11389 and then Nkind
(Type_Definition
(N
)) =
11390 N_Access_Procedure_Definition
11392 L
:= Parameter_Specifications
(Type_Definition
(N
));
11393 Process_Async_Pragma
;
11395 if Is_Asynchronous
(Nm
)
11396 and then Expander_Active
11397 and then Get_PCS_Name
/= Name_No_DSA
11399 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11404 ("pragma% cannot reference access-to-function type",
11408 -- Only other possibility is Access-to-class-wide type
11410 elsif Is_Access_Type
(Nm
)
11411 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11413 Check_First_Subtype
(Arg1
);
11414 Set_Is_Asynchronous
(Nm
);
11415 if Expander_Active
then
11416 RACW_Type_Is_Asynchronous
(Nm
);
11420 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11428 -- pragma Atomic (LOCAL_NAME);
11430 when Pragma_Atomic
=>
11431 Process_Atomic_Shared_Volatile
;
11433 -----------------------
11434 -- Atomic_Components --
11435 -----------------------
11437 -- pragma Atomic_Components (array_LOCAL_NAME);
11439 -- This processing is shared by Volatile_Components
11441 when Pragma_Atomic_Components |
11442 Pragma_Volatile_Components
=>
11444 Atomic_Components
: declare
11451 Check_Ada_83_Warning
;
11452 Check_No_Identifiers
;
11453 Check_Arg_Count
(1);
11454 Check_Arg_Is_Local_Name
(Arg1
);
11455 E_Id
:= Get_Pragma_Arg
(Arg1
);
11457 if Etype
(E_Id
) = Any_Type
then
11461 E
:= Entity
(E_Id
);
11463 Check_Duplicate_Pragma
(E
);
11465 if Rep_Item_Too_Early
(E
, N
)
11467 Rep_Item_Too_Late
(E
, N
)
11472 D
:= Declaration_Node
(E
);
11475 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11477 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11478 and then Nkind
(D
) = N_Object_Declaration
11479 and then Nkind
(Object_Definition
(D
)) =
11480 N_Constrained_Array_Definition
)
11482 -- The flag is set on the object, or on the base type
11484 if Nkind
(D
) /= N_Object_Declaration
then
11485 E
:= Base_Type
(E
);
11488 Set_Has_Volatile_Components
(E
);
11490 if Prag_Id
= Pragma_Atomic_Components
then
11491 Set_Has_Atomic_Components
(E
);
11495 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11497 end Atomic_Components
;
11499 --------------------
11500 -- Attach_Handler --
11501 --------------------
11503 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11505 when Pragma_Attach_Handler
=>
11506 Check_Ada_83_Warning
;
11507 Check_No_Identifiers
;
11508 Check_Arg_Count
(2);
11510 if No_Run_Time_Mode
then
11511 Error_Msg_CRT
("Attach_Handler pragma", N
);
11513 Check_Interrupt_Or_Attach_Handler
;
11515 -- The expression that designates the attribute may depend on a
11516 -- discriminant, and is therefore a per-object expression, to
11517 -- be expanded in the init proc. If expansion is enabled, then
11518 -- perform semantic checks on a copy only.
11523 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11526 -- In Relaxed_RM_Semantics mode, we allow any static
11527 -- integer value, for compatibility with other compilers.
11529 if Relaxed_RM_Semantics
11530 and then Nkind
(Parg2
) = N_Integer_Literal
11532 Typ
:= Standard_Integer
;
11534 Typ
:= RTE
(RE_Interrupt_ID
);
11537 if Expander_Active
then
11538 Temp
:= New_Copy_Tree
(Parg2
);
11539 Set_Parent
(Temp
, N
);
11540 Preanalyze_And_Resolve
(Temp
, Typ
);
11543 Resolve
(Parg2
, Typ
);
11547 Process_Interrupt_Or_Attach_Handler
;
11550 --------------------
11551 -- C_Pass_By_Copy --
11552 --------------------
11554 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11556 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11562 Check_Valid_Configuration_Pragma
;
11563 Check_Arg_Count
(1);
11564 Check_Optional_Identifier
(Arg1
, "max_size");
11566 Arg
:= Get_Pragma_Arg
(Arg1
);
11567 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11569 Val
:= Expr_Value
(Arg
);
11573 ("maximum size for pragma% must be positive", Arg1
);
11575 elsif UI_Is_In_Int_Range
(Val
) then
11576 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11578 -- If a giant value is given, Int'Last will do well enough.
11579 -- If sometime someone complains that a record larger than
11580 -- two gigabytes is not copied, we will worry about it then.
11583 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11585 end C_Pass_By_Copy
;
11591 -- pragma Check ([Name =>] CHECK_KIND,
11592 -- [Check =>] Boolean_EXPRESSION
11593 -- [,[Message =>] String_EXPRESSION]);
11595 -- CHECK_KIND ::= IDENTIFIER |
11598 -- Invariant'Class |
11599 -- Type_Invariant'Class
11601 -- The identifiers Assertions and Statement_Assertions are not
11602 -- allowed, since they have special meaning for Check_Policy.
11604 when Pragma_Check
=> Check
: declare
11612 Check_At_Least_N_Arguments
(2);
11613 Check_At_Most_N_Arguments
(3);
11614 Check_Optional_Identifier
(Arg1
, Name_Name
);
11615 Check_Optional_Identifier
(Arg2
, Name_Check
);
11617 if Arg_Count
= 3 then
11618 Check_Optional_Identifier
(Arg3
, Name_Message
);
11619 Str
:= Get_Pragma_Arg
(Arg3
);
11622 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11623 Check_Arg_Is_Identifier
(Arg1
);
11624 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11626 -- Check forbidden name Assertions or Statement_Assertions
11629 when Name_Assertions
=>
11631 ("""Assertions"" is not allowed as a check kind "
11632 & "for pragma%", Arg1
);
11634 when Name_Statement_Assertions
=>
11636 ("""Statement_Assertions"" is not allowed as a check kind "
11637 & "for pragma%", Arg1
);
11643 -- Check applicable policy. We skip this if Checked/Ignored status
11644 -- is already set (e.g. in the casse of a pragma from an aspect).
11646 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11649 -- For a non-source pragma that is a rewriting of another pragma,
11650 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11652 elsif Is_Rewrite_Substitution
(N
)
11653 and then Nkind
(Original_Node
(N
)) = N_Pragma
11654 and then Original_Node
(N
) /= N
11656 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11657 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11659 -- Otherwise query the applicable policy at this point
11662 case Check_Kind
(Cname
) is
11663 when Name_Ignore
=>
11664 Set_Is_Ignored
(N
, True);
11665 Set_Is_Checked
(N
, False);
11668 Set_Is_Ignored
(N
, False);
11669 Set_Is_Checked
(N
, True);
11671 -- For disable, rewrite pragma as null statement and skip
11672 -- rest of the analysis of the pragma.
11674 when Name_Disable
=>
11675 Rewrite
(N
, Make_Null_Statement
(Loc
));
11679 -- No other possibilities
11682 raise Program_Error
;
11686 -- If check kind was not Disable, then continue pragma analysis
11688 Expr
:= Get_Pragma_Arg
(Arg2
);
11690 -- Deal with SCO generation
11693 when Name_Predicate |
11696 -- Nothing to do: since checks occur in client units,
11697 -- the SCO for the aspect in the declaration unit is
11698 -- conservatively always enabled.
11704 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11706 -- Mark aspect/pragma SCO as enabled
11708 Set_SCO_Pragma_Enabled
(Loc
);
11712 -- Deal with analyzing the string argument.
11714 if Arg_Count
= 3 then
11716 -- If checks are not on we don't want any expansion (since
11717 -- such expansion would not get properly deleted) but
11718 -- we do want to analyze (to get proper references).
11719 -- The Preanalyze_And_Resolve routine does just what we want
11721 if Is_Ignored
(N
) then
11722 Preanalyze_And_Resolve
(Str
, Standard_String
);
11724 -- Otherwise we need a proper analysis and expansion
11727 Analyze_And_Resolve
(Str
, Standard_String
);
11731 -- Now you might think we could just do the same with the Boolean
11732 -- expression if checks are off (and expansion is on) and then
11733 -- rewrite the check as a null statement. This would work but we
11734 -- would lose the useful warnings about an assertion being bound
11735 -- to fail even if assertions are turned off.
11737 -- So instead we wrap the boolean expression in an if statement
11738 -- that looks like:
11740 -- if False and then condition then
11744 -- The reason we do this rewriting during semantic analysis rather
11745 -- than as part of normal expansion is that we cannot analyze and
11746 -- expand the code for the boolean expression directly, or it may
11747 -- cause insertion of actions that would escape the attempt to
11748 -- suppress the check code.
11750 -- Note that the Sloc for the if statement corresponds to the
11751 -- argument condition, not the pragma itself. The reason for
11752 -- this is that we may generate a warning if the condition is
11753 -- False at compile time, and we do not want to delete this
11754 -- warning when we delete the if statement.
11756 if Expander_Active
and Is_Ignored
(N
) then
11757 Eloc
:= Sloc
(Expr
);
11760 Make_If_Statement
(Eloc
,
11762 Make_And_Then
(Eloc
,
11763 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
11764 Right_Opnd
=> Expr
),
11765 Then_Statements
=> New_List
(
11766 Make_Null_Statement
(Eloc
))));
11768 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11770 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11772 -- Check is active or expansion not active. In these cases we can
11773 -- just go ahead and analyze the boolean with no worries.
11776 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11777 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11778 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11782 --------------------------
11783 -- Check_Float_Overflow --
11784 --------------------------
11786 -- pragma Check_Float_Overflow;
11788 when Pragma_Check_Float_Overflow
=>
11790 Check_Valid_Configuration_Pragma
;
11791 Check_Arg_Count
(0);
11792 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11798 -- pragma Check_Name (check_IDENTIFIER);
11800 when Pragma_Check_Name
=>
11802 Check_No_Identifiers
;
11803 Check_Valid_Configuration_Pragma
;
11804 Check_Arg_Count
(1);
11805 Check_Arg_Is_Identifier
(Arg1
);
11808 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11811 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11812 if Check_Names
.Table
(J
) = Nam
then
11817 Check_Names
.Append
(Nam
);
11824 -- This is the old style syntax, which is still allowed in all modes:
11826 -- pragma Check_Policy ([Name =>] CHECK_KIND
11827 -- [Policy =>] POLICY_IDENTIFIER);
11829 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11831 -- CHECK_KIND ::= IDENTIFIER |
11834 -- Type_Invariant'Class |
11837 -- This is the new style syntax, compatible with Assertion_Policy
11838 -- and also allowed in all modes.
11840 -- Pragma Check_Policy (
11841 -- CHECK_KIND => POLICY_IDENTIFIER
11842 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11844 -- Note: the identifiers Name and Policy are not allowed as
11845 -- Check_Kind values. This avoids ambiguities between the old and
11846 -- new form syntax.
11848 when Pragma_Check_Policy
=> Check_Policy
: declare
11854 Check_At_Least_N_Arguments
(1);
11856 -- A Check_Policy pragma can appear either as a configuration
11857 -- pragma, or in a declarative part or a package spec (see RM
11858 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11859 -- followed for Check_Policy).
11861 if not Is_Configuration_Pragma
then
11862 Check_Is_In_Decl_Part_Or_Package_Spec
;
11865 -- Figure out if we have the old or new syntax. We have the
11866 -- old syntax if the first argument has no identifier, or the
11867 -- identifier is Name.
11869 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11870 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11874 Check_Arg_Count
(2);
11875 Check_Optional_Identifier
(Arg1
, Name_Name
);
11876 Kind
:= Get_Pragma_Arg
(Arg1
);
11877 Rewrite_Assertion_Kind
(Kind
);
11878 Check_Arg_Is_Identifier
(Arg1
);
11880 -- Check forbidden check kind
11882 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11883 Error_Msg_Name_2
:= Chars
(Kind
);
11885 ("pragma% does not allow% as check name", Arg1
);
11890 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11891 Check_Arg_Is_One_Of
11893 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11894 Ident
:= Get_Pragma_Arg
(Arg2
);
11896 if Chars
(Kind
) = Name_Ghost
then
11898 -- Pragma Check_Policy specifying a Ghost policy cannot
11899 -- occur within a ghost subprogram or package.
11901 if Within_Ghost_Scope
then
11903 ("pragma % cannot appear within ghost subprogram or "
11906 -- The policy identifier of pragma Ghost must be either
11907 -- Check or Ignore (SPARK RM 6.9(7)).
11909 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11913 ("argument of pragma % Ghost must be Check or Ignore",
11918 -- And chain pragma on the Check_Policy_List for search
11920 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11921 Opt
.Check_Policy_List
:= N
;
11923 -- For the new syntax, what we do is to convert each argument to
11924 -- an old syntax equivalent. We do that because we want to chain
11925 -- old style Check_Policy pragmas for the search (we don't want
11926 -- to have to deal with multiple arguments in the search).
11936 while Present
(Arg
) loop
11937 LocP
:= Sloc
(Arg
);
11938 Argx
:= Get_Pragma_Arg
(Arg
);
11940 -- Kind must be specified
11942 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11943 or else Chars
(Arg
) = No_Name
11946 ("missing assertion kind for pragma%", Arg
);
11949 -- Construct equivalent old form syntax Check_Policy
11950 -- pragma and insert it to get remaining checks.
11954 Chars
=> Name_Check_Policy
,
11955 Pragma_Argument_Associations
=> New_List
(
11956 Make_Pragma_Argument_Association
(LocP
,
11958 Make_Identifier
(LocP
, Chars
(Arg
))),
11959 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11960 Expression
=> Argx
))));
11965 -- Rewrite original Check_Policy pragma to null, since we
11966 -- have converted it into a series of old syntax pragmas.
11968 Rewrite
(N
, Make_Null_Statement
(Loc
));
11974 ---------------------
11975 -- CIL_Constructor --
11976 ---------------------
11978 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
11980 -- Processing for this pragma is shared with Java_Constructor
11986 -- pragma Comment (static_string_EXPRESSION)
11988 -- Processing for pragma Comment shares the circuitry for pragma
11989 -- Ident. The only differences are that Ident enforces a limit of 31
11990 -- characters on its argument, and also enforces limitations on
11991 -- placement for DEC compatibility. Pragma Comment shares neither of
11992 -- these restrictions.
11994 -------------------
11995 -- Common_Object --
11996 -------------------
11998 -- pragma Common_Object (
11999 -- [Internal =>] LOCAL_NAME
12000 -- [, [External =>] EXTERNAL_SYMBOL]
12001 -- [, [Size =>] EXTERNAL_SYMBOL]);
12003 -- Processing for this pragma is shared with Psect_Object
12005 ------------------------
12006 -- Compile_Time_Error --
12007 ------------------------
12009 -- pragma Compile_Time_Error
12010 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12012 when Pragma_Compile_Time_Error
=>
12014 Process_Compile_Time_Warning_Or_Error
;
12016 --------------------------
12017 -- Compile_Time_Warning --
12018 --------------------------
12020 -- pragma Compile_Time_Warning
12021 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12023 when Pragma_Compile_Time_Warning
=>
12025 Process_Compile_Time_Warning_Or_Error
;
12027 ---------------------------
12028 -- Compiler_Unit_Warning --
12029 ---------------------------
12031 -- pragma Compiler_Unit_Warning;
12035 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12036 -- errors not warnings. This means that we had introduced a big extra
12037 -- inertia to compiler changes, since even if we implemented a new
12038 -- feature, and even if all versions to be used for bootstrapping
12039 -- implemented this new feature, we could not use it, since old
12040 -- compilers would give errors for using this feature in units
12041 -- having Compiler_Unit pragmas.
12043 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12044 -- problem. We no longer have any units mentioning Compiler_Unit,
12045 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12046 -- and thus generates a warning which can be ignored. So that deals
12047 -- with the problem of old compilers not implementing the newer form
12050 -- Newer compilers recognize the new pragma, but generate warning
12051 -- messages instead of errors, which again can be ignored in the
12052 -- case of an old compiler which implements a wanted new feature
12053 -- but at the time felt like warning about it for older compilers.
12055 -- We retain Compiler_Unit so that new compilers can be used to build
12056 -- older run-times that use this pragma. That's an unusual case, but
12057 -- it's easy enough to handle, so why not?
12059 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12061 Check_Arg_Count
(0);
12063 -- Only recognized in main unit
12065 if Current_Sem_Unit
= Main_Unit
then
12066 Compiler_Unit
:= True;
12069 -----------------------------
12070 -- Complete_Representation --
12071 -----------------------------
12073 -- pragma Complete_Representation;
12075 when Pragma_Complete_Representation
=>
12077 Check_Arg_Count
(0);
12079 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12081 ("pragma & must appear within record representation clause");
12084 ----------------------------
12085 -- Complex_Representation --
12086 ----------------------------
12088 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12090 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12097 Check_Arg_Count
(1);
12098 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12099 Check_Arg_Is_Local_Name
(Arg1
);
12100 E_Id
:= Get_Pragma_Arg
(Arg1
);
12102 if Etype
(E_Id
) = Any_Type
then
12106 E
:= Entity
(E_Id
);
12108 if not Is_Record_Type
(E
) then
12110 ("argument for pragma% must be record type", Arg1
);
12113 Ent
:= First_Entity
(E
);
12116 or else No
(Next_Entity
(Ent
))
12117 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12118 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12119 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12122 ("record for pragma% must have two fields of the same "
12123 & "floating-point type", Arg1
);
12126 Set_Has_Complex_Representation
(Base_Type
(E
));
12128 -- We need to treat the type has having a non-standard
12129 -- representation, for back-end purposes, even though in
12130 -- general a complex will have the default representation
12131 -- of a record with two real components.
12133 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12135 end Complex_Representation
;
12137 -------------------------
12138 -- Component_Alignment --
12139 -------------------------
12141 -- pragma Component_Alignment (
12142 -- [Form =>] ALIGNMENT_CHOICE
12143 -- [, [Name =>] type_LOCAL_NAME]);
12145 -- ALIGNMENT_CHOICE ::=
12147 -- | Component_Size_4
12151 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12152 Args
: Args_List
(1 .. 2);
12153 Names
: constant Name_List
(1 .. 2) := (
12157 Form
: Node_Id
renames Args
(1);
12158 Name
: Node_Id
renames Args
(2);
12160 Atype
: Component_Alignment_Kind
;
12165 Gather_Associations
(Names
, Args
);
12168 Error_Pragma
("missing Form argument for pragma%");
12171 Check_Arg_Is_Identifier
(Form
);
12173 -- Get proper alignment, note that Default = Component_Size on all
12174 -- machines we have so far, and we want to set this value rather
12175 -- than the default value to indicate that it has been explicitly
12176 -- set (and thus will not get overridden by the default component
12177 -- alignment for the current scope)
12179 if Chars
(Form
) = Name_Component_Size
then
12180 Atype
:= Calign_Component_Size
;
12182 elsif Chars
(Form
) = Name_Component_Size_4
then
12183 Atype
:= Calign_Component_Size_4
;
12185 elsif Chars
(Form
) = Name_Default
then
12186 Atype
:= Calign_Component_Size
;
12188 elsif Chars
(Form
) = Name_Storage_Unit
then
12189 Atype
:= Calign_Storage_Unit
;
12193 ("invalid Form parameter for pragma%", Form
);
12196 -- Case with no name, supplied, affects scope table entry
12200 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12202 -- Case of name supplied
12205 Check_Arg_Is_Local_Name
(Name
);
12207 Typ
:= Entity
(Name
);
12210 or else Rep_Item_Too_Early
(Typ
, N
)
12214 Typ
:= Underlying_Type
(Typ
);
12217 if not Is_Record_Type
(Typ
)
12218 and then not Is_Array_Type
(Typ
)
12221 ("Name parameter of pragma% must identify record or "
12222 & "array type", Name
);
12225 -- An explicit Component_Alignment pragma overrides an
12226 -- implicit pragma Pack, but not an explicit one.
12228 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12229 Set_Is_Packed
(Base_Type
(Typ
), False);
12230 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12233 end Component_AlignmentP
;
12235 --------------------
12236 -- Contract_Cases --
12237 --------------------
12239 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12241 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12243 -- CASE_GUARD ::= boolean_EXPRESSION | others
12245 -- CONSEQUENCE ::= boolean_EXPRESSION
12247 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12248 Subp_Decl
: Node_Id
;
12252 Check_No_Identifiers
;
12253 Check_Arg_Count
(1);
12254 Ensure_Aggregate_Form
(Arg1
);
12256 -- The pragma is analyzed at the end of the declarative part which
12257 -- contains the related subprogram. Reset the analyzed flag.
12259 Set_Analyzed
(N
, False);
12261 -- Ensure the proper placement of the pragma. Contract_Cases must
12262 -- be associated with a subprogram declaration or a body that acts
12266 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12268 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12271 -- Body acts as spec
12273 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12274 and then No
(Corresponding_Spec
(Subp_Decl
))
12278 -- Body stub acts as spec
12280 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12281 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12290 -- When the pragma appears on a subprogram body, perform the full
12293 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12294 Analyze_Contract_Cases_In_Decl_Part
(N
);
12296 -- When Contract_Cases applies to a subprogram compilation unit,
12297 -- the corresponding pragma is placed after the unit's declaration
12298 -- node and needs to be analyzed immediately.
12300 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12301 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12303 Analyze_Contract_Cases_In_Decl_Part
(N
);
12306 -- Chain the pragma on the contract for further processing
12308 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12309 end Contract_Cases
;
12315 -- pragma Controlled (first_subtype_LOCAL_NAME);
12317 when Pragma_Controlled
=> Controlled
: declare
12321 Check_No_Identifiers
;
12322 Check_Arg_Count
(1);
12323 Check_Arg_Is_Local_Name
(Arg1
);
12324 Arg
:= Get_Pragma_Arg
(Arg1
);
12326 if not Is_Entity_Name
(Arg
)
12327 or else not Is_Access_Type
(Entity
(Arg
))
12329 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12331 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12339 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12340 -- [Entity =>] LOCAL_NAME);
12342 when Pragma_Convention
=> Convention
: declare
12345 pragma Warnings
(Off
, C
);
12346 pragma Warnings
(Off
, E
);
12348 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12349 Check_Ada_83_Warning
;
12350 Check_Arg_Count
(2);
12351 Process_Convention
(C
, E
);
12354 ---------------------------
12355 -- Convention_Identifier --
12356 ---------------------------
12358 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12359 -- [Convention =>] convention_IDENTIFIER);
12361 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12367 Check_Arg_Order
((Name_Name
, Name_Convention
));
12368 Check_Arg_Count
(2);
12369 Check_Optional_Identifier
(Arg1
, Name_Name
);
12370 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12371 Check_Arg_Is_Identifier
(Arg1
);
12372 Check_Arg_Is_Identifier
(Arg2
);
12373 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12374 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12376 if Is_Convention_Name
(Cname
) then
12377 Record_Convention_Identifier
12378 (Idnam
, Get_Convention_Id
(Cname
));
12381 ("second arg for % pragma must be convention", Arg2
);
12383 end Convention_Identifier
;
12389 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12391 when Pragma_CPP_Class
=> CPP_Class
: declare
12395 if Warn_On_Obsolescent_Feature
then
12397 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12398 & "effect; replace it by pragma import?j?", N
);
12401 Check_Arg_Count
(1);
12405 Chars
=> Name_Import
,
12406 Pragma_Argument_Associations
=> New_List
(
12407 Make_Pragma_Argument_Association
(Loc
,
12408 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12409 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12413 ---------------------
12414 -- CPP_Constructor --
12415 ---------------------
12417 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12418 -- [, [External_Name =>] static_string_EXPRESSION ]
12419 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12421 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12424 Def_Id
: Entity_Id
;
12425 Tag_Typ
: Entity_Id
;
12429 Check_At_Least_N_Arguments
(1);
12430 Check_At_Most_N_Arguments
(3);
12431 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12432 Check_Arg_Is_Local_Name
(Arg1
);
12434 Id
:= Get_Pragma_Arg
(Arg1
);
12435 Find_Program_Unit_Name
(Id
);
12437 -- If we did not find the name, we are done
12439 if Etype
(Id
) = Any_Type
then
12443 Def_Id
:= Entity
(Id
);
12445 -- Check if already defined as constructor
12447 if Is_Constructor
(Def_Id
) then
12449 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12453 if Ekind
(Def_Id
) = E_Function
12454 and then (Is_CPP_Class
(Etype
(Def_Id
))
12455 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12457 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12459 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12461 ("'C'P'P constructor must be defined in the scope of "
12462 & "its returned type", Arg1
);
12465 if Arg_Count
>= 2 then
12466 Set_Imported
(Def_Id
);
12467 Set_Is_Public
(Def_Id
);
12468 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12471 Set_Has_Completion
(Def_Id
);
12472 Set_Is_Constructor
(Def_Id
);
12473 Set_Convention
(Def_Id
, Convention_CPP
);
12475 -- Imported C++ constructors are not dispatching primitives
12476 -- because in C++ they don't have a dispatch table slot.
12477 -- However, in Ada the constructor has the profile of a
12478 -- function that returns a tagged type and therefore it has
12479 -- been treated as a primitive operation during semantic
12480 -- analysis. We now remove it from the list of primitive
12481 -- operations of the type.
12483 if Is_Tagged_Type
(Etype
(Def_Id
))
12484 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12485 and then Is_Dispatching_Operation
(Def_Id
)
12487 Tag_Typ
:= Etype
(Def_Id
);
12489 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12490 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12494 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12495 Set_Is_Dispatching_Operation
(Def_Id
, False);
12498 -- For backward compatibility, if the constructor returns a
12499 -- class wide type, and we internally change the return type to
12500 -- the corresponding root type.
12502 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12503 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12507 ("pragma% requires function returning a 'C'P'P_Class type",
12510 end CPP_Constructor
;
12516 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12520 if Warn_On_Obsolescent_Feature
then
12522 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12531 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12535 if Warn_On_Obsolescent_Feature
then
12537 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12546 -- pragma CPU (EXPRESSION);
12548 when Pragma_CPU
=> CPU
: declare
12549 P
: constant Node_Id
:= Parent
(N
);
12555 Check_No_Identifiers
;
12556 Check_Arg_Count
(1);
12560 if Nkind
(P
) = N_Subprogram_Body
then
12561 Check_In_Main_Program
;
12563 Arg
:= Get_Pragma_Arg
(Arg1
);
12564 Analyze_And_Resolve
(Arg
, Any_Integer
);
12566 Ent
:= Defining_Unit_Name
(Specification
(P
));
12568 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12569 Ent
:= Defining_Identifier
(Ent
);
12574 if not Is_OK_Static_Expression
(Arg
) then
12575 Flag_Non_Static_Expr
12576 ("main subprogram affinity is not static!", Arg
);
12579 -- If constraint error, then we already signalled an error
12581 elsif Raises_Constraint_Error
(Arg
) then
12584 -- Otherwise check in range
12588 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12589 -- This is the entity System.Multiprocessors.CPU_Range;
12591 Val
: constant Uint
:= Expr_Value
(Arg
);
12594 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12596 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12599 ("main subprogram CPU is out of range", Arg1
);
12605 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12609 elsif Nkind
(P
) = N_Task_Definition
then
12610 Arg
:= Get_Pragma_Arg
(Arg1
);
12611 Ent
:= Defining_Identifier
(Parent
(P
));
12613 -- The expression must be analyzed in the special manner
12614 -- described in "Handling of Default and Per-Object
12615 -- Expressions" in sem.ads.
12617 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12619 -- Anything else is incorrect
12625 -- Check duplicate pragma before we chain the pragma in the Rep
12626 -- Item chain of Ent.
12628 Check_Duplicate_Pragma
(Ent
);
12629 Record_Rep_Item
(Ent
, N
);
12636 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12638 when Pragma_Debug
=> Debug
: declare
12645 -- The condition for executing the call is that the expander
12646 -- is active and that we are not ignoring this debug pragma.
12651 (Expander_Active
and then not Is_Ignored
(N
)),
12654 if not Is_Ignored
(N
) then
12655 Set_SCO_Pragma_Enabled
(Loc
);
12658 if Arg_Count
= 2 then
12660 Make_And_Then
(Loc
,
12661 Left_Opnd
=> Relocate_Node
(Cond
),
12662 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12663 Call
:= Get_Pragma_Arg
(Arg2
);
12665 Call
:= Get_Pragma_Arg
(Arg1
);
12669 N_Indexed_Component
,
12673 N_Selected_Component
)
12675 -- If this pragma Debug comes from source, its argument was
12676 -- parsed as a name form (which is syntactically identical).
12677 -- In a generic context a parameterless call will be left as
12678 -- an expanded name (if global) or selected_component if local.
12679 -- Change it to a procedure call statement now.
12681 Change_Name_To_Procedure_Call_Statement
(Call
);
12683 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12685 -- Already in the form of a procedure call statement: nothing
12686 -- to do (could happen in case of an internally generated
12692 -- All other cases: diagnose error
12695 ("argument of pragma ""Debug"" is not procedure call",
12700 -- Rewrite into a conditional with an appropriate condition. We
12701 -- wrap the procedure call in a block so that overhead from e.g.
12702 -- use of the secondary stack does not generate execution overhead
12703 -- for suppressed conditions.
12705 -- Normally the analysis that follows will freeze the subprogram
12706 -- being called. However, if the call is to a null procedure,
12707 -- we want to freeze it before creating the block, because the
12708 -- analysis that follows may be done with expansion disabled, in
12709 -- which case the body will not be generated, leading to spurious
12712 if Nkind
(Call
) = N_Procedure_Call_Statement
12713 and then Is_Entity_Name
(Name
(Call
))
12715 Analyze
(Name
(Call
));
12716 Freeze_Before
(N
, Entity
(Name
(Call
)));
12720 Make_Implicit_If_Statement
(N
,
12722 Then_Statements
=> New_List
(
12723 Make_Block_Statement
(Loc
,
12724 Handled_Statement_Sequence
=>
12725 Make_Handled_Sequence_Of_Statements
(Loc
,
12726 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12729 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12730 -- after analysis of the normally rewritten node, to capture all
12731 -- references to entities, which avoids issuing wrong warnings
12732 -- about unused entities.
12734 if GNATprove_Mode
then
12735 Rewrite
(N
, Make_Null_Statement
(Loc
));
12743 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12745 when Pragma_Debug_Policy
=>
12747 Check_Arg_Count
(1);
12748 Check_No_Identifiers
;
12749 Check_Arg_Is_Identifier
(Arg1
);
12751 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12752 -- rewrite it that way, and let the rest of the checking come
12753 -- from analyzing the rewritten pragma.
12757 Chars
=> Name_Check_Policy
,
12758 Pragma_Argument_Associations
=> New_List
(
12759 Make_Pragma_Argument_Association
(Loc
,
12760 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12762 Make_Pragma_Argument_Association
(Loc
,
12763 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12766 -------------------------------
12767 -- Default_Initial_Condition --
12768 -------------------------------
12770 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12772 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12779 Check_No_Identifiers
;
12780 Check_At_Most_N_Arguments
(1);
12783 while Present
(Stmt
) loop
12785 -- Skip prior pragmas, but check for duplicates
12787 if Nkind
(Stmt
) = N_Pragma
then
12788 if Pragma_Name
(Stmt
) = Pname
then
12789 Error_Msg_Name_1
:= Pname
;
12790 Error_Msg_Sloc
:= Sloc
(Stmt
);
12791 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12794 -- Skip internally generated code
12796 elsif not Comes_From_Source
(Stmt
) then
12799 -- The associated private type [extension] has been found, stop
12802 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12803 N_Private_Type_Declaration
)
12805 Typ
:= Defining_Entity
(Stmt
);
12808 -- The pragma does not apply to a legal construct, issue an
12809 -- error and stop the analysis.
12816 Stmt
:= Prev
(Stmt
);
12819 Set_Has_Default_Init_Cond
(Typ
);
12820 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12822 -- Chain the pragma on the rep item chain for further processing
12824 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12825 end Default_Init_Cond
;
12827 ----------------------------------
12828 -- Default_Scalar_Storage_Order --
12829 ----------------------------------
12831 -- pragma Default_Scalar_Storage_Order
12832 -- (High_Order_First | Low_Order_First);
12834 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12835 Default
: Character;
12839 Check_Arg_Count
(1);
12841 -- Default_Scalar_Storage_Order can appear as a configuration
12842 -- pragma, or in a declarative part of a package spec.
12844 if not Is_Configuration_Pragma
then
12845 Check_Is_In_Decl_Part_Or_Package_Spec
;
12848 Check_No_Identifiers
;
12849 Check_Arg_Is_One_Of
12850 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12851 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12852 Default
:= Fold_Upper
(Name_Buffer
(1));
12854 if not Support_Nondefault_SSO_On_Target
12855 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12857 if Warn_On_Unrecognized_Pragma
then
12859 ("non-default Scalar_Storage_Order not supported "
12860 & "on target?g?", N
);
12862 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12865 -- Here set the specified default
12868 Opt
.Default_SSO
:= Default
;
12872 --------------------------
12873 -- Default_Storage_Pool --
12874 --------------------------
12876 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12878 when Pragma_Default_Storage_Pool
=>
12880 Check_Arg_Count
(1);
12882 -- Default_Storage_Pool can appear as a configuration pragma, or
12883 -- in a declarative part of a package spec.
12885 if not Is_Configuration_Pragma
then
12886 Check_Is_In_Decl_Part_Or_Package_Spec
;
12889 -- Case of Default_Storage_Pool (null);
12891 if Nkind
(Expression
(Arg1
)) = N_Null
then
12892 Analyze
(Expression
(Arg1
));
12894 -- This is an odd case, this is not really an expression, so
12895 -- we don't have a type for it. So just set the type to Empty.
12897 Set_Etype
(Expression
(Arg1
), Empty
);
12899 -- Case of Default_Storage_Pool (storage_pool_NAME);
12902 -- If it's a configuration pragma, then the only allowed
12903 -- argument is "null".
12905 if Is_Configuration_Pragma
then
12906 Error_Pragma_Arg
("NULL expected", Arg1
);
12909 -- The expected type for a non-"null" argument is
12910 -- Root_Storage_Pool'Class, and the pool must be a variable.
12912 Analyze_And_Resolve
12913 (Get_Pragma_Arg
(Arg1
),
12914 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12916 if not Is_Variable
(Expression
(Arg1
)) then
12918 ("default storage pool must be a variable", Arg1
);
12922 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12923 -- for an access type will use this information to set the
12924 -- appropriate attributes of the access type.
12926 Default_Pool
:= Expression
(Arg1
);
12932 -- pragma Depends (DEPENDENCY_RELATION);
12934 -- DEPENDENCY_RELATION ::=
12936 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12938 -- DEPENDENCY_CLAUSE ::=
12939 -- OUTPUT_LIST =>[+] INPUT_LIST
12940 -- | NULL_DEPENDENCY_CLAUSE
12942 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12944 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12946 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12948 -- OUTPUT ::= NAME | FUNCTION_RESULT
12951 -- where FUNCTION_RESULT is a function Result attribute_reference
12953 when Pragma_Depends
=> Depends
: declare
12954 Subp_Decl
: Node_Id
;
12958 Check_Arg_Count
(1);
12959 Ensure_Aggregate_Form
(Arg1
);
12961 -- Ensure the proper placement of the pragma. Depends must be
12962 -- associated with a subprogram declaration or a body that acts
12966 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12968 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12971 -- Body acts as spec
12973 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12974 and then No
(Corresponding_Spec
(Subp_Decl
))
12978 -- Body stub acts as spec
12980 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12981 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12990 -- When the pragma appears on a subprogram body, perform the full
12993 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12994 Analyze_Depends_In_Decl_Part
(N
);
12996 -- When Depends applies to a subprogram compilation unit, the
12997 -- corresponding pragma is placed after the unit's declaration
12998 -- node and needs to be analyzed immediately.
13000 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13001 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
13003 Analyze_Depends_In_Decl_Part
(N
);
13006 -- Chain the pragma on the contract for further processing
13008 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13011 ---------------------
13012 -- Detect_Blocking --
13013 ---------------------
13015 -- pragma Detect_Blocking;
13017 when Pragma_Detect_Blocking
=>
13019 Check_Arg_Count
(0);
13020 Check_Valid_Configuration_Pragma
;
13021 Detect_Blocking
:= True;
13023 ------------------------------------
13024 -- Disable_Atomic_Synchronization --
13025 ------------------------------------
13027 -- pragma Disable_Atomic_Synchronization [(Entity)];
13029 when Pragma_Disable_Atomic_Synchronization
=>
13031 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13033 -------------------
13034 -- Discard_Names --
13035 -------------------
13037 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13039 when Pragma_Discard_Names
=> Discard_Names
: declare
13044 Check_Ada_83_Warning
;
13046 -- Deal with configuration pragma case
13048 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13049 Global_Discard_Names
:= True;
13052 -- Otherwise, check correct appropriate context
13055 Check_Is_In_Decl_Part_Or_Package_Spec
;
13057 if Arg_Count
= 0 then
13059 -- If there is no parameter, then from now on this pragma
13060 -- applies to any enumeration, exception or tagged type
13061 -- defined in the current declarative part, and recursively
13062 -- to any nested scope.
13064 Set_Discard_Names
(Current_Scope
);
13068 Check_Arg_Count
(1);
13069 Check_Optional_Identifier
(Arg1
, Name_On
);
13070 Check_Arg_Is_Local_Name
(Arg1
);
13072 E_Id
:= Get_Pragma_Arg
(Arg1
);
13074 if Etype
(E_Id
) = Any_Type
then
13077 E
:= Entity
(E_Id
);
13080 if (Is_First_Subtype
(E
)
13082 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13083 or else Ekind
(E
) = E_Exception
13085 Set_Discard_Names
(E
);
13086 Record_Rep_Item
(E
, N
);
13090 ("inappropriate entity for pragma%", Arg1
);
13097 ------------------------
13098 -- Dispatching_Domain --
13099 ------------------------
13101 -- pragma Dispatching_Domain (EXPRESSION);
13103 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13104 P
: constant Node_Id
:= Parent
(N
);
13110 Check_No_Identifiers
;
13111 Check_Arg_Count
(1);
13113 -- This pragma is born obsolete, but not the aspect
13115 if not From_Aspect_Specification
(N
) then
13117 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13120 if Nkind
(P
) = N_Task_Definition
then
13121 Arg
:= Get_Pragma_Arg
(Arg1
);
13122 Ent
:= Defining_Identifier
(Parent
(P
));
13124 -- The expression must be analyzed in the special manner
13125 -- described in "Handling of Default and Per-Object
13126 -- Expressions" in sem.ads.
13128 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13130 -- Check duplicate pragma before we chain the pragma in the Rep
13131 -- Item chain of Ent.
13133 Check_Duplicate_Pragma
(Ent
);
13134 Record_Rep_Item
(Ent
, N
);
13136 -- Anything else is incorrect
13141 end Dispatching_Domain
;
13147 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13149 when Pragma_Elaborate
=> Elaborate
: declare
13154 -- Pragma must be in context items list of a compilation unit
13156 if not Is_In_Context_Clause
then
13160 -- Must be at least one argument
13162 if Arg_Count
= 0 then
13163 Error_Pragma
("pragma% requires at least one argument");
13166 -- In Ada 83 mode, there can be no items following it in the
13167 -- context list except other pragmas and implicit with clauses
13168 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13169 -- placement rule does not apply.
13171 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13173 while Present
(Citem
) loop
13174 if Nkind
(Citem
) = N_Pragma
13175 or else (Nkind
(Citem
) = N_With_Clause
13176 and then Implicit_With
(Citem
))
13181 ("(Ada 83) pragma% must be at end of context clause");
13188 -- Finally, the arguments must all be units mentioned in a with
13189 -- clause in the same context clause. Note we already checked (in
13190 -- Par.Prag) that the arguments are all identifiers or selected
13194 Outer
: while Present
(Arg
) loop
13195 Citem
:= First
(List_Containing
(N
));
13196 Inner
: while Citem
/= N
loop
13197 if Nkind
(Citem
) = N_With_Clause
13198 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13200 Set_Elaborate_Present
(Citem
, True);
13201 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13202 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
13204 -- With the pragma present, elaboration calls on
13205 -- subprograms from the named unit need no further
13206 -- checks, as long as the pragma appears in the current
13207 -- compilation unit. If the pragma appears in some unit
13208 -- in the context, there might still be a need for an
13209 -- Elaborate_All_Desirable from the current compilation
13210 -- to the named unit, so we keep the check enabled.
13212 if In_Extended_Main_Source_Unit
(N
) then
13214 -- This does not apply in SPARK mode, where we allow
13215 -- pragma Elaborate, but we don't trust it to be right
13216 -- so we will still insist on the Elaborate_All.
13218 if SPARK_Mode
/= On
then
13219 Set_Suppress_Elaboration_Warnings
13220 (Entity
(Name
(Citem
)));
13232 ("argument of pragma% is not withed unit", Arg
);
13238 -- Give a warning if operating in static mode with one of the
13239 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13242 and not Dynamic_Elaboration_Checks
13244 -- pragma Elaborate not allowed in SPARK mode anyway. We
13245 -- already complained about it, no point in generating any
13246 -- further complaint.
13248 and SPARK_Mode
/= On
13251 ("?l?use of pragma Elaborate may not be safe", N
);
13253 ("?l?use pragma Elaborate_All instead if possible", N
);
13257 -------------------
13258 -- Elaborate_All --
13259 -------------------
13261 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13263 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13268 Check_Ada_83_Warning
;
13270 -- Pragma must be in context items list of a compilation unit
13272 if not Is_In_Context_Clause
then
13276 -- Must be at least one argument
13278 if Arg_Count
= 0 then
13279 Error_Pragma
("pragma% requires at least one argument");
13282 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13283 -- have to appear at the end of the context clause, but may
13284 -- appear mixed in with other items, even in Ada 83 mode.
13286 -- Final check: the arguments must all be units mentioned in
13287 -- a with clause in the same context clause. Note that we
13288 -- already checked (in Par.Prag) that all the arguments are
13289 -- either identifiers or selected components.
13292 Outr
: while Present
(Arg
) loop
13293 Citem
:= First
(List_Containing
(N
));
13294 Innr
: while Citem
/= N
loop
13295 if Nkind
(Citem
) = N_With_Clause
13296 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13298 Set_Elaborate_All_Present
(Citem
, True);
13299 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13301 -- Suppress warnings and elaboration checks on the named
13302 -- unit if the pragma is in the current compilation, as
13303 -- for pragma Elaborate.
13305 if In_Extended_Main_Source_Unit
(N
) then
13306 Set_Suppress_Elaboration_Warnings
13307 (Entity
(Name
(Citem
)));
13316 Set_Error_Posted
(N
);
13318 ("argument of pragma% is not withed unit", Arg
);
13325 --------------------
13326 -- Elaborate_Body --
13327 --------------------
13329 -- pragma Elaborate_Body [( library_unit_NAME )];
13331 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13332 Cunit_Node
: Node_Id
;
13333 Cunit_Ent
: Entity_Id
;
13336 Check_Ada_83_Warning
;
13337 Check_Valid_Library_Unit_Pragma
;
13339 if Nkind
(N
) = N_Null_Statement
then
13343 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13344 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13346 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13349 Error_Pragma
("pragma% must refer to a spec, not a body");
13351 Set_Body_Required
(Cunit_Node
, True);
13352 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13354 -- If we are in dynamic elaboration mode, then we suppress
13355 -- elaboration warnings for the unit, since it is definitely
13356 -- fine NOT to do dynamic checks at the first level (and such
13357 -- checks will be suppressed because no elaboration boolean
13358 -- is created for Elaborate_Body packages).
13360 -- But in the static model of elaboration, Elaborate_Body is
13361 -- definitely NOT good enough to ensure elaboration safety on
13362 -- its own, since the body may WITH other units that are not
13363 -- safe from an elaboration point of view, so a client must
13364 -- still do an Elaborate_All on such units.
13366 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13367 -- Elaborate_Body always suppressed elab warnings.
13369 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13370 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13373 end Elaborate_Body
;
13375 ------------------------
13376 -- Elaboration_Checks --
13377 ------------------------
13379 -- pragma Elaboration_Checks (Static | Dynamic);
13381 when Pragma_Elaboration_Checks
=>
13383 Check_Arg_Count
(1);
13384 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13386 -- Set flag accordingly (ignore attempt at dynamic elaboration
13387 -- checks in SPARK mode).
13389 Dynamic_Elaboration_Checks
:=
13390 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13391 and then SPARK_Mode
/= On
;
13397 -- pragma Eliminate (
13398 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13399 -- [,[Entity =>] IDENTIFIER |
13400 -- SELECTED_COMPONENT |
13402 -- [, OVERLOADING_RESOLUTION]);
13404 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13407 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13408 -- FUNCTION_PROFILE
13410 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13412 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13413 -- Result_Type => result_SUBTYPE_NAME]
13415 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13416 -- SUBTYPE_NAME ::= STRING_LITERAL
13418 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13419 -- SOURCE_TRACE ::= STRING_LITERAL
13421 when Pragma_Eliminate
=> Eliminate
: declare
13422 Args
: Args_List
(1 .. 5);
13423 Names
: constant Name_List
(1 .. 5) := (
13426 Name_Parameter_Types
,
13428 Name_Source_Location
);
13430 Unit_Name
: Node_Id
renames Args
(1);
13431 Entity
: Node_Id
renames Args
(2);
13432 Parameter_Types
: Node_Id
renames Args
(3);
13433 Result_Type
: Node_Id
renames Args
(4);
13434 Source_Location
: Node_Id
renames Args
(5);
13438 Check_Valid_Configuration_Pragma
;
13439 Gather_Associations
(Names
, Args
);
13441 if No
(Unit_Name
) then
13442 Error_Pragma
("missing Unit_Name argument for pragma%");
13446 and then (Present
(Parameter_Types
)
13448 Present
(Result_Type
)
13450 Present
(Source_Location
))
13452 Error_Pragma
("missing Entity argument for pragma%");
13455 if (Present
(Parameter_Types
)
13457 Present
(Result_Type
))
13459 Present
(Source_Location
)
13462 ("parameter profile and source location cannot be used "
13463 & "together in pragma%");
13466 Process_Eliminate_Pragma
13475 -----------------------------------
13476 -- Enable_Atomic_Synchronization --
13477 -----------------------------------
13479 -- pragma Enable_Atomic_Synchronization [(Entity)];
13481 when Pragma_Enable_Atomic_Synchronization
=>
13483 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13490 -- [ Convention =>] convention_IDENTIFIER,
13491 -- [ Entity =>] LOCAL_NAME
13492 -- [, [External_Name =>] static_string_EXPRESSION ]
13493 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13495 when Pragma_Export
=> Export
: declare
13497 Def_Id
: Entity_Id
;
13499 pragma Warnings
(Off
, C
);
13502 Check_Ada_83_Warning
;
13506 Name_External_Name
,
13509 Check_At_Least_N_Arguments
(2);
13510 Check_At_Most_N_Arguments
(4);
13512 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13513 -- pragma Export (Entity, "external name");
13515 if Relaxed_RM_Semantics
13516 and then Arg_Count
= 2
13517 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13520 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13523 if not Is_Entity_Name
(Def_Id
) then
13524 Error_Pragma_Arg
("entity name required", Arg1
);
13527 Def_Id
:= Entity
(Def_Id
);
13528 Set_Exported
(Def_Id
, Arg1
);
13531 Process_Convention
(C
, Def_Id
);
13533 if Ekind
(Def_Id
) /= E_Constant
then
13534 Note_Possible_Modification
13535 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13538 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13539 Set_Exported
(Def_Id
, Arg2
);
13542 -- If the entity is a deferred constant, propagate the information
13543 -- to the full view, because gigi elaborates the full view only.
13545 if Ekind
(Def_Id
) = E_Constant
13546 and then Present
(Full_View
(Def_Id
))
13549 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13551 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13552 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13553 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13558 ---------------------
13559 -- Export_Function --
13560 ---------------------
13562 -- pragma Export_Function (
13563 -- [Internal =>] LOCAL_NAME
13564 -- [, [External =>] EXTERNAL_SYMBOL]
13565 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13566 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13567 -- [, [Mechanism =>] MECHANISM]
13568 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13570 -- EXTERNAL_SYMBOL ::=
13572 -- | static_string_EXPRESSION
13574 -- PARAMETER_TYPES ::=
13576 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13578 -- TYPE_DESIGNATOR ::=
13580 -- | subtype_Name ' Access
13584 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13586 -- MECHANISM_ASSOCIATION ::=
13587 -- [formal_parameter_NAME =>] MECHANISM_NAME
13589 -- MECHANISM_NAME ::=
13593 when Pragma_Export_Function
=> Export_Function
: declare
13594 Args
: Args_List
(1 .. 6);
13595 Names
: constant Name_List
(1 .. 6) := (
13598 Name_Parameter_Types
,
13601 Name_Result_Mechanism
);
13603 Internal
: Node_Id
renames Args
(1);
13604 External
: Node_Id
renames Args
(2);
13605 Parameter_Types
: Node_Id
renames Args
(3);
13606 Result_Type
: Node_Id
renames Args
(4);
13607 Mechanism
: Node_Id
renames Args
(5);
13608 Result_Mechanism
: Node_Id
renames Args
(6);
13612 Gather_Associations
(Names
, Args
);
13613 Process_Extended_Import_Export_Subprogram_Pragma
(
13614 Arg_Internal
=> Internal
,
13615 Arg_External
=> External
,
13616 Arg_Parameter_Types
=> Parameter_Types
,
13617 Arg_Result_Type
=> Result_Type
,
13618 Arg_Mechanism
=> Mechanism
,
13619 Arg_Result_Mechanism
=> Result_Mechanism
);
13620 end Export_Function
;
13622 -------------------
13623 -- Export_Object --
13624 -------------------
13626 -- pragma Export_Object (
13627 -- [Internal =>] LOCAL_NAME
13628 -- [, [External =>] EXTERNAL_SYMBOL]
13629 -- [, [Size =>] EXTERNAL_SYMBOL]);
13631 -- EXTERNAL_SYMBOL ::=
13633 -- | static_string_EXPRESSION
13635 -- PARAMETER_TYPES ::=
13637 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13639 -- TYPE_DESIGNATOR ::=
13641 -- | subtype_Name ' Access
13645 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13647 -- MECHANISM_ASSOCIATION ::=
13648 -- [formal_parameter_NAME =>] MECHANISM_NAME
13650 -- MECHANISM_NAME ::=
13654 when Pragma_Export_Object
=> Export_Object
: declare
13655 Args
: Args_List
(1 .. 3);
13656 Names
: constant Name_List
(1 .. 3) := (
13661 Internal
: Node_Id
renames Args
(1);
13662 External
: Node_Id
renames Args
(2);
13663 Size
: Node_Id
renames Args
(3);
13667 Gather_Associations
(Names
, Args
);
13668 Process_Extended_Import_Export_Object_Pragma
(
13669 Arg_Internal
=> Internal
,
13670 Arg_External
=> External
,
13674 ----------------------
13675 -- Export_Procedure --
13676 ----------------------
13678 -- pragma Export_Procedure (
13679 -- [Internal =>] LOCAL_NAME
13680 -- [, [External =>] EXTERNAL_SYMBOL]
13681 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13682 -- [, [Mechanism =>] MECHANISM]);
13684 -- EXTERNAL_SYMBOL ::=
13686 -- | static_string_EXPRESSION
13688 -- PARAMETER_TYPES ::=
13690 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13692 -- TYPE_DESIGNATOR ::=
13694 -- | subtype_Name ' Access
13698 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13700 -- MECHANISM_ASSOCIATION ::=
13701 -- [formal_parameter_NAME =>] MECHANISM_NAME
13703 -- MECHANISM_NAME ::=
13707 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13708 Args
: Args_List
(1 .. 4);
13709 Names
: constant Name_List
(1 .. 4) := (
13712 Name_Parameter_Types
,
13715 Internal
: Node_Id
renames Args
(1);
13716 External
: Node_Id
renames Args
(2);
13717 Parameter_Types
: Node_Id
renames Args
(3);
13718 Mechanism
: Node_Id
renames Args
(4);
13722 Gather_Associations
(Names
, Args
);
13723 Process_Extended_Import_Export_Subprogram_Pragma
(
13724 Arg_Internal
=> Internal
,
13725 Arg_External
=> External
,
13726 Arg_Parameter_Types
=> Parameter_Types
,
13727 Arg_Mechanism
=> Mechanism
);
13728 end Export_Procedure
;
13734 -- pragma Export_Value (
13735 -- [Value =>] static_integer_EXPRESSION,
13736 -- [Link_Name =>] static_string_EXPRESSION);
13738 when Pragma_Export_Value
=>
13740 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13741 Check_Arg_Count
(2);
13743 Check_Optional_Identifier
(Arg1
, Name_Value
);
13744 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13746 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13747 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13749 -----------------------------
13750 -- Export_Valued_Procedure --
13751 -----------------------------
13753 -- pragma Export_Valued_Procedure (
13754 -- [Internal =>] LOCAL_NAME
13755 -- [, [External =>] EXTERNAL_SYMBOL,]
13756 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13757 -- [, [Mechanism =>] MECHANISM]);
13759 -- EXTERNAL_SYMBOL ::=
13761 -- | static_string_EXPRESSION
13763 -- PARAMETER_TYPES ::=
13765 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13767 -- TYPE_DESIGNATOR ::=
13769 -- | subtype_Name ' Access
13773 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13775 -- MECHANISM_ASSOCIATION ::=
13776 -- [formal_parameter_NAME =>] MECHANISM_NAME
13778 -- MECHANISM_NAME ::=
13782 when Pragma_Export_Valued_Procedure
=>
13783 Export_Valued_Procedure
: declare
13784 Args
: Args_List
(1 .. 4);
13785 Names
: constant Name_List
(1 .. 4) := (
13788 Name_Parameter_Types
,
13791 Internal
: Node_Id
renames Args
(1);
13792 External
: Node_Id
renames Args
(2);
13793 Parameter_Types
: Node_Id
renames Args
(3);
13794 Mechanism
: Node_Id
renames Args
(4);
13798 Gather_Associations
(Names
, Args
);
13799 Process_Extended_Import_Export_Subprogram_Pragma
(
13800 Arg_Internal
=> Internal
,
13801 Arg_External
=> External
,
13802 Arg_Parameter_Types
=> Parameter_Types
,
13803 Arg_Mechanism
=> Mechanism
);
13804 end Export_Valued_Procedure
;
13806 -------------------
13807 -- Extend_System --
13808 -------------------
13810 -- pragma Extend_System ([Name =>] Identifier);
13812 when Pragma_Extend_System
=> Extend_System
: declare
13815 Check_Valid_Configuration_Pragma
;
13816 Check_Arg_Count
(1);
13817 Check_Optional_Identifier
(Arg1
, Name_Name
);
13818 Check_Arg_Is_Identifier
(Arg1
);
13820 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13823 and then Name_Buffer
(1 .. 4) = "aux_"
13825 if Present
(System_Extend_Pragma_Arg
) then
13826 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13827 Chars
(Expression
(System_Extend_Pragma_Arg
))
13831 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13832 Error_Pragma
("pragma% conflicts with that #");
13836 System_Extend_Pragma_Arg
:= Arg1
;
13838 if not GNAT_Mode
then
13839 System_Extend_Unit
:= Arg1
;
13843 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13847 ------------------------
13848 -- Extensions_Allowed --
13849 ------------------------
13851 -- pragma Extensions_Allowed (ON | OFF);
13853 when Pragma_Extensions_Allowed
=>
13855 Check_Arg_Count
(1);
13856 Check_No_Identifiers
;
13857 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13859 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13860 Extensions_Allowed
:= True;
13861 Ada_Version
:= Ada_Version_Type
'Last;
13864 Extensions_Allowed
:= False;
13865 Ada_Version
:= Ada_Version_Explicit
;
13866 Ada_Version_Pragma
:= Empty
;
13869 ------------------------
13870 -- Extensions_Visible --
13871 ------------------------
13873 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13875 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13876 Context
: constant Node_Id
:= Parent
(N
);
13878 Formal
: Entity_Id
;
13879 Orig_Stmt
: Node_Id
;
13883 Has_OK_Formal
: Boolean := False;
13887 Check_No_Identifiers
;
13888 Check_At_Most_N_Arguments
(1);
13892 while Present
(Stmt
) loop
13894 -- Skip prior pragmas, but check for duplicates
13896 if Nkind
(Stmt
) = N_Pragma
then
13897 if Pragma_Name
(Stmt
) = Pname
then
13898 Error_Msg_Name_1
:= Pname
;
13899 Error_Msg_Sloc
:= Sloc
(Stmt
);
13900 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13903 -- Skip internally generated code
13905 elsif not Comes_From_Source
(Stmt
) then
13906 Orig_Stmt
:= Original_Node
(Stmt
);
13908 -- When pragma Ghost applies to an expression function, the
13909 -- expression function is transformed into a subprogram.
13911 if Nkind
(Stmt
) = N_Subprogram_Declaration
13912 and then Comes_From_Source
(Orig_Stmt
)
13913 and then Nkind
(Orig_Stmt
) = N_Expression_Function
13915 Subp
:= Defining_Entity
(Stmt
);
13919 -- The associated [generic] subprogram declaration has been
13920 -- found, stop the search.
13922 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
13923 N_Subprogram_Declaration
)
13925 Subp
:= Defining_Entity
(Stmt
);
13928 -- The pragma does not apply to a legal construct, issue an
13929 -- error and stop the analysis.
13932 Error_Pragma
("pragma % must apply to a subprogram");
13936 Stmt
:= Prev
(Stmt
);
13939 -- When the pragma applies to a stand alone subprogram body, it
13940 -- appears within the declarations of the body. In that case the
13941 -- enclosing construct is the proper context. This check is done
13942 -- after the traversal above to allow for duplicate detection.
13945 and then Nkind
(Context
) = N_Subprogram_Body
13946 and then No
(Corresponding_Spec
(Context
))
13948 Subp
:= Defining_Entity
(Context
);
13952 Error_Pragma
("pragma % must apply to a subprogram");
13956 -- Examine the formals of the related subprogram
13958 Formal
:= First_Formal
(Subp
);
13959 while Present
(Formal
) loop
13961 -- At least one of the formals is of a specific tagged type,
13962 -- the pragma is legal.
13964 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13965 Has_OK_Formal
:= True;
13968 -- A generic subprogram with at least one formal of a private
13969 -- type ensures the legality of the pragma because the actual
13970 -- may be specifically tagged. Note that this is verified by
13971 -- the check above at instantiation time.
13973 elsif Is_Private_Type
(Etype
(Formal
))
13974 and then Is_Generic_Type
(Etype
(Formal
))
13976 Has_OK_Formal
:= True;
13980 Next_Formal
(Formal
);
13983 if not Has_OK_Formal
then
13984 Error_Msg_Name_1
:= Pname
;
13985 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
13987 ("\subprogram & lacks parameter of specific tagged or "
13988 & "generic private type", N
, Subp
);
13992 -- Analyze the Boolean expression (if any)
13994 if Present
(Arg1
) then
13995 Expr
:= Get_Pragma_Arg
(Arg1
);
13997 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
13999 if not Is_OK_Static_Expression
(Expr
) then
14001 ("expression of pragma % must be static", Expr
);
14006 -- Chain the pragma on the contract for further processing
14008 Add_Contract_Item
(N
, Subp
);
14009 end Extensions_Visible
;
14015 -- pragma External (
14016 -- [ Convention =>] convention_IDENTIFIER,
14017 -- [ Entity =>] LOCAL_NAME
14018 -- [, [External_Name =>] static_string_EXPRESSION ]
14019 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14021 when Pragma_External
=> External
: declare
14022 Def_Id
: Entity_Id
;
14025 pragma Warnings
(Off
, C
);
14032 Name_External_Name
,
14034 Check_At_Least_N_Arguments
(2);
14035 Check_At_Most_N_Arguments
(4);
14036 Process_Convention
(C
, Def_Id
);
14037 Note_Possible_Modification
14038 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14039 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14040 Set_Exported
(Def_Id
, Arg2
);
14043 --------------------------
14044 -- External_Name_Casing --
14045 --------------------------
14047 -- pragma External_Name_Casing (
14048 -- UPPERCASE | LOWERCASE
14049 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14051 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14054 Check_No_Identifiers
;
14056 if Arg_Count
= 2 then
14057 Check_Arg_Is_One_Of
14058 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14060 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14062 Opt
.External_Name_Exp_Casing
:= As_Is
;
14064 when Name_Uppercase
=>
14065 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14067 when Name_Lowercase
=>
14068 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14075 Check_Arg_Count
(1);
14078 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14080 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14081 when Name_Uppercase
=>
14082 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14084 when Name_Lowercase
=>
14085 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14090 end External_Name_Casing
;
14096 -- pragma Fast_Math;
14098 when Pragma_Fast_Math
=>
14100 Check_No_Identifiers
;
14101 Check_Valid_Configuration_Pragma
;
14104 --------------------------
14105 -- Favor_Top_Level --
14106 --------------------------
14108 -- pragma Favor_Top_Level (type_NAME);
14110 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14111 Named_Entity
: Entity_Id
;
14115 Check_No_Identifiers
;
14116 Check_Arg_Count
(1);
14117 Check_Arg_Is_Local_Name
(Arg1
);
14118 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14120 -- If it's an access-to-subprogram type (in particular, not a
14121 -- subtype), set the flag on that type.
14123 if Is_Access_Subprogram_Type
(Named_Entity
) then
14124 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14126 -- Otherwise it's an error (name denotes the wrong sort of entity)
14130 ("access-to-subprogram type expected",
14131 Get_Pragma_Arg
(Arg1
));
14133 end Favor_Top_Level
;
14135 ---------------------------
14136 -- Finalize_Storage_Only --
14137 ---------------------------
14139 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14141 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14142 Assoc
: constant Node_Id
:= Arg1
;
14143 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14148 Check_No_Identifiers
;
14149 Check_Arg_Count
(1);
14150 Check_Arg_Is_Local_Name
(Arg1
);
14152 Find_Type
(Type_Id
);
14153 Typ
:= Entity
(Type_Id
);
14156 or else Rep_Item_Too_Early
(Typ
, N
)
14160 Typ
:= Underlying_Type
(Typ
);
14163 if not Is_Controlled
(Typ
) then
14164 Error_Pragma
("pragma% must specify controlled type");
14167 Check_First_Subtype
(Arg1
);
14169 if Finalize_Storage_Only
(Typ
) then
14170 Error_Pragma
("duplicate pragma%, only one allowed");
14172 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14173 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14175 end Finalize_Storage
;
14181 -- pragma Ghost [ (boolean_EXPRESSION) ];
14183 when Pragma_Ghost
=> Ghost
: declare
14187 Orig_Stmt
: Node_Id
;
14188 Prev_Id
: Entity_Id
;
14193 Check_No_Identifiers
;
14194 Check_At_Most_N_Arguments
(1);
14196 Context
:= Parent
(N
);
14198 -- Handle compilation units
14200 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14201 Context
:= Unit
(Parent
(Context
));
14206 while Present
(Stmt
) loop
14208 -- Skip prior pragmas, but check for duplicates
14210 if Nkind
(Stmt
) = N_Pragma
then
14211 if Pragma_Name
(Stmt
) = Pname
then
14212 Error_Msg_Name_1
:= Pname
;
14213 Error_Msg_Sloc
:= Sloc
(Stmt
);
14214 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14217 -- Protected and task types cannot be subject to pragma Ghost
14219 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
14220 Error_Pragma
("pragma % cannot apply to a protected type");
14223 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
14224 Error_Pragma
("pragma % cannot apply to a task type");
14227 -- Skip internally generated code
14229 elsif not Comes_From_Source
(Stmt
) then
14230 Orig_Stmt
:= Original_Node
(Stmt
);
14232 -- When pragma Ghost applies to an untagged derivation, the
14233 -- derivation is transformed into a [sub]type declaration.
14235 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14236 N_Subtype_Declaration
)
14237 and then Comes_From_Source
(Orig_Stmt
)
14238 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14239 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14240 N_Derived_Type_Definition
14242 Id
:= Defining_Entity
(Stmt
);
14245 -- When pragma Ghost applies to an expression function, the
14246 -- expression function is transformed into a subprogram.
14248 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14249 and then Comes_From_Source
(Orig_Stmt
)
14250 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14252 Id
:= Defining_Entity
(Stmt
);
14256 -- The pragma applies to a legal construct, stop the traversal
14258 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14259 N_Full_Type_Declaration
,
14260 N_Generic_Subprogram_Declaration
,
14261 N_Object_Declaration
,
14262 N_Private_Extension_Declaration
,
14263 N_Private_Type_Declaration
,
14264 N_Subprogram_Declaration
,
14265 N_Subtype_Declaration
)
14267 Id
:= Defining_Entity
(Stmt
);
14270 -- The pragma does not apply to a legal construct, issue an
14271 -- error and stop the analysis.
14275 ("pragma % must apply to an object, package, subprogram "
14280 Stmt
:= Prev
(Stmt
);
14285 -- When pragma Ghost is associated with a [generic] package, it
14286 -- appears in the visible declarations.
14288 if Nkind
(Context
) = N_Package_Specification
14289 and then Present
(Visible_Declarations
(Context
))
14290 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14292 Id
:= Defining_Entity
(Context
);
14294 -- Pragma Ghost applies to a stand alone subprogram body
14296 elsif Nkind
(Context
) = N_Subprogram_Body
14297 and then No
(Corresponding_Spec
(Context
))
14299 Id
:= Defining_Entity
(Context
);
14305 ("pragma % must apply to an object, package, subprogram or "
14310 -- A derived type or type extension cannot be subject to pragma
14311 -- Ghost if either the parent type or one of the progenitor types
14312 -- is not Ghost (SPARK RM 6.9(9)).
14314 if Is_Derived_Type
(Id
) then
14315 Check_Ghost_Derivation
(Id
);
14318 -- Handle completions of types and constants that are subject to
14321 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14322 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14324 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14325 Error_Msg_Name_1
:= Pname
;
14327 -- The full declaration of a deferred constant cannot be
14328 -- subject to pragma Ghost unless the deferred declaration
14329 -- is also Ghost (SPARK RM 6.9(10)).
14331 if Ekind
(Prev_Id
) = E_Constant
then
14332 Error_Msg_Name_1
:= Pname
;
14333 Error_Msg_NE
(Fix_Error
14334 ("pragma % must apply to declaration of deferred "
14335 & "constant &"), N
, Id
);
14338 -- Pragma Ghost may appear on the full view of an incomplete
14339 -- type because the incomplete declaration lacks aspects and
14340 -- cannot be subject to pragma Ghost.
14342 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14345 -- The full declaration of a type cannot be subject to
14346 -- pragma Ghost unless the partial view is also Ghost
14347 -- (SPARK RM 6.9(10)).
14350 Error_Msg_NE
(Fix_Error
14351 ("pragma % must apply to partial view of type &"),
14358 -- Analyze the Boolean expression (if any)
14360 if Present
(Arg1
) then
14361 Expr
:= Get_Pragma_Arg
(Arg1
);
14363 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14365 if Is_OK_Static_Expression
(Expr
) then
14367 -- "Ghostness" cannot be turned off once enabled within a
14368 -- region (SPARK RM 6.9(7)).
14370 if Is_False
(Expr_Value
(Expr
))
14371 and then Within_Ghost_Scope
14374 ("pragma % with value False cannot appear in enabled "
14379 -- Otherwie the expression is not static
14383 ("expression of pragma % must be static", Expr
);
14388 Set_Is_Ghost_Entity
(Id
);
14395 -- pragma Global (GLOBAL_SPECIFICATION);
14397 -- GLOBAL_SPECIFICATION ::=
14400 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14402 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14404 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14405 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14406 -- GLOBAL_ITEM ::= NAME
14408 when Pragma_Global
=> Global
: declare
14409 Subp_Decl
: Node_Id
;
14413 Check_Arg_Count
(1);
14414 Ensure_Aggregate_Form
(Arg1
);
14416 -- Ensure the proper placement of the pragma. Global must be
14417 -- associated with a subprogram declaration or a body that acts
14421 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14423 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14426 -- Body acts as spec
14428 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14429 and then No
(Corresponding_Spec
(Subp_Decl
))
14433 -- Body stub acts as spec
14435 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14436 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14445 -- When the pragma appears on a subprogram body, perform the full
14448 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14449 Analyze_Global_In_Decl_Part
(N
);
14451 -- When Global applies to a subprogram compilation unit, the
14452 -- corresponding pragma is placed after the unit's declaration
14453 -- node and needs to be analyzed immediately.
14455 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14456 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14458 Analyze_Global_In_Decl_Part
(N
);
14461 -- Chain the pragma on the contract for further processing
14463 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14470 -- pragma Ident (static_string_EXPRESSION)
14472 -- Note: pragma Comment shares this processing. Pragma Ident is
14473 -- identical in effect to pragma Commment.
14475 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14480 Check_Arg_Count
(1);
14481 Check_No_Identifiers
;
14482 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14485 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14492 GP
:= Parent
(Parent
(N
));
14494 if Nkind_In
(GP
, N_Package_Declaration
,
14495 N_Generic_Package_Declaration
)
14500 -- If we have a compilation unit, then record the ident value,
14501 -- checking for improper duplication.
14503 if Nkind
(GP
) = N_Compilation_Unit
then
14504 CS
:= Ident_String
(Current_Sem_Unit
);
14506 if Present
(CS
) then
14508 -- If we have multiple instances, concatenate them, but
14509 -- not in ASIS, where we want the original tree.
14511 if not ASIS_Mode
then
14512 Start_String
(Strval
(CS
));
14513 Store_String_Char
(' ');
14514 Store_String_Chars
(Strval
(Str
));
14515 Set_Strval
(CS
, End_String
);
14519 Set_Ident_String
(Current_Sem_Unit
, Str
);
14522 -- For subunits, we just ignore the Ident, since in GNAT these
14523 -- are not separate object files, and hence not separate units
14524 -- in the unit table.
14526 elsif Nkind
(GP
) = N_Subunit
then
14532 ----------------------------
14533 -- Implementation_Defined --
14534 ----------------------------
14536 -- pragma Implementation_Defined (LOCAL_NAME);
14538 -- Marks previously declared entity as implementation defined. For
14539 -- an overloaded entity, applies to the most recent homonym.
14541 -- pragma Implementation_Defined;
14543 -- The form with no arguments appears anywhere within a scope, most
14544 -- typically a package spec, and indicates that all entities that are
14545 -- defined within the package spec are Implementation_Defined.
14547 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14552 Check_No_Identifiers
;
14554 -- Form with no arguments
14556 if Arg_Count
= 0 then
14557 Set_Is_Implementation_Defined
(Current_Scope
);
14559 -- Form with one argument
14562 Check_Arg_Count
(1);
14563 Check_Arg_Is_Local_Name
(Arg1
);
14564 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14565 Set_Is_Implementation_Defined
(Ent
);
14567 end Implementation_Defined
;
14573 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14575 -- IMPLEMENTATION_KIND ::=
14576 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14578 -- "By_Any" and "Optional" are treated as synonyms in order to
14579 -- support Ada 2012 aspect Synchronization.
14581 when Pragma_Implemented
=> Implemented
: declare
14582 Proc_Id
: Entity_Id
;
14587 Check_Arg_Count
(2);
14588 Check_No_Identifiers
;
14589 Check_Arg_Is_Identifier
(Arg1
);
14590 Check_Arg_Is_Local_Name
(Arg1
);
14591 Check_Arg_Is_One_Of
(Arg2
,
14594 Name_By_Protected_Procedure
,
14597 -- Extract the name of the local procedure
14599 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14601 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14602 -- primitive procedure of a synchronized tagged type.
14604 if Ekind
(Proc_Id
) = E_Procedure
14605 and then Is_Primitive
(Proc_Id
)
14606 and then Present
(First_Formal
(Proc_Id
))
14608 Typ
:= Etype
(First_Formal
(Proc_Id
));
14610 if Is_Tagged_Type
(Typ
)
14613 -- Check for a protected, a synchronized or a task interface
14615 ((Is_Interface
(Typ
)
14616 and then Is_Synchronized_Interface
(Typ
))
14618 -- Check for a protected type or a task type that implements
14622 (Is_Concurrent_Record_Type
(Typ
)
14623 and then Present
(Interfaces
(Typ
)))
14625 -- In analysis-only mode, examine original protected type
14628 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
14629 and then Present
(Interface_List
(Parent
(Typ
))))
14631 -- Check for a private record extension with keyword
14635 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14636 E_Record_Subtype_With_Private
)
14637 and then Synchronized_Present
(Parent
(Typ
))))
14642 ("controlling formal must be of synchronized tagged type",
14647 -- Procedures declared inside a protected type must be accepted
14649 elsif Ekind
(Proc_Id
) = E_Procedure
14650 and then Is_Protected_Type
(Scope
(Proc_Id
))
14654 -- The first argument is not a primitive procedure
14658 ("pragma % must be applied to a primitive procedure", Arg1
);
14662 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14663 -- By_Protected_Procedure to the primitive procedure of a task
14666 if Chars
(Arg2
) = Name_By_Protected_Procedure
14667 and then Is_Interface
(Typ
)
14668 and then Is_Task_Interface
(Typ
)
14671 ("implementation kind By_Protected_Procedure cannot be "
14672 & "applied to a task interface primitive", Arg2
);
14676 Record_Rep_Item
(Proc_Id
, N
);
14679 ----------------------
14680 -- Implicit_Packing --
14681 ----------------------
14683 -- pragma Implicit_Packing;
14685 when Pragma_Implicit_Packing
=>
14687 Check_Arg_Count
(0);
14688 Implicit_Packing
:= True;
14695 -- [Convention =>] convention_IDENTIFIER,
14696 -- [Entity =>] LOCAL_NAME
14697 -- [, [External_Name =>] static_string_EXPRESSION ]
14698 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14700 when Pragma_Import
=>
14701 Check_Ada_83_Warning
;
14705 Name_External_Name
,
14708 Check_At_Least_N_Arguments
(2);
14709 Check_At_Most_N_Arguments
(4);
14710 Process_Import_Or_Interface
;
14712 ---------------------
14713 -- Import_Function --
14714 ---------------------
14716 -- pragma Import_Function (
14717 -- [Internal =>] LOCAL_NAME,
14718 -- [, [External =>] EXTERNAL_SYMBOL]
14719 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14720 -- [, [Result_Type =>] SUBTYPE_MARK]
14721 -- [, [Mechanism =>] MECHANISM]
14722 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14724 -- EXTERNAL_SYMBOL ::=
14726 -- | static_string_EXPRESSION
14728 -- PARAMETER_TYPES ::=
14730 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14732 -- TYPE_DESIGNATOR ::=
14734 -- | subtype_Name ' Access
14738 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14740 -- MECHANISM_ASSOCIATION ::=
14741 -- [formal_parameter_NAME =>] MECHANISM_NAME
14743 -- MECHANISM_NAME ::=
14747 when Pragma_Import_Function
=> Import_Function
: declare
14748 Args
: Args_List
(1 .. 6);
14749 Names
: constant Name_List
(1 .. 6) := (
14752 Name_Parameter_Types
,
14755 Name_Result_Mechanism
);
14757 Internal
: Node_Id
renames Args
(1);
14758 External
: Node_Id
renames Args
(2);
14759 Parameter_Types
: Node_Id
renames Args
(3);
14760 Result_Type
: Node_Id
renames Args
(4);
14761 Mechanism
: Node_Id
renames Args
(5);
14762 Result_Mechanism
: Node_Id
renames Args
(6);
14766 Gather_Associations
(Names
, Args
);
14767 Process_Extended_Import_Export_Subprogram_Pragma
(
14768 Arg_Internal
=> Internal
,
14769 Arg_External
=> External
,
14770 Arg_Parameter_Types
=> Parameter_Types
,
14771 Arg_Result_Type
=> Result_Type
,
14772 Arg_Mechanism
=> Mechanism
,
14773 Arg_Result_Mechanism
=> Result_Mechanism
);
14774 end Import_Function
;
14776 -------------------
14777 -- Import_Object --
14778 -------------------
14780 -- pragma Import_Object (
14781 -- [Internal =>] LOCAL_NAME
14782 -- [, [External =>] EXTERNAL_SYMBOL]
14783 -- [, [Size =>] EXTERNAL_SYMBOL]);
14785 -- EXTERNAL_SYMBOL ::=
14787 -- | static_string_EXPRESSION
14789 when Pragma_Import_Object
=> Import_Object
: declare
14790 Args
: Args_List
(1 .. 3);
14791 Names
: constant Name_List
(1 .. 3) := (
14796 Internal
: Node_Id
renames Args
(1);
14797 External
: Node_Id
renames Args
(2);
14798 Size
: Node_Id
renames Args
(3);
14802 Gather_Associations
(Names
, Args
);
14803 Process_Extended_Import_Export_Object_Pragma
(
14804 Arg_Internal
=> Internal
,
14805 Arg_External
=> External
,
14809 ----------------------
14810 -- Import_Procedure --
14811 ----------------------
14813 -- pragma Import_Procedure (
14814 -- [Internal =>] LOCAL_NAME
14815 -- [, [External =>] EXTERNAL_SYMBOL]
14816 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14817 -- [, [Mechanism =>] MECHANISM]);
14819 -- EXTERNAL_SYMBOL ::=
14821 -- | static_string_EXPRESSION
14823 -- PARAMETER_TYPES ::=
14825 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14827 -- TYPE_DESIGNATOR ::=
14829 -- | subtype_Name ' Access
14833 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14835 -- MECHANISM_ASSOCIATION ::=
14836 -- [formal_parameter_NAME =>] MECHANISM_NAME
14838 -- MECHANISM_NAME ::=
14842 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14843 Args
: Args_List
(1 .. 4);
14844 Names
: constant Name_List
(1 .. 4) := (
14847 Name_Parameter_Types
,
14850 Internal
: Node_Id
renames Args
(1);
14851 External
: Node_Id
renames Args
(2);
14852 Parameter_Types
: Node_Id
renames Args
(3);
14853 Mechanism
: Node_Id
renames Args
(4);
14857 Gather_Associations
(Names
, Args
);
14858 Process_Extended_Import_Export_Subprogram_Pragma
(
14859 Arg_Internal
=> Internal
,
14860 Arg_External
=> External
,
14861 Arg_Parameter_Types
=> Parameter_Types
,
14862 Arg_Mechanism
=> Mechanism
);
14863 end Import_Procedure
;
14865 -----------------------------
14866 -- Import_Valued_Procedure --
14867 -----------------------------
14869 -- pragma Import_Valued_Procedure (
14870 -- [Internal =>] LOCAL_NAME
14871 -- [, [External =>] EXTERNAL_SYMBOL]
14872 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14873 -- [, [Mechanism =>] MECHANISM]);
14875 -- EXTERNAL_SYMBOL ::=
14877 -- | static_string_EXPRESSION
14879 -- PARAMETER_TYPES ::=
14881 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14883 -- TYPE_DESIGNATOR ::=
14885 -- | subtype_Name ' Access
14889 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14891 -- MECHANISM_ASSOCIATION ::=
14892 -- [formal_parameter_NAME =>] MECHANISM_NAME
14894 -- MECHANISM_NAME ::=
14898 when Pragma_Import_Valued_Procedure
=>
14899 Import_Valued_Procedure
: declare
14900 Args
: Args_List
(1 .. 4);
14901 Names
: constant Name_List
(1 .. 4) := (
14904 Name_Parameter_Types
,
14907 Internal
: Node_Id
renames Args
(1);
14908 External
: Node_Id
renames Args
(2);
14909 Parameter_Types
: Node_Id
renames Args
(3);
14910 Mechanism
: Node_Id
renames Args
(4);
14914 Gather_Associations
(Names
, Args
);
14915 Process_Extended_Import_Export_Subprogram_Pragma
(
14916 Arg_Internal
=> Internal
,
14917 Arg_External
=> External
,
14918 Arg_Parameter_Types
=> Parameter_Types
,
14919 Arg_Mechanism
=> Mechanism
);
14920 end Import_Valued_Procedure
;
14926 -- pragma Independent (record_component_LOCAL_NAME);
14928 when Pragma_Independent
=> Independent
: declare
14933 Check_Ada_83_Warning
;
14935 Check_No_Identifiers
;
14936 Check_Arg_Count
(1);
14937 Check_Arg_Is_Local_Name
(Arg1
);
14938 E_Id
:= Get_Pragma_Arg
(Arg1
);
14940 if Etype
(E_Id
) = Any_Type
then
14944 E
:= Entity
(E_Id
);
14946 -- Check we have a record component. We have not yet setup
14947 -- components fully, so identify by syntactic structure.
14949 if Nkind
(Declaration_Node
(E
)) /= N_Component_Declaration
then
14951 ("argument for pragma% must be record component", Arg1
);
14954 -- Check duplicate before we chain ourselves
14956 Check_Duplicate_Pragma
(E
);
14960 if Rep_Item_Too_Early
(E
, N
)
14962 Rep_Item_Too_Late
(E
, N
)
14967 -- Set flag in component
14969 Set_Is_Independent
(E
);
14971 Independence_Checks
.Append
((N
, E
));
14974 ----------------------------
14975 -- Independent_Components --
14976 ----------------------------
14978 -- pragma Atomic_Components (array_LOCAL_NAME);
14980 -- This processing is shared by Volatile_Components
14982 when Pragma_Independent_Components
=> Independent_Components
: declare
14990 Check_Ada_83_Warning
;
14992 Check_No_Identifiers
;
14993 Check_Arg_Count
(1);
14994 Check_Arg_Is_Local_Name
(Arg1
);
14995 E_Id
:= Get_Pragma_Arg
(Arg1
);
14997 if Etype
(E_Id
) = Any_Type
then
15001 E
:= Entity
(E_Id
);
15003 -- Check duplicate before we chain ourselves
15005 Check_Duplicate_Pragma
(E
);
15007 -- Check appropriate entity
15009 if Rep_Item_Too_Early
(E
, N
)
15011 Rep_Item_Too_Late
(E
, N
)
15016 D
:= Declaration_Node
(E
);
15019 if K
= N_Full_Type_Declaration
15020 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15022 Independence_Checks
.Append
((N
, Base_Type
(E
)));
15023 Set_Has_Independent_Components
(Base_Type
(E
));
15025 -- For record type, set all components independent
15027 if Is_Record_Type
(E
) then
15028 C
:= First_Component
(E
);
15029 while Present
(C
) loop
15030 Set_Is_Independent
(C
);
15031 Next_Component
(C
);
15035 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15036 and then Nkind
(D
) = N_Object_Declaration
15037 and then Nkind
(Object_Definition
(D
)) =
15038 N_Constrained_Array_Definition
15040 Independence_Checks
.Append
((N
, Base_Type
(Etype
(E
))));
15041 Set_Has_Independent_Components
(Base_Type
(Etype
(E
)));
15044 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15046 end Independent_Components
;
15048 -----------------------
15049 -- Initial_Condition --
15050 -----------------------
15052 -- pragma Initial_Condition (boolean_EXPRESSION);
15054 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15055 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15056 Pack_Id
: Entity_Id
;
15061 Check_No_Identifiers
;
15062 Check_Arg_Count
(1);
15064 -- Ensure the proper placement of the pragma. Initial_Condition
15065 -- must be associated with a package declaration.
15067 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15068 N_Package_Declaration
)
15075 while Present
(Stmt
) loop
15077 -- Skip prior pragmas, but check for duplicates
15079 if Nkind
(Stmt
) = N_Pragma
then
15080 if Pragma_Name
(Stmt
) = Pname
then
15081 Error_Msg_Name_1
:= Pname
;
15082 Error_Msg_Sloc
:= Sloc
(Stmt
);
15083 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15086 -- Skip internally generated code
15088 elsif not Comes_From_Source
(Stmt
) then
15091 -- The pragma does not apply to a legal construct, issue an
15092 -- error and stop the analysis.
15099 Stmt
:= Prev
(Stmt
);
15102 -- The pragma must be analyzed at the end of the visible
15103 -- declarations of the related package. Save the pragma for later
15104 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15105 -- the contract of the package.
15107 Pack_Id
:= Defining_Entity
(Context
);
15108 Add_Contract_Item
(N
, Pack_Id
);
15110 -- Verify the declaration order of pragma Initial_Condition with
15111 -- respect to pragmas Abstract_State and Initializes when SPARK
15112 -- checks are enabled.
15114 if SPARK_Mode
/= Off
then
15115 Check_Declaration_Order
15116 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15119 Check_Declaration_Order
15120 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
15123 end Initial_Condition
;
15125 ------------------------
15126 -- Initialize_Scalars --
15127 ------------------------
15129 -- pragma Initialize_Scalars;
15131 when Pragma_Initialize_Scalars
=>
15133 Check_Arg_Count
(0);
15134 Check_Valid_Configuration_Pragma
;
15135 Check_Restriction
(No_Initialize_Scalars
, N
);
15137 -- Initialize_Scalars creates false positives in CodePeer, and
15138 -- incorrect negative results in GNATprove mode, so ignore this
15139 -- pragma in these modes.
15141 if not Restriction_Active
(No_Initialize_Scalars
)
15142 and then not (CodePeer_Mode
or GNATprove_Mode
)
15144 Init_Or_Norm_Scalars
:= True;
15145 Initialize_Scalars
:= True;
15152 -- pragma Initializes (INITIALIZATION_SPEC);
15154 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15156 -- INITIALIZATION_LIST ::=
15157 -- INITIALIZATION_ITEM
15158 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15160 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15165 -- | (INPUT {, INPUT})
15169 when Pragma_Initializes
=> Initializes
: declare
15170 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15171 Pack_Id
: Entity_Id
;
15176 Check_No_Identifiers
;
15177 Check_Arg_Count
(1);
15178 Ensure_Aggregate_Form
(Arg1
);
15180 -- Ensure the proper placement of the pragma. Initializes must be
15181 -- associated with a package declaration.
15183 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15184 N_Package_Declaration
)
15191 while Present
(Stmt
) loop
15193 -- Skip prior pragmas, but check for duplicates
15195 if Nkind
(Stmt
) = N_Pragma
then
15196 if Pragma_Name
(Stmt
) = Pname
then
15197 Error_Msg_Name_1
:= Pname
;
15198 Error_Msg_Sloc
:= Sloc
(Stmt
);
15199 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15202 -- Skip internally generated code
15204 elsif not Comes_From_Source
(Stmt
) then
15207 -- The pragma does not apply to a legal construct, issue an
15208 -- error and stop the analysis.
15215 Stmt
:= Prev
(Stmt
);
15218 -- The pragma must be analyzed at the end of the visible
15219 -- declarations of the related package. Save the pragma for later
15220 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15221 -- contract of the package.
15223 Pack_Id
:= Defining_Entity
(Context
);
15224 Add_Contract_Item
(N
, Pack_Id
);
15226 -- Verify the declaration order of pragmas Abstract_State and
15227 -- Initializes when SPARK checks are enabled.
15229 if SPARK_Mode
/= Off
then
15230 Check_Declaration_Order
15231 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15240 -- pragma Inline ( NAME {, NAME} );
15242 when Pragma_Inline
=>
15244 -- Pragma always active unless in GNATprove mode. It is disabled
15245 -- in GNATprove mode because frontend inlining is applied
15246 -- independently of pragmas Inline and Inline_Always for
15247 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15250 if not GNATprove_Mode
then
15252 -- Inline status is Enabled if inlining option is active
15254 if Inline_Active
then
15255 Process_Inline
(Enabled
);
15257 Process_Inline
(Disabled
);
15261 -------------------
15262 -- Inline_Always --
15263 -------------------
15265 -- pragma Inline_Always ( NAME {, NAME} );
15267 when Pragma_Inline_Always
=>
15270 -- Pragma always active unless in CodePeer mode or GNATprove
15271 -- mode. It is disabled in CodePeer mode because inlining is
15272 -- not helpful, and enabling it caused walk order issues. It
15273 -- is disabled in GNATprove mode because frontend inlining is
15274 -- applied independently of pragmas Inline and Inline_Always for
15275 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15278 if not CodePeer_Mode
and not GNATprove_Mode
then
15279 Process_Inline
(Enabled
);
15282 --------------------
15283 -- Inline_Generic --
15284 --------------------
15286 -- pragma Inline_Generic (NAME {, NAME});
15288 when Pragma_Inline_Generic
=>
15290 Process_Generic_List
;
15292 ----------------------
15293 -- Inspection_Point --
15294 ----------------------
15296 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15298 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15305 if Arg_Count
> 0 then
15308 Exp
:= Get_Pragma_Arg
(Arg
);
15311 if not Is_Entity_Name
(Exp
)
15312 or else not Is_Object
(Entity
(Exp
))
15314 Error_Pragma_Arg
("object name required", Arg
);
15318 exit when No
(Arg
);
15321 end Inspection_Point
;
15327 -- pragma Interface (
15328 -- [ Convention =>] convention_IDENTIFIER,
15329 -- [ Entity =>] LOCAL_NAME
15330 -- [, [External_Name =>] static_string_EXPRESSION ]
15331 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15333 when Pragma_Interface
=>
15338 Name_External_Name
,
15340 Check_At_Least_N_Arguments
(2);
15341 Check_At_Most_N_Arguments
(4);
15342 Process_Import_Or_Interface
;
15344 -- In Ada 2005, the permission to use Interface (a reserved word)
15345 -- as a pragma name is considered an obsolescent feature, and this
15346 -- pragma was already obsolescent in Ada 95.
15348 if Ada_Version
>= Ada_95
then
15350 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15352 if Warn_On_Obsolescent_Feature
then
15354 ("pragma Interface is an obsolescent feature?j?", N
);
15356 ("|use pragma Import instead?j?", N
);
15360 --------------------
15361 -- Interface_Name --
15362 --------------------
15364 -- pragma Interface_Name (
15365 -- [ Entity =>] LOCAL_NAME
15366 -- [,[External_Name =>] static_string_EXPRESSION ]
15367 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15369 when Pragma_Interface_Name
=> Interface_Name
: declare
15371 Def_Id
: Entity_Id
;
15372 Hom_Id
: Entity_Id
;
15378 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15379 Check_At_Least_N_Arguments
(2);
15380 Check_At_Most_N_Arguments
(3);
15381 Id
:= Get_Pragma_Arg
(Arg1
);
15384 -- This is obsolete from Ada 95 on, but it is an implementation
15385 -- defined pragma, so we do not consider that it violates the
15386 -- restriction (No_Obsolescent_Features).
15388 if Ada_Version
>= Ada_95
then
15389 if Warn_On_Obsolescent_Feature
then
15391 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15393 ("|use pragma Import instead?j?", N
);
15397 if not Is_Entity_Name
(Id
) then
15399 ("first argument for pragma% must be entity name", Arg1
);
15400 elsif Etype
(Id
) = Any_Type
then
15403 Def_Id
:= Entity
(Id
);
15406 -- Special DEC-compatible processing for the object case, forces
15407 -- object to be imported.
15409 if Ekind
(Def_Id
) = E_Variable
then
15410 Kill_Size_Check_Code
(Def_Id
);
15411 Note_Possible_Modification
(Id
, Sure
=> False);
15413 -- Initialization is not allowed for imported variable
15415 if Present
(Expression
(Parent
(Def_Id
)))
15416 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15418 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15420 ("no initialization allowed for declaration of& #",
15424 -- For compatibility, support VADS usage of providing both
15425 -- pragmas Interface and Interface_Name to obtain the effect
15426 -- of a single Import pragma.
15428 if Is_Imported
(Def_Id
)
15429 and then Present
(First_Rep_Item
(Def_Id
))
15430 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15432 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15436 Set_Imported
(Def_Id
);
15439 Set_Is_Public
(Def_Id
);
15440 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15443 -- Otherwise must be subprogram
15445 elsif not Is_Subprogram
(Def_Id
) then
15447 ("argument of pragma% is not subprogram", Arg1
);
15450 Check_At_Most_N_Arguments
(3);
15454 -- Loop through homonyms
15457 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15459 if Is_Imported
(Def_Id
) then
15460 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15464 exit when From_Aspect_Specification
(N
);
15465 Hom_Id
:= Homonym
(Hom_Id
);
15467 exit when No
(Hom_Id
)
15468 or else Scope
(Hom_Id
) /= Current_Scope
;
15473 ("argument of pragma% is not imported subprogram",
15477 end Interface_Name
;
15479 -----------------------
15480 -- Interrupt_Handler --
15481 -----------------------
15483 -- pragma Interrupt_Handler (handler_NAME);
15485 when Pragma_Interrupt_Handler
=>
15486 Check_Ada_83_Warning
;
15487 Check_Arg_Count
(1);
15488 Check_No_Identifiers
;
15490 if No_Run_Time_Mode
then
15491 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15493 Check_Interrupt_Or_Attach_Handler
;
15494 Process_Interrupt_Or_Attach_Handler
;
15497 ------------------------
15498 -- Interrupt_Priority --
15499 ------------------------
15501 -- pragma Interrupt_Priority [(EXPRESSION)];
15503 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15504 P
: constant Node_Id
:= Parent
(N
);
15509 Check_Ada_83_Warning
;
15511 if Arg_Count
/= 0 then
15512 Arg
:= Get_Pragma_Arg
(Arg1
);
15513 Check_Arg_Count
(1);
15514 Check_No_Identifiers
;
15516 -- The expression must be analyzed in the special manner
15517 -- described in "Handling of Default and Per-Object
15518 -- Expressions" in sem.ads.
15520 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15523 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15528 Ent
:= Defining_Identifier
(Parent
(P
));
15530 -- Check duplicate pragma before we chain the pragma in the Rep
15531 -- Item chain of Ent.
15533 Check_Duplicate_Pragma
(Ent
);
15534 Record_Rep_Item
(Ent
, N
);
15536 end Interrupt_Priority
;
15538 ---------------------
15539 -- Interrupt_State --
15540 ---------------------
15542 -- pragma Interrupt_State (
15543 -- [Name =>] INTERRUPT_ID,
15544 -- [State =>] INTERRUPT_STATE);
15546 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15547 -- INTERRUPT_STATE => System | Runtime | User
15549 -- Note: if the interrupt id is given as an identifier, then it must
15550 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15551 -- given as a static integer expression which must be in the range of
15552 -- Ada.Interrupts.Interrupt_ID.
15554 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15555 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15556 -- This is the entity Ada.Interrupts.Interrupt_ID;
15558 State_Type
: Character;
15559 -- Set to 's'/'r'/'u' for System/Runtime/User
15562 -- Index to entry in Interrupt_States table
15565 -- Value of interrupt
15567 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15568 -- The first argument to the pragma
15570 Int_Ent
: Entity_Id
;
15571 -- Interrupt entity in Ada.Interrupts.Names
15575 Check_Arg_Order
((Name_Name
, Name_State
));
15576 Check_Arg_Count
(2);
15578 Check_Optional_Identifier
(Arg1
, Name_Name
);
15579 Check_Optional_Identifier
(Arg2
, Name_State
);
15580 Check_Arg_Is_Identifier
(Arg2
);
15582 -- First argument is identifier
15584 if Nkind
(Arg1X
) = N_Identifier
then
15586 -- Search list of names in Ada.Interrupts.Names
15588 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15590 if No
(Int_Ent
) then
15591 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15593 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15594 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15598 Next_Entity
(Int_Ent
);
15601 -- First argument is not an identifier, so it must be a static
15602 -- expression of type Ada.Interrupts.Interrupt_ID.
15605 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15606 Int_Val
:= Expr_Value
(Arg1X
);
15608 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15610 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15613 ("value not in range of type "
15614 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15620 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15621 when Name_Runtime
=> State_Type
:= 'r';
15622 when Name_System
=> State_Type
:= 's';
15623 when Name_User
=> State_Type
:= 'u';
15626 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15629 -- Check if entry is already stored
15631 IST_Num
:= Interrupt_States
.First
;
15633 -- If entry not found, add it
15635 if IST_Num
> Interrupt_States
.Last
then
15636 Interrupt_States
.Append
15637 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15638 Interrupt_State
=> State_Type
,
15639 Pragma_Loc
=> Loc
));
15642 -- Case of entry for the same entry
15644 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15647 -- If state matches, done, no need to make redundant entry
15650 State_Type
= Interrupt_States
.Table
(IST_Num
).
15653 -- Otherwise if state does not match, error
15656 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15658 ("state conflicts with that given #", Arg2
);
15662 IST_Num
:= IST_Num
+ 1;
15664 end Interrupt_State
;
15670 -- pragma Invariant
15671 -- ([Entity =>] type_LOCAL_NAME,
15672 -- [Check =>] EXPRESSION
15673 -- [,[Message =>] String_Expression]);
15675 when Pragma_Invariant
=> Invariant
: declare
15682 Check_At_Least_N_Arguments
(2);
15683 Check_At_Most_N_Arguments
(3);
15684 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15685 Check_Optional_Identifier
(Arg2
, Name_Check
);
15687 if Arg_Count
= 3 then
15688 Check_Optional_Identifier
(Arg3
, Name_Message
);
15689 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15692 Check_Arg_Is_Local_Name
(Arg1
);
15694 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15695 Find_Type
(Type_Id
);
15696 Typ
:= Entity
(Type_Id
);
15698 if Typ
= Any_Type
then
15701 -- An invariant must apply to a private type, or appear in the
15702 -- private part of a package spec and apply to a completion.
15703 -- a class-wide invariant can only appear on a private declaration
15704 -- or private extension, not a completion.
15706 elsif Ekind_In
(Typ
, E_Private_Type
,
15707 E_Record_Type_With_Private
,
15708 E_Limited_Private_Type
)
15712 elsif In_Private_Part
(Current_Scope
)
15713 and then Has_Private_Declaration
(Typ
)
15714 and then not Class_Present
(N
)
15718 elsif In_Private_Part
(Current_Scope
) then
15720 ("pragma% only allowed for private type declared in "
15721 & "visible part", Arg1
);
15725 ("pragma% only allowed for private type", Arg1
);
15728 -- Note that the type has at least one invariant, and also that
15729 -- it has inheritable invariants if we have Invariant'Class
15730 -- or Type_Invariant'Class. Build the corresponding invariant
15731 -- procedure declaration, so that calls to it can be generated
15732 -- before the body is built (e.g. within an expression function).
15734 Insert_After_And_Analyze
15735 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15737 if Class_Present
(N
) then
15738 Set_Has_Inheritable_Invariants
(Typ
);
15741 -- The remaining processing is simply to link the pragma on to
15742 -- the rep item chain, for processing when the type is frozen.
15743 -- This is accomplished by a call to Rep_Item_Too_Late.
15745 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15748 ----------------------
15749 -- Java_Constructor --
15750 ----------------------
15752 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15754 -- Also handles pragma CIL_Constructor
15756 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15757 Java_Constructor
: declare
15758 Convention
: Convention_Id
;
15759 Def_Id
: Entity_Id
;
15760 Hom_Id
: Entity_Id
;
15762 This_Formal
: Entity_Id
;
15766 Check_Arg_Count
(1);
15767 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15768 Check_Arg_Is_Local_Name
(Arg1
);
15770 Id
:= Get_Pragma_Arg
(Arg1
);
15771 Find_Program_Unit_Name
(Id
);
15773 -- If we did not find the name, we are done
15775 if Etype
(Id
) = Any_Type
then
15779 -- Check wrong use of pragma in wrong VM target
15781 if VM_Target
= No_VM
then
15784 elsif VM_Target
= CLI_Target
15785 and then Prag_Id
= Pragma_Java_Constructor
15787 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15789 elsif VM_Target
= JVM_Target
15790 and then Prag_Id
= Pragma_CIL_Constructor
15792 Error_Pragma
("must use pragma 'Java_'Constructor");
15796 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15797 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15798 when others => null;
15801 Hom_Id
:= Entity
(Id
);
15803 -- Loop through homonyms
15806 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15808 -- The constructor is required to be a function
15810 if Ekind
(Def_Id
) /= E_Function
then
15811 if VM_Target
= JVM_Target
then
15813 ("pragma% requires function returning a 'Java access "
15817 ("pragma% requires function returning a 'C'I'L access "
15822 -- Check arguments: For tagged type the first formal must be
15823 -- named "this" and its type must be a named access type
15824 -- designating a class-wide tagged type that has convention
15825 -- CIL/Java. The first formal must also have a null default
15826 -- value. For example:
15828 -- type Typ is tagged ...
15829 -- type Ref is access all Typ;
15830 -- pragma Convention (CIL, Typ);
15832 -- function New_Typ (This : Ref) return Ref;
15833 -- function New_Typ (This : Ref; I : Integer) return Ref;
15834 -- pragma Cil_Constructor (New_Typ);
15836 -- Reason: The first formal must NOT be a primitive of the
15839 -- This rule also applies to constructors of delegates used
15840 -- to interface with standard target libraries. For example:
15842 -- type Delegate is access procedure ...
15843 -- pragma Import (CIL, Delegate, ...);
15845 -- function new_Delegate
15846 -- (This : Delegate := null; ... ) return Delegate;
15848 -- For value-types this rule does not apply.
15850 if not Is_Value_Type
(Etype
(Def_Id
)) then
15851 if No
(First_Formal
(Def_Id
)) then
15852 Error_Msg_Name_1
:= Pname
;
15853 Error_Msg_N
("% function must have parameters", Def_Id
);
15857 -- In the JRE library we have several occurrences in which
15858 -- the "this" parameter is not the first formal.
15860 This_Formal
:= First_Formal
(Def_Id
);
15862 -- In the JRE library we have several occurrences in which
15863 -- the "this" parameter is not the first formal. Search for
15866 if VM_Target
= JVM_Target
then
15867 while Present
(This_Formal
)
15868 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15870 Next_Formal
(This_Formal
);
15873 if No
(This_Formal
) then
15874 This_Formal
:= First_Formal
(Def_Id
);
15878 -- Warning: The first parameter should be named "this".
15879 -- We temporarily allow it because we have the following
15880 -- case in the Java runtime (file s-osinte.ads) ???
15882 -- function new_Thread
15883 -- (Self_Id : System.Address) return Thread_Id;
15884 -- pragma Java_Constructor (new_Thread);
15886 if VM_Target
= JVM_Target
15887 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15889 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15893 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15894 Error_Msg_Name_1
:= Pname
;
15896 ("first formal of % function must be named `this`",
15897 Parent
(This_Formal
));
15899 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15900 Error_Msg_Name_1
:= Pname
;
15902 ("first formal of % function must be an access type",
15903 Parameter_Type
(Parent
(This_Formal
)));
15905 -- For delegates the type of the first formal must be a
15906 -- named access-to-subprogram type (see previous example)
15908 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15909 and then Ekind
(Etype
(This_Formal
))
15910 /= E_Access_Subprogram_Type
15912 Error_Msg_Name_1
:= Pname
;
15914 ("first formal of % function must be a named access "
15915 & "to subprogram type",
15916 Parameter_Type
(Parent
(This_Formal
)));
15918 -- Warning: We should reject anonymous access types because
15919 -- the constructor must not be handled as a primitive of the
15920 -- tagged type. We temporarily allow it because this profile
15921 -- is currently generated by cil2ada???
15923 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15924 and then not Ekind_In
(Etype
(This_Formal
),
15926 E_General_Access_Type
,
15927 E_Anonymous_Access_Type
)
15929 Error_Msg_Name_1
:= Pname
;
15931 ("first formal of % function must be a named access "
15932 & "type", Parameter_Type
(Parent
(This_Formal
)));
15934 elsif Atree
.Convention
15935 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15937 Error_Msg_Name_1
:= Pname
;
15939 if Convention
= Convention_Java
then
15941 ("pragma% requires convention 'Cil in designated "
15942 & "type", Parameter_Type
(Parent
(This_Formal
)));
15945 ("pragma% requires convention 'Java in designated "
15946 & "type", Parameter_Type
(Parent
(This_Formal
)));
15949 elsif No
(Expression
(Parent
(This_Formal
)))
15950 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15952 Error_Msg_Name_1
:= Pname
;
15954 ("pragma% requires first formal with default `null`",
15955 Parameter_Type
(Parent
(This_Formal
)));
15959 -- Check result type: the constructor must be a function
15961 -- * a value type (only allowed in the CIL compiler)
15962 -- * an access-to-subprogram type with convention Java/CIL
15963 -- * an access-type designating a type that has convention
15966 if Is_Value_Type
(Etype
(Def_Id
)) then
15969 -- Access-to-subprogram type with convention Java/CIL
15971 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15972 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15973 if Convention
= Convention_Java
then
15975 ("pragma% requires function returning a 'Java "
15976 & "access type", Arg1
);
15978 pragma Assert
(Convention
= Convention_CIL
);
15980 ("pragma% requires function returning a 'C'I'L "
15981 & "access type", Arg1
);
15985 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15986 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15987 E_General_Access_Type
)
15990 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15992 Error_Msg_Name_1
:= Pname
;
15994 if Convention
= Convention_Java
then
15996 ("pragma% requires function returning a named "
15997 & "'Java access type", Arg1
);
16000 ("pragma% requires function returning a named "
16001 & "'C'I'L access type", Arg1
);
16006 Set_Is_Constructor
(Def_Id
);
16007 Set_Convention
(Def_Id
, Convention
);
16008 Set_Is_Imported
(Def_Id
);
16010 exit when From_Aspect_Specification
(N
);
16011 Hom_Id
:= Homonym
(Hom_Id
);
16013 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
16015 end Java_Constructor
;
16017 ----------------------
16018 -- Java_Interface --
16019 ----------------------
16021 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16023 when Pragma_Java_Interface
=> Java_Interface
: declare
16029 Check_Arg_Count
(1);
16030 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16031 Check_Arg_Is_Local_Name
(Arg1
);
16033 Arg
:= Get_Pragma_Arg
(Arg1
);
16036 if Etype
(Arg
) = Any_Type
then
16040 if not Is_Entity_Name
(Arg
)
16041 or else not Is_Type
(Entity
(Arg
))
16043 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
16046 Typ
:= Underlying_Type
(Entity
(Arg
));
16048 -- For now simply check some of the semantic constraints on the
16049 -- type. This currently leaves out some restrictions on interface
16050 -- types, namely that the parent type must be java.lang.Object.Typ
16051 -- and that all primitives of the type should be declared
16054 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
16056 ("pragma% requires an abstract tagged type", Arg1
);
16058 elsif not Has_Discriminants
(Typ
)
16059 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
16060 /= E_Anonymous_Access_Type
16062 not Is_Class_Wide_Type
16063 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
16066 ("type must have a class-wide access discriminant", Arg1
);
16068 end Java_Interface
;
16074 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16076 when Pragma_Keep_Names
=> Keep_Names
: declare
16081 Check_Arg_Count
(1);
16082 Check_Optional_Identifier
(Arg1
, Name_On
);
16083 Check_Arg_Is_Local_Name
(Arg1
);
16085 Arg
:= Get_Pragma_Arg
(Arg1
);
16088 if Etype
(Arg
) = Any_Type
then
16092 if not Is_Entity_Name
(Arg
)
16093 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16096 ("pragma% requires a local enumeration type", Arg1
);
16099 Set_Discard_Names
(Entity
(Arg
), False);
16106 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16108 when Pragma_License
=>
16111 -- Do not analyze pragma any further in CodePeer mode, to avoid
16112 -- extraneous errors in this implementation-dependent pragma,
16113 -- which has a different profile on other compilers.
16115 if CodePeer_Mode
then
16119 Check_Arg_Count
(1);
16120 Check_No_Identifiers
;
16121 Check_Valid_Configuration_Pragma
;
16122 Check_Arg_Is_Identifier
(Arg1
);
16125 Sind
: constant Source_File_Index
:=
16126 Source_Index
(Current_Sem_Unit
);
16129 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16131 Set_License
(Sind
, GPL
);
16133 when Name_Modified_GPL
=>
16134 Set_License
(Sind
, Modified_GPL
);
16136 when Name_Restricted
=>
16137 Set_License
(Sind
, Restricted
);
16139 when Name_Unrestricted
=>
16140 Set_License
(Sind
, Unrestricted
);
16143 Error_Pragma_Arg
("invalid license name", Arg1
);
16151 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16153 when Pragma_Link_With
=> Link_With
: declare
16159 if Operating_Mode
= Generate_Code
16160 and then In_Extended_Main_Source_Unit
(N
)
16162 Check_At_Least_N_Arguments
(1);
16163 Check_No_Identifiers
;
16164 Check_Is_In_Decl_Part_Or_Package_Spec
;
16165 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16169 while Present
(Arg
) loop
16170 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16172 -- Store argument, converting sequences of spaces to a
16173 -- single null character (this is one of the differences
16174 -- in processing between Link_With and Linker_Options).
16176 Arg_Store
: declare
16177 C
: constant Char_Code
:= Get_Char_Code
(' ');
16178 S
: constant String_Id
:=
16179 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16180 L
: constant Nat
:= String_Length
(S
);
16183 procedure Skip_Spaces
;
16184 -- Advance F past any spaces
16190 procedure Skip_Spaces
is
16192 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16197 -- Start of processing for Arg_Store
16200 Skip_Spaces
; -- skip leading spaces
16202 -- Loop through characters, changing any embedded
16203 -- sequence of spaces to a single null character (this
16204 -- is how Link_With/Linker_Options differ)
16207 if Get_String_Char
(S
, F
) = C
then
16210 Store_String_Char
(ASCII
.NUL
);
16213 Store_String_Char
(Get_String_Char
(S
, F
));
16221 if Present
(Arg
) then
16222 Store_String_Char
(ASCII
.NUL
);
16226 Store_Linker_Option_String
(End_String
);
16234 -- pragma Linker_Alias (
16235 -- [Entity =>] LOCAL_NAME
16236 -- [Target =>] static_string_EXPRESSION);
16238 when Pragma_Linker_Alias
=>
16240 Check_Arg_Order
((Name_Entity
, Name_Target
));
16241 Check_Arg_Count
(2);
16242 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16243 Check_Optional_Identifier
(Arg2
, Name_Target
);
16244 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16245 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16247 -- The only processing required is to link this item on to the
16248 -- list of rep items for the given entity. This is accomplished
16249 -- by the call to Rep_Item_Too_Late (when no error is detected
16250 -- and False is returned).
16252 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16255 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16258 ------------------------
16259 -- Linker_Constructor --
16260 ------------------------
16262 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16264 -- Code is shared with Linker_Destructor
16266 -----------------------
16267 -- Linker_Destructor --
16268 -----------------------
16270 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16272 when Pragma_Linker_Constructor |
16273 Pragma_Linker_Destructor
=>
16274 Linker_Constructor
: declare
16280 Check_Arg_Count
(1);
16281 Check_No_Identifiers
;
16282 Check_Arg_Is_Local_Name
(Arg1
);
16283 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16285 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16287 if not Is_Library_Level_Entity
(Proc
) then
16289 ("argument for pragma% must be library level entity", Arg1
);
16292 -- The only processing required is to link this item on to the
16293 -- list of rep items for the given entity. This is accomplished
16294 -- by the call to Rep_Item_Too_Late (when no error is detected
16295 -- and False is returned).
16297 if Rep_Item_Too_Late
(Proc
, N
) then
16300 Set_Has_Gigi_Rep_Item
(Proc
);
16302 end Linker_Constructor
;
16304 --------------------
16305 -- Linker_Options --
16306 --------------------
16308 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16310 when Pragma_Linker_Options
=> Linker_Options
: declare
16314 Check_Ada_83_Warning
;
16315 Check_No_Identifiers
;
16316 Check_Arg_Count
(1);
16317 Check_Is_In_Decl_Part_Or_Package_Spec
;
16318 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16319 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16322 while Present
(Arg
) loop
16323 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16324 Store_String_Char
(ASCII
.NUL
);
16326 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16330 if Operating_Mode
= Generate_Code
16331 and then In_Extended_Main_Source_Unit
(N
)
16333 Store_Linker_Option_String
(End_String
);
16335 end Linker_Options
;
16337 --------------------
16338 -- Linker_Section --
16339 --------------------
16341 -- pragma Linker_Section (
16342 -- [Entity =>] LOCAL_NAME
16343 -- [Section =>] static_string_EXPRESSION);
16345 when Pragma_Linker_Section
=> Linker_Section
: declare
16352 Check_Arg_Order
((Name_Entity
, Name_Section
));
16353 Check_Arg_Count
(2);
16354 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16355 Check_Optional_Identifier
(Arg2
, Name_Section
);
16356 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16357 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16359 -- Check kind of entity
16361 Arg
:= Get_Pragma_Arg
(Arg1
);
16362 Ent
:= Entity
(Arg
);
16364 case Ekind
(Ent
) is
16366 -- Objects (constants and variables) and types. For these cases
16367 -- all we need to do is to set the Linker_Section_pragma field,
16368 -- checking that we do not have a duplicate.
16370 when E_Constant | E_Variable | Type_Kind
=>
16371 LPE
:= Linker_Section_Pragma
(Ent
);
16373 if Present
(LPE
) then
16374 Error_Msg_Sloc
:= Sloc
(LPE
);
16376 ("Linker_Section already specified for &#", Arg1
, Ent
);
16379 Set_Linker_Section_Pragma
(Ent
, N
);
16383 when Subprogram_Kind
=>
16385 -- Aspect case, entity already set
16387 if From_Aspect_Specification
(N
) then
16388 Set_Linker_Section_Pragma
16389 (Entity
(Corresponding_Aspect
(N
)), N
);
16391 -- Pragma case, we must climb the homonym chain, but skip
16392 -- any for which the linker section is already set.
16396 if No
(Linker_Section_Pragma
(Ent
)) then
16397 Set_Linker_Section_Pragma
(Ent
, N
);
16400 Ent
:= Homonym
(Ent
);
16402 or else Scope
(Ent
) /= Current_Scope
;
16406 -- All other cases are illegal
16410 ("pragma% applies only to objects, subprograms, and types",
16413 end Linker_Section
;
16419 -- pragma List (On | Off)
16421 -- There is nothing to do here, since we did all the processing for
16422 -- this pragma in Par.Prag (so that it works properly even in syntax
16425 when Pragma_List
=>
16432 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16434 when Pragma_Lock_Free
=> Lock_Free
: declare
16435 P
: constant Node_Id
:= Parent
(N
);
16441 Check_No_Identifiers
;
16442 Check_At_Most_N_Arguments
(1);
16444 -- Protected definition case
16446 if Nkind
(P
) = N_Protected_Definition
then
16447 Ent
:= Defining_Identifier
(Parent
(P
));
16451 if Arg_Count
= 1 then
16452 Arg
:= Get_Pragma_Arg
(Arg1
);
16453 Val
:= Is_True
(Static_Boolean
(Arg
));
16455 -- No arguments (expression is considered to be True)
16461 -- Check duplicate pragma before we chain the pragma in the Rep
16462 -- Item chain of Ent.
16464 Check_Duplicate_Pragma
(Ent
);
16465 Record_Rep_Item
(Ent
, N
);
16466 Set_Uses_Lock_Free
(Ent
, Val
);
16468 -- Anything else is incorrect placement
16475 --------------------
16476 -- Locking_Policy --
16477 --------------------
16479 -- pragma Locking_Policy (policy_IDENTIFIER);
16481 when Pragma_Locking_Policy
=> declare
16482 subtype LP_Range
is Name_Id
16483 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16488 Check_Ada_83_Warning
;
16489 Check_Arg_Count
(1);
16490 Check_No_Identifiers
;
16491 Check_Arg_Is_Locking_Policy
(Arg1
);
16492 Check_Valid_Configuration_Pragma
;
16493 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16496 when Name_Ceiling_Locking
=>
16498 when Name_Inheritance_Locking
=>
16500 when Name_Concurrent_Readers_Locking
=>
16504 if Locking_Policy
/= ' '
16505 and then Locking_Policy
/= LP
16507 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16508 Error_Pragma
("locking policy incompatible with policy#");
16510 -- Set new policy, but always preserve System_Location since we
16511 -- like the error message with the run time name.
16514 Locking_Policy
:= LP
;
16516 if Locking_Policy_Sloc
/= System_Location
then
16517 Locking_Policy_Sloc
:= Loc
;
16522 -------------------
16523 -- Loop_Optimize --
16524 -------------------
16526 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16528 -- OPTIMIZATION_HINT ::=
16529 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16531 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16536 Check_At_Least_N_Arguments
(1);
16537 Check_No_Identifiers
;
16539 Hint
:= First
(Pragma_Argument_Associations
(N
));
16540 while Present
(Hint
) loop
16541 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16549 Check_Loop_Pragma_Placement
;
16556 -- pragma Loop_Variant
16557 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16559 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16561 -- CHANGE_DIRECTION ::= Increases | Decreases
16563 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16568 Check_At_Least_N_Arguments
(1);
16569 Check_Loop_Pragma_Placement
;
16571 -- Process all increasing / decreasing expressions
16573 Variant
:= First
(Pragma_Argument_Associations
(N
));
16574 while Present
(Variant
) loop
16575 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16578 Error_Pragma_Arg
("wrong change modifier", Variant
);
16581 Preanalyze_Assert_Expression
16582 (Expression
(Variant
), Any_Discrete
);
16588 -----------------------
16589 -- Machine_Attribute --
16590 -----------------------
16592 -- pragma Machine_Attribute (
16593 -- [Entity =>] LOCAL_NAME,
16594 -- [Attribute_Name =>] static_string_EXPRESSION
16595 -- [, [Info =>] static_EXPRESSION] );
16597 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16598 Def_Id
: Entity_Id
;
16602 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16604 if Arg_Count
= 3 then
16605 Check_Optional_Identifier
(Arg3
, Name_Info
);
16606 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16608 Check_Arg_Count
(2);
16611 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16612 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16613 Check_Arg_Is_Local_Name
(Arg1
);
16614 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16615 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16617 if Is_Access_Type
(Def_Id
) then
16618 Def_Id
:= Designated_Type
(Def_Id
);
16621 if Rep_Item_Too_Early
(Def_Id
, N
) then
16625 Def_Id
:= Underlying_Type
(Def_Id
);
16627 -- The only processing required is to link this item on to the
16628 -- list of rep items for the given entity. This is accomplished
16629 -- by the call to Rep_Item_Too_Late (when no error is detected
16630 -- and False is returned).
16632 if Rep_Item_Too_Late
(Def_Id
, N
) then
16635 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16637 end Machine_Attribute
;
16644 -- (MAIN_OPTION [, MAIN_OPTION]);
16647 -- [STACK_SIZE =>] static_integer_EXPRESSION
16648 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16649 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16651 when Pragma_Main
=> Main
: declare
16652 Args
: Args_List
(1 .. 3);
16653 Names
: constant Name_List
(1 .. 3) := (
16655 Name_Task_Stack_Size_Default
,
16656 Name_Time_Slicing_Enabled
);
16662 Gather_Associations
(Names
, Args
);
16664 for J
in 1 .. 2 loop
16665 if Present
(Args
(J
)) then
16666 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16670 if Present
(Args
(3)) then
16671 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16675 while Present
(Nod
) loop
16676 if Nkind
(Nod
) = N_Pragma
16677 and then Pragma_Name
(Nod
) = Name_Main
16679 Error_Msg_Name_1
:= Pname
;
16680 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16691 -- pragma Main_Storage
16692 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16694 -- MAIN_STORAGE_OPTION ::=
16695 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16696 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16698 when Pragma_Main_Storage
=> Main_Storage
: declare
16699 Args
: Args_List
(1 .. 2);
16700 Names
: constant Name_List
(1 .. 2) := (
16701 Name_Working_Storage
,
16708 Gather_Associations
(Names
, Args
);
16710 for J
in 1 .. 2 loop
16711 if Present
(Args
(J
)) then
16712 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16716 Check_In_Main_Program
;
16719 while Present
(Nod
) loop
16720 if Nkind
(Nod
) = N_Pragma
16721 and then Pragma_Name
(Nod
) = Name_Main_Storage
16723 Error_Msg_Name_1
:= Pname
;
16724 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16735 -- pragma Memory_Size (NUMERIC_LITERAL)
16737 when Pragma_Memory_Size
=>
16740 -- Memory size is simply ignored
16742 Check_No_Identifiers
;
16743 Check_Arg_Count
(1);
16744 Check_Arg_Is_Integer_Literal
(Arg1
);
16752 -- The only correct use of this pragma is on its own in a file, in
16753 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16754 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16755 -- check for a file containing nothing but a No_Body pragma). If we
16756 -- attempt to process it during normal semantics processing, it means
16757 -- it was misplaced.
16759 when Pragma_No_Body
=>
16763 -----------------------------
16764 -- No_Elaboration_Code_All --
16765 -----------------------------
16767 -- pragma No_Elaboration_Code_All;
16769 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16772 Check_Valid_Library_Unit_Pragma
;
16774 if Nkind
(N
) = N_Null_Statement
then
16778 -- Must appear for a spec or generic spec
16780 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16781 N_Generic_Package_Declaration
,
16782 N_Generic_Subprogram_Declaration
,
16783 N_Package_Declaration
,
16784 N_Subprogram_Declaration
)
16788 ("pragma% can only occur for package "
16789 & "or subprogram spec"));
16792 -- Set flag in unit table
16794 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16796 -- Set restriction No_Elaboration_Code if this is the main unit
16798 if Current_Sem_Unit
= Main_Unit
then
16799 Set_Restriction
(No_Elaboration_Code
, N
);
16802 -- If we are in the main unit or in an extended main source unit,
16803 -- then we also add it to the configuration restrictions so that
16804 -- it will apply to all units in the extended main source.
16806 if Current_Sem_Unit
= Main_Unit
16807 or else In_Extended_Main_Source_Unit
(N
)
16809 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16812 -- If in main extended unit, activate transitive with test
16814 if In_Extended_Main_Source_Unit
(N
) then
16815 Opt
.No_Elab_Code_All_Pragma
:= N
;
16823 -- pragma No_Inline ( NAME {, NAME} );
16825 when Pragma_No_Inline
=>
16827 Process_Inline
(Suppressed
);
16833 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16835 when Pragma_No_Return
=> No_Return
: declare
16843 Check_At_Least_N_Arguments
(1);
16845 -- Loop through arguments of pragma
16848 while Present
(Arg
) loop
16849 Check_Arg_Is_Local_Name
(Arg
);
16850 Id
:= Get_Pragma_Arg
(Arg
);
16853 if not Is_Entity_Name
(Id
) then
16854 Error_Pragma_Arg
("entity name required", Arg
);
16857 if Etype
(Id
) = Any_Type
then
16861 -- Loop to find matching procedures
16866 and then Scope
(E
) = Current_Scope
16868 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16871 -- Set flag on any alias as well
16873 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16874 Set_No_Return
(Alias
(E
));
16880 exit when From_Aspect_Specification
(N
);
16884 -- If entity in not in current scope it may be the enclosing
16885 -- suprogram body to which the aspect applies.
16888 if Entity
(Id
) = Current_Scope
16889 and then From_Aspect_Specification
(N
)
16891 Set_No_Return
(Entity
(Id
));
16893 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16905 -- pragma No_Run_Time;
16907 -- Note: this pragma is retained for backwards compatibility. See
16908 -- body of Rtsfind for full details on its handling.
16910 when Pragma_No_Run_Time
=>
16912 Check_Valid_Configuration_Pragma
;
16913 Check_Arg_Count
(0);
16915 No_Run_Time_Mode
:= True;
16916 Configurable_Run_Time_Mode
:= True;
16918 -- Set Duration to 32 bits if word size is 32
16920 if Ttypes
.System_Word_Size
= 32 then
16921 Duration_32_Bits_On_Target
:= True;
16924 -- Set appropriate restrictions
16926 Set_Restriction
(No_Finalization
, N
);
16927 Set_Restriction
(No_Exception_Handlers
, N
);
16928 Set_Restriction
(Max_Tasks
, N
, 0);
16929 Set_Restriction
(No_Tasking
, N
);
16931 -----------------------
16932 -- No_Tagged_Streams --
16933 -----------------------
16935 -- pragma No_Tagged_Streams;
16936 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16938 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16944 Check_At_Most_N_Arguments
(1);
16946 -- One argument case
16948 if Arg_Count
= 1 then
16949 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16950 Check_Arg_Is_Local_Name
(Arg1
);
16951 E_Id
:= Get_Pragma_Arg
(Arg1
);
16953 if Etype
(E_Id
) = Any_Type
then
16957 E
:= Entity
(E_Id
);
16959 Check_Duplicate_Pragma
(E
);
16961 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16963 ("argument for pragma% must be root tagged type", Arg1
);
16966 if Rep_Item_Too_Early
(E
, N
)
16968 Rep_Item_Too_Late
(E
, N
)
16972 Set_No_Tagged_Streams_Pragma
(E
, N
);
16975 -- Zero argument case
16978 Check_Is_In_Decl_Part_Or_Package_Spec
;
16979 No_Tagged_Streams
:= N
;
16981 end No_Tagged_Strms
;
16983 ------------------------
16984 -- No_Strict_Aliasing --
16985 ------------------------
16987 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16989 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16994 Check_At_Most_N_Arguments
(1);
16996 if Arg_Count
= 0 then
16997 Check_Valid_Configuration_Pragma
;
16998 Opt
.No_Strict_Aliasing
:= True;
17001 Check_Optional_Identifier
(Arg2
, Name_Entity
);
17002 Check_Arg_Is_Local_Name
(Arg1
);
17003 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17005 if E_Id
= Any_Type
then
17007 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
17008 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
17011 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
17013 end No_Strict_Aliasing
;
17015 -----------------------
17016 -- Normalize_Scalars --
17017 -----------------------
17019 -- pragma Normalize_Scalars;
17021 when Pragma_Normalize_Scalars
=>
17022 Check_Ada_83_Warning
;
17023 Check_Arg_Count
(0);
17024 Check_Valid_Configuration_Pragma
;
17026 -- Normalize_Scalars creates false positives in CodePeer, and
17027 -- incorrect negative results in GNATprove mode, so ignore this
17028 -- pragma in these modes.
17030 if not (CodePeer_Mode
or GNATprove_Mode
) then
17031 Normalize_Scalars
:= True;
17032 Init_Or_Norm_Scalars
:= True;
17039 -- pragma Obsolescent;
17041 -- pragma Obsolescent (
17042 -- [Message =>] static_string_EXPRESSION
17043 -- [,[Version =>] Ada_05]]);
17045 -- pragma Obsolescent (
17046 -- [Entity =>] NAME
17047 -- [,[Message =>] static_string_EXPRESSION
17048 -- [,[Version =>] Ada_05]] );
17050 when Pragma_Obsolescent
=> Obsolescent
: declare
17054 procedure Set_Obsolescent
(E
: Entity_Id
);
17055 -- Given an entity Ent, mark it as obsolescent if appropriate
17057 ---------------------
17058 -- Set_Obsolescent --
17059 ---------------------
17061 procedure Set_Obsolescent
(E
: Entity_Id
) is
17070 -- Entity name was given
17072 if Present
(Ename
) then
17074 -- If entity name matches, we are fine. Save entity in
17075 -- pragma argument, for ASIS use.
17077 if Chars
(Ename
) = Chars
(Ent
) then
17078 Set_Entity
(Ename
, Ent
);
17079 Generate_Reference
(Ent
, Ename
);
17081 -- If entity name does not match, only possibility is an
17082 -- enumeration literal from an enumeration type declaration.
17084 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17086 ("pragma % entity name does not match declaration");
17089 Ent
:= First_Literal
(E
);
17093 ("pragma % entity name does not match any "
17094 & "enumeration literal");
17096 elsif Chars
(Ent
) = Chars
(Ename
) then
17097 Set_Entity
(Ename
, Ent
);
17098 Generate_Reference
(Ent
, Ename
);
17102 Ent
:= Next_Literal
(Ent
);
17108 -- Ent points to entity to be marked
17110 if Arg_Count
>= 1 then
17112 -- Deal with static string argument
17114 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17115 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17117 for J
in 1 .. String_Length
(S
) loop
17118 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17120 ("pragma% argument does not allow wide characters",
17125 Obsolescent_Warnings
.Append
17126 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17128 -- Check for Ada_05 parameter
17130 if Arg_Count
/= 1 then
17131 Check_Arg_Count
(2);
17134 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17137 Check_Arg_Is_Identifier
(Argx
);
17139 if Chars
(Argx
) /= Name_Ada_05
then
17140 Error_Msg_Name_2
:= Name_Ada_05
;
17142 ("only allowed argument for pragma% is %", Argx
);
17145 if Ada_Version_Explicit
< Ada_2005
17146 or else not Warn_On_Ada_2005_Compatibility
17154 -- Set flag if pragma active
17157 Set_Is_Obsolescent
(Ent
);
17161 end Set_Obsolescent
;
17163 -- Start of processing for pragma Obsolescent
17168 Check_At_Most_N_Arguments
(3);
17170 -- See if first argument specifies an entity name
17174 (Chars
(Arg1
) = Name_Entity
17176 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17178 N_Operator_Symbol
))
17180 Ename
:= Get_Pragma_Arg
(Arg1
);
17182 -- Eliminate first argument, so we can share processing
17186 Arg_Count
:= Arg_Count
- 1;
17188 -- No Entity name argument given
17194 if Arg_Count
>= 1 then
17195 Check_Optional_Identifier
(Arg1
, Name_Message
);
17197 if Arg_Count
= 2 then
17198 Check_Optional_Identifier
(Arg2
, Name_Version
);
17202 -- Get immediately preceding declaration
17205 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17209 -- Cases where we do not follow anything other than another pragma
17213 -- First case: library level compilation unit declaration with
17214 -- the pragma immediately following the declaration.
17216 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17218 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17221 -- Case 2: library unit placement for package
17225 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17227 if Is_Package_Or_Generic_Package
(Ent
) then
17228 Set_Obsolescent
(Ent
);
17234 -- Cases where we must follow a declaration
17237 if Nkind
(Decl
) not in N_Declaration
17238 and then Nkind
(Decl
) not in N_Later_Decl_Item
17239 and then Nkind
(Decl
) not in N_Generic_Declaration
17240 and then Nkind
(Decl
) not in N_Renaming_Declaration
17243 ("pragma% misplaced, "
17244 & "must immediately follow a declaration");
17247 Set_Obsolescent
(Defining_Entity
(Decl
));
17257 -- pragma Optimize (Time | Space | Off);
17259 -- The actual check for optimize is done in Gigi. Note that this
17260 -- pragma does not actually change the optimization setting, it
17261 -- simply checks that it is consistent with the pragma.
17263 when Pragma_Optimize
=>
17264 Check_No_Identifiers
;
17265 Check_Arg_Count
(1);
17266 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17268 ------------------------
17269 -- Optimize_Alignment --
17270 ------------------------
17272 -- pragma Optimize_Alignment (Time | Space | Off);
17274 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17276 Check_No_Identifiers
;
17277 Check_Arg_Count
(1);
17278 Check_Valid_Configuration_Pragma
;
17281 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17285 Opt
.Optimize_Alignment
:= 'T';
17287 Opt
.Optimize_Alignment
:= 'S';
17289 Opt
.Optimize_Alignment
:= 'O';
17291 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17295 -- Set indication that mode is set locally. If we are in fact in a
17296 -- configuration pragma file, this setting is harmless since the
17297 -- switch will get reset anyway at the start of each unit.
17299 Optimize_Alignment_Local
:= True;
17300 end Optimize_Alignment
;
17306 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17308 when Pragma_Ordered
=> Ordered
: declare
17309 Assoc
: constant Node_Id
:= Arg1
;
17315 Check_No_Identifiers
;
17316 Check_Arg_Count
(1);
17317 Check_Arg_Is_Local_Name
(Arg1
);
17319 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17320 Find_Type
(Type_Id
);
17321 Typ
:= Entity
(Type_Id
);
17323 if Typ
= Any_Type
then
17326 Typ
:= Underlying_Type
(Typ
);
17329 if not Is_Enumeration_Type
(Typ
) then
17330 Error_Pragma
("pragma% must specify enumeration type");
17333 Check_First_Subtype
(Arg1
);
17334 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17337 -------------------
17338 -- Overflow_Mode --
17339 -------------------
17341 -- pragma Overflow_Mode
17342 -- ([General => ] MODE [, [Assertions => ] MODE]);
17344 -- MODE := STRICT | MINIMIZED | ELIMINATED
17346 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17347 -- since System.Bignums makes this assumption. This is true of nearly
17348 -- all (all?) targets.
17350 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17351 function Get_Overflow_Mode
17353 Arg
: Node_Id
) return Overflow_Mode_Type
;
17354 -- Function to process one pragma argument, Arg. If an identifier
17355 -- is present, it must be Name. Mode type is returned if a valid
17356 -- argument exists, otherwise an error is signalled.
17358 -----------------------
17359 -- Get_Overflow_Mode --
17360 -----------------------
17362 function Get_Overflow_Mode
17364 Arg
: Node_Id
) return Overflow_Mode_Type
17366 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17369 Check_Optional_Identifier
(Arg
, Name
);
17370 Check_Arg_Is_Identifier
(Argx
);
17372 if Chars
(Argx
) = Name_Strict
then
17375 elsif Chars
(Argx
) = Name_Minimized
then
17378 elsif Chars
(Argx
) = Name_Eliminated
then
17379 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17381 ("Eliminated not implemented on this target", Argx
);
17387 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17389 end Get_Overflow_Mode
;
17391 -- Start of processing for Overflow_Mode
17395 Check_At_Least_N_Arguments
(1);
17396 Check_At_Most_N_Arguments
(2);
17398 -- Process first argument
17400 Scope_Suppress
.Overflow_Mode_General
:=
17401 Get_Overflow_Mode
(Name_General
, Arg1
);
17403 -- Case of only one argument
17405 if Arg_Count
= 1 then
17406 Scope_Suppress
.Overflow_Mode_Assertions
:=
17407 Scope_Suppress
.Overflow_Mode_General
;
17409 -- Case of two arguments present
17412 Scope_Suppress
.Overflow_Mode_Assertions
:=
17413 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17417 --------------------------
17418 -- Overriding Renamings --
17419 --------------------------
17421 -- pragma Overriding_Renamings;
17423 when Pragma_Overriding_Renamings
=>
17425 Check_Arg_Count
(0);
17426 Check_Valid_Configuration_Pragma
;
17427 Overriding_Renamings
:= True;
17433 -- pragma Pack (first_subtype_LOCAL_NAME);
17435 when Pragma_Pack
=> Pack
: declare
17436 Assoc
: constant Node_Id
:= Arg1
;
17440 Ignore
: Boolean := False;
17443 Check_No_Identifiers
;
17444 Check_Arg_Count
(1);
17445 Check_Arg_Is_Local_Name
(Arg1
);
17446 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17448 if not Is_Entity_Name
(Type_Id
)
17449 or else not Is_Type
(Entity
(Type_Id
))
17452 ("argument for pragma% must be type or subtype", Arg1
);
17455 Find_Type
(Type_Id
);
17456 Typ
:= Entity
(Type_Id
);
17459 or else Rep_Item_Too_Early
(Typ
, N
)
17463 Typ
:= Underlying_Type
(Typ
);
17466 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17467 Error_Pragma
("pragma% must specify array or record type");
17470 Check_First_Subtype
(Arg1
);
17471 Check_Duplicate_Pragma
(Typ
);
17475 if Is_Array_Type
(Typ
) then
17476 Ctyp
:= Component_Type
(Typ
);
17478 -- Ignore pack that does nothing
17480 if Known_Static_Esize
(Ctyp
)
17481 and then Known_Static_RM_Size
(Ctyp
)
17482 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17483 and then Addressable
(Esize
(Ctyp
))
17488 -- Process OK pragma Pack. Note that if there is a separate
17489 -- component clause present, the Pack will be cancelled. This
17490 -- processing is in Freeze.
17492 if not Rep_Item_Too_Late
(Typ
, N
) then
17494 -- In CodePeer mode, we do not need complex front-end
17495 -- expansions related to pragma Pack, so disable handling
17498 if CodePeer_Mode
then
17501 -- Don't attempt any packing for VM targets. We possibly
17502 -- could deal with some cases of array bit-packing, but we
17503 -- don't bother, since this is not a typical kind of
17504 -- representation in the VM context anyway (and would not
17505 -- for example work nicely with the debugger).
17507 elsif VM_Target
/= No_VM
then
17508 if not GNAT_Mode
then
17510 ("??pragma% ignored in this configuration");
17513 -- Normal case where we do the pack action
17517 Set_Is_Packed
(Base_Type
(Typ
));
17518 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17521 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17525 -- For record types, the pack is always effective
17527 else pragma Assert
(Is_Record_Type
(Typ
));
17528 if not Rep_Item_Too_Late
(Typ
, N
) then
17530 -- Ignore pack request with warning in VM mode (skip warning
17531 -- if we are compiling GNAT run time library).
17533 if VM_Target
/= No_VM
then
17534 if not GNAT_Mode
then
17536 ("??pragma% ignored in this configuration");
17539 -- Normal case of pack request active
17542 Set_Is_Packed
(Base_Type
(Typ
));
17543 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17544 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17556 -- There is nothing to do here, since we did all the processing for
17557 -- this pragma in Par.Prag (so that it works properly even in syntax
17560 when Pragma_Page
=>
17567 -- pragma Part_Of (ABSTRACT_STATE);
17569 -- ABSTRACT_STATE ::= NAME
17571 when Pragma_Part_Of
=> Part_Of
: declare
17572 procedure Propagate_Part_Of
17573 (Pack_Id
: Entity_Id
;
17574 State_Id
: Entity_Id
;
17575 Instance
: Node_Id
);
17576 -- Propagate the Part_Of indicator to all abstract states and
17577 -- variables declared in the visible state space of a package
17578 -- denoted by Pack_Id. State_Id is the encapsulating state.
17579 -- Instance is the package instantiation node.
17581 -----------------------
17582 -- Propagate_Part_Of --
17583 -----------------------
17585 procedure Propagate_Part_Of
17586 (Pack_Id
: Entity_Id
;
17587 State_Id
: Entity_Id
;
17588 Instance
: Node_Id
)
17590 Has_Item
: Boolean := False;
17591 -- Flag set when the visible state space contains at least one
17592 -- abstract state or variable.
17594 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17595 -- Propagate the Part_Of indicator to all abstract states and
17596 -- variables declared in the visible state space of a package
17597 -- denoted by Pack_Id.
17599 -----------------------
17600 -- Propagate_Part_Of --
17601 -----------------------
17603 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17604 Item_Id
: Entity_Id
;
17607 -- Traverse the entity chain of the package and set relevant
17608 -- attributes of abstract states and variables declared in
17609 -- the visible state space of the package.
17611 Item_Id
:= First_Entity
(Pack_Id
);
17612 while Present
(Item_Id
)
17613 and then not In_Private_Part
(Item_Id
)
17615 -- Do not consider internally generated items
17617 if not Comes_From_Source
(Item_Id
) then
17620 -- The Part_Of indicator turns an abstract state or
17621 -- variable into a constituent of the encapsulating
17624 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17629 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17630 Set_Encapsulating_State
(Item_Id
, State_Id
);
17632 -- Recursively handle nested packages and instantiations
17634 elsif Ekind
(Item_Id
) = E_Package
then
17635 Propagate_Part_Of
(Item_Id
);
17638 Next_Entity
(Item_Id
);
17640 end Propagate_Part_Of
;
17642 -- Start of processing for Propagate_Part_Of
17645 Propagate_Part_Of
(Pack_Id
);
17647 -- Detect a package instantiation that is subject to a Part_Of
17648 -- indicator, but has no visible state.
17650 if not Has_Item
then
17652 ("package instantiation & has Part_Of indicator but "
17653 & "lacks visible state", Instance
, Pack_Id
);
17655 end Propagate_Part_Of
;
17659 Item_Id
: Entity_Id
;
17662 State_Id
: Entity_Id
;
17665 -- Start of processing for Part_Of
17669 Check_No_Identifiers
;
17670 Check_Arg_Count
(1);
17672 -- Ensure the proper placement of the pragma. Part_Of must appear
17673 -- on a variable declaration or a package instantiation.
17676 while Present
(Stmt
) loop
17678 -- Skip prior pragmas, but check for duplicates
17680 if Nkind
(Stmt
) = N_Pragma
then
17681 if Pragma_Name
(Stmt
) = Pname
then
17682 Error_Msg_Name_1
:= Pname
;
17683 Error_Msg_Sloc
:= Sloc
(Stmt
);
17684 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17687 -- Skip internally generated code
17689 elsif not Comes_From_Source
(Stmt
) then
17692 -- The pragma applies to an object declaration (possibly a
17693 -- variable) or a package instantiation. Stop the traversal
17694 -- and continue the analysis.
17696 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17697 N_Package_Instantiation
)
17701 -- The pragma does not apply to a legal construct, issue an
17702 -- error and stop the analysis.
17709 Stmt
:= Prev
(Stmt
);
17712 -- When the context is an object declaration, ensure that we are
17713 -- dealing with a variable.
17715 if Nkind
(Stmt
) = N_Object_Declaration
17716 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17718 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17722 -- Extract the entity of the related object declaration or package
17723 -- instantiation. In the case of the instantiation, use the entity
17724 -- of the instance spec.
17726 if Nkind
(Stmt
) = N_Package_Instantiation
then
17727 Stmt
:= Instance_Spec
(Stmt
);
17730 Item_Id
:= Defining_Entity
(Stmt
);
17731 State
:= Get_Pragma_Arg
(Arg1
);
17733 -- Detect any discrepancies between the placement of the object
17734 -- or package instantiation with respect to state space and the
17735 -- encapsulating state.
17738 (Item_Id
=> Item_Id
,
17744 State_Id
:= Entity
(State
);
17746 -- Add the pragma to the contract of the item. This aids with
17747 -- the detection of a missing but required Part_Of indicator.
17749 Add_Contract_Item
(N
, Item_Id
);
17751 -- The Part_Of indicator turns a variable into a constituent
17752 -- of the encapsulating state.
17754 if Ekind
(Item_Id
) = E_Variable
then
17755 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17756 Set_Encapsulating_State
(Item_Id
, State_Id
);
17758 -- Propagate the Part_Of indicator to the visible state space
17759 -- of the package instantiation.
17763 (Pack_Id
=> Item_Id
,
17764 State_Id
=> State_Id
,
17770 ----------------------------------
17771 -- Partition_Elaboration_Policy --
17772 ----------------------------------
17774 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17776 when Pragma_Partition_Elaboration_Policy
=> declare
17777 subtype PEP_Range
is Name_Id
17778 range First_Partition_Elaboration_Policy_Name
17779 .. Last_Partition_Elaboration_Policy_Name
;
17780 PEP_Val
: PEP_Range
;
17785 Check_Arg_Count
(1);
17786 Check_No_Identifiers
;
17787 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17788 Check_Valid_Configuration_Pragma
;
17789 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17792 when Name_Concurrent
=>
17794 when Name_Sequential
=>
17798 if Partition_Elaboration_Policy
/= ' '
17799 and then Partition_Elaboration_Policy
/= PEP
17801 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17803 ("partition elaboration policy incompatible with policy#");
17805 -- Set new policy, but always preserve System_Location since we
17806 -- like the error message with the run time name.
17809 Partition_Elaboration_Policy
:= PEP
;
17811 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17812 Partition_Elaboration_Policy_Sloc
:= Loc
;
17821 -- pragma Passive [(PASSIVE_FORM)];
17823 -- PASSIVE_FORM ::= Semaphore | No
17825 when Pragma_Passive
=>
17828 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17829 Error_Pragma
("pragma% must be within task definition");
17832 if Arg_Count
/= 0 then
17833 Check_Arg_Count
(1);
17834 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17837 ----------------------------------
17838 -- Preelaborable_Initialization --
17839 ----------------------------------
17841 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17843 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17848 Check_Arg_Count
(1);
17849 Check_No_Identifiers
;
17850 Check_Arg_Is_Identifier
(Arg1
);
17851 Check_Arg_Is_Local_Name
(Arg1
);
17852 Check_First_Subtype
(Arg1
);
17853 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17855 -- The pragma may come from an aspect on a private declaration,
17856 -- even if the freeze point at which this is analyzed in the
17857 -- private part after the full view.
17859 if Has_Private_Declaration
(Ent
)
17860 and then From_Aspect_Specification
(N
)
17864 elsif Is_Private_Type
(Ent
)
17865 or else Is_Protected_Type
(Ent
)
17866 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17872 ("pragma % can only be applied to private, formal derived or "
17873 & "protected type",
17877 -- Give an error if the pragma is applied to a protected type that
17878 -- does not qualify (due to having entries, or due to components
17879 -- that do not qualify).
17881 if Is_Protected_Type
(Ent
)
17882 and then not Has_Preelaborable_Initialization
(Ent
)
17885 ("protected type & does not have preelaborable "
17886 & "initialization", Ent
);
17888 -- Otherwise mark the type as definitely having preelaborable
17892 Set_Known_To_Have_Preelab_Init
(Ent
);
17895 if Has_Pragma_Preelab_Init
(Ent
)
17896 and then Warn_On_Redundant_Constructs
17898 Error_Pragma
("?r?duplicate pragma%!");
17900 Set_Has_Pragma_Preelab_Init
(Ent
);
17904 --------------------
17905 -- Persistent_BSS --
17906 --------------------
17908 -- pragma Persistent_BSS [(object_NAME)];
17910 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17917 Check_At_Most_N_Arguments
(1);
17919 -- Case of application to specific object (one argument)
17921 if Arg_Count
= 1 then
17922 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17924 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17926 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17929 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17932 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17933 Decl
:= Parent
(Ent
);
17935 -- Check for duplication before inserting in list of
17936 -- representation items.
17938 Check_Duplicate_Pragma
(Ent
);
17940 if Rep_Item_Too_Late
(Ent
, N
) then
17944 if Present
(Expression
(Decl
)) then
17946 ("object for pragma% cannot have initialization", Arg1
);
17949 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17951 ("object type for pragma% is not potentially persistent",
17956 Make_Linker_Section_Pragma
17957 (Ent
, Sloc
(N
), ".persistent.bss");
17958 Insert_After
(N
, Prag
);
17961 -- Case of use as configuration pragma with no arguments
17964 Check_Valid_Configuration_Pragma
;
17965 Persistent_BSS_Mode
:= True;
17967 end Persistent_BSS
;
17973 -- pragma Polling (ON | OFF);
17975 when Pragma_Polling
=>
17977 Check_Arg_Count
(1);
17978 Check_No_Identifiers
;
17979 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17980 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17986 -- pragma Post (Boolean_EXPRESSION);
17987 -- pragma Post_Class (Boolean_EXPRESSION);
17989 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
17990 PC_Pragma
: Node_Id
;
17994 Check_Arg_Count
(1);
17995 Check_No_Identifiers
;
17998 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
17999 -- flag Class_Present to True for the Post_Class case.
18001 Set_Class_Present
(N
, Prag_Id
= Pragma_Post_Class
);
18002 PC_Pragma
:= New_Copy
(N
);
18003 Set_Pragma_Identifier
18004 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
18005 Rewrite
(N
, PC_Pragma
);
18006 Set_Analyzed
(N
, False);
18010 -------------------
18011 -- Postcondition --
18012 -------------------
18014 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18015 -- [,[Message =>] String_EXPRESSION]);
18017 when Pragma_Postcondition
=> Postcondition
: declare
18022 Check_At_Least_N_Arguments
(1);
18023 Check_At_Most_N_Arguments
(2);
18024 Check_Optional_Identifier
(Arg1
, Name_Check
);
18026 -- Verify the proper placement of the pragma. The remainder of the
18027 -- processing is found in Sem_Ch6/Sem_Ch7.
18029 Check_Precondition_Postcondition
(In_Body
);
18031 -- When the pragma is a source construct appearing inside a body,
18032 -- preanalyze the boolean_expression to detect illegal forward
18036 -- pragma Postcondition (X'Old ...);
18039 if Comes_From_Source
(N
) and then In_Body
then
18040 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
18048 -- pragma Pre (Boolean_EXPRESSION);
18049 -- pragma Pre_Class (Boolean_EXPRESSION);
18051 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
18052 PC_Pragma
: Node_Id
;
18056 Check_Arg_Count
(1);
18057 Check_No_Identifiers
;
18060 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
18061 -- flag Class_Present to True for the Pre_Class case.
18063 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
18064 PC_Pragma
:= New_Copy
(N
);
18065 Set_Pragma_Identifier
18066 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
18067 Rewrite
(N
, PC_Pragma
);
18068 Set_Analyzed
(N
, False);
18076 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18077 -- [,[Message =>] String_EXPRESSION]);
18079 when Pragma_Precondition
=> Precondition
: declare
18084 Check_At_Least_N_Arguments
(1);
18085 Check_At_Most_N_Arguments
(2);
18086 Check_Optional_Identifier
(Arg1
, Name_Check
);
18087 Check_Precondition_Postcondition
(In_Body
);
18089 -- If in spec, nothing more to do. If in body, then we convert
18090 -- the pragma to an equivalent pragma Check. That works fine since
18091 -- pragma Check will analyze the condition in the proper context.
18093 -- The form of the pragma Check is either:
18095 -- pragma Check (Precondition, cond [, msg])
18097 -- pragma Check (Pre, cond [, msg])
18099 -- We use the Pre form if this pragma derived from a Pre aspect.
18100 -- This is needed to make sure that the right set of Policy
18101 -- pragmas are checked.
18105 -- Rewrite as Check pragma
18109 Chars
=> Name_Check
,
18110 Pragma_Argument_Associations
=> New_List
(
18111 Make_Pragma_Argument_Association
(Loc
,
18112 Expression
=> Make_Identifier
(Loc
, Pname
)),
18114 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
18116 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
18118 if Arg_Count
= 2 then
18119 Append_To
(Pragma_Argument_Associations
(N
),
18120 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
18122 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
18133 -- pragma Predicate
18134 -- ([Entity =>] type_LOCAL_NAME,
18135 -- [Check =>] boolean_EXPRESSION);
18137 when Pragma_Predicate
=> Predicate
: declare
18144 Check_Arg_Count
(2);
18145 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18146 Check_Optional_Identifier
(Arg2
, Name_Check
);
18148 Check_Arg_Is_Local_Name
(Arg1
);
18150 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18151 Find_Type
(Type_Id
);
18152 Typ
:= Entity
(Type_Id
);
18154 if Typ
= Any_Type
then
18158 -- The remaining processing is simply to link the pragma on to
18159 -- the rep item chain, for processing when the type is frozen.
18160 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18161 -- mark the type as having predicates.
18163 Set_Has_Predicates
(Typ
);
18164 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18171 -- pragma Preelaborate [(library_unit_NAME)];
18173 -- Set the flag Is_Preelaborated of program unit name entity
18175 when Pragma_Preelaborate
=> Preelaborate
: declare
18176 Pa
: constant Node_Id
:= Parent
(N
);
18177 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18181 Check_Ada_83_Warning
;
18182 Check_Valid_Library_Unit_Pragma
;
18184 if Nkind
(N
) = N_Null_Statement
then
18188 Ent
:= Find_Lib_Unit_Name
;
18189 Check_Duplicate_Pragma
(Ent
);
18191 -- This filters out pragmas inside generic parents that show up
18192 -- inside instantiations. Pragmas that come from aspects in the
18193 -- unit are not ignored.
18195 if Present
(Ent
) then
18196 if Pk
= N_Package_Specification
18197 and then Present
(Generic_Parent
(Pa
))
18198 and then not From_Aspect_Specification
(N
)
18203 if not Debug_Flag_U
then
18204 Set_Is_Preelaborated
(Ent
);
18205 Set_Suppress_Elaboration_Warnings
(Ent
);
18211 -------------------------------
18212 -- Prefix_Exception_Messages --
18213 -------------------------------
18215 -- pragma Prefix_Exception_Messages;
18217 when Pragma_Prefix_Exception_Messages
=>
18219 Check_Valid_Configuration_Pragma
;
18220 Check_Arg_Count
(0);
18221 Prefix_Exception_Messages
:= True;
18227 -- pragma Priority (EXPRESSION);
18229 when Pragma_Priority
=> Priority
: declare
18230 P
: constant Node_Id
:= Parent
(N
);
18235 Check_No_Identifiers
;
18236 Check_Arg_Count
(1);
18240 if Nkind
(P
) = N_Subprogram_Body
then
18241 Check_In_Main_Program
;
18243 Ent
:= Defining_Unit_Name
(Specification
(P
));
18245 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18246 Ent
:= Defining_Identifier
(Ent
);
18249 Arg
:= Get_Pragma_Arg
(Arg1
);
18250 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18254 if not Is_OK_Static_Expression
(Arg
) then
18255 Flag_Non_Static_Expr
18256 ("main subprogram priority is not static!", Arg
);
18259 -- If constraint error, then we already signalled an error
18261 elsif Raises_Constraint_Error
(Arg
) then
18264 -- Otherwise check in range except if Relaxed_RM_Semantics
18265 -- where we ignore the value if out of range.
18269 Val
: constant Uint
:= Expr_Value
(Arg
);
18271 if not Relaxed_RM_Semantics
18274 or else Val
> Expr_Value
(Expression
18275 (Parent
(RTE
(RE_Max_Priority
)))))
18278 ("main subprogram priority is out of range", Arg1
);
18281 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18286 -- Load an arbitrary entity from System.Tasking.Stages or
18287 -- System.Tasking.Restricted.Stages (depending on the
18288 -- supported profile) to make sure that one of these packages
18289 -- is implicitly with'ed, since we need to have the tasking
18290 -- run time active for the pragma Priority to have any effect.
18291 -- Previously we with'ed the package System.Tasking, but this
18292 -- package does not trigger the required initialization of the
18293 -- run-time library.
18296 Discard
: Entity_Id
;
18297 pragma Warnings
(Off
, Discard
);
18299 if Restricted_Profile
then
18300 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18302 Discard
:= RTE
(RE_Activate_Tasks
);
18306 -- Task or Protected, must be of type Integer
18308 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18309 Arg
:= Get_Pragma_Arg
(Arg1
);
18310 Ent
:= Defining_Identifier
(Parent
(P
));
18312 -- The expression must be analyzed in the special manner
18313 -- described in "Handling of Default and Per-Object
18314 -- Expressions" in sem.ads.
18316 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18318 if not Is_OK_Static_Expression
(Arg
) then
18319 Check_Restriction
(Static_Priorities
, Arg
);
18322 -- Anything else is incorrect
18328 -- Check duplicate pragma before we chain the pragma in the Rep
18329 -- Item chain of Ent.
18331 Check_Duplicate_Pragma
(Ent
);
18332 Record_Rep_Item
(Ent
, N
);
18335 -----------------------------------
18336 -- Priority_Specific_Dispatching --
18337 -----------------------------------
18339 -- pragma Priority_Specific_Dispatching (
18340 -- policy_IDENTIFIER,
18341 -- first_priority_EXPRESSION,
18342 -- last_priority_EXPRESSION);
18344 when Pragma_Priority_Specific_Dispatching
=>
18345 Priority_Specific_Dispatching
: declare
18346 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18347 -- This is the entity System.Any_Priority;
18350 Lower_Bound
: Node_Id
;
18351 Upper_Bound
: Node_Id
;
18357 Check_Arg_Count
(3);
18358 Check_No_Identifiers
;
18359 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18360 Check_Valid_Configuration_Pragma
;
18361 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18362 DP
:= Fold_Upper
(Name_Buffer
(1));
18364 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18365 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18366 Lower_Val
:= Expr_Value
(Lower_Bound
);
18368 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18369 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18370 Upper_Val
:= Expr_Value
(Upper_Bound
);
18372 -- It is not allowed to use Task_Dispatching_Policy and
18373 -- Priority_Specific_Dispatching in the same partition.
18375 if Task_Dispatching_Policy
/= ' ' then
18376 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18378 ("pragma% incompatible with Task_Dispatching_Policy#");
18380 -- Check lower bound in range
18382 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18384 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18387 ("first_priority is out of range", Arg2
);
18389 -- Check upper bound in range
18391 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18393 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18396 ("last_priority is out of range", Arg3
);
18398 -- Check that the priority range is valid
18400 elsif Lower_Val
> Upper_Val
then
18402 ("last_priority_expression must be greater than or equal to "
18403 & "first_priority_expression");
18405 -- Store the new policy, but always preserve System_Location since
18406 -- we like the error message with the run-time name.
18409 -- Check overlapping in the priority ranges specified in other
18410 -- Priority_Specific_Dispatching pragmas within the same
18411 -- partition. We can only check those we know about.
18414 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18416 if Specific_Dispatching
.Table
(J
).First_Priority
in
18417 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18418 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18419 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18422 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18424 ("priority range overlaps with "
18425 & "Priority_Specific_Dispatching#");
18429 -- The use of Priority_Specific_Dispatching is incompatible
18430 -- with Task_Dispatching_Policy.
18432 if Task_Dispatching_Policy
/= ' ' then
18433 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18435 ("Priority_Specific_Dispatching incompatible "
18436 & "with Task_Dispatching_Policy#");
18439 -- The use of Priority_Specific_Dispatching forces ceiling
18442 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18443 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18445 ("Priority_Specific_Dispatching incompatible "
18446 & "with Locking_Policy#");
18448 -- Set the Ceiling_Locking policy, but preserve System_Location
18449 -- since we like the error message with the run time name.
18452 Locking_Policy
:= 'C';
18454 if Locking_Policy_Sloc
/= System_Location
then
18455 Locking_Policy_Sloc
:= Loc
;
18459 -- Add entry in the table
18461 Specific_Dispatching
.Append
18462 ((Dispatching_Policy
=> DP
,
18463 First_Priority
=> UI_To_Int
(Lower_Val
),
18464 Last_Priority
=> UI_To_Int
(Upper_Val
),
18465 Pragma_Loc
=> Loc
));
18467 end Priority_Specific_Dispatching
;
18473 -- pragma Profile (profile_IDENTIFIER);
18475 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18477 when Pragma_Profile
=>
18479 Check_Arg_Count
(1);
18480 Check_Valid_Configuration_Pragma
;
18481 Check_No_Identifiers
;
18484 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18487 if Chars
(Argx
) = Name_Ravenscar
then
18488 Set_Ravenscar_Profile
(N
);
18490 elsif Chars
(Argx
) = Name_Restricted
then
18491 Set_Profile_Restrictions
18493 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18495 elsif Chars
(Argx
) = Name_Rational
then
18496 Set_Rational_Profile
;
18498 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18499 Set_Profile_Restrictions
18500 (No_Implementation_Extensions
,
18501 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18504 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18508 ----------------------
18509 -- Profile_Warnings --
18510 ----------------------
18512 -- pragma Profile_Warnings (profile_IDENTIFIER);
18514 -- profile_IDENTIFIER => Restricted | Ravenscar
18516 when Pragma_Profile_Warnings
=>
18518 Check_Arg_Count
(1);
18519 Check_Valid_Configuration_Pragma
;
18520 Check_No_Identifiers
;
18523 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18526 if Chars
(Argx
) = Name_Ravenscar
then
18527 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18529 elsif Chars
(Argx
) = Name_Restricted
then
18530 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18532 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18533 Set_Profile_Restrictions
18534 (No_Implementation_Extensions
, N
, Warn
=> True);
18537 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18541 --------------------------
18542 -- Propagate_Exceptions --
18543 --------------------------
18545 -- pragma Propagate_Exceptions;
18547 -- Note: this pragma is obsolete and has no effect
18549 when Pragma_Propagate_Exceptions
=>
18551 Check_Arg_Count
(0);
18553 if Warn_On_Obsolescent_Feature
then
18555 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18556 "and has no effect?j?", N
);
18559 -----------------------------
18560 -- Provide_Shift_Operators --
18561 -----------------------------
18563 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18565 when Pragma_Provide_Shift_Operators
=>
18566 Provide_Shift_Operators
: declare
18569 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18570 -- Insert declaration and pragma Instrinsic for named shift op
18572 ----------------------------
18573 -- Declare_Shift_Operator --
18574 ----------------------------
18576 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18582 Make_Subprogram_Declaration
(Loc
,
18583 Make_Function_Specification
(Loc
,
18584 Defining_Unit_Name
=>
18585 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18587 Result_Definition
=>
18588 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18590 Parameter_Specifications
=> New_List
(
18591 Make_Parameter_Specification
(Loc
,
18592 Defining_Identifier
=>
18593 Make_Defining_Identifier
(Loc
, Name_Value
),
18595 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18597 Make_Parameter_Specification
(Loc
,
18598 Defining_Identifier
=>
18599 Make_Defining_Identifier
(Loc
, Name_Amount
),
18601 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18605 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18606 Pragma_Argument_Associations
=> New_List
(
18607 Make_Pragma_Argument_Association
(Loc
,
18608 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18609 Make_Pragma_Argument_Association
(Loc
,
18610 Expression
=> Make_Identifier
(Loc
, Nam
))));
18612 Insert_After
(N
, Import
);
18613 Insert_After
(N
, Func
);
18614 end Declare_Shift_Operator
;
18616 -- Start of processing for Provide_Shift_Operators
18620 Check_Arg_Count
(1);
18621 Check_Arg_Is_Local_Name
(Arg1
);
18623 Arg1
:= Get_Pragma_Arg
(Arg1
);
18625 -- We must have an entity name
18627 if not Is_Entity_Name
(Arg1
) then
18629 ("pragma % must apply to integer first subtype", Arg1
);
18632 -- If no Entity, means there was a prior error so ignore
18634 if Present
(Entity
(Arg1
)) then
18635 Ent
:= Entity
(Arg1
);
18637 -- Apply error checks
18639 if not Is_First_Subtype
(Ent
) then
18641 ("cannot apply pragma %",
18642 "\& is not a first subtype",
18645 elsif not Is_Integer_Type
(Ent
) then
18647 ("cannot apply pragma %",
18648 "\& is not an integer type",
18651 elsif Has_Shift_Operator
(Ent
) then
18653 ("cannot apply pragma %",
18654 "\& already has declared shift operators",
18657 elsif Is_Frozen
(Ent
) then
18659 ("pragma % appears too late",
18660 "\& is already frozen",
18664 -- Now declare the operators. We do this during analysis rather
18665 -- than expansion, since we want the operators available if we
18666 -- are operating in -gnatc or ASIS mode.
18668 Declare_Shift_Operator
(Name_Rotate_Left
);
18669 Declare_Shift_Operator
(Name_Rotate_Right
);
18670 Declare_Shift_Operator
(Name_Shift_Left
);
18671 Declare_Shift_Operator
(Name_Shift_Right
);
18672 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18674 end Provide_Shift_Operators
;
18680 -- pragma Psect_Object (
18681 -- [Internal =>] LOCAL_NAME,
18682 -- [, [External =>] EXTERNAL_SYMBOL]
18683 -- [, [Size =>] EXTERNAL_SYMBOL]);
18685 when Pragma_Psect_Object | Pragma_Common_Object
=>
18686 Psect_Object
: declare
18687 Args
: Args_List
(1 .. 3);
18688 Names
: constant Name_List
(1 .. 3) := (
18693 Internal
: Node_Id
renames Args
(1);
18694 External
: Node_Id
renames Args
(2);
18695 Size
: Node_Id
renames Args
(3);
18697 Def_Id
: Entity_Id
;
18699 procedure Check_Arg
(Arg
: Node_Id
);
18700 -- Checks that argument is either a string literal or an
18701 -- identifier, and posts error message if not.
18707 procedure Check_Arg
(Arg
: Node_Id
) is
18709 if not Nkind_In
(Original_Node
(Arg
),
18714 ("inappropriate argument for pragma %", Arg
);
18718 -- Start of processing for Common_Object/Psect_Object
18722 Gather_Associations
(Names
, Args
);
18723 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18725 Def_Id
:= Entity
(Internal
);
18727 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18729 ("pragma% must designate an object", Internal
);
18732 Check_Arg
(Internal
);
18734 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18736 ("cannot use pragma% for imported/exported object",
18740 if Is_Concurrent_Type
(Etype
(Internal
)) then
18742 ("cannot specify pragma % for task/protected object",
18746 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18748 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18750 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18753 if Ekind
(Def_Id
) = E_Constant
then
18755 ("cannot specify pragma % for a constant", Internal
);
18758 if Is_Record_Type
(Etype
(Internal
)) then
18764 Ent
:= First_Entity
(Etype
(Internal
));
18765 while Present
(Ent
) loop
18766 Decl
:= Declaration_Node
(Ent
);
18768 if Ekind
(Ent
) = E_Component
18769 and then Nkind
(Decl
) = N_Component_Declaration
18770 and then Present
(Expression
(Decl
))
18771 and then Warn_On_Export_Import
18774 ("?x?object for pragma % has defaults", Internal
);
18784 if Present
(Size
) then
18788 if Present
(External
) then
18789 Check_Arg_Is_External_Name
(External
);
18792 -- If all error tests pass, link pragma on to the rep item chain
18794 Record_Rep_Item
(Def_Id
, N
);
18801 -- pragma Pure [(library_unit_NAME)];
18803 when Pragma_Pure
=> Pure
: declare
18807 Check_Ada_83_Warning
;
18808 Check_Valid_Library_Unit_Pragma
;
18810 if Nkind
(N
) = N_Null_Statement
then
18814 Ent
:= Find_Lib_Unit_Name
;
18816 Set_Has_Pragma_Pure
(Ent
);
18817 Set_Suppress_Elaboration_Warnings
(Ent
);
18820 -------------------
18821 -- Pure_Function --
18822 -------------------
18824 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18826 when Pragma_Pure_Function
=> Pure_Function
: declare
18829 Def_Id
: Entity_Id
;
18830 Effective
: Boolean := False;
18834 Check_Arg_Count
(1);
18835 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18836 Check_Arg_Is_Local_Name
(Arg1
);
18837 E_Id
:= Get_Pragma_Arg
(Arg1
);
18839 if Error_Posted
(E_Id
) then
18843 -- Loop through homonyms (overloadings) of referenced entity
18845 E
:= Entity
(E_Id
);
18847 if Present
(E
) then
18849 Def_Id
:= Get_Base_Subprogram
(E
);
18851 if not Ekind_In
(Def_Id
, E_Function
,
18852 E_Generic_Function
,
18856 ("pragma% requires a function name", Arg1
);
18859 Set_Is_Pure
(Def_Id
);
18861 if not Has_Pragma_Pure_Function
(Def_Id
) then
18862 Set_Has_Pragma_Pure_Function
(Def_Id
);
18866 exit when From_Aspect_Specification
(N
);
18868 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18872 and then Warn_On_Redundant_Constructs
18875 ("pragma Pure_Function on& is redundant?r?",
18881 --------------------
18882 -- Queuing_Policy --
18883 --------------------
18885 -- pragma Queuing_Policy (policy_IDENTIFIER);
18887 when Pragma_Queuing_Policy
=> declare
18891 Check_Ada_83_Warning
;
18892 Check_Arg_Count
(1);
18893 Check_No_Identifiers
;
18894 Check_Arg_Is_Queuing_Policy
(Arg1
);
18895 Check_Valid_Configuration_Pragma
;
18896 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18897 QP
:= Fold_Upper
(Name_Buffer
(1));
18899 if Queuing_Policy
/= ' '
18900 and then Queuing_Policy
/= QP
18902 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18903 Error_Pragma
("queuing policy incompatible with policy#");
18905 -- Set new policy, but always preserve System_Location since we
18906 -- like the error message with the run time name.
18909 Queuing_Policy
:= QP
;
18911 if Queuing_Policy_Sloc
/= System_Location
then
18912 Queuing_Policy_Sloc
:= Loc
;
18921 -- pragma Rational, for compatibility with foreign compiler
18923 when Pragma_Rational
=>
18924 Set_Rational_Profile
;
18926 ------------------------------------
18927 -- Refined_Depends/Refined_Global --
18928 ------------------------------------
18930 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18932 -- DEPENDENCY_RELATION ::=
18934 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18936 -- DEPENDENCY_CLAUSE ::=
18937 -- OUTPUT_LIST =>[+] INPUT_LIST
18938 -- | NULL_DEPENDENCY_CLAUSE
18940 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18942 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18944 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18946 -- OUTPUT ::= NAME | FUNCTION_RESULT
18949 -- where FUNCTION_RESULT is a function Result attribute_reference
18951 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18953 -- GLOBAL_SPECIFICATION ::=
18956 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18958 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18960 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18961 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18962 -- GLOBAL_ITEM ::= NAME
18964 when Pragma_Refined_Depends |
18965 Pragma_Refined_Global
=> Refined_Depends_Global
:
18967 Body_Id
: Entity_Id
;
18969 Spec_Id
: Entity_Id
;
18972 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18974 -- Save the pragma in the contract of the subprogram body. The
18975 -- remaining analysis is performed at the end of the enclosing
18979 Add_Contract_Item
(N
, Body_Id
);
18981 end Refined_Depends_Global
;
18987 -- pragma Refined_Post (boolean_EXPRESSION);
18989 when Pragma_Refined_Post
=> Refined_Post
: declare
18990 Body_Id
: Entity_Id
;
18992 Result_Seen
: Boolean := False;
18993 Spec_Id
: Entity_Id
;
18996 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18998 -- Analyze the boolean expression as a "spec expression"
19001 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
19003 -- Verify that the refined postcondition mentions attribute
19004 -- 'Result and its expression introduces a post-state.
19006 if Warn_On_Suspicious_Contract
19007 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
19009 Check_Result_And_Post_State
(N
, Result_Seen
);
19011 if not Result_Seen
then
19013 ("pragma % does not mention function result?T?");
19017 -- Chain the pragma on the contract for easy retrieval
19019 Add_Contract_Item
(N
, Body_Id
);
19023 -------------------
19024 -- Refined_State --
19025 -------------------
19027 -- pragma Refined_State (REFINEMENT_LIST);
19029 -- REFINEMENT_LIST ::=
19030 -- REFINEMENT_CLAUSE
19031 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19033 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19035 -- CONSTITUENT_LIST ::=
19038 -- | (CONSTITUENT {, CONSTITUENT})
19040 -- CONSTITUENT ::= object_NAME | state_NAME
19042 when Pragma_Refined_State
=> Refined_State
: declare
19043 Context
: constant Node_Id
:= Parent
(N
);
19044 Spec_Id
: Entity_Id
;
19049 Check_No_Identifiers
;
19050 Check_Arg_Count
(1);
19052 -- Ensure the proper placement of the pragma. Refined states must
19053 -- be associated with a package body.
19055 if Nkind
(Context
) /= N_Package_Body
then
19061 while Present
(Stmt
) loop
19063 -- Skip prior pragmas, but check for duplicates
19065 if Nkind
(Stmt
) = N_Pragma
then
19066 if Pragma_Name
(Stmt
) = Pname
then
19067 Error_Msg_Name_1
:= Pname
;
19068 Error_Msg_Sloc
:= Sloc
(Stmt
);
19069 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
19072 -- Skip internally generated code
19074 elsif not Comes_From_Source
(Stmt
) then
19077 -- The pragma does not apply to a legal construct, issue an
19078 -- error and stop the analysis.
19085 Stmt
:= Prev
(Stmt
);
19088 Spec_Id
:= Corresponding_Spec
(Context
);
19090 -- State refinement is allowed only when the corresponding package
19091 -- declaration has non-null pragma Abstract_State. Refinement not
19092 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19094 if SPARK_Mode
/= Off
19096 (No
(Abstract_States
(Spec_Id
))
19097 or else Has_Null_Abstract_State
(Spec_Id
))
19100 ("useless refinement, package & does not define abstract "
19101 & "states", N
, Spec_Id
);
19105 -- The pragma must be analyzed at the end of the declarations as
19106 -- it has visibility over the whole declarative region. Save the
19107 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19108 -- adding it to the contract of the package body.
19110 Add_Contract_Item
(N
, Defining_Entity
(Context
));
19113 -----------------------
19114 -- Relative_Deadline --
19115 -----------------------
19117 -- pragma Relative_Deadline (time_span_EXPRESSION);
19119 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19120 P
: constant Node_Id
:= Parent
(N
);
19125 Check_No_Identifiers
;
19126 Check_Arg_Count
(1);
19128 Arg
:= Get_Pragma_Arg
(Arg1
);
19130 -- The expression must be analyzed in the special manner described
19131 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19133 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19137 if Nkind
(P
) = N_Subprogram_Body
then
19138 Check_In_Main_Program
;
19140 -- Only Task and subprogram cases allowed
19142 elsif Nkind
(P
) /= N_Task_Definition
then
19146 -- Check duplicate pragma before we set the corresponding flag
19148 if Has_Relative_Deadline_Pragma
(P
) then
19149 Error_Pragma
("duplicate pragma% not allowed");
19152 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19153 -- Relative_Deadline pragma node cannot be inserted in the Rep
19154 -- Item chain of Ent since it is rewritten by the expander as a
19155 -- procedure call statement that will break the chain.
19157 Set_Has_Relative_Deadline_Pragma
(P
, True);
19158 end Relative_Deadline
;
19160 ------------------------
19161 -- Remote_Access_Type --
19162 ------------------------
19164 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19166 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19171 Check_Arg_Count
(1);
19172 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19173 Check_Arg_Is_Local_Name
(Arg1
);
19175 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19177 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19178 and then Ekind
(E
) = E_General_Access_Type
19179 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19180 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19182 and then Is_Valid_Remote_Object_Type
19183 (Root_Type
(Directly_Designated_Type
(E
)))
19185 Set_Is_Remote_Types
(E
);
19189 ("pragma% applies only to formal access to classwide types",
19192 end Remote_Access_Type
;
19194 ---------------------------
19195 -- Remote_Call_Interface --
19196 ---------------------------
19198 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19200 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19201 Cunit_Node
: Node_Id
;
19202 Cunit_Ent
: Entity_Id
;
19206 Check_Ada_83_Warning
;
19207 Check_Valid_Library_Unit_Pragma
;
19209 if Nkind
(N
) = N_Null_Statement
then
19213 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19214 K
:= Nkind
(Unit
(Cunit_Node
));
19215 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19217 if K
= N_Package_Declaration
19218 or else K
= N_Generic_Package_Declaration
19219 or else K
= N_Subprogram_Declaration
19220 or else K
= N_Generic_Subprogram_Declaration
19221 or else (K
= N_Subprogram_Body
19222 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19227 "pragma% must apply to package or subprogram declaration");
19230 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19231 end Remote_Call_Interface
;
19237 -- pragma Remote_Types [(library_unit_NAME)];
19239 when Pragma_Remote_Types
=> Remote_Types
: declare
19240 Cunit_Node
: Node_Id
;
19241 Cunit_Ent
: Entity_Id
;
19244 Check_Ada_83_Warning
;
19245 Check_Valid_Library_Unit_Pragma
;
19247 if Nkind
(N
) = N_Null_Statement
then
19251 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19252 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19254 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19255 N_Generic_Package_Declaration
)
19258 ("pragma% can only apply to a package declaration");
19261 Set_Is_Remote_Types
(Cunit_Ent
);
19268 -- pragma Ravenscar;
19270 when Pragma_Ravenscar
=>
19272 Check_Arg_Count
(0);
19273 Check_Valid_Configuration_Pragma
;
19274 Set_Ravenscar_Profile
(N
);
19276 if Warn_On_Obsolescent_Feature
then
19278 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19280 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19283 -------------------------
19284 -- Restricted_Run_Time --
19285 -------------------------
19287 -- pragma Restricted_Run_Time;
19289 when Pragma_Restricted_Run_Time
=>
19291 Check_Arg_Count
(0);
19292 Check_Valid_Configuration_Pragma
;
19293 Set_Profile_Restrictions
19294 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19296 if Warn_On_Obsolescent_Feature
then
19298 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19301 ("|use pragma Profile (Restricted) instead?j?", N
);
19308 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19311 -- restriction_IDENTIFIER
19312 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19314 when Pragma_Restrictions
=>
19315 Process_Restrictions_Or_Restriction_Warnings
19316 (Warn
=> Treat_Restrictions_As_Warnings
);
19318 --------------------------
19319 -- Restriction_Warnings --
19320 --------------------------
19322 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19325 -- restriction_IDENTIFIER
19326 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19328 when Pragma_Restriction_Warnings
=>
19330 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19336 -- pragma Reviewable;
19338 when Pragma_Reviewable
=>
19339 Check_Ada_83_Warning
;
19340 Check_Arg_Count
(0);
19342 -- Call dummy debugging function rv. This is done to assist front
19343 -- end debugging. By placing a Reviewable pragma in the source
19344 -- program, a breakpoint on rv catches this place in the source,
19345 -- allowing convenient stepping to the point of interest.
19349 --------------------------
19350 -- Short_Circuit_And_Or --
19351 --------------------------
19353 -- pragma Short_Circuit_And_Or;
19355 when Pragma_Short_Circuit_And_Or
=>
19357 Check_Arg_Count
(0);
19358 Check_Valid_Configuration_Pragma
;
19359 Short_Circuit_And_Or
:= True;
19361 -------------------
19362 -- Share_Generic --
19363 -------------------
19365 -- pragma Share_Generic (GNAME {, GNAME});
19367 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19369 when Pragma_Share_Generic
=>
19371 Process_Generic_List
;
19377 -- pragma Shared (LOCAL_NAME);
19379 when Pragma_Shared
=>
19381 Process_Atomic_Shared_Volatile
;
19383 --------------------
19384 -- Shared_Passive --
19385 --------------------
19387 -- pragma Shared_Passive [(library_unit_NAME)];
19389 -- Set the flag Is_Shared_Passive of program unit name entity
19391 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19392 Cunit_Node
: Node_Id
;
19393 Cunit_Ent
: Entity_Id
;
19396 Check_Ada_83_Warning
;
19397 Check_Valid_Library_Unit_Pragma
;
19399 if Nkind
(N
) = N_Null_Statement
then
19403 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19404 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19406 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19407 N_Generic_Package_Declaration
)
19410 ("pragma% can only apply to a package declaration");
19413 Set_Is_Shared_Passive
(Cunit_Ent
);
19414 end Shared_Passive
;
19416 -----------------------
19417 -- Short_Descriptors --
19418 -----------------------
19420 -- pragma Short_Descriptors;
19422 -- Recognize and validate, but otherwise ignore
19424 when Pragma_Short_Descriptors
=>
19426 Check_Arg_Count
(0);
19427 Check_Valid_Configuration_Pragma
;
19429 ------------------------------
19430 -- Simple_Storage_Pool_Type --
19431 ------------------------------
19433 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19435 when Pragma_Simple_Storage_Pool_Type
=>
19436 Simple_Storage_Pool_Type
: declare
19442 Check_Arg_Count
(1);
19443 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19445 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19446 Find_Type
(Type_Id
);
19447 Typ
:= Entity
(Type_Id
);
19449 if Typ
= Any_Type
then
19453 -- We require the pragma to apply to a type declared in a package
19454 -- declaration, but not (immediately) within a package body.
19456 if Ekind
(Current_Scope
) /= E_Package
19457 or else In_Package_Body
(Current_Scope
)
19460 ("pragma% can only apply to type declared immediately "
19461 & "within a package declaration");
19464 -- A simple storage pool type must be an immutably limited record
19465 -- or private type. If the pragma is given for a private type,
19466 -- the full type is similarly restricted (which is checked later
19467 -- in Freeze_Entity).
19469 if Is_Record_Type
(Typ
)
19470 and then not Is_Limited_View
(Typ
)
19473 ("pragma% can only apply to explicitly limited record type");
19475 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19477 ("pragma% can only apply to a private type that is limited");
19479 elsif not Is_Record_Type
(Typ
)
19480 and then not Is_Private_Type
(Typ
)
19483 ("pragma% can only apply to limited record or private type");
19486 Record_Rep_Item
(Typ
, N
);
19487 end Simple_Storage_Pool_Type
;
19489 ----------------------
19490 -- Source_File_Name --
19491 ----------------------
19493 -- There are five forms for this pragma:
19495 -- pragma Source_File_Name (
19496 -- [UNIT_NAME =>] unit_NAME,
19497 -- BODY_FILE_NAME => STRING_LITERAL
19498 -- [, [INDEX =>] INTEGER_LITERAL]);
19500 -- pragma Source_File_Name (
19501 -- [UNIT_NAME =>] unit_NAME,
19502 -- SPEC_FILE_NAME => STRING_LITERAL
19503 -- [, [INDEX =>] INTEGER_LITERAL]);
19505 -- pragma Source_File_Name (
19506 -- BODY_FILE_NAME => STRING_LITERAL
19507 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19508 -- [, CASING => CASING_SPEC]);
19510 -- pragma Source_File_Name (
19511 -- SPEC_FILE_NAME => STRING_LITERAL
19512 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19513 -- [, CASING => CASING_SPEC]);
19515 -- pragma Source_File_Name (
19516 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19517 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19518 -- [, CASING => CASING_SPEC]);
19520 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19522 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19523 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19524 -- only be used when no project file is used, while SFNP can only be
19525 -- used when a project file is used.
19527 -- No processing here. Processing was completed during parsing, since
19528 -- we need to have file names set as early as possible. Units are
19529 -- loaded well before semantic processing starts.
19531 -- The only processing we defer to this point is the check for
19532 -- correct placement.
19534 when Pragma_Source_File_Name
=>
19536 Check_Valid_Configuration_Pragma
;
19538 ------------------------------
19539 -- Source_File_Name_Project --
19540 ------------------------------
19542 -- See Source_File_Name for syntax
19544 -- No processing here. Processing was completed during parsing, since
19545 -- we need to have file names set as early as possible. Units are
19546 -- loaded well before semantic processing starts.
19548 -- The only processing we defer to this point is the check for
19549 -- correct placement.
19551 when Pragma_Source_File_Name_Project
=>
19553 Check_Valid_Configuration_Pragma
;
19555 -- Check that a pragma Source_File_Name_Project is used only in a
19556 -- configuration pragmas file.
19558 -- Pragmas Source_File_Name_Project should only be generated by
19559 -- the Project Manager in configuration pragmas files.
19561 -- This is really an ugly test. It seems to depend on some
19562 -- accidental and undocumented property. At the very least it
19563 -- needs to be documented, but it would be better to have a
19564 -- clean way of testing if we are in a configuration file???
19566 if Present
(Parent
(N
)) then
19568 ("pragma% can only appear in a configuration pragmas file");
19571 ----------------------
19572 -- Source_Reference --
19573 ----------------------
19575 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19577 -- Nothing to do, all processing completed in Par.Prag, since we need
19578 -- the information for possible parser messages that are output.
19580 when Pragma_Source_Reference
=>
19587 -- pragma SPARK_Mode [(On | Off)];
19589 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19590 Mode_Id
: SPARK_Mode_Type
;
19592 procedure Check_Pragma_Conformance
19593 (Context_Pragma
: Node_Id
;
19594 Entity_Pragma
: Node_Id
;
19595 Entity
: Entity_Id
);
19596 -- If Context_Pragma is not Empty, verify that the new pragma N
19597 -- is compatible with the pragma Context_Pragma that was inherited
19598 -- from the context:
19599 -- . if Context_Pragma is ON, then the new mode can be anything
19600 -- . if Context_Pragma is OFF, then the only allowed new mode is
19603 -- If Entity is not Empty, verify that the new pragma N is
19604 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19605 -- for Entity (which may be Empty):
19606 -- . if Entity_Pragma is ON, then the new mode can be anything
19607 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19609 -- . if Entity_Pragma is Empty, we always issue an error, as this
19610 -- corresponds to a case where a previous section of Entity
19611 -- had no SPARK_Mode set.
19613 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19614 -- Verify that pragma is applied to library-level entity E
19616 procedure Set_SPARK_Flags
;
19617 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19618 -- and ensures that Dynamic_Elaboration_Checks are off if the
19619 -- call sets SPARK_Mode On.
19621 ------------------------------
19622 -- Check_Pragma_Conformance --
19623 ------------------------------
19625 procedure Check_Pragma_Conformance
19626 (Context_Pragma
: Node_Id
;
19627 Entity_Pragma
: Node_Id
;
19628 Entity
: Entity_Id
)
19631 if Present
(Context_Pragma
) then
19632 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19634 -- New mode less restrictive than the established mode
19636 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19637 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19640 ("cannot change SPARK_Mode from Off to On", Arg1
);
19641 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19642 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg1
);
19647 if Present
(Entity
) then
19648 if Present
(Entity_Pragma
) then
19649 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19650 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19652 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19653 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19655 ("\value Off was set for SPARK_Mode on&#",
19661 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19662 Error_Msg_Sloc
:= Sloc
(Entity
);
19664 ("\no value was set for SPARK_Mode on&#",
19669 end Check_Pragma_Conformance
;
19671 --------------------------------
19672 -- Check_Library_Level_Entity --
19673 --------------------------------
19675 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19676 MsgF
: constant String := "incorrect placement of pragma%";
19679 if not Is_Library_Level_Entity
(E
) then
19680 Error_Msg_Name_1
:= Pname
;
19681 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19683 if Ekind_In
(E
, E_Generic_Package
,
19688 ("\& is not a library-level package", N
, E
);
19691 ("\& is not a library-level subprogram", N
, E
);
19696 end Check_Library_Level_Entity
;
19698 ---------------------
19699 -- Set_SPARK_Flags --
19700 ---------------------
19702 procedure Set_SPARK_Flags
is
19704 SPARK_Mode
:= Mode_Id
;
19705 SPARK_Mode_Pragma
:= N
;
19707 if SPARK_Mode
= On
then
19708 Dynamic_Elaboration_Checks
:= False;
19710 end Set_SPARK_Flags
;
19714 Body_Id
: Entity_Id
;
19717 Spec_Id
: Entity_Id
;
19720 -- Start of processing for Do_SPARK_Mode
19723 -- When a SPARK_Mode pragma appears inside an instantiation whose
19724 -- enclosing context has SPARK_Mode set to "off", the pragma has
19725 -- no semantic effect.
19727 if Ignore_Pragma_SPARK_Mode
then
19728 Rewrite
(N
, Make_Null_Statement
(Loc
));
19734 Check_No_Identifiers
;
19735 Check_At_Most_N_Arguments
(1);
19737 -- Check the legality of the mode (no argument = ON)
19739 if Arg_Count
= 1 then
19740 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19741 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19746 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19747 Context
:= Parent
(N
);
19749 -- The pragma appears in a configuration pragmas file
19751 if No
(Context
) then
19752 Check_Valid_Configuration_Pragma
;
19754 if Present
(SPARK_Mode_Pragma
) then
19755 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19756 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19762 -- The pragma acts as a configuration pragma in a compilation unit
19764 -- pragma SPARK_Mode ...;
19765 -- package Pack is ...;
19767 elsif Nkind
(Context
) = N_Compilation_Unit
19768 and then List_Containing
(N
) = Context_Items
(Context
)
19770 Check_Valid_Configuration_Pragma
;
19773 -- Otherwise the placement of the pragma within the tree dictates
19774 -- its associated construct. Inspect the declarative list where
19775 -- the pragma resides to find a potential construct.
19779 while Present
(Stmt
) loop
19781 -- Skip prior pragmas, but check for duplicates
19783 if Nkind
(Stmt
) = N_Pragma
then
19784 if Pragma_Name
(Stmt
) = Pname
then
19785 Error_Msg_Name_1
:= Pname
;
19786 Error_Msg_Sloc
:= Sloc
(Stmt
);
19787 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19791 -- The pragma applies to a [generic] subprogram declaration.
19792 -- Note that this case covers an internally generated spec
19793 -- for a stand alone body.
19796 -- procedure Proc ...;
19797 -- pragma SPARK_Mode ..;
19799 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19800 N_Subprogram_Declaration
)
19802 Spec_Id
:= Defining_Entity
(Stmt
);
19803 Check_Library_Level_Entity
(Spec_Id
);
19804 Check_Pragma_Conformance
19805 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19806 Entity_Pragma
=> Empty
,
19809 Set_SPARK_Pragma
(Spec_Id
, N
);
19810 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19813 -- Skip internally generated code
19815 elsif not Comes_From_Source
(Stmt
) then
19818 -- Otherwise the pragma does not apply to a legal construct
19819 -- or it does not appear at the top of a declarative or a
19820 -- statement list. Issue an error and stop the analysis.
19830 -- The pragma applies to a package or a subprogram that acts as
19831 -- a compilation unit.
19833 -- procedure Proc ...;
19834 -- pragma SPARK_Mode ...;
19836 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19837 Context
:= Unit
(Parent
(Context
));
19840 -- The pragma appears within package declarations
19842 if Nkind
(Context
) = N_Package_Specification
then
19843 Spec_Id
:= Defining_Entity
(Context
);
19844 Check_Library_Level_Entity
(Spec_Id
);
19846 -- The pragma is at the top of the visible declarations
19849 -- pragma SPARK_Mode ...;
19851 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19852 Check_Pragma_Conformance
19853 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19854 Entity_Pragma
=> Empty
,
19858 Set_SPARK_Pragma
(Spec_Id
, N
);
19859 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19860 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19861 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19863 -- The pragma is at the top of the private declarations
19867 -- pragma SPARK_Mode ...;
19870 Check_Pragma_Conformance
19871 (Context_Pragma
=> Empty
,
19872 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19873 Entity
=> Spec_Id
);
19876 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19877 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19880 -- The pragma appears at the top of package body declarations
19882 -- package body Pack is
19883 -- pragma SPARK_Mode ...;
19885 elsif Nkind
(Context
) = N_Package_Body
then
19886 Spec_Id
:= Corresponding_Spec
(Context
);
19887 Body_Id
:= Defining_Entity
(Context
);
19888 Check_Library_Level_Entity
(Body_Id
);
19889 Check_Pragma_Conformance
19890 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19891 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19892 Entity
=> Spec_Id
);
19895 Set_SPARK_Pragma
(Body_Id
, N
);
19896 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19897 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19898 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19900 -- The pragma appears at the top of package body statements
19902 -- package body Pack is
19904 -- pragma SPARK_Mode;
19906 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19907 and then Nkind
(Parent
(Context
)) = N_Package_Body
19909 Context
:= Parent
(Context
);
19910 Spec_Id
:= Corresponding_Spec
(Context
);
19911 Body_Id
:= Defining_Entity
(Context
);
19912 Check_Library_Level_Entity
(Body_Id
);
19913 Check_Pragma_Conformance
19914 (Context_Pragma
=> Empty
,
19915 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19916 Entity
=> Body_Id
);
19919 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19920 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19922 -- The pragma appeared as an aspect of a [generic] subprogram
19923 -- declaration that acts as a compilation unit.
19926 -- procedure Proc ...;
19927 -- pragma SPARK_Mode ...;
19929 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19930 N_Subprogram_Declaration
)
19932 Spec_Id
:= Defining_Entity
(Context
);
19933 Check_Library_Level_Entity
(Spec_Id
);
19934 Check_Pragma_Conformance
19935 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19936 Entity_Pragma
=> Empty
,
19939 Set_SPARK_Pragma
(Spec_Id
, N
);
19940 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19942 -- The pragma appears at the top of subprogram body
19945 -- procedure Proc ... is
19946 -- pragma SPARK_Mode;
19948 elsif Nkind
(Context
) = N_Subprogram_Body
then
19949 Spec_Id
:= Corresponding_Spec
(Context
);
19950 Context
:= Specification
(Context
);
19951 Body_Id
:= Defining_Entity
(Context
);
19953 -- Ignore pragma when applied to the special body created
19954 -- for inlining, recognized by its internal name _Parent.
19956 if Chars
(Body_Id
) = Name_uParent
then
19960 Check_Library_Level_Entity
(Body_Id
);
19962 -- The body is a completion of a previous declaration
19964 if Present
(Spec_Id
) then
19965 Check_Pragma_Conformance
19966 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19967 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19968 Entity
=> Spec_Id
);
19970 -- The body acts as spec
19973 Check_Pragma_Conformance
19974 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19975 Entity_Pragma
=> Empty
,
19981 Set_SPARK_Pragma
(Body_Id
, N
);
19982 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19984 -- The pragma does not apply to a legal construct, issue error
19992 --------------------------------
19993 -- Static_Elaboration_Desired --
19994 --------------------------------
19996 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19998 when Pragma_Static_Elaboration_Desired
=>
20000 Check_At_Most_N_Arguments
(1);
20002 if Is_Compilation_Unit
(Current_Scope
)
20003 and then Ekind
(Current_Scope
) = E_Package
20005 Set_Static_Elaboration_Desired
(Current_Scope
, True);
20007 Error_Pragma
("pragma% must apply to a library-level package");
20014 -- pragma Storage_Size (EXPRESSION);
20016 when Pragma_Storage_Size
=> Storage_Size
: declare
20017 P
: constant Node_Id
:= Parent
(N
);
20021 Check_No_Identifiers
;
20022 Check_Arg_Count
(1);
20024 -- The expression must be analyzed in the special manner described
20025 -- in "Handling of Default Expressions" in sem.ads.
20027 Arg
:= Get_Pragma_Arg
(Arg1
);
20028 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20030 if not Is_OK_Static_Expression
(Arg
) then
20031 Check_Restriction
(Static_Storage_Size
, Arg
);
20034 if Nkind
(P
) /= N_Task_Definition
then
20039 if Has_Storage_Size_Pragma
(P
) then
20040 Error_Pragma
("duplicate pragma% not allowed");
20042 Set_Has_Storage_Size_Pragma
(P
, True);
20045 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20053 -- pragma Storage_Unit (NUMERIC_LITERAL);
20055 -- Only permitted argument is System'Storage_Unit value
20057 when Pragma_Storage_Unit
=>
20058 Check_No_Identifiers
;
20059 Check_Arg_Count
(1);
20060 Check_Arg_Is_Integer_Literal
(Arg1
);
20062 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20063 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20065 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20067 ("the only allowed argument for pragma% is ^", Arg1
);
20070 --------------------
20071 -- Stream_Convert --
20072 --------------------
20074 -- pragma Stream_Convert (
20075 -- [Entity =>] type_LOCAL_NAME,
20076 -- [Read =>] function_NAME,
20077 -- [Write =>] function NAME);
20079 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20081 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20082 -- Check that the given argument is the name of a local function
20083 -- of one argument that is not overloaded earlier in the current
20084 -- local scope. A check is also made that the argument is a
20085 -- function with one parameter.
20087 --------------------------------------
20088 -- Check_OK_Stream_Convert_Function --
20089 --------------------------------------
20091 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20095 Check_Arg_Is_Local_Name
(Arg
);
20096 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20098 if Has_Homonym
(Ent
) then
20100 ("argument for pragma% may not be overloaded", Arg
);
20103 if Ekind
(Ent
) /= E_Function
20104 or else No
(First_Formal
(Ent
))
20105 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20108 ("argument for pragma% must be function of one argument",
20111 end Check_OK_Stream_Convert_Function
;
20113 -- Start of processing for Stream_Convert
20117 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20118 Check_Arg_Count
(3);
20119 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20120 Check_Optional_Identifier
(Arg2
, Name_Read
);
20121 Check_Optional_Identifier
(Arg3
, Name_Write
);
20122 Check_Arg_Is_Local_Name
(Arg1
);
20123 Check_OK_Stream_Convert_Function
(Arg2
);
20124 Check_OK_Stream_Convert_Function
(Arg3
);
20127 Typ
: constant Entity_Id
:=
20128 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20129 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20130 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20133 Check_First_Subtype
(Arg1
);
20135 -- Check for too early or too late. Note that we don't enforce
20136 -- the rule about primitive operations in this case, since, as
20137 -- is the case for explicit stream attributes themselves, these
20138 -- restrictions are not appropriate. Note that the chaining of
20139 -- the pragma by Rep_Item_Too_Late is actually the critical
20140 -- processing done for this pragma.
20142 if Rep_Item_Too_Early
(Typ
, N
)
20144 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20149 -- Return if previous error
20151 if Etype
(Typ
) = Any_Type
20153 Etype
(Read
) = Any_Type
20155 Etype
(Write
) = Any_Type
20162 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20164 ("incorrect return type for function&", Arg2
);
20167 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20169 ("incorrect parameter type for function&", Arg3
);
20172 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20173 Underlying_Type
(Etype
(Write
))
20176 ("result type of & does not match Read parameter type",
20180 end Stream_Convert
;
20186 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20188 -- This is processed by the parser since some of the style checks
20189 -- take place during source scanning and parsing. This means that
20190 -- we don't need to issue error messages here.
20192 when Pragma_Style_Checks
=> Style_Checks
: declare
20193 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20199 Check_No_Identifiers
;
20201 -- Two argument form
20203 if Arg_Count
= 2 then
20204 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20211 E_Id
:= Get_Pragma_Arg
(Arg2
);
20214 if not Is_Entity_Name
(E_Id
) then
20216 ("second argument of pragma% must be entity name",
20220 E
:= Entity
(E_Id
);
20222 if not Ignore_Style_Checks_Pragmas
then
20227 Set_Suppress_Style_Checks
20228 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20229 exit when No
(Homonym
(E
));
20236 -- One argument form
20239 Check_Arg_Count
(1);
20241 if Nkind
(A
) = N_String_Literal
then
20245 Slen
: constant Natural := Natural (String_Length
(S
));
20246 Options
: String (1 .. Slen
);
20252 C
:= Get_String_Char
(S
, Int
(J
));
20253 exit when not In_Character_Range
(C
);
20254 Options
(J
) := Get_Character
(C
);
20256 -- If at end of string, set options. As per discussion
20257 -- above, no need to check for errors, since we issued
20258 -- them in the parser.
20261 if not Ignore_Style_Checks_Pragmas
then
20262 Set_Style_Check_Options
(Options
);
20272 elsif Nkind
(A
) = N_Identifier
then
20273 if Chars
(A
) = Name_All_Checks
then
20274 if not Ignore_Style_Checks_Pragmas
then
20276 Set_GNAT_Style_Check_Options
;
20278 Set_Default_Style_Check_Options
;
20282 elsif Chars
(A
) = Name_On
then
20283 if not Ignore_Style_Checks_Pragmas
then
20284 Style_Check
:= True;
20287 elsif Chars
(A
) = Name_Off
then
20288 if not Ignore_Style_Checks_Pragmas
then
20289 Style_Check
:= False;
20300 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20302 when Pragma_Subtitle
=>
20304 Check_Arg_Count
(1);
20305 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20306 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20313 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20315 when Pragma_Suppress
=>
20316 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
20322 -- pragma Suppress_All;
20324 -- The only check made here is that the pragma has no arguments.
20325 -- There are no placement rules, and the processing required (setting
20326 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20327 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20328 -- then creates and inserts a pragma Suppress (All_Checks).
20330 when Pragma_Suppress_All
=>
20332 Check_Arg_Count
(0);
20334 -------------------------
20335 -- Suppress_Debug_Info --
20336 -------------------------
20338 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20340 when Pragma_Suppress_Debug_Info
=>
20342 Check_Arg_Count
(1);
20343 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20344 Check_Arg_Is_Local_Name
(Arg1
);
20345 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20347 ----------------------------------
20348 -- Suppress_Exception_Locations --
20349 ----------------------------------
20351 -- pragma Suppress_Exception_Locations;
20353 when Pragma_Suppress_Exception_Locations
=>
20355 Check_Arg_Count
(0);
20356 Check_Valid_Configuration_Pragma
;
20357 Exception_Locations_Suppressed
:= True;
20359 -----------------------------
20360 -- Suppress_Initialization --
20361 -----------------------------
20363 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20365 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20371 Check_Arg_Count
(1);
20372 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20373 Check_Arg_Is_Local_Name
(Arg1
);
20375 E_Id
:= Get_Pragma_Arg
(Arg1
);
20377 if Etype
(E_Id
) = Any_Type
then
20381 E
:= Entity
(E_Id
);
20383 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20385 ("pragma% requires variable, type or subtype", Arg1
);
20388 if Rep_Item_Too_Early
(E
, N
)
20390 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20395 -- For incomplete/private type, set flag on full view
20397 if Is_Incomplete_Or_Private_Type
(E
) then
20398 if No
(Full_View
(Base_Type
(E
))) then
20400 ("argument of pragma% cannot be an incomplete type", Arg1
);
20402 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20405 -- For first subtype, set flag on base type
20407 elsif Is_First_Subtype
(E
) then
20408 Set_Suppress_Initialization
(Base_Type
(E
));
20410 -- For other than first subtype, set flag on subtype or variable
20413 Set_Suppress_Initialization
(E
);
20421 -- pragma System_Name (DIRECT_NAME);
20423 -- Syntax check: one argument, which must be the identifier GNAT or
20424 -- the identifier GCC, no other identifiers are acceptable.
20426 when Pragma_System_Name
=>
20428 Check_No_Identifiers
;
20429 Check_Arg_Count
(1);
20430 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20432 -----------------------------
20433 -- Task_Dispatching_Policy --
20434 -----------------------------
20436 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20438 when Pragma_Task_Dispatching_Policy
=> declare
20442 Check_Ada_83_Warning
;
20443 Check_Arg_Count
(1);
20444 Check_No_Identifiers
;
20445 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20446 Check_Valid_Configuration_Pragma
;
20447 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20448 DP
:= Fold_Upper
(Name_Buffer
(1));
20450 if Task_Dispatching_Policy
/= ' '
20451 and then Task_Dispatching_Policy
/= DP
20453 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20455 ("task dispatching policy incompatible with policy#");
20457 -- Set new policy, but always preserve System_Location since we
20458 -- like the error message with the run time name.
20461 Task_Dispatching_Policy
:= DP
;
20463 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20464 Task_Dispatching_Policy_Sloc
:= Loc
;
20473 -- pragma Task_Info (EXPRESSION);
20475 when Pragma_Task_Info
=> Task_Info
: declare
20476 P
: constant Node_Id
:= Parent
(N
);
20482 if Warn_On_Obsolescent_Feature
then
20484 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20485 & "instead?j?", N
);
20488 if Nkind
(P
) /= N_Task_Definition
then
20489 Error_Pragma
("pragma% must appear in task definition");
20492 Check_No_Identifiers
;
20493 Check_Arg_Count
(1);
20495 Analyze_And_Resolve
20496 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20498 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20502 Ent
:= Defining_Identifier
(Parent
(P
));
20504 -- Check duplicate pragma before we chain the pragma in the Rep
20505 -- Item chain of Ent.
20508 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20510 Error_Pragma
("duplicate pragma% not allowed");
20513 Record_Rep_Item
(Ent
, N
);
20520 -- pragma Task_Name (string_EXPRESSION);
20522 when Pragma_Task_Name
=> Task_Name
: declare
20523 P
: constant Node_Id
:= Parent
(N
);
20528 Check_No_Identifiers
;
20529 Check_Arg_Count
(1);
20531 Arg
:= Get_Pragma_Arg
(Arg1
);
20533 -- The expression is used in the call to Create_Task, and must be
20534 -- expanded there, not in the context of the current spec. It must
20535 -- however be analyzed to capture global references, in case it
20536 -- appears in a generic context.
20538 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20540 if Nkind
(P
) /= N_Task_Definition
then
20544 Ent
:= Defining_Identifier
(Parent
(P
));
20546 -- Check duplicate pragma before we chain the pragma in the Rep
20547 -- Item chain of Ent.
20550 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20552 Error_Pragma
("duplicate pragma% not allowed");
20555 Record_Rep_Item
(Ent
, N
);
20562 -- pragma Task_Storage (
20563 -- [Task_Type =>] LOCAL_NAME,
20564 -- [Top_Guard =>] static_integer_EXPRESSION);
20566 when Pragma_Task_Storage
=> Task_Storage
: declare
20567 Args
: Args_List
(1 .. 2);
20568 Names
: constant Name_List
(1 .. 2) := (
20572 Task_Type
: Node_Id
renames Args
(1);
20573 Top_Guard
: Node_Id
renames Args
(2);
20579 Gather_Associations
(Names
, Args
);
20581 if No
(Task_Type
) then
20583 ("missing task_type argument for pragma%");
20586 Check_Arg_Is_Local_Name
(Task_Type
);
20588 Ent
:= Entity
(Task_Type
);
20590 if not Is_Task_Type
(Ent
) then
20592 ("argument for pragma% must be task type", Task_Type
);
20595 if No
(Top_Guard
) then
20597 ("pragma% takes two arguments", Task_Type
);
20599 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20602 Check_First_Subtype
(Task_Type
);
20604 if Rep_Item_Too_Late
(Ent
, N
) then
20613 -- pragma Test_Case
20614 -- ([Name =>] Static_String_EXPRESSION
20615 -- ,[Mode =>] MODE_TYPE
20616 -- [, Requires => Boolean_EXPRESSION]
20617 -- [, Ensures => Boolean_EXPRESSION]);
20619 -- MODE_TYPE ::= Nominal | Robustness
20621 when Pragma_Test_Case
=>
20625 --------------------------
20626 -- Thread_Local_Storage --
20627 --------------------------
20629 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20631 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20637 Check_Arg_Count
(1);
20638 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20639 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20641 Id
:= Get_Pragma_Arg
(Arg1
);
20644 if not Is_Entity_Name
(Id
)
20645 or else Ekind
(Entity
(Id
)) /= E_Variable
20647 Error_Pragma_Arg
("local variable name required", Arg1
);
20652 if Rep_Item_Too_Early
(E
, N
)
20653 or else Rep_Item_Too_Late
(E
, N
)
20658 Set_Has_Pragma_Thread_Local_Storage
(E
);
20659 Set_Has_Gigi_Rep_Item
(E
);
20660 end Thread_Local_Storage
;
20666 -- pragma Time_Slice (static_duration_EXPRESSION);
20668 when Pragma_Time_Slice
=> Time_Slice
: declare
20674 Check_Arg_Count
(1);
20675 Check_No_Identifiers
;
20676 Check_In_Main_Program
;
20677 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20679 if not Error_Posted
(Arg1
) then
20681 while Present
(Nod
) loop
20682 if Nkind
(Nod
) = N_Pragma
20683 and then Pragma_Name
(Nod
) = Name_Time_Slice
20685 Error_Msg_Name_1
:= Pname
;
20686 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20693 -- Process only if in main unit
20695 if Get_Source_Unit
(Loc
) = Main_Unit
then
20696 Opt
.Time_Slice_Set
:= True;
20697 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20699 if Val
<= Ureal_0
then
20700 Opt
.Time_Slice_Value
:= 0;
20702 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20703 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20706 Opt
.Time_Slice_Value
:=
20707 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20716 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20718 -- TITLING_OPTION ::=
20719 -- [Title =>] STRING_LITERAL
20720 -- | [Subtitle =>] STRING_LITERAL
20722 when Pragma_Title
=> Title
: declare
20723 Args
: Args_List
(1 .. 2);
20724 Names
: constant Name_List
(1 .. 2) := (
20730 Gather_Associations
(Names
, Args
);
20733 for J
in 1 .. 2 loop
20734 if Present
(Args
(J
)) then
20735 Check_Arg_Is_OK_Static_Expression
20736 (Args
(J
), Standard_String
);
20741 ----------------------------
20742 -- Type_Invariant[_Class] --
20743 ----------------------------
20745 -- pragma Type_Invariant[_Class]
20746 -- ([Entity =>] type_LOCAL_NAME,
20747 -- [Check =>] EXPRESSION);
20749 when Pragma_Type_Invariant |
20750 Pragma_Type_Invariant_Class
=>
20751 Type_Invariant
: declare
20752 I_Pragma
: Node_Id
;
20755 Check_Arg_Count
(2);
20757 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20758 -- setting Class_Present for the Type_Invariant_Class case.
20760 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20761 I_Pragma
:= New_Copy
(N
);
20762 Set_Pragma_Identifier
20763 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20764 Rewrite
(N
, I_Pragma
);
20765 Set_Analyzed
(N
, False);
20767 end Type_Invariant
;
20769 ---------------------
20770 -- Unchecked_Union --
20771 ---------------------
20773 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20775 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20776 Assoc
: constant Node_Id
:= Arg1
;
20777 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20787 Check_No_Identifiers
;
20788 Check_Arg_Count
(1);
20789 Check_Arg_Is_Local_Name
(Arg1
);
20791 Find_Type
(Type_Id
);
20793 Typ
:= Entity
(Type_Id
);
20796 or else Rep_Item_Too_Early
(Typ
, N
)
20800 Typ
:= Underlying_Type
(Typ
);
20803 if Rep_Item_Too_Late
(Typ
, N
) then
20807 Check_First_Subtype
(Arg1
);
20809 -- Note remaining cases are references to a type in the current
20810 -- declarative part. If we find an error, we post the error on
20811 -- the relevant type declaration at an appropriate point.
20813 if not Is_Record_Type
(Typ
) then
20814 Error_Msg_N
("unchecked union must be record type", Typ
);
20817 elsif Is_Tagged_Type
(Typ
) then
20818 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20821 elsif not Has_Discriminants
(Typ
) then
20823 ("unchecked union must have one discriminant", Typ
);
20826 -- Note: in previous versions of GNAT we used to check for limited
20827 -- types and give an error, but in fact the standard does allow
20828 -- Unchecked_Union on limited types, so this check was removed.
20830 -- Similarly, GNAT used to require that all discriminants have
20831 -- default values, but this is not mandated by the RM.
20833 -- Proceed with basic error checks completed
20836 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20837 Clist
:= Component_List
(Tdef
);
20839 -- Check presence of component list and variant part
20841 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20843 ("unchecked union must have variant part", Tdef
);
20847 -- Check components
20849 Comp
:= First
(Component_Items
(Clist
));
20850 while Present
(Comp
) loop
20851 Check_Component
(Comp
, Typ
);
20855 -- Check variant part
20857 Vpart
:= Variant_Part
(Clist
);
20859 Variant
:= First
(Variants
(Vpart
));
20860 while Present
(Variant
) loop
20861 Check_Variant
(Variant
, Typ
);
20866 Set_Is_Unchecked_Union
(Typ
);
20867 Set_Convention
(Typ
, Convention_C
);
20868 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20869 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20870 end Unchecked_Union
;
20872 ------------------------
20873 -- Unimplemented_Unit --
20874 ------------------------
20876 -- pragma Unimplemented_Unit;
20878 -- Note: this only gives an error if we are generating code, or if
20879 -- we are in a generic library unit (where the pragma appears in the
20880 -- body, not in the spec).
20882 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20883 Cunitent
: constant Entity_Id
:=
20884 Cunit_Entity
(Get_Source_Unit
(Loc
));
20885 Ent_Kind
: constant Entity_Kind
:=
20890 Check_Arg_Count
(0);
20892 if Operating_Mode
= Generate_Code
20893 or else Ent_Kind
= E_Generic_Function
20894 or else Ent_Kind
= E_Generic_Procedure
20895 or else Ent_Kind
= E_Generic_Package
20897 Get_Name_String
(Chars
(Cunitent
));
20898 Set_Casing
(Mixed_Case
);
20899 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20900 Write_Str
(" is not supported in this configuration");
20902 raise Unrecoverable_Error
;
20904 end Unimplemented_Unit
;
20906 ------------------------
20907 -- Universal_Aliasing --
20908 ------------------------
20910 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20912 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20917 Check_Arg_Count
(1);
20918 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20919 Check_Arg_Is_Local_Name
(Arg1
);
20920 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20922 if E_Id
= Any_Type
then
20924 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20925 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20928 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20929 Record_Rep_Item
(E_Id
, N
);
20930 end Universal_Alias
;
20932 --------------------
20933 -- Universal_Data --
20934 --------------------
20936 -- pragma Universal_Data [(library_unit_NAME)];
20938 when Pragma_Universal_Data
=>
20941 -- If this is a configuration pragma, then set the universal
20942 -- addressing option, otherwise confirm that the pragma satisfies
20943 -- the requirements of library unit pragma placement and leave it
20944 -- to the GNAAMP back end to detect the pragma (avoids transitive
20945 -- setting of the option due to withed units).
20947 if Is_Configuration_Pragma
then
20948 Universal_Addressing_On_AAMP
:= True;
20950 Check_Valid_Library_Unit_Pragma
;
20953 if not AAMP_On_Target
then
20954 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20961 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20963 when Pragma_Unmodified
=> Unmodified
: declare
20964 Arg_Node
: Node_Id
;
20965 Arg_Expr
: Node_Id
;
20966 Arg_Ent
: Entity_Id
;
20970 Check_At_Least_N_Arguments
(1);
20972 -- Loop through arguments
20975 while Present
(Arg_Node
) loop
20976 Check_No_Identifier
(Arg_Node
);
20978 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
20979 -- in fact generate reference, so that the entity will have a
20980 -- reference, which will inhibit any warnings about it not
20981 -- being referenced, and also properly show up in the ali file
20982 -- as a reference. But this reference is recorded before the
20983 -- Has_Pragma_Unreferenced flag is set, so that no warning is
20984 -- generated for this reference.
20986 Check_Arg_Is_Local_Name
(Arg_Node
);
20987 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20989 if Is_Entity_Name
(Arg_Expr
) then
20990 Arg_Ent
:= Entity
(Arg_Expr
);
20992 if not Is_Assignable
(Arg_Ent
) then
20994 ("pragma% can only be applied to a variable",
20997 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21009 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21011 -- or when used in a context clause:
21013 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21015 when Pragma_Unreferenced
=> Unreferenced
: declare
21016 Arg_Node
: Node_Id
;
21017 Arg_Expr
: Node_Id
;
21018 Arg_Ent
: Entity_Id
;
21023 Check_At_Least_N_Arguments
(1);
21025 -- Check case of appearing within context clause
21027 if Is_In_Context_Clause
then
21029 -- The arguments must all be units mentioned in a with clause
21030 -- in the same context clause. Note we already checked (in
21031 -- Par.Prag) that the arguments are either identifiers or
21032 -- selected components.
21035 while Present
(Arg_Node
) loop
21036 Citem
:= First
(List_Containing
(N
));
21037 while Citem
/= N
loop
21038 if Nkind
(Citem
) = N_With_Clause
21040 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21042 Set_Has_Pragma_Unreferenced
21045 (Library_Unit
(Citem
))));
21047 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21056 ("argument of pragma% is not withed unit", Arg_Node
);
21062 -- Case of not in list of context items
21066 while Present
(Arg_Node
) loop
21067 Check_No_Identifier
(Arg_Node
);
21069 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21070 -- will in fact generate reference, so that the entity will
21071 -- have a reference, which will inhibit any warnings about
21072 -- it not being referenced, and also properly show up in the
21073 -- ali file as a reference. But this reference is recorded
21074 -- before the Has_Pragma_Unreferenced flag is set, so that
21075 -- no warning is generated for this reference.
21077 Check_Arg_Is_Local_Name
(Arg_Node
);
21078 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21080 if Is_Entity_Name
(Arg_Expr
) then
21081 Arg_Ent
:= Entity
(Arg_Expr
);
21083 -- If the entity is overloaded, the pragma applies to the
21084 -- most recent overloading, as documented. In this case,
21085 -- name resolution does not generate a reference, so it
21086 -- must be done here explicitly.
21088 if Is_Overloaded
(Arg_Expr
) then
21089 Generate_Reference
(Arg_Ent
, N
);
21092 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21100 --------------------------
21101 -- Unreferenced_Objects --
21102 --------------------------
21104 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21106 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21107 Arg_Node
: Node_Id
;
21108 Arg_Expr
: Node_Id
;
21112 Check_At_Least_N_Arguments
(1);
21115 while Present
(Arg_Node
) loop
21116 Check_No_Identifier
(Arg_Node
);
21117 Check_Arg_Is_Local_Name
(Arg_Node
);
21118 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21120 if not Is_Entity_Name
(Arg_Expr
)
21121 or else not Is_Type
(Entity
(Arg_Expr
))
21124 ("argument for pragma% must be type or subtype", Arg_Node
);
21127 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21130 end Unreferenced_Objects
;
21132 ------------------------------
21133 -- Unreserve_All_Interrupts --
21134 ------------------------------
21136 -- pragma Unreserve_All_Interrupts;
21138 when Pragma_Unreserve_All_Interrupts
=>
21140 Check_Arg_Count
(0);
21142 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21143 Unreserve_All_Interrupts
:= True;
21150 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21152 when Pragma_Unsuppress
=>
21154 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
21156 ----------------------------
21157 -- Unevaluated_Use_Of_Old --
21158 ----------------------------
21160 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21162 when Pragma_Unevaluated_Use_Of_Old
=>
21164 Check_Arg_Count
(1);
21165 Check_No_Identifiers
;
21166 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
21168 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21169 -- a declarative part or a package spec.
21171 if not Is_Configuration_Pragma
then
21172 Check_Is_In_Decl_Part_Or_Package_Spec
;
21175 -- Store proper setting of Uneval_Old
21177 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21178 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
21180 -------------------
21181 -- Use_VADS_Size --
21182 -------------------
21184 -- pragma Use_VADS_Size;
21186 when Pragma_Use_VADS_Size
=>
21188 Check_Arg_Count
(0);
21189 Check_Valid_Configuration_Pragma
;
21190 Use_VADS_Size
:= True;
21192 ---------------------
21193 -- Validity_Checks --
21194 ---------------------
21196 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21198 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21199 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21205 Check_Arg_Count
(1);
21206 Check_No_Identifiers
;
21208 -- Pragma always active unless in CodePeer or GNATprove modes,
21209 -- which use a fixed configuration of validity checks.
21211 if not (CodePeer_Mode
or GNATprove_Mode
) then
21212 if Nkind
(A
) = N_String_Literal
then
21216 Slen
: constant Natural := Natural (String_Length
(S
));
21217 Options
: String (1 .. Slen
);
21221 -- Couldn't we use a for loop here over Options'Range???
21225 C
:= Get_String_Char
(S
, Int
(J
));
21227 -- This is a weird test, it skips setting validity
21228 -- checks entirely if any element of S is out of
21229 -- range of Character, what is that about ???
21231 exit when not In_Character_Range
(C
);
21232 Options
(J
) := Get_Character
(C
);
21235 Set_Validity_Check_Options
(Options
);
21243 elsif Nkind
(A
) = N_Identifier
then
21244 if Chars
(A
) = Name_All_Checks
then
21245 Set_Validity_Check_Options
("a");
21246 elsif Chars
(A
) = Name_On
then
21247 Validity_Checks_On
:= True;
21248 elsif Chars
(A
) = Name_Off
then
21249 Validity_Checks_On
:= False;
21253 end Validity_Checks
;
21259 -- pragma Volatile (LOCAL_NAME);
21261 when Pragma_Volatile
=>
21262 Process_Atomic_Shared_Volatile
;
21264 -------------------------
21265 -- Volatile_Components --
21266 -------------------------
21268 -- pragma Volatile_Components (array_LOCAL_NAME);
21270 -- Volatile is handled by the same circuit as Atomic_Components
21272 ----------------------
21273 -- Warning_As_Error --
21274 ----------------------
21276 -- pragma Warning_As_Error (static_string_EXPRESSION);
21278 when Pragma_Warning_As_Error
=>
21280 Check_Arg_Count
(1);
21281 Check_No_Identifiers
;
21282 Check_Valid_Configuration_Pragma
;
21284 if not Is_Static_String_Expression
(Arg1
) then
21286 ("argument of pragma% must be static string expression",
21289 -- OK static string expression
21292 Acquire_Warning_Match_String
(Arg1
);
21293 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21294 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21295 new String'(Name_Buffer (1 .. Name_Len));
21302 -- pragma Warnings (On | Off [,REASON]);
21303 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
21304 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
21305 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
21307 -- REASON ::= Reason => Static_String_Expression
21309 when Pragma_Warnings => Warnings : declare
21310 Reason : String_Id;
21314 Check_At_Least_N_Arguments (1);
21316 -- See if last argument is labeled Reason. If so, make sure we
21317 -- have a static string expression, and acquire the REASON string.
21318 -- Then remove the REASON argument by decreasing Num_Args by one;
21319 -- Remaining processing looks only at first Num_Args arguments).
21322 Last_Arg : constant Node_Id :=
21323 Last (Pragma_Argument_Associations (N));
21326 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21327 and then Chars (Last_Arg) = Name_Reason
21330 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21331 Reason := End_String;
21332 Arg_Count := Arg_Count - 1;
21334 -- Not allowed in compiler units (bootstrap issues)
21336 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21338 -- No REASON string, set null string as reason
21341 Reason := Null_String_Id;
21345 -- Now proceed with REASON taken care of and eliminated
21347 Check_No_Identifiers;
21349 -- If debug flag -gnatd.i is set, pragma is ignored
21351 if Debug_Flag_Dot_I then
21355 -- Process various forms of the pragma
21358 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21361 -- One argument case
21363 if Arg_Count = 1 then
21365 -- On/Off one argument case was processed by parser
21367 if Nkind (Argx) = N_Identifier
21368 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21372 -- One argument case must be ON/OFF or static string expr
21374 elsif not Is_Static_String_Expression (Arg1) then
21376 ("argument of pragma% must be On/Off or static string "
21377 & "expression", Arg1);
21379 -- One argument string expression case
21383 Lit : constant Node_Id := Expr_Value_S (Argx);
21384 Str : constant String_Id := Strval (Lit);
21385 Len : constant Nat := String_Length (Str);
21393 while J <= Len loop
21394 C := Get_String_Char (Str, J);
21395 OK := In_Character_Range (C);
21398 Chr := Get_Character (C);
21400 -- Dash case: only -Wxxx is accepted
21407 C := Get_String_Char (Str, J);
21408 Chr := Get_Character (C);
21409 exit when Chr = 'W
';
21414 elsif J < Len and then Chr = '.' then
21416 C := Get_String_Char (Str, J);
21417 Chr := Get_Character (C);
21419 if not Set_Dot_Warning_Switch (Chr) then
21421 ("invalid warning switch character "
21422 & '.' & Chr, Arg1);
21428 OK := Set_Warning_Switch (Chr);
21434 ("invalid warning switch character " & Chr,
21443 -- Two or more arguments (must be two)
21446 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21447 Check_Arg_Count (2);
21455 E_Id := Get_Pragma_Arg (Arg2);
21458 -- In the expansion of an inlined body, a reference to
21459 -- the formal may be wrapped in a conversion if the
21460 -- actual is a conversion. Retrieve the real entity name.
21462 if (In_Instance_Body or In_Inlined_Body)
21463 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21465 E_Id := Expression (E_Id);
21468 -- Entity name case
21470 if Is_Entity_Name (E_Id) then
21471 E := Entity (E_Id);
21478 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21481 -- For OFF case, make entry in warnings off
21482 -- pragma table for later processing. But we do
21483 -- not do that within an instance, since these
21484 -- warnings are about what is needed in the
21485 -- template, not an instance of it.
21487 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21488 and then Warn_On_Warnings_Off
21489 and then not In_Instance
21491 Warnings_Off_Pragmas.Append ((N, E, Reason));
21494 if Is_Enumeration_Type (E) then
21498 Lit := First_Literal (E);
21499 while Present (Lit) loop
21500 Set_Warnings_Off (Lit);
21501 Next_Literal (Lit);
21506 exit when No (Homonym (E));
21511 -- Error if not entity or static string expression case
21513 elsif not Is_Static_String_Expression (Arg2) then
21515 ("second argument of pragma% must be entity name "
21516 & "or static string expression", Arg2);
21518 -- Static string expression case
21521 Acquire_Warning_Match_String (Arg2);
21523 -- Note on configuration pragma case: If this is a
21524 -- configuration pragma, then for an OFF pragma, we
21525 -- just set Config True in the call, which is all
21526 -- that needs to be done. For the case of ON, this
21527 -- is normally an error, unless it is canceling the
21528 -- effect of a previous OFF pragma in the same file.
21529 -- In any other case, an error will be signalled (ON
21530 -- with no matching OFF).
21532 -- Note: We set Used if we are inside a generic to
21533 -- disable the test that the non-config case actually
21534 -- cancels a warning. That's because we can't be sure
21535 -- there isn't an instantiation in some other unit
21536 -- where a warning is suppressed.
21538 -- We could do a little better here by checking if the
21539 -- generic unit we are inside is public, but for now
21540 -- we don't bother with that refinement.
21542 if Chars (Argx) = Name_Off then
21543 Set_Specific_Warning_Off
21544 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21545 Config => Is_Configuration_Pragma,
21546 Used => Inside_A_Generic or else In_Instance);
21548 elsif Chars (Argx) = Name_On then
21549 Set_Specific_Warning_On
21550 (Loc, Name_Buffer (1 .. Name_Len), Err);
21554 ("??pragma Warnings On with no matching "
21555 & "Warnings Off", Loc);
21564 -------------------
21565 -- Weak_External --
21566 -------------------
21568 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21570 when Pragma_Weak_External => Weak_External : declare
21575 Check_Arg_Count (1);
21576 Check_Optional_Identifier (Arg1, Name_Entity);
21577 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21578 Ent := Entity (Get_Pragma_Arg (Arg1));
21580 if Rep_Item_Too_Early (Ent, N) then
21583 Ent := Underlying_Type (Ent);
21586 -- The only processing required is to link this item on to the
21587 -- list of rep items for the given entity. This is accomplished
21588 -- by the call to Rep_Item_Too_Late (when no error is detected
21589 -- and False is returned).
21591 if Rep_Item_Too_Late (Ent, N) then
21594 Set_Has_Gigi_Rep_Item (Ent);
21598 -----------------------------
21599 -- Wide_Character_Encoding --
21600 -----------------------------
21602 -- pragma Wide_Character_Encoding (IDENTIFIER);
21604 when Pragma_Wide_Character_Encoding =>
21607 -- Nothing to do, handled in parser. Note that we do not enforce
21608 -- configuration pragma placement, this pragma can appear at any
21609 -- place in the source, allowing mixed encodings within a single
21614 --------------------
21615 -- Unknown_Pragma --
21616 --------------------
21618 -- Should be impossible, since the case of an unknown pragma is
21619 -- separately processed before the case statement is entered.
21621 when Unknown_Pragma =>
21622 raise Program_Error;
21625 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21626 -- until AI is formally approved.
21628 -- Check_Order_Dependence;
21631 when Pragma_Exit => null;
21632 end Analyze_Pragma;
21634 ---------------------------------------------
21635 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21636 ---------------------------------------------
21638 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21640 Subp_Id : Entity_Id)
21642 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21643 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21646 Restore_Scope : Boolean := False;
21647 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21650 -- Ensure that the subprogram and its formals are visible when analyzing
21651 -- the expression of the pragma.
21653 if not In_Open_Scopes (Subp_Id) then
21654 Restore_Scope := True;
21655 Push_Scope (Subp_Id);
21656 Install_Formals (Subp_Id);
21659 -- Preanalyze the boolean expression, we treat this as a spec expression
21660 -- (i.e. similar to a default expression).
21662 Expr := Get_Pragma_Arg (Arg1);
21664 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21665 -- the original aspect expression, which is shared with the generated
21668 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21669 Expr := Expression (Corresponding_Aspect (Prag));
21672 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21674 -- For a class-wide condition, a reference to a controlling formal must
21675 -- be interpreted as having the class-wide type (or an access to such)
21676 -- so that the inherited condition can be properly applied to any
21677 -- overriding operation (see ARM12 6.6.1 (7)).
21679 if Class_Present (Prag) then
21680 Class_Wide_Condition : declare
21681 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21683 ACW : Entity_Id := Empty;
21684 -- Access to T'class, created if there is a controlling formal
21685 -- that is an access parameter.
21687 function Get_ACW return Entity_Id;
21688 -- If the expression has a reference to an controlling access
21689 -- parameter, create an access to T'class for the necessary
21690 -- conversions if one does not exist.
21692 function Process (N : Node_Id) return Traverse_Result;
21693 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21694 -- aspect for a primitive subprogram of a tagged type T, a name
21695 -- that denotes a formal parameter of type T is interpreted as
21696 -- having type T'Class. Similarly, a name that denotes a formal
21697 -- accessparameter of type access-to-T is interpreted as having
21698 -- type access-to-T'Class. This ensures the expression is well-
21699 -- defined for a primitive subprogram of a type descended from T.
21700 -- Note that this replacement is not done for selector names in
21701 -- parameter associations. These carry an entity for reference
21702 -- purposes, but semantically they are just identifiers.
21708 function Get_ACW return Entity_Id is
21709 Loc : constant Source_Ptr := Sloc (Prag);
21715 Make_Full_Type_Declaration (Loc,
21716 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21718 Make_Access_To_Object_Definition (Loc,
21719 Subtype_Indication =>
21720 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21721 All_Present => True));
21723 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21725 ACW := Defining_Identifier (Decl);
21726 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21736 function Process (N : Node_Id) return Traverse_Result is
21737 Loc : constant Source_Ptr := Sloc (N);
21741 if Is_Entity_Name (N)
21742 and then Present (Entity (N))
21743 and then Is_Formal (Entity (N))
21744 and then Nkind (Parent (N)) /= N_Type_Conversion
21746 (Nkind (Parent (N)) /= N_Parameter_Association
21747 or else N /= Selector_Name (Parent (N)))
21749 if Etype (Entity (N)) = T then
21750 Typ := Class_Wide_Type (T);
21752 elsif Is_Access_Type (Etype (Entity (N)))
21753 and then Designated_Type (Etype (Entity (N))) = T
21760 if Present (Typ) then
21762 Make_Type_Conversion (Loc,
21764 New_Occurrence_Of (Typ, Loc),
21765 Expression => New_Occurrence_Of (Entity (N), Loc)));
21766 Set_Etype (N, Typ);
21773 procedure Replace_Type is new Traverse_Proc (Process);
21775 -- Start of processing for Class_Wide_Condition
21778 if not Present (T) then
21780 -- Pre'Class/Post'Class aspect cases
21782 if From_Aspect_Specification (Prag) then
21783 if Nam = Name_uPre then
21784 Error_Msg_Name_1 := Name_Pre;
21786 Error_Msg_Name_1 := Name_Post;
21789 Error_Msg_Name_2 := Name_Class;
21792 ("aspect `%''%` can only be specified for a primitive "
21793 & "operation of a tagged type",
21794 Corresponding_Aspect (Prag));
21796 -- Pre_Class, Post_Class pragma cases
21799 if Nam = Name_uPre then
21800 Error_Msg_Name_1 := Name_Pre_Class;
21802 Error_Msg_Name_1 := Name_Post_Class;
21806 ("pragma% can only be specified for a primitive "
21807 & "operation of a tagged type",
21808 Corresponding_Aspect (Prag));
21812 Replace_Type (Get_Pragma_Arg (Arg1));
21813 end Class_Wide_Condition;
21816 -- Remove the subprogram from the scope stack now that the pre-analysis
21817 -- of the precondition/postcondition is done.
21819 if Restore_Scope then
21822 end Analyze_Pre_Post_Condition_In_Decl_Part;
21824 ------------------------------------------
21825 -- Analyze_Refined_Depends_In_Decl_Part --
21826 ------------------------------------------
21828 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21829 Body_Inputs : Elist_Id := No_Elist;
21830 Body_Outputs : Elist_Id := No_Elist;
21831 -- The inputs and outputs of the subprogram body synthesized from pragma
21832 -- Refined_Depends.
21834 Dependencies : List_Id := No_List;
21836 -- The corresponding Depends pragma along with its clauses
21838 Matched_Items : Elist_Id := No_Elist;
21839 -- A list containing the entities of all successfully matched items
21840 -- found in pragma Depends.
21842 Refinements : List_Id := No_List;
21843 -- The clauses of pragma Refined_Depends
21845 Spec_Id : Entity_Id;
21846 -- The entity of the subprogram subject to pragma Refined_Depends
21848 Spec_Inputs : Elist_Id := No_Elist;
21849 Spec_Outputs : Elist_Id := No_Elist;
21850 -- The inputs and outputs of the subprogram spec synthesized from pragma
21853 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21854 -- Try to match a single dependency clause Dep_Clause against one or
21855 -- more refinement clauses found in list Refinements. Each successful
21856 -- match eliminates at least one refinement clause from Refinements.
21858 procedure Check_Output_States;
21859 -- Determine whether pragma Depends contains an output state with a
21860 -- visible refinement and if so, ensure that pragma Refined_Depends
21861 -- mentions all its constituents as outputs.
21863 procedure Normalize_Clauses (Clauses : List_Id);
21864 -- Given a list of dependence or refinement clauses Clauses, normalize
21865 -- each clause by creating multiple dependencies with exactly one input
21868 procedure Report_Extra_Clauses;
21869 -- Emit an error for each extra clause found in list Refinements
21871 -----------------------------
21872 -- Check_Dependency_Clause --
21873 -----------------------------
21875 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21876 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21877 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21879 function Is_In_Out_State_Clause return Boolean;
21880 -- Determine whether dependence clause Dep_Clause denotes an abstract
21881 -- state that depends on itself (State => State).
21883 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21884 -- Determine whether item Item denotes an abstract state with visible
21885 -- null refinement.
21887 procedure Match_Items
21888 (Dep_Item : Node_Id;
21889 Ref_Item : Node_Id;
21890 Matched : out Boolean);
21891 -- Try to match dependence item Dep_Item against refinement item
21892 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21893 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21894 -- the following conformance scenarios is in effect:
21895 -- 1) Both items denote null
21896 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21897 -- 3) Both items denote attribute 'Result
21898 -- 4) Both items denote the same formal parameter
21899 -- 5) Both items denote the same variable
21900 -- 6) Dep_Item is an abstract state with visible null refinement
21901 -- and Ref_Item denotes null.
21902 -- 7) Dep_Item is an abstract state with visible null refinement
21903 -- and Ref_Item is Empty (special case).
21904 -- 8) Dep_Item is an abstract state with visible non-null
21905 -- refinement and Ref_Item denotes one of its constituents.
21906 -- 9) Dep_Item is an abstract state without a visible refinement
21907 -- and Ref_Item denotes the same state.
21908 -- When scenario 8 is in effect, the entity of the abstract state
21909 -- denoted by Dep_Item is added to list Refined_States.
21911 procedure Record_Item
(Item_Id
: Entity_Id
);
21912 -- Store the entity of an item denoted by Item_Id in Matched_Items
21914 ----------------------------
21915 -- Is_In_Out_State_Clause --
21916 ----------------------------
21918 function Is_In_Out_State_Clause
return Boolean is
21919 Dep_Input_Id
: Entity_Id
;
21920 Dep_Output_Id
: Entity_Id
;
21923 -- Detect the following clause:
21926 if Is_Entity_Name
(Dep_Input
)
21927 and then Is_Entity_Name
(Dep_Output
)
21929 -- Handle abstract views generated for limited with clauses
21931 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
21932 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
21935 Ekind
(Dep_Input_Id
) = E_Abstract_State
21936 and then Dep_Input_Id
= Dep_Output_Id
;
21940 end Is_In_Out_State_Clause
;
21942 ---------------------------
21943 -- Is_Null_Refined_State --
21944 ---------------------------
21946 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
21947 Item_Id
: Entity_Id
;
21950 if Is_Entity_Name
(Item
) then
21952 -- Handle abstract views generated for limited with clauses
21954 Item_Id
:= Available_View
(Entity_Of
(Item
));
21956 return Ekind
(Item_Id
) = E_Abstract_State
21957 and then Has_Null_Refinement
(Item_Id
);
21962 end Is_Null_Refined_State
;
21968 procedure Match_Items
21969 (Dep_Item
: Node_Id
;
21970 Ref_Item
: Node_Id
;
21971 Matched
: out Boolean)
21973 Dep_Item_Id
: Entity_Id
;
21974 Ref_Item_Id
: Entity_Id
;
21977 -- Assume that the two items do not match
21981 -- A null matches null or Empty (special case)
21983 if Nkind
(Dep_Item
) = N_Null
21984 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21988 -- Attribute 'Result matches attribute 'Result
21990 elsif Is_Attribute_Result
(Dep_Item
)
21991 and then Is_Attribute_Result
(Dep_Item
)
21995 -- Abstract states, formal parameters and variables
21997 elsif Is_Entity_Name
(Dep_Item
) then
21999 -- Handle abstract views generated for limited with clauses
22001 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
22003 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
22005 -- An abstract state with visible null refinement matches
22006 -- null or Empty (special case).
22008 if Has_Null_Refinement
(Dep_Item_Id
)
22009 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22011 Record_Item
(Dep_Item_Id
);
22014 -- An abstract state with visible non-null refinement
22015 -- matches one of its constituents.
22017 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
22018 if Is_Entity_Name
(Ref_Item
) then
22019 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
22021 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
, E_Variable
)
22022 and then Present
(Encapsulating_State
(Ref_Item_Id
))
22023 and then Encapsulating_State
(Ref_Item_Id
) =
22026 Record_Item
(Dep_Item_Id
);
22031 -- An abstract state without a visible refinement matches
22034 elsif Is_Entity_Name
(Ref_Item
)
22035 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22037 Record_Item
(Dep_Item_Id
);
22041 -- A formal parameter or a variable matches itself
22043 elsif Is_Entity_Name
(Ref_Item
)
22044 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22046 Record_Item
(Dep_Item_Id
);
22056 procedure Record_Item
(Item_Id
: Entity_Id
) is
22058 if not Contains
(Matched_Items
, Item_Id
) then
22059 Add_Item
(Item_Id
, Matched_Items
);
22065 Clause_Matched
: Boolean := False;
22066 Dummy
: Boolean := False;
22067 Inputs_Match
: Boolean;
22068 Next_Ref_Clause
: Node_Id
;
22069 Outputs_Match
: Boolean;
22070 Ref_Clause
: Node_Id
;
22071 Ref_Input
: Node_Id
;
22072 Ref_Output
: Node_Id
;
22074 -- Start of processing for Check_Dependency_Clause
22077 -- Examine all refinement clauses and compare them against the
22078 -- dependence clause.
22080 Ref_Clause
:= First
(Refinements
);
22081 while Present
(Ref_Clause
) loop
22082 Next_Ref_Clause
:= Next
(Ref_Clause
);
22084 -- Obtain the attributes of the current refinement clause
22086 Ref_Input
:= Expression
(Ref_Clause
);
22087 Ref_Output
:= First
(Choices
(Ref_Clause
));
22089 -- The current refinement clause matches the dependence clause
22090 -- when both outputs match and both inputs match. See routine
22091 -- Match_Items for all possible conformance scenarios.
22093 -- Depends Dep_Output => Dep_Input
22097 -- Refined_Depends Ref_Output => Ref_Input
22100 (Dep_Item
=> Dep_Input
,
22101 Ref_Item
=> Ref_Input
,
22102 Matched
=> Inputs_Match
);
22105 (Dep_Item
=> Dep_Output
,
22106 Ref_Item
=> Ref_Output
,
22107 Matched
=> Outputs_Match
);
22109 -- An In_Out state clause may be matched against a refinement with
22110 -- a null input or null output as long as the non-null side of the
22111 -- relation contains a valid constituent of the In_Out_State.
22113 if Is_In_Out_State_Clause
then
22115 -- Depends => (State => State)
22116 -- Refined_Depends => (null => Constit) -- OK
22119 and then not Outputs_Match
22120 and then Nkind
(Ref_Output
) = N_Null
22122 Outputs_Match
:= True;
22125 -- Depends => (State => State)
22126 -- Refined_Depends => (Constit => null) -- OK
22128 if not Inputs_Match
22129 and then Outputs_Match
22130 and then Nkind
(Ref_Input
) = N_Null
22132 Inputs_Match
:= True;
22136 -- The current refinement clause is legally constructed following
22137 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22138 -- the pool of candidates. The seach continues because a single
22139 -- dependence clause may have multiple matching refinements.
22141 if Inputs_Match
and then Outputs_Match
then
22142 Clause_Matched
:= True;
22143 Remove
(Ref_Clause
);
22146 Ref_Clause
:= Next_Ref_Clause
;
22149 -- Depending on the order or composition of refinement clauses, an
22150 -- In_Out state clause may not be directly refinable.
22152 -- Depends => ((Output, State) => (Input, State))
22153 -- Refined_State => (State => (Constit_1, Constit_2))
22154 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22156 -- Matching normalized clause (State => State) fails because there is
22157 -- no direct refinement capable of satisfying this relation. Another
22158 -- similar case arises when clauses (Constit_1 => Input) and (Output
22159 -- => Constit_2) are matched first, leaving no candidates for clause
22160 -- (State => State). Both scenarios are legal as long as one of the
22161 -- previous clauses mentioned a valid constituent of State.
22163 if not Clause_Matched
22164 and then Is_In_Out_State_Clause
22166 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22168 Clause_Matched
:= True;
22171 -- A clause where the input is an abstract state with visible null
22172 -- refinement is implicitly matched when the output has already been
22173 -- matched in a previous clause.
22175 -- Depends => (Output => State) -- implicitly OK
22176 -- Refined_State => (State => null)
22177 -- Refined_Depends => (Output => ...)
22179 if not Clause_Matched
22180 and then Is_Null_Refined_State
(Dep_Input
)
22181 and then Is_Entity_Name
(Dep_Output
)
22183 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
22185 Clause_Matched
:= True;
22188 -- A clause where the output is an abstract state with visible null
22189 -- refinement is implicitly matched when the input has already been
22190 -- matched in a previous clause.
22192 -- Depends => (State => Input) -- implicitly OK
22193 -- Refined_State => (State => null)
22194 -- Refined_Depends => (... => Input)
22196 if not Clause_Matched
22197 and then Is_Null_Refined_State
(Dep_Output
)
22198 and then Is_Entity_Name
(Dep_Input
)
22200 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22202 Clause_Matched
:= True;
22205 -- At this point either all refinement clauses have been examined or
22206 -- pragma Refined_Depends contains a solitary null. Only an abstract
22207 -- state with null refinement can possibly match these cases.
22209 -- Depends => (State => null)
22210 -- Refined_State => (State => null)
22211 -- Refined_Depends => null -- OK
22213 if not Clause_Matched
then
22215 (Dep_Item
=> Dep_Input
,
22217 Matched
=> Inputs_Match
);
22220 (Dep_Item
=> Dep_Output
,
22222 Matched
=> Outputs_Match
);
22224 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
22227 -- If the contents of Refined_Depends are legal, then the current
22228 -- dependence clause should be satisfied either by an explicit match
22229 -- or by one of the special cases.
22231 if not Clause_Matched
then
22233 ("dependence clause of subprogram & has no matching refinement "
22234 & "in body", Dep_Clause
, Spec_Id
);
22236 end Check_Dependency_Clause
;
22238 -------------------------
22239 -- Check_Output_States --
22240 -------------------------
22242 procedure Check_Output_States
is
22243 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22244 -- Determine whether all constituents of state State_Id with visible
22245 -- refinement are used as outputs in pragma Refined_Depends. Emit an
22246 -- error if this is not the case.
22248 -----------------------------
22249 -- Check_Constituent_Usage --
22250 -----------------------------
22252 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22253 Constit_Elmt
: Elmt_Id
;
22254 Constit_Id
: Entity_Id
;
22255 Posted
: Boolean := False;
22258 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22259 while Present
(Constit_Elmt
) loop
22260 Constit_Id
:= Node
(Constit_Elmt
);
22262 -- The constituent acts as an input (SPARK RM 7.2.5(3))
22264 if Present
(Body_Inputs
)
22265 and then Appears_In
(Body_Inputs
, Constit_Id
)
22267 Error_Msg_Name_1
:= Chars
(State_Id
);
22269 ("constituent & of state % must act as output in "
22270 & "dependence refinement", N
, Constit_Id
);
22272 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22274 elsif No
(Body_Outputs
)
22275 or else not Appears_In
(Body_Outputs
, Constit_Id
)
22280 ("output state & must be replaced by all its "
22281 & "constituents in dependence refinement",
22286 ("\constituent & is missing in output list",
22290 Next_Elmt
(Constit_Elmt
);
22292 end Check_Constituent_Usage
;
22297 Item_Elmt
: Elmt_Id
;
22298 Item_Id
: Entity_Id
;
22300 -- Start of processing for Check_Output_States
22303 -- Inspect the outputs of pragma Depends looking for a state with a
22304 -- visible refinement.
22306 if Present
(Spec_Outputs
) then
22307 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
22308 while Present
(Item_Elmt
) loop
22309 Item
:= Node
(Item_Elmt
);
22311 -- Deal with the mixed nature of the input and output lists
22313 if Nkind
(Item
) = N_Defining_Identifier
then
22316 Item_Id
:= Available_View
(Entity_Of
(Item
));
22319 if Ekind
(Item_Id
) = E_Abstract_State
then
22321 -- The state acts as an input-output, skip it
22323 if Present
(Spec_Inputs
)
22324 and then Appears_In
(Spec_Inputs
, Item_Id
)
22328 -- Ensure that all of the constituents are utilized as
22329 -- outputs in pragma Refined_Depends.
22331 elsif Has_Non_Null_Refinement
(Item_Id
) then
22332 Check_Constituent_Usage
(Item_Id
);
22336 Next_Elmt
(Item_Elmt
);
22339 end Check_Output_States
;
22341 -----------------------
22342 -- Normalize_Clauses --
22343 -----------------------
22345 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22346 procedure Normalize_Inputs
(Clause
: Node_Id
);
22347 -- Normalize clause Clause by creating multiple clauses for each
22348 -- input item of Clause. It is assumed that Clause has exactly one
22349 -- output. The transformation is as follows:
22351 -- Output => (Input_1, Input_2) -- original
22353 -- Output => Input_1 -- normalizations
22354 -- Output => Input_2
22356 procedure Normalize_Outputs
(Clause
: Node_Id
);
22357 -- Normalize clause Clause by creating multiple clause for each
22358 -- output item of Clause. The transformation is as follows:
22360 -- (Output_1, Output_2) => Input -- original
22362 -- Output_1 => Input -- normalization
22363 -- Output_2 => Input
22365 ----------------------
22366 -- Normalize_Inputs --
22367 ----------------------
22369 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22370 Inputs
: constant Node_Id
:= Expression
(Clause
);
22371 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22372 Output
: constant List_Id
:= Choices
(Clause
);
22373 Last_Input
: Node_Id
;
22375 New_Clause
: Node_Id
;
22376 Next_Input
: Node_Id
;
22379 -- Normalization is performed only when the original clause has
22380 -- more than one input. Multiple inputs appear as an aggregate.
22382 if Nkind
(Inputs
) = N_Aggregate
then
22383 Last_Input
:= Last
(Expressions
(Inputs
));
22385 -- Create a new clause for each input
22387 Input
:= First
(Expressions
(Inputs
));
22388 while Present
(Input
) loop
22389 Next_Input
:= Next
(Input
);
22391 -- Unhook the current input from the original input list
22392 -- because it will be relocated to a new clause.
22396 -- Special processing for the last input. At this point the
22397 -- original aggregate has been stripped down to one element.
22398 -- Replace the aggregate by the element itself.
22400 if Input
= Last_Input
then
22401 Rewrite
(Inputs
, Input
);
22403 -- Generate a clause of the form:
22408 Make_Component_Association
(Loc
,
22409 Choices
=> New_Copy_List_Tree
(Output
),
22410 Expression
=> Input
);
22412 -- The new clause contains replicated content that has
22413 -- already been analyzed, mark the clause as analyzed.
22415 Set_Analyzed
(New_Clause
);
22416 Insert_After
(Clause
, New_Clause
);
22419 Input
:= Next_Input
;
22422 end Normalize_Inputs
;
22424 -----------------------
22425 -- Normalize_Outputs --
22426 -----------------------
22428 procedure Normalize_Outputs
(Clause
: Node_Id
) is
22429 Inputs
: constant Node_Id
:= Expression
(Clause
);
22430 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22431 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
22432 Last_Output
: Node_Id
;
22433 New_Clause
: Node_Id
;
22434 Next_Output
: Node_Id
;
22438 -- Multiple outputs appear as an aggregate. Nothing to do when
22439 -- the clause has exactly one output.
22441 if Nkind
(Outputs
) = N_Aggregate
then
22442 Last_Output
:= Last
(Expressions
(Outputs
));
22444 -- Create a clause for each output. Note that each time a new
22445 -- clause is created, the original output list slowly shrinks
22446 -- until there is one item left.
22448 Output
:= First
(Expressions
(Outputs
));
22449 while Present
(Output
) loop
22450 Next_Output
:= Next
(Output
);
22452 -- Unhook the output from the original output list as it
22453 -- will be relocated to a new clause.
22457 -- Special processing for the last output. At this point
22458 -- the original aggregate has been stripped down to one
22459 -- element. Replace the aggregate by the element itself.
22461 if Output
= Last_Output
then
22462 Rewrite
(Outputs
, Output
);
22465 -- Generate a clause of the form:
22466 -- (Output => Inputs)
22469 Make_Component_Association
(Loc
,
22470 Choices
=> New_List
(Output
),
22471 Expression
=> New_Copy_Tree
(Inputs
));
22473 -- The new clause contains replicated content that has
22474 -- already been analyzed. There is not need to reanalyze
22477 Set_Analyzed
(New_Clause
);
22478 Insert_After
(Clause
, New_Clause
);
22481 Output
:= Next_Output
;
22484 end Normalize_Outputs
;
22490 -- Start of processing for Normalize_Clauses
22493 Clause
:= First
(Clauses
);
22494 while Present
(Clause
) loop
22495 Normalize_Outputs
(Clause
);
22499 Clause
:= First
(Clauses
);
22500 while Present
(Clause
) loop
22501 Normalize_Inputs
(Clause
);
22504 end Normalize_Clauses
;
22506 --------------------------
22507 -- Report_Extra_Clauses --
22508 --------------------------
22510 procedure Report_Extra_Clauses
is
22514 if Present
(Refinements
) then
22515 Clause
:= First
(Refinements
);
22516 while Present
(Clause
) loop
22518 -- Do not complain about a null input refinement, since a null
22519 -- input legitimately matches anything.
22521 if Nkind
(Clause
) /= N_Component_Association
22522 or else Nkind
(Expression
(Clause
)) /= N_Null
22525 ("unmatched or extra clause in dependence refinement",
22532 end Report_Extra_Clauses
;
22536 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22537 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
22538 Errors
: constant Nat
:= Serious_Errors_Detected
;
22539 Refs
: constant Node_Id
:=
22540 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22545 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22548 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22549 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22551 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22554 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22556 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22557 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22559 if No
(Depends
) then
22561 ("useless refinement, declaration of subprogram & lacks aspect or "
22562 & "pragma Depends", N
, Spec_Id
);
22566 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
22568 -- A null dependency relation renders the refinement useless because it
22569 -- cannot possibly mention abstract states with visible refinement. Note
22570 -- that the inverse is not true as states may be refined to null
22571 -- (SPARK RM 7.2.5(2)).
22573 if Nkind
(Deps
) = N_Null
then
22575 ("useless refinement, subprogram & does not depend on abstract "
22576 & "state with visible refinement", N
, Spec_Id
);
22580 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22581 -- This ensures that the categorization of all refined dependency items
22582 -- is consistent with their role.
22584 Analyze_Depends_In_Decl_Part
(N
);
22586 -- Do not match dependencies against refinements if Refined_Depends is
22587 -- illegal to avoid emitting misleading error.
22589 if Serious_Errors_Detected
= Errors
then
22591 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
22592 -- the inputs and outputs of the subprogram spec and body to verify
22593 -- the use of states with visible refinement and their constituents.
22595 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
22596 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
22598 Collect_Subprogram_Inputs_Outputs
22599 (Subp_Id
=> Spec_Id
,
22600 Synthesize
=> True,
22601 Subp_Inputs
=> Spec_Inputs
,
22602 Subp_Outputs
=> Spec_Outputs
,
22603 Global_Seen
=> Dummy
);
22605 Collect_Subprogram_Inputs_Outputs
22606 (Subp_Id
=> Body_Id
,
22607 Synthesize
=> True,
22608 Subp_Inputs
=> Body_Inputs
,
22609 Subp_Outputs
=> Body_Outputs
,
22610 Global_Seen
=> Dummy
);
22612 -- For an output state with a visible refinement, ensure that all
22613 -- constituents appear as outputs in the dependency refinement.
22615 Check_Output_States
;
22618 -- Matching is disabled in ASIS because clauses are not normalized as
22619 -- this is a tree altering activity similar to expansion.
22625 -- Multiple dependency clauses appear as component associations of an
22626 -- aggregate. Note that the clauses are copied because the algorithm
22627 -- modifies them and this should not be visible in Depends.
22629 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22630 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22631 Normalize_Clauses
(Dependencies
);
22633 if Nkind
(Refs
) = N_Null
then
22634 Refinements
:= No_List
;
22636 -- Multiple dependency clauses appear as component associations of an
22637 -- aggregate. Note that the clauses are copied because the algorithm
22638 -- modifies them and this should not be visible in Refined_Depends.
22640 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22641 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22642 Normalize_Clauses
(Refinements
);
22645 -- At this point the clauses of pragmas Depends and Refined_Depends
22646 -- have been normalized into simple dependencies between one output
22647 -- and one input. Examine all clauses of pragma Depends looking for
22648 -- matching clauses in pragma Refined_Depends.
22650 Clause
:= First
(Dependencies
);
22651 while Present
(Clause
) loop
22652 Check_Dependency_Clause
(Clause
);
22656 if Serious_Errors_Detected
= Errors
then
22657 Report_Extra_Clauses
;
22660 end Analyze_Refined_Depends_In_Decl_Part
;
22662 -----------------------------------------
22663 -- Analyze_Refined_Global_In_Decl_Part --
22664 -----------------------------------------
22666 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22668 -- The corresponding Global pragma
22670 Has_In_State
: Boolean := False;
22671 Has_In_Out_State
: Boolean := False;
22672 Has_Out_State
: Boolean := False;
22673 Has_Proof_In_State
: Boolean := False;
22674 -- These flags are set when the corresponding Global pragma has a state
22675 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22678 Has_Null_State
: Boolean := False;
22679 -- This flag is set when the corresponding Global pragma has at least
22680 -- one state with a null refinement.
22682 In_Constits
: Elist_Id
:= No_Elist
;
22683 In_Out_Constits
: Elist_Id
:= No_Elist
;
22684 Out_Constits
: Elist_Id
:= No_Elist
;
22685 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22686 -- These lists contain the entities of all Input, In_Out, Output and
22687 -- Proof_In constituents that appear in Refined_Global and participate
22688 -- in state refinement.
22690 In_Items
: Elist_Id
:= No_Elist
;
22691 In_Out_Items
: Elist_Id
:= No_Elist
;
22692 Out_Items
: Elist_Id
:= No_Elist
;
22693 Proof_In_Items
: Elist_Id
:= No_Elist
;
22694 -- These list contain the entities of all Input, In_Out, Output and
22695 -- Proof_In items defined in the corresponding Global pragma.
22697 procedure Check_In_Out_States
;
22698 -- Determine whether the corresponding Global pragma mentions In_Out
22699 -- states with visible refinement and if so, ensure that one of the
22700 -- following completions apply to the constituents of the state:
22701 -- 1) there is at least one constituent of mode In_Out
22702 -- 2) there is at least one Input and one Output constituent
22703 -- 3) not all constituents are present and one of them is of mode
22705 -- This routine may remove elements from In_Constits, In_Out_Constits,
22706 -- Out_Constits and Proof_In_Constits.
22708 procedure Check_Input_States
;
22709 -- Determine whether the corresponding Global pragma mentions Input
22710 -- states with visible refinement and if so, ensure that at least one of
22711 -- its constituents appears as an Input item in Refined_Global.
22712 -- This routine may remove elements from In_Constits, In_Out_Constits,
22713 -- Out_Constits and Proof_In_Constits.
22715 procedure Check_Output_States
;
22716 -- Determine whether the corresponding Global pragma mentions Output
22717 -- states with visible refinement and if so, ensure that all of its
22718 -- constituents appear as Output items in Refined_Global.
22719 -- This routine may remove elements from In_Constits, In_Out_Constits,
22720 -- Out_Constits and Proof_In_Constits.
22722 procedure Check_Proof_In_States
;
22723 -- Determine whether the corresponding Global pragma mentions Proof_In
22724 -- states with visible refinement and if so, ensure that at least one of
22725 -- its constituents appears as a Proof_In item in Refined_Global.
22726 -- This routine may remove elements from In_Constits, In_Out_Constits,
22727 -- Out_Constits and Proof_In_Constits.
22729 procedure Check_Refined_Global_List
22731 Global_Mode
: Name_Id
:= Name_Input
);
22732 -- Verify the legality of a single global list declaration. Global_Mode
22733 -- denotes the current mode in effect.
22735 procedure Collect_Global_Items
(Prag
: Node_Id
);
22736 -- Gather all input, in out, output and Proof_In items of pragma Prag
22737 -- in lists In_Items, In_Out_Items, Out_Items and Proof_In_Items. Flags
22738 -- Has_In_State, Has_In_Out_State, Has_Out_State and Has_Proof_In_State
22739 -- are set when there is at least one abstract state with visible
22740 -- refinement available in the corresponding mode. Flag Has_Null_State
22741 -- is set when at least state has a null refinement.
22743 function Present_Then_Remove
22745 Item
: Entity_Id
) return Boolean;
22746 -- Search List for a particular entity Item. If Item has been found,
22747 -- remove it from List. This routine is used to strip lists In_Constits,
22748 -- In_Out_Constits and Out_Constits of valid constituents.
22750 procedure Report_Extra_Constituents
;
22751 -- Emit an error for each constituent found in lists In_Constits,
22752 -- In_Out_Constits and Out_Constits.
22754 -------------------------
22755 -- Check_In_Out_States --
22756 -------------------------
22758 procedure Check_In_Out_States
is
22759 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22760 -- Determine whether one of the following coverage scenarios is in
22762 -- 1) there is at least one constituent of mode In_Out
22763 -- 2) there is at least one Input and one Output constituent
22764 -- 3) not all constituents are present and one of them is of mode
22766 -- If this is not the case, emit an error.
22768 -----------------------------
22769 -- Check_Constituent_Usage --
22770 -----------------------------
22772 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22773 Constit_Elmt
: Elmt_Id
;
22774 Constit_Id
: Entity_Id
;
22775 Has_Missing
: Boolean := False;
22776 In_Out_Seen
: Boolean := False;
22777 In_Seen
: Boolean := False;
22778 Out_Seen
: Boolean := False;
22781 -- Process all the constituents of the state and note their modes
22782 -- within the global refinement.
22784 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22785 while Present
(Constit_Elmt
) loop
22786 Constit_Id
:= Node
(Constit_Elmt
);
22788 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22791 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22792 In_Out_Seen
:= True;
22794 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22797 -- A Proof_In constituent cannot participate in the completion
22798 -- of an Output state (SPARK RM 7.2.4(5)).
22800 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22801 Error_Msg_Name_1
:= Chars
(State_Id
);
22803 ("constituent & of state % must have mode Input, In_Out "
22804 & "or Output in global refinement",
22808 Has_Missing
:= True;
22811 Next_Elmt
(Constit_Elmt
);
22814 -- A single In_Out constituent is a valid completion
22816 if In_Out_Seen
then
22819 -- A pair of one Input and one Output constituent is a valid
22822 elsif In_Seen
and then Out_Seen
then
22825 -- A single Output constituent is a valid completion only when
22826 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22828 elsif Has_Missing
and then Out_Seen
then
22833 ("global refinement of state & redefines the mode of its "
22834 & "constituents", N
, State_Id
);
22836 end Check_Constituent_Usage
;
22840 Item_Elmt
: Elmt_Id
;
22841 Item_Id
: Entity_Id
;
22843 -- Start of processing for Check_In_Out_States
22846 -- Inspect the In_Out items of the corresponding Global pragma
22847 -- looking for a state with a visible refinement.
22849 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22850 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22851 while Present
(Item_Elmt
) loop
22852 Item_Id
:= Node
(Item_Elmt
);
22854 -- Ensure that one of the three coverage variants is satisfied
22856 if Ekind
(Item_Id
) = E_Abstract_State
22857 and then Has_Non_Null_Refinement
(Item_Id
)
22859 Check_Constituent_Usage
(Item_Id
);
22862 Next_Elmt
(Item_Elmt
);
22865 end Check_In_Out_States
;
22867 ------------------------
22868 -- Check_Input_States --
22869 ------------------------
22871 procedure Check_Input_States
is
22872 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22873 -- Determine whether at least one constituent of state State_Id with
22874 -- visible refinement is used and has mode Input. Ensure that the
22875 -- remaining constituents do not have In_Out, Output or Proof_In
22878 -----------------------------
22879 -- Check_Constituent_Usage --
22880 -----------------------------
22882 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22883 Constit_Elmt
: Elmt_Id
;
22884 Constit_Id
: Entity_Id
;
22885 In_Seen
: Boolean := False;
22888 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22889 while Present
(Constit_Elmt
) loop
22890 Constit_Id
:= Node
(Constit_Elmt
);
22892 -- At least one of the constituents appears as an Input
22894 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22897 -- The constituent appears in the global refinement, but has
22898 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22900 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22901 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22902 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22904 Error_Msg_Name_1
:= Chars
(State_Id
);
22906 ("constituent & of state % must have mode Input in global "
22907 & "refinement", N
, Constit_Id
);
22910 Next_Elmt
(Constit_Elmt
);
22913 -- Not one of the constituents appeared as Input
22915 if not In_Seen
then
22917 ("global refinement of state & must include at least one "
22918 & "constituent of mode Input", N
, State_Id
);
22920 end Check_Constituent_Usage
;
22924 Item_Elmt
: Elmt_Id
;
22925 Item_Id
: Entity_Id
;
22927 -- Start of processing for Check_Input_States
22930 -- Inspect the Input items of the corresponding Global pragma
22931 -- looking for a state with a visible refinement.
22933 if Has_In_State
and then Present
(In_Items
) then
22934 Item_Elmt
:= First_Elmt
(In_Items
);
22935 while Present
(Item_Elmt
) loop
22936 Item_Id
:= Node
(Item_Elmt
);
22938 -- Ensure that at least one of the constituents is utilized and
22939 -- is of mode Input.
22941 if Ekind
(Item_Id
) = E_Abstract_State
22942 and then Has_Non_Null_Refinement
(Item_Id
)
22944 Check_Constituent_Usage
(Item_Id
);
22947 Next_Elmt
(Item_Elmt
);
22950 end Check_Input_States
;
22952 -------------------------
22953 -- Check_Output_States --
22954 -------------------------
22956 procedure Check_Output_States
is
22957 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22958 -- Determine whether all constituents of state State_Id with visible
22959 -- refinement are used and have mode Output. Emit an error if this is
22962 -----------------------------
22963 -- Check_Constituent_Usage --
22964 -----------------------------
22966 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22967 Constit_Elmt
: Elmt_Id
;
22968 Constit_Id
: Entity_Id
;
22969 Posted
: Boolean := False;
22972 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22973 while Present
(Constit_Elmt
) loop
22974 Constit_Id
:= Node
(Constit_Elmt
);
22976 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22979 -- The constituent appears in the global refinement, but has
22980 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22982 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22983 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22984 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22986 Error_Msg_Name_1
:= Chars
(State_Id
);
22988 ("constituent & of state % must have mode Output in "
22989 & "global refinement", N
, Constit_Id
);
22991 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22997 ("output state & must be replaced by all its "
22998 & "constituents in global refinement", N
, State_Id
);
23002 ("\constituent & is missing in output list",
23006 Next_Elmt
(Constit_Elmt
);
23008 end Check_Constituent_Usage
;
23012 Item_Elmt
: Elmt_Id
;
23013 Item_Id
: Entity_Id
;
23015 -- Start of processing for Check_Output_States
23018 -- Inspect the Output items of the corresponding Global pragma
23019 -- looking for a state with a visible refinement.
23021 if Has_Out_State
and then Present
(Out_Items
) then
23022 Item_Elmt
:= First_Elmt
(Out_Items
);
23023 while Present
(Item_Elmt
) loop
23024 Item_Id
:= Node
(Item_Elmt
);
23026 -- Ensure that all of the constituents are utilized and they
23027 -- have mode Output.
23029 if Ekind
(Item_Id
) = E_Abstract_State
23030 and then Has_Non_Null_Refinement
(Item_Id
)
23032 Check_Constituent_Usage
(Item_Id
);
23035 Next_Elmt
(Item_Elmt
);
23038 end Check_Output_States
;
23040 ---------------------------
23041 -- Check_Proof_In_States --
23042 ---------------------------
23044 procedure Check_Proof_In_States
is
23045 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23046 -- Determine whether at least one constituent of state State_Id with
23047 -- visible refinement is used and has mode Proof_In. Ensure that the
23048 -- remaining constituents do not have Input, In_Out or Output modes.
23050 -----------------------------
23051 -- Check_Constituent_Usage --
23052 -----------------------------
23054 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23055 Constit_Elmt
: Elmt_Id
;
23056 Constit_Id
: Entity_Id
;
23057 Proof_In_Seen
: Boolean := False;
23060 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23061 while Present
(Constit_Elmt
) loop
23062 Constit_Id
:= Node
(Constit_Elmt
);
23064 -- At least one of the constituents appears as Proof_In
23066 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23067 Proof_In_Seen
:= True;
23069 -- The constituent appears in the global refinement, but has
23070 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23072 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23073 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23074 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23076 Error_Msg_Name_1
:= Chars
(State_Id
);
23078 ("constituent & of state % must have mode Proof_In in "
23079 & "global refinement", N
, Constit_Id
);
23082 Next_Elmt
(Constit_Elmt
);
23085 -- Not one of the constituents appeared as Proof_In
23087 if not Proof_In_Seen
then
23089 ("global refinement of state & must include at least one "
23090 & "constituent of mode Proof_In", N
, State_Id
);
23092 end Check_Constituent_Usage
;
23096 Item_Elmt
: Elmt_Id
;
23097 Item_Id
: Entity_Id
;
23099 -- Start of processing for Check_Proof_In_States
23102 -- Inspect the Proof_In items of the corresponding Global pragma
23103 -- looking for a state with a visible refinement.
23105 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23106 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23107 while Present
(Item_Elmt
) loop
23108 Item_Id
:= Node
(Item_Elmt
);
23110 -- Ensure that at least one of the constituents is utilized and
23111 -- is of mode Proof_In
23113 if Ekind
(Item_Id
) = E_Abstract_State
23114 and then Has_Non_Null_Refinement
(Item_Id
)
23116 Check_Constituent_Usage
(Item_Id
);
23119 Next_Elmt
(Item_Elmt
);
23122 end Check_Proof_In_States
;
23124 -------------------------------
23125 -- Check_Refined_Global_List --
23126 -------------------------------
23128 procedure Check_Refined_Global_List
23130 Global_Mode
: Name_Id
:= Name_Input
)
23132 procedure Check_Refined_Global_Item
23134 Global_Mode
: Name_Id
);
23135 -- Verify the legality of a single global item declaration. Parameter
23136 -- Global_Mode denotes the current mode in effect.
23138 -------------------------------
23139 -- Check_Refined_Global_Item --
23140 -------------------------------
23142 procedure Check_Refined_Global_Item
23144 Global_Mode
: Name_Id
)
23146 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23148 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23149 -- Issue a common error message for all mode mismatches. Expect
23150 -- denotes the expected mode.
23152 -----------------------------
23153 -- Inconsistent_Mode_Error --
23154 -----------------------------
23156 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23159 ("global item & has inconsistent modes", Item
, Item_Id
);
23161 Error_Msg_Name_1
:= Global_Mode
;
23162 Error_Msg_Name_2
:= Expect
;
23163 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
23164 end Inconsistent_Mode_Error
;
23166 -- Start of processing for Check_Refined_Global_Item
23169 -- When the state or variable acts as a constituent of another
23170 -- state with a visible refinement, collect it for the state
23171 -- completeness checks performed later on.
23173 if Present
(Encapsulating_State
(Item_Id
))
23174 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23176 if Global_Mode
= Name_Input
then
23177 Add_Item
(Item_Id
, In_Constits
);
23179 elsif Global_Mode
= Name_In_Out
then
23180 Add_Item
(Item_Id
, In_Out_Constits
);
23182 elsif Global_Mode
= Name_Output
then
23183 Add_Item
(Item_Id
, Out_Constits
);
23185 elsif Global_Mode
= Name_Proof_In
then
23186 Add_Item
(Item_Id
, Proof_In_Constits
);
23189 -- When not a constituent, ensure that both occurrences of the
23190 -- item in pragmas Global and Refined_Global match.
23192 elsif Contains
(In_Items
, Item_Id
) then
23193 if Global_Mode
/= Name_Input
then
23194 Inconsistent_Mode_Error
(Name_Input
);
23197 elsif Contains
(In_Out_Items
, Item_Id
) then
23198 if Global_Mode
/= Name_In_Out
then
23199 Inconsistent_Mode_Error
(Name_In_Out
);
23202 elsif Contains
(Out_Items
, Item_Id
) then
23203 if Global_Mode
/= Name_Output
then
23204 Inconsistent_Mode_Error
(Name_Output
);
23207 elsif Contains
(Proof_In_Items
, Item_Id
) then
23210 -- The item does not appear in the corresponding Global pragma,
23211 -- it must be an extra (SPARK RM 7.2.4(3)).
23214 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
23216 end Check_Refined_Global_Item
;
23222 -- Start of processing for Check_Refined_Global_List
23225 if Nkind
(List
) = N_Null
then
23228 -- Single global item declaration
23230 elsif Nkind_In
(List
, N_Expanded_Name
,
23232 N_Selected_Component
)
23234 Check_Refined_Global_Item
(List
, Global_Mode
);
23236 -- Simple global list or moded global list declaration
23238 elsif Nkind
(List
) = N_Aggregate
then
23240 -- The declaration of a simple global list appear as a collection
23243 if Present
(Expressions
(List
)) then
23244 Item
:= First
(Expressions
(List
));
23245 while Present
(Item
) loop
23246 Check_Refined_Global_Item
(Item
, Global_Mode
);
23251 -- The declaration of a moded global list appears as a collection
23252 -- of component associations where individual choices denote
23255 elsif Present
(Component_Associations
(List
)) then
23256 Item
:= First
(Component_Associations
(List
));
23257 while Present
(Item
) loop
23258 Check_Refined_Global_List
23259 (List
=> Expression
(Item
),
23260 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23268 raise Program_Error
;
23274 raise Program_Error
;
23276 end Check_Refined_Global_List
;
23278 --------------------------
23279 -- Collect_Global_Items --
23280 --------------------------
23282 procedure Collect_Global_Items
(Prag
: Node_Id
) is
23283 procedure Process_Global_List
23285 Mode
: Name_Id
:= Name_Input
);
23286 -- Collect all items housed in a global list. Formal Mode denotes the
23287 -- current mode in effect.
23289 -------------------------
23290 -- Process_Global_List --
23291 -------------------------
23293 procedure Process_Global_List
23295 Mode
: Name_Id
:= Name_Input
)
23297 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
23298 -- Add a single item to the appropriate list. Formal Mode denotes
23299 -- the current mode in effect.
23301 -------------------------
23302 -- Process_Global_Item --
23303 -------------------------
23305 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
23306 Item_Id
: constant Entity_Id
:=
23307 Available_View
(Entity_Of
(Item
));
23308 -- The above handles abstract views of variables and states
23309 -- built for limited with clauses.
23312 -- Signal that the global list contains at least one abstract
23313 -- state with a visible refinement. Note that the refinement
23314 -- may be null in which case there are no constituents.
23316 if Ekind
(Item_Id
) = E_Abstract_State
then
23317 if Has_Null_Refinement
(Item_Id
) then
23318 Has_Null_State
:= True;
23320 elsif Has_Non_Null_Refinement
(Item_Id
) then
23321 if Mode
= Name_Input
then
23322 Has_In_State
:= True;
23323 elsif Mode
= Name_In_Out
then
23324 Has_In_Out_State
:= True;
23325 elsif Mode
= Name_Output
then
23326 Has_Out_State
:= True;
23327 elsif Mode
= Name_Proof_In
then
23328 Has_Proof_In_State
:= True;
23333 -- Add the item to the proper list
23335 if Mode
= Name_Input
then
23336 Add_Item
(Item_Id
, In_Items
);
23337 elsif Mode
= Name_In_Out
then
23338 Add_Item
(Item_Id
, In_Out_Items
);
23339 elsif Mode
= Name_Output
then
23340 Add_Item
(Item_Id
, Out_Items
);
23341 elsif Mode
= Name_Proof_In
then
23342 Add_Item
(Item_Id
, Proof_In_Items
);
23344 end Process_Global_Item
;
23350 -- Start of processing for Process_Global_List
23353 if Nkind
(List
) = N_Null
then
23356 -- Single global item declaration
23358 elsif Nkind_In
(List
, N_Expanded_Name
,
23360 N_Selected_Component
)
23362 Process_Global_Item
(List
, Mode
);
23364 -- Single global list or moded global list declaration
23366 elsif Nkind
(List
) = N_Aggregate
then
23368 -- The declaration of a simple global list appear as a
23369 -- collection of expressions.
23371 if Present
(Expressions
(List
)) then
23372 Item
:= First
(Expressions
(List
));
23373 while Present
(Item
) loop
23374 Process_Global_Item
(Item
, Mode
);
23378 -- The declaration of a moded global list appears as a
23379 -- collection of component associations where individual
23380 -- choices denote mode.
23382 elsif Present
(Component_Associations
(List
)) then
23383 Item
:= First
(Component_Associations
(List
));
23384 while Present
(Item
) loop
23385 Process_Global_List
23386 (List
=> Expression
(Item
),
23387 Mode
=> Chars
(First
(Choices
(Item
))));
23395 raise Program_Error
;
23398 -- To accomodate partial decoration of disabled SPARK features,
23399 -- this routine may be called with illegal input. If this is the
23400 -- case, do not raise Program_Error.
23405 end Process_Global_List
;
23407 -- Start of processing for Collect_Global_Items
23410 Process_Global_List
23411 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
))));
23412 end Collect_Global_Items
;
23414 -------------------------
23415 -- Present_Then_Remove --
23416 -------------------------
23418 function Present_Then_Remove
23420 Item
: Entity_Id
) return Boolean
23425 if Present
(List
) then
23426 Elmt
:= First_Elmt
(List
);
23427 while Present
(Elmt
) loop
23428 if Node
(Elmt
) = Item
then
23429 Remove_Elmt
(List
, Elmt
);
23438 end Present_Then_Remove
;
23440 -------------------------------
23441 -- Report_Extra_Constituents --
23442 -------------------------------
23444 procedure Report_Extra_Constituents
is
23445 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23446 -- Emit an error for every element of List
23448 ---------------------------------------
23449 -- Report_Extra_Constituents_In_List --
23450 ---------------------------------------
23452 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23453 Constit_Elmt
: Elmt_Id
;
23456 if Present
(List
) then
23457 Constit_Elmt
:= First_Elmt
(List
);
23458 while Present
(Constit_Elmt
) loop
23459 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23460 Next_Elmt
(Constit_Elmt
);
23463 end Report_Extra_Constituents_In_List
;
23465 -- Start of processing for Report_Extra_Constituents
23468 Report_Extra_Constituents_In_List
(In_Constits
);
23469 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23470 Report_Extra_Constituents_In_List
(Out_Constits
);
23471 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23472 end Report_Extra_Constituents
;
23476 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23477 Errors
: constant Nat
:= Serious_Errors_Detected
;
23478 Items
: constant Node_Id
:=
23479 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23480 Spec_Id
: Entity_Id
;
23482 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23485 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23486 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23488 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23491 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23493 -- The subprogram declaration lacks pragma Global. This renders
23494 -- Refined_Global useless as there is nothing to refine.
23496 if No
(Global
) then
23498 ("useless refinement, declaration of subprogram & lacks aspect or "
23499 & "pragma Global", N
, Spec_Id
);
23503 -- Extract all relevant items from the corresponding Global pragma
23505 Collect_Global_Items
(Global
);
23507 -- Corresponding Global pragma must mention at least one state witha
23508 -- visible refinement at the point Refined_Global is processed. States
23509 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23511 if not Has_In_State
23512 and then not Has_In_Out_State
23513 and then not Has_Out_State
23514 and then not Has_Proof_In_State
23515 and then not Has_Null_State
23518 ("useless refinement, subprogram & does not depend on abstract "
23519 & "state with visible refinement", N
, Spec_Id
);
23523 -- The global refinement of inputs and outputs cannot be null when the
23524 -- corresponding Global pragma contains at least one item except in the
23525 -- case where we have states with null refinements.
23527 if Nkind
(Items
) = N_Null
23529 (Present
(In_Items
)
23530 or else Present
(In_Out_Items
)
23531 or else Present
(Out_Items
)
23532 or else Present
(Proof_In_Items
))
23533 and then not Has_Null_State
23536 ("refinement cannot be null, subprogram & has global items",
23541 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23542 -- This ensures that the categorization of all refined global items is
23543 -- consistent with their role.
23545 Analyze_Global_In_Decl_Part
(N
);
23547 -- Perform all refinement checks with respect to completeness and mode
23550 if Serious_Errors_Detected
= Errors
then
23551 Check_Refined_Global_List
(Items
);
23554 -- For Input states with visible refinement, at least one constituent
23555 -- must be used as an Input in the global refinement.
23557 if Serious_Errors_Detected
= Errors
then
23558 Check_Input_States
;
23561 -- Verify all possible completion variants for In_Out states with
23562 -- visible refinement.
23564 if Serious_Errors_Detected
= Errors
then
23565 Check_In_Out_States
;
23568 -- For Output states with visible refinement, all constituents must be
23569 -- used as Outputs in the global refinement.
23571 if Serious_Errors_Detected
= Errors
then
23572 Check_Output_States
;
23575 -- For Proof_In states with visible refinement, at least one constituent
23576 -- must be used as Proof_In in the global refinement.
23578 if Serious_Errors_Detected
= Errors
then
23579 Check_Proof_In_States
;
23582 -- Emit errors for all constituents that belong to other states with
23583 -- visible refinement that do not appear in Global.
23585 if Serious_Errors_Detected
= Errors
then
23586 Report_Extra_Constituents
;
23588 end Analyze_Refined_Global_In_Decl_Part
;
23590 ----------------------------------------
23591 -- Analyze_Refined_State_In_Decl_Part --
23592 ----------------------------------------
23594 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23595 Available_States
: Elist_Id
:= No_Elist
;
23596 -- A list of all abstract states defined in the package declaration that
23597 -- are available for refinement. The list is used to report unrefined
23600 Body_Id
: Entity_Id
;
23601 -- The body entity of the package subject to pragma Refined_State
23603 Body_States
: Elist_Id
:= No_Elist
;
23604 -- A list of all hidden states that appear in the body of the related
23605 -- package. The list is used to report unused hidden states.
23607 Constituents_Seen
: Elist_Id
:= No_Elist
;
23608 -- A list that contains all constituents processed so far. The list is
23609 -- used to detect multiple uses of the same constituent.
23611 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23612 -- A list that contains all refined states processed so far. The list is
23613 -- used to detect duplicate refinements.
23615 Spec_Id
: Entity_Id
;
23616 -- The spec entity of the package subject to pragma Refined_State
23618 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23619 -- Perform full analysis of a single refinement clause
23621 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23622 -- Gather the entities of all abstract states and variables declared in
23623 -- the body state space of package Pack_Id.
23625 procedure Report_Unrefined_States
(States
: Elist_Id
);
23626 -- Emit errors for all unrefined abstract states found in list States
23628 procedure Report_Unused_States
(States
: Elist_Id
);
23629 -- Emit errors for all unused states found in list States
23631 -------------------------------
23632 -- Analyze_Refinement_Clause --
23633 -------------------------------
23635 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23636 AR_Constit
: Entity_Id
:= Empty
;
23637 AW_Constit
: Entity_Id
:= Empty
;
23638 ER_Constit
: Entity_Id
:= Empty
;
23639 EW_Constit
: Entity_Id
:= Empty
;
23640 -- The entities of external constituents that contain one of the
23641 -- following enabled properties: Async_Readers, Async_Writers,
23642 -- Effective_Reads and Effective_Writes.
23644 External_Constit_Seen
: Boolean := False;
23645 -- Flag used to mark when at least one external constituent is part
23646 -- of the state refinement.
23648 Non_Null_Seen
: Boolean := False;
23649 Null_Seen
: Boolean := False;
23650 -- Flags used to detect multiple uses of null in a single clause or a
23651 -- mixture of null and non-null constituents.
23653 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23654 -- A list of all candidate constituents subject to indicator Part_Of
23655 -- where the encapsulating state is the current state.
23658 State_Id
: Entity_Id
;
23659 -- The current state being refined
23661 procedure Analyze_Constituent
(Constit
: Node_Id
);
23662 -- Perform full analysis of a single constituent
23664 procedure Check_External_Property
23665 (Prop_Nam
: Name_Id
;
23667 Constit
: Entity_Id
);
23668 -- Determine whether a property denoted by name Prop_Nam is present
23669 -- in both the refined state and constituent Constit. Flag Enabled
23670 -- should be set when the property applies to the refined state. If
23671 -- this is not the case, emit an error message.
23673 procedure Check_Matching_State
;
23674 -- Determine whether the state being refined appears in list
23675 -- Available_States. Emit an error when attempting to re-refine the
23676 -- state or when the state is not defined in the package declaration,
23677 -- otherwise remove the state from Available_States.
23679 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23680 -- Emit errors for all unused Part_Of constituents in list Constits
23682 -------------------------
23683 -- Analyze_Constituent --
23684 -------------------------
23686 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23687 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23688 -- Verify that the constituent Constit_Id is a Ghost entity if the
23689 -- abstract state being refined is also Ghost. If this is the case
23690 -- verify that the Ghost policy in effect at the point of state
23691 -- and constituent declaration is the same.
23693 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23694 -- Determine whether constituent Constit denoted by its entity
23695 -- Constit_Id appears in Hidden_States. Emit an error when the
23696 -- constituent is not a valid hidden state of the related package
23697 -- or when it is used more than once. Otherwise remove the
23698 -- constituent from Hidden_States.
23700 --------------------------------
23701 -- Check_Matching_Constituent --
23702 --------------------------------
23704 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23705 procedure Collect_Constituent
;
23706 -- Add constituent Constit_Id to the refinements of State_Id
23708 -------------------------
23709 -- Collect_Constituent --
23710 -------------------------
23712 procedure Collect_Constituent
is
23714 -- Add the constituent to the list of processed items to aid
23715 -- with the detection of duplicates.
23717 Add_Item
(Constit_Id
, Constituents_Seen
);
23719 -- Collect the constituent in the list of refinement items
23720 -- and establish a relation between the refined state and
23723 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23724 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23726 -- The state has at least one legal constituent, mark the
23727 -- start of the refinement region. The region ends when the
23728 -- body declarations end (see routine Analyze_Declarations).
23730 Set_Has_Visible_Refinement
(State_Id
);
23732 -- When the constituent is external, save its relevant
23733 -- property for further checks.
23735 if Async_Readers_Enabled
(Constit_Id
) then
23736 AR_Constit
:= Constit_Id
;
23737 External_Constit_Seen
:= True;
23740 if Async_Writers_Enabled
(Constit_Id
) then
23741 AW_Constit
:= Constit_Id
;
23742 External_Constit_Seen
:= True;
23745 if Effective_Reads_Enabled
(Constit_Id
) then
23746 ER_Constit
:= Constit_Id
;
23747 External_Constit_Seen
:= True;
23750 if Effective_Writes_Enabled
(Constit_Id
) then
23751 EW_Constit
:= Constit_Id
;
23752 External_Constit_Seen
:= True;
23754 end Collect_Constituent
;
23758 State_Elmt
: Elmt_Id
;
23760 -- Start of processing for Check_Matching_Constituent
23763 -- Detect a duplicate use of a constituent
23765 if Contains
(Constituents_Seen
, Constit_Id
) then
23767 ("duplicate use of constituent &", Constit
, Constit_Id
);
23771 -- The constituent is subject to a Part_Of indicator
23773 if Present
(Encapsulating_State
(Constit_Id
)) then
23774 if Encapsulating_State
(Constit_Id
) = State_Id
then
23775 Check_Ghost_Constituent
(Constit_Id
);
23776 Remove
(Part_Of_Constits
, Constit_Id
);
23777 Collect_Constituent
;
23779 -- The constituent is part of another state and is used
23780 -- incorrectly in the refinement of the current state.
23783 Error_Msg_Name_1
:= Chars
(State_Id
);
23785 ("& cannot act as constituent of state %",
23786 Constit
, Constit_Id
);
23788 ("\Part_Of indicator specifies & as encapsulating "
23789 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23792 -- The only other source of legal constituents is the body
23793 -- state space of the related package.
23796 if Present
(Body_States
) then
23797 State_Elmt
:= First_Elmt
(Body_States
);
23798 while Present
(State_Elmt
) loop
23800 -- Consume a valid constituent to signal that it has
23801 -- been encountered.
23803 if Node
(State_Elmt
) = Constit_Id
then
23804 Check_Ghost_Constituent
(Constit_Id
);
23806 Remove_Elmt
(Body_States
, State_Elmt
);
23807 Collect_Constituent
;
23811 Next_Elmt
(State_Elmt
);
23815 -- If we get here, then the constituent is not a hidden
23816 -- state of the related package and may not be used in a
23817 -- refinement (SPARK RM 7.2.2(9)).
23819 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23821 ("cannot use & in refinement, constituent is not a hidden "
23822 & "state of package %", Constit
, Constit_Id
);
23824 end Check_Matching_Constituent
;
23826 -----------------------------
23827 -- Check_Ghost_Constituent --
23828 -----------------------------
23830 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
23832 if Is_Ghost_Entity
(State_Id
) then
23833 if Is_Ghost_Entity
(Constit_Id
) then
23835 -- The Ghost policy in effect at the point of abstract
23836 -- state declaration and constituent must match
23837 -- (SPARK RM 6.9(16)).
23839 if Is_Checked_Ghost_Entity
(State_Id
)
23840 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
23842 Error_Msg_Sloc
:= Sloc
(Constit
);
23845 ("incompatible ghost policies in effect", State
);
23847 ("\abstract state & declared with ghost policy "
23848 & "Check", State
, State_Id
);
23850 ("\constituent & declared # with ghost policy "
23851 & "Ignore", State
, Constit_Id
);
23853 elsif Is_Ignored_Ghost_Entity
(State_Id
)
23854 and then Is_Checked_Ghost_Entity
(Constit_Id
)
23856 Error_Msg_Sloc
:= Sloc
(Constit
);
23859 ("incompatible ghost policies in effect", State
);
23861 ("\abstract state & declared with ghost policy "
23862 & "Ignore", State
, State_Id
);
23864 ("\constituent & declared # with ghost policy "
23865 & "Check", State
, Constit_Id
);
23868 -- A constituent of a Ghost abstract state must be a Ghost
23869 -- entity (SPARK RM 7.2.2(12)).
23873 ("constituent of ghost state & must be ghost",
23874 Constit
, State_Id
);
23877 end Check_Ghost_Constituent
;
23881 Constit_Id
: Entity_Id
;
23883 -- Start of processing for Analyze_Constituent
23886 -- Detect multiple uses of null in a single refinement clause or a
23887 -- mixture of null and non-null constituents.
23889 if Nkind
(Constit
) = N_Null
then
23892 ("multiple null constituents not allowed", Constit
);
23894 elsif Non_Null_Seen
then
23896 ("cannot mix null and non-null constituents", Constit
);
23901 -- Collect the constituent in the list of refinement items
23903 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23905 -- The state has at least one legal constituent, mark the
23906 -- start of the refinement region. The region ends when the
23907 -- body declarations end (see Analyze_Declarations).
23909 Set_Has_Visible_Refinement
(State_Id
);
23912 -- Non-null constituents
23915 Non_Null_Seen
:= True;
23919 ("cannot mix null and non-null constituents", Constit
);
23923 Resolve_State
(Constit
);
23925 -- Ensure that the constituent denotes a valid state or a
23928 if Is_Entity_Name
(Constit
) then
23929 Constit_Id
:= Entity_Of
(Constit
);
23931 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
23932 Check_Matching_Constituent
(Constit_Id
);
23936 ("constituent & must denote a variable or state (SPARK "
23937 & "RM 7.2.2(5))", Constit
, Constit_Id
);
23940 -- The constituent is illegal
23943 SPARK_Msg_N
("malformed constituent", Constit
);
23946 end Analyze_Constituent
;
23948 -----------------------------
23949 -- Check_External_Property --
23950 -----------------------------
23952 procedure Check_External_Property
23953 (Prop_Nam
: Name_Id
;
23955 Constit
: Entity_Id
)
23958 Error_Msg_Name_1
:= Prop_Nam
;
23960 -- The property is enabled in the related Abstract_State pragma
23961 -- that defines the state (SPARK RM 7.2.8(3)).
23964 if No
(Constit
) then
23966 ("external state & requires at least one constituent with "
23967 & "property %", State
, State_Id
);
23970 -- The property is missing in the declaration of the state, but
23971 -- a constituent is introducing it in the state refinement
23972 -- (SPARK RM 7.2.8(3)).
23974 elsif Present
(Constit
) then
23975 Error_Msg_Name_2
:= Chars
(Constit
);
23977 ("external state & lacks property % set by constituent %",
23980 end Check_External_Property
;
23982 --------------------------
23983 -- Check_Matching_State --
23984 --------------------------
23986 procedure Check_Matching_State
is
23987 State_Elmt
: Elmt_Id
;
23990 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23992 if Contains
(Refined_States_Seen
, State_Id
) then
23994 ("duplicate refinement of state &", State
, State_Id
);
23998 -- Inspect the abstract states defined in the package declaration
23999 -- looking for a match.
24001 State_Elmt
:= First_Elmt
(Available_States
);
24002 while Present
(State_Elmt
) loop
24004 -- A valid abstract state is being refined in the body. Add
24005 -- the state to the list of processed refined states to aid
24006 -- with the detection of duplicate refinements. Remove the
24007 -- state from Available_States to signal that it has already
24010 if Node
(State_Elmt
) = State_Id
then
24011 Add_Item
(State_Id
, Refined_States_Seen
);
24012 Remove_Elmt
(Available_States
, State_Elmt
);
24016 Next_Elmt
(State_Elmt
);
24019 -- If we get here, we are refining a state that is not defined in
24020 -- the package declaration.
24022 Error_Msg_Name_1
:= Chars
(Spec_Id
);
24024 ("cannot refine state, & is not defined in package %",
24026 end Check_Matching_State
;
24028 --------------------------------
24029 -- Report_Unused_Constituents --
24030 --------------------------------
24032 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
24033 Constit_Elmt
: Elmt_Id
;
24034 Constit_Id
: Entity_Id
;
24035 Posted
: Boolean := False;
24038 if Present
(Constits
) then
24039 Constit_Elmt
:= First_Elmt
(Constits
);
24040 while Present
(Constit_Elmt
) loop
24041 Constit_Id
:= Node
(Constit_Elmt
);
24043 -- Generate an error message of the form:
24045 -- state ... has unused Part_Of constituents
24046 -- abstract state ... defined at ...
24047 -- variable ... defined at ...
24052 ("state & has unused Part_Of constituents",
24056 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
24058 if Ekind
(Constit_Id
) = E_Abstract_State
then
24060 ("\abstract state & defined #", State
, Constit_Id
);
24063 ("\variable & defined #", State
, Constit_Id
);
24066 Next_Elmt
(Constit_Elmt
);
24069 end Report_Unused_Constituents
;
24071 -- Local declarations
24073 Body_Ref
: Node_Id
;
24074 Body_Ref_Elmt
: Elmt_Id
;
24076 Extra_State
: Node_Id
;
24078 -- Start of processing for Analyze_Refinement_Clause
24081 -- A refinement clause appears as a component association where the
24082 -- sole choice is the state and the expressions are the constituents.
24083 -- This is a syntax error, always report.
24085 if Nkind
(Clause
) /= N_Component_Association
then
24086 Error_Msg_N
("malformed state refinement clause", Clause
);
24090 -- Analyze the state name of a refinement clause
24092 State
:= First
(Choices
(Clause
));
24095 Resolve_State
(State
);
24097 -- Ensure that the state name denotes a valid abstract state that is
24098 -- defined in the spec of the related package.
24100 if Is_Entity_Name
(State
) then
24101 State_Id
:= Entity_Of
(State
);
24103 -- Catch any attempts to re-refine a state or refine a state that
24104 -- is not defined in the package declaration.
24106 if Ekind
(State_Id
) = E_Abstract_State
then
24107 Check_Matching_State
;
24110 ("& must denote an abstract state", State
, State_Id
);
24114 -- References to a state with visible refinement are illegal.
24115 -- When nested packages are involved, detecting such references is
24116 -- tricky because pragma Refined_State is analyzed later than the
24117 -- offending pragma Depends or Global. References that occur in
24118 -- such nested context are stored in a list. Emit errors for all
24119 -- references found in Body_References (SPARK RM 6.1.4(8)).
24121 if Present
(Body_References
(State_Id
)) then
24122 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
24123 while Present
(Body_Ref_Elmt
) loop
24124 Body_Ref
:= Node
(Body_Ref_Elmt
);
24126 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
24127 Error_Msg_Sloc
:= Sloc
(State
);
24128 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
24130 Next_Elmt
(Body_Ref_Elmt
);
24134 -- The state name is illegal. This is a syntax error, always report.
24137 Error_Msg_N
("malformed state name in refinement clause", State
);
24141 -- A refinement clause may only refine one state at a time
24143 Extra_State
:= Next
(State
);
24145 if Present
(Extra_State
) then
24147 ("refinement clause cannot cover multiple states", Extra_State
);
24150 -- Replicate the Part_Of constituents of the refined state because
24151 -- the algorithm will consume items.
24153 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
24155 -- Analyze all constituents of the refinement. Multiple constituents
24156 -- appear as an aggregate.
24158 Constit
:= Expression
(Clause
);
24160 if Nkind
(Constit
) = N_Aggregate
then
24161 if Present
(Component_Associations
(Constit
)) then
24163 ("constituents of refinement clause must appear in "
24164 & "positional form", Constit
);
24166 else pragma Assert
(Present
(Expressions
(Constit
)));
24167 Constit
:= First
(Expressions
(Constit
));
24168 while Present
(Constit
) loop
24169 Analyze_Constituent
(Constit
);
24175 -- Various forms of a single constituent. Note that these may include
24176 -- malformed constituents.
24179 Analyze_Constituent
(Constit
);
24182 -- A refined external state is subject to special rules with respect
24183 -- to its properties and constituents.
24185 if Is_External_State
(State_Id
) then
24187 -- The set of properties that all external constituents yield must
24188 -- match that of the refined state. There are two cases to detect:
24189 -- the refined state lacks a property or has an extra property.
24191 if External_Constit_Seen
then
24192 Check_External_Property
24193 (Prop_Nam
=> Name_Async_Readers
,
24194 Enabled
=> Async_Readers_Enabled
(State_Id
),
24195 Constit
=> AR_Constit
);
24197 Check_External_Property
24198 (Prop_Nam
=> Name_Async_Writers
,
24199 Enabled
=> Async_Writers_Enabled
(State_Id
),
24200 Constit
=> AW_Constit
);
24202 Check_External_Property
24203 (Prop_Nam
=> Name_Effective_Reads
,
24204 Enabled
=> Effective_Reads_Enabled
(State_Id
),
24205 Constit
=> ER_Constit
);
24207 Check_External_Property
24208 (Prop_Nam
=> Name_Effective_Writes
,
24209 Enabled
=> Effective_Writes_Enabled
(State_Id
),
24210 Constit
=> EW_Constit
);
24212 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24214 elsif Null_Seen
then
24217 -- The external state has constituents, but none of them are
24218 -- external (SPARK RM 7.2.8(2)).
24222 ("external state & requires at least one external "
24223 & "constituent or null refinement", State
, State_Id
);
24226 -- When a refined state is not external, it should not have external
24227 -- constituents (SPARK RM 7.2.8(1)).
24229 elsif External_Constit_Seen
then
24231 ("non-external state & cannot contain external constituents in "
24232 & "refinement", State
, State_Id
);
24235 -- Ensure that all Part_Of candidate constituents have been mentioned
24236 -- in the refinement clause.
24238 Report_Unused_Constituents
(Part_Of_Constits
);
24239 end Analyze_Refinement_Clause
;
24241 -------------------------
24242 -- Collect_Body_States --
24243 -------------------------
24245 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24246 Result
: Elist_Id
:= No_Elist
;
24247 -- A list containing all body states of Pack_Id
24249 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24250 -- Gather the entities of all abstract states and variables declared
24251 -- in the visible state space of package Pack_Id.
24253 ----------------------------
24254 -- Collect_Visible_States --
24255 ----------------------------
24257 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24258 Item_Id
: Entity_Id
;
24261 -- Traverse the entity chain of the package and inspect all
24264 Item_Id
:= First_Entity
(Pack_Id
);
24265 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24267 -- Do not consider internally generated items as those cannot
24268 -- be named and participate in refinement.
24270 if not Comes_From_Source
(Item_Id
) then
24273 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24274 Add_Item
(Item_Id
, Result
);
24276 -- Recursively gather the visible states of a nested package
24278 elsif Ekind
(Item_Id
) = E_Package
then
24279 Collect_Visible_States
(Item_Id
);
24282 Next_Entity
(Item_Id
);
24284 end Collect_Visible_States
;
24288 Pack_Body
: constant Node_Id
:=
24289 Declaration_Node
(Body_Entity
(Pack_Id
));
24291 Item_Id
: Entity_Id
;
24293 -- Start of processing for Collect_Body_States
24296 -- Inspect the declarations of the body looking for source variables,
24297 -- packages and package instantiations.
24299 Decl
:= First
(Declarations
(Pack_Body
));
24300 while Present
(Decl
) loop
24301 if Nkind
(Decl
) = N_Object_Declaration
then
24302 Item_Id
:= Defining_Entity
(Decl
);
24304 -- Capture source variables only as internally generated
24305 -- temporaries cannot be named and participate in refinement.
24307 if Ekind
(Item_Id
) = E_Variable
24308 and then Comes_From_Source
(Item_Id
)
24310 Add_Item
(Item_Id
, Result
);
24313 elsif Nkind
(Decl
) = N_Package_Declaration
then
24314 Item_Id
:= Defining_Entity
(Decl
);
24316 -- Capture the visible abstract states and variables of a
24317 -- source package [instantiation].
24319 if Comes_From_Source
(Item_Id
) then
24320 Collect_Visible_States
(Item_Id
);
24328 end Collect_Body_States
;
24330 -----------------------------
24331 -- Report_Unrefined_States --
24332 -----------------------------
24334 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24335 State_Elmt
: Elmt_Id
;
24338 if Present
(States
) then
24339 State_Elmt
:= First_Elmt
(States
);
24340 while Present
(State_Elmt
) loop
24342 ("abstract state & must be refined", Node
(State_Elmt
));
24344 Next_Elmt
(State_Elmt
);
24347 end Report_Unrefined_States
;
24349 --------------------------
24350 -- Report_Unused_States --
24351 --------------------------
24353 procedure Report_Unused_States
(States
: Elist_Id
) is
24354 Posted
: Boolean := False;
24355 State_Elmt
: Elmt_Id
;
24356 State_Id
: Entity_Id
;
24359 if Present
(States
) then
24360 State_Elmt
:= First_Elmt
(States
);
24361 while Present
(State_Elmt
) loop
24362 State_Id
:= Node
(State_Elmt
);
24364 -- Generate an error message of the form:
24366 -- body of package ... has unused hidden states
24367 -- abstract state ... defined at ...
24368 -- variable ... defined at ...
24373 ("body of package & has unused hidden states", Body_Id
);
24376 Error_Msg_Sloc
:= Sloc
(State_Id
);
24378 if Ekind
(State_Id
) = E_Abstract_State
then
24380 ("\abstract state & defined #", Body_Id
, State_Id
);
24383 ("\variable & defined #", Body_Id
, State_Id
);
24386 Next_Elmt
(State_Elmt
);
24389 end Report_Unused_States
;
24391 -- Local declarations
24393 Body_Decl
: constant Node_Id
:= Parent
(N
);
24394 Clauses
: constant Node_Id
:=
24395 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
24398 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24403 Body_Id
:= Defining_Entity
(Body_Decl
);
24404 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
24406 -- Replicate the abstract states declared by the package because the
24407 -- matching algorithm will consume states.
24409 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24411 -- Gather all abstract states and variables declared in the visible
24412 -- state space of the package body. These items must be utilized as
24413 -- constituents in a state refinement.
24415 Body_States
:= Collect_Body_States
(Spec_Id
);
24417 -- Multiple non-null state refinements appear as an aggregate
24419 if Nkind
(Clauses
) = N_Aggregate
then
24420 if Present
(Expressions
(Clauses
)) then
24422 ("state refinements must appear as component associations",
24425 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24426 Clause
:= First
(Component_Associations
(Clauses
));
24427 while Present
(Clause
) loop
24428 Analyze_Refinement_Clause
(Clause
);
24434 -- Various forms of a single state refinement. Note that these may
24435 -- include malformed refinements.
24438 Analyze_Refinement_Clause
(Clauses
);
24441 -- List all abstract states that were left unrefined
24443 Report_Unrefined_States
(Available_States
);
24445 -- Ensure that all abstract states and variables declared in the body
24446 -- state space of the related package are utilized as constituents.
24448 Report_Unused_States
(Body_States
);
24449 end Analyze_Refined_State_In_Decl_Part
;
24451 ------------------------------------
24452 -- Analyze_Test_Case_In_Decl_Part --
24453 ------------------------------------
24455 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
24457 -- Install formals and push subprogram spec onto scope stack so that we
24458 -- can see the formals from the pragma.
24461 Install_Formals
(S
);
24463 -- Preanalyze the boolean expressions, we treat these as spec
24464 -- expressions (i.e. similar to a default expression).
24466 if Pragma_Name
(N
) = Name_Test_Case
then
24467 Preanalyze_CTC_Args
24469 Get_Requires_From_CTC_Pragma
(N
),
24470 Get_Ensures_From_CTC_Pragma
(N
));
24473 -- Remove the subprogram from the scope stack now that the pre-analysis
24474 -- of the expressions in the contract case or test case is done.
24477 end Analyze_Test_Case_In_Decl_Part
;
24483 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24488 if Present
(List
) then
24489 Elmt
:= First_Elmt
(List
);
24490 while Present
(Elmt
) loop
24491 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24494 Id
:= Entity_Of
(Node
(Elmt
));
24497 if Id
= Item_Id
then
24508 -----------------------------
24509 -- Check_Applicable_Policy --
24510 -----------------------------
24512 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24516 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
24519 -- No effect if not valid assertion kind name
24521 if not Is_Valid_Assertion_Kind
(Ename
) then
24525 -- Loop through entries in check policy list
24527 PP
:= Opt
.Check_Policy_List
;
24528 while Present
(PP
) loop
24530 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24531 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24535 or else Pnm
= Name_Assertion
24536 or else (Pnm
= Name_Statement_Assertions
24537 and then Nam_In
(Ename
, Name_Assert
,
24538 Name_Assert_And_Cut
,
24540 Name_Loop_Invariant
,
24541 Name_Loop_Variant
))
24543 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24546 when Name_Off | Name_Ignore
=>
24547 Set_Is_Ignored
(N
, True);
24548 Set_Is_Checked
(N
, False);
24550 when Name_On | Name_Check
=>
24551 Set_Is_Checked
(N
, True);
24552 Set_Is_Ignored
(N
, False);
24554 when Name_Disable
=>
24555 Set_Is_Ignored
(N
, True);
24556 Set_Is_Checked
(N
, False);
24557 Set_Is_Disabled
(N
, True);
24559 -- That should be exhaustive, the null here is a defence
24560 -- against a malformed tree from previous errors.
24569 PP
:= Next_Pragma
(PP
);
24573 -- If there are no specific entries that matched, then we let the
24574 -- setting of assertions govern. Note that this provides the needed
24575 -- compatibility with the RM for the cases of assertion, invariant,
24576 -- precondition, predicate, and postcondition.
24578 if Assertions_Enabled
then
24579 Set_Is_Checked
(N
, True);
24580 Set_Is_Ignored
(N
, False);
24582 Set_Is_Checked
(N
, False);
24583 Set_Is_Ignored
(N
, True);
24585 end Check_Applicable_Policy
;
24587 -------------------------------
24588 -- Check_External_Properties --
24589 -------------------------------
24591 procedure Check_External_Properties
24599 -- All properties enabled
24601 if AR
and AW
and ER
and EW
then
24604 -- Async_Readers + Effective_Writes
24605 -- Async_Readers + Async_Writers + Effective_Writes
24607 elsif AR
and EW
and not ER
then
24610 -- Async_Writers + Effective_Reads
24611 -- Async_Readers + Async_Writers + Effective_Reads
24613 elsif AW
and ER
and not EW
then
24616 -- Async_Readers + Async_Writers
24618 elsif AR
and AW
and not ER
and not EW
then
24623 elsif AR
and not AW
and not ER
and not EW
then
24628 elsif AW
and not AR
and not ER
and not EW
then
24633 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24636 end Check_External_Properties
;
24642 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24646 -- Loop through entries in check policy list
24648 PP
:= Opt
.Check_Policy_List
;
24649 while Present
(PP
) loop
24651 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24652 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24656 or else (Pnm
= Name_Assertion
24657 and then Is_Valid_Assertion_Kind
(Nam
))
24658 or else (Pnm
= Name_Statement_Assertions
24659 and then Nam_In
(Nam
, Name_Assert
,
24660 Name_Assert_And_Cut
,
24662 Name_Loop_Invariant
,
24663 Name_Loop_Variant
))
24665 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24666 when Name_On | Name_Check
=>
24668 when Name_Off | Name_Ignore
=>
24669 return Name_Ignore
;
24670 when Name_Disable
=>
24671 return Name_Disable
;
24673 raise Program_Error
;
24677 PP
:= Next_Pragma
(PP
);
24682 -- If there are no specific entries that matched, then we let the
24683 -- setting of assertions govern. Note that this provides the needed
24684 -- compatibility with the RM for the cases of assertion, invariant,
24685 -- precondition, predicate, and postcondition.
24687 if Assertions_Enabled
then
24690 return Name_Ignore
;
24694 ---------------------------
24695 -- Check_Missing_Part_Of --
24696 ---------------------------
24698 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24699 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24700 -- Determine whether a package denoted by Pack_Id declares at least one
24703 -----------------------
24704 -- Has_Visible_State --
24705 -----------------------
24707 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24708 Item_Id
: Entity_Id
;
24711 -- Traverse the entity chain of the package trying to find at least
24712 -- one visible abstract state, variable or a package [instantiation]
24713 -- that declares a visible state.
24715 Item_Id
:= First_Entity
(Pack_Id
);
24716 while Present
(Item_Id
)
24717 and then not In_Private_Part
(Item_Id
)
24719 -- Do not consider internally generated items
24721 if not Comes_From_Source
(Item_Id
) then
24724 -- A visible state has been found
24726 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24729 -- Recursively peek into nested packages and instantiations
24731 elsif Ekind
(Item_Id
) = E_Package
24732 and then Has_Visible_State
(Item_Id
)
24737 Next_Entity
(Item_Id
);
24741 end Has_Visible_State
;
24745 Pack_Id
: Entity_Id
;
24746 Placement
: State_Space_Kind
;
24748 -- Start of processing for Check_Missing_Part_Of
24751 -- Do not consider abstract states, variables or package instantiations
24752 -- coming from an instance as those always inherit the Part_Of indicator
24753 -- of the instance itself.
24755 if In_Instance
then
24758 -- Do not consider internally generated entities as these can never
24759 -- have a Part_Of indicator.
24761 elsif not Comes_From_Source
(Item_Id
) then
24764 -- Perform these checks only when SPARK_Mode is enabled as they will
24765 -- interfere with standard Ada rules and produce false positives.
24767 elsif SPARK_Mode
/= On
then
24771 -- Find where the abstract state, variable or package instantiation
24772 -- lives with respect to the state space.
24774 Find_Placement_In_State_Space
24775 (Item_Id
=> Item_Id
,
24776 Placement
=> Placement
,
24777 Pack_Id
=> Pack_Id
);
24779 -- Items that appear in a non-package construct (subprogram, block, etc)
24780 -- do not require a Part_Of indicator because they can never act as a
24783 if Placement
= Not_In_Package
then
24786 -- An item declared in the body state space of a package always act as a
24787 -- constituent and does not need explicit Part_Of indicator.
24789 elsif Placement
= Body_State_Space
then
24792 -- In general an item declared in the visible state space of a package
24793 -- does not require a Part_Of indicator. The only exception is when the
24794 -- related package is a private child unit in which case Part_Of must
24795 -- denote a state in the parent unit or in one of its descendants.
24797 elsif Placement
= Visible_State_Space
then
24798 if Is_Child_Unit
(Pack_Id
)
24799 and then Is_Private_Descendant
(Pack_Id
)
24801 -- A package instantiation does not need a Part_Of indicator when
24802 -- the related generic template has no visible state.
24804 if Ekind
(Item_Id
) = E_Package
24805 and then Is_Generic_Instance
(Item_Id
)
24806 and then not Has_Visible_State
(Item_Id
)
24810 -- All other cases require Part_Of
24814 ("indicator Part_Of is required in this context "
24815 & "(SPARK RM 7.2.6(3))", Item_Id
);
24816 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24818 ("\& is declared in the visible part of private child "
24819 & "unit %", Item_Id
);
24823 -- When the item appears in the private state space of a packge, it must
24824 -- be a part of some state declared by the said package.
24826 else pragma Assert
(Placement
= Private_State_Space
);
24828 -- The related package does not declare a state, the item cannot act
24829 -- as a Part_Of constituent.
24831 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24834 -- A package instantiation does not need a Part_Of indicator when the
24835 -- related generic template has no visible state.
24837 elsif Ekind
(Pack_Id
) = E_Package
24838 and then Is_Generic_Instance
(Pack_Id
)
24839 and then not Has_Visible_State
(Pack_Id
)
24843 -- All other cases require Part_Of
24847 ("indicator Part_Of is required in this context "
24848 & "(SPARK RM 7.2.6(2))", Item_Id
);
24849 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24851 ("\& is declared in the private part of package %", Item_Id
);
24854 end Check_Missing_Part_Of
;
24856 ---------------------------------
24857 -- Check_SPARK_Aspect_For_ASIS --
24858 ---------------------------------
24860 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
24864 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
24865 Expr
:= Expression
(Corresponding_Aspect
(N
));
24866 if Nkind
(Expr
) /= N_Aggregate
then
24867 Preanalyze_And_Resolve
(Expr
);
24871 Comps
: constant List_Id
:= Component_Associations
(Expr
);
24872 Exprs
: constant List_Id
:= Expressions
(Expr
);
24877 E
:= First
(Exprs
);
24878 while Present
(E
) loop
24883 C
:= First
(Comps
);
24884 while Present
(C
) loop
24885 Analyze
(Expression
(C
));
24891 end Check_SPARK_Aspect_For_ASIS
;
24893 -------------------------------------
24894 -- Check_State_And_Constituent_Use --
24895 -------------------------------------
24897 procedure Check_State_And_Constituent_Use
24898 (States
: Elist_Id
;
24899 Constits
: Elist_Id
;
24902 function Find_Encapsulating_State
24903 (Constit_Id
: Entity_Id
) return Entity_Id
;
24904 -- Given the entity of a constituent, try to find a corresponding
24905 -- encapsulating state that appears in the same context. The routine
24906 -- returns Empty is no such state is found.
24908 ------------------------------
24909 -- Find_Encapsulating_State --
24910 ------------------------------
24912 function Find_Encapsulating_State
24913 (Constit_Id
: Entity_Id
) return Entity_Id
24915 State_Id
: Entity_Id
;
24918 -- Since a constituent may be part of a larger constituent set, climb
24919 -- the encapsulated state chain looking for a state that appears in
24920 -- the same context.
24922 State_Id
:= Encapsulating_State
(Constit_Id
);
24923 while Present
(State_Id
) loop
24924 if Contains
(States
, State_Id
) then
24928 State_Id
:= Encapsulating_State
(State_Id
);
24932 end Find_Encapsulating_State
;
24936 Constit_Elmt
: Elmt_Id
;
24937 Constit_Id
: Entity_Id
;
24938 State_Id
: Entity_Id
;
24940 -- Start of processing for Check_State_And_Constituent_Use
24943 -- Nothing to do if there are no states or constituents
24945 if No
(States
) or else No
(Constits
) then
24949 -- Inspect the list of constituents and try to determine whether its
24950 -- encapsulating state is in list States.
24952 Constit_Elmt
:= First_Elmt
(Constits
);
24953 while Present
(Constit_Elmt
) loop
24954 Constit_Id
:= Node
(Constit_Elmt
);
24956 -- Determine whether the constituent is part of an encapsulating
24957 -- state that appears in the same context and if this is the case,
24958 -- emit an error (SPARK RM 7.2.6(7)).
24960 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
24962 if Present
(State_Id
) then
24963 Error_Msg_Name_1
:= Chars
(Constit_Id
);
24965 ("cannot mention state & and its constituent % in the same "
24966 & "context", Context
, State_Id
);
24970 Next_Elmt
(Constit_Elmt
);
24972 end Check_State_And_Constituent_Use
;
24974 ---------------------------------------
24975 -- Collect_Subprogram_Inputs_Outputs --
24976 ---------------------------------------
24978 procedure Collect_Subprogram_Inputs_Outputs
24979 (Subp_Id
: Entity_Id
;
24980 Synthesize
: Boolean := False;
24981 Subp_Inputs
: in out Elist_Id
;
24982 Subp_Outputs
: in out Elist_Id
;
24983 Global_Seen
: out Boolean)
24985 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
24986 -- Collect all relevant items from a dependency clause
24988 procedure Collect_Global_List
24990 Mode
: Name_Id
:= Name_Input
);
24991 -- Collect all relevant items from a global list
24993 -------------------------------
24994 -- Collect_Dependency_Clause --
24995 -------------------------------
24997 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
24998 procedure Collect_Dependency_Item
25000 Is_Input
: Boolean);
25001 -- Add an item to the proper subprogram input or output collection
25003 -----------------------------
25004 -- Collect_Dependency_Item --
25005 -----------------------------
25007 procedure Collect_Dependency_Item
25009 Is_Input
: Boolean)
25014 -- Nothing to collect when the item is null
25016 if Nkind
(Item
) = N_Null
then
25019 -- Ditto for attribute 'Result
25021 elsif Is_Attribute_Result
(Item
) then
25024 -- Multiple items appear as an aggregate
25026 elsif Nkind
(Item
) = N_Aggregate
then
25027 Extra
:= First
(Expressions
(Item
));
25028 while Present
(Extra
) loop
25029 Collect_Dependency_Item
(Extra
, Is_Input
);
25033 -- Otherwise this is a solitary item
25037 Add_Item
(Item
, Subp_Inputs
);
25039 Add_Item
(Item
, Subp_Outputs
);
25042 end Collect_Dependency_Item
;
25044 -- Start of processing for Collect_Dependency_Clause
25047 if Nkind
(Clause
) = N_Null
then
25050 -- A dependency cause appears as component association
25052 elsif Nkind
(Clause
) = N_Component_Association
then
25053 Collect_Dependency_Item
25054 (Expression
(Clause
), Is_Input
=> True);
25055 Collect_Dependency_Item
25056 (First
(Choices
(Clause
)), Is_Input
=> False);
25058 -- To accomodate partial decoration of disabled SPARK features, this
25059 -- routine may be called with illegal input. If this is the case, do
25060 -- not raise Program_Error.
25065 end Collect_Dependency_Clause
;
25067 -------------------------
25068 -- Collect_Global_List --
25069 -------------------------
25071 procedure Collect_Global_List
25073 Mode
: Name_Id
:= Name_Input
)
25075 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25076 -- Add an item to the proper subprogram input or output collection
25078 -------------------------
25079 -- Collect_Global_Item --
25080 -------------------------
25082 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25084 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
25085 Add_Item
(Item
, Subp_Inputs
);
25088 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
25089 Add_Item
(Item
, Subp_Outputs
);
25091 end Collect_Global_Item
;
25098 -- Start of processing for Collect_Global_List
25101 if Nkind
(List
) = N_Null
then
25104 -- Single global item declaration
25106 elsif Nkind_In
(List
, N_Expanded_Name
,
25108 N_Selected_Component
)
25110 Collect_Global_Item
(List
, Mode
);
25112 -- Simple global list or moded global list declaration
25114 elsif Nkind
(List
) = N_Aggregate
then
25115 if Present
(Expressions
(List
)) then
25116 Item
:= First
(Expressions
(List
));
25117 while Present
(Item
) loop
25118 Collect_Global_Item
(Item
, Mode
);
25123 Assoc
:= First
(Component_Associations
(List
));
25124 while Present
(Assoc
) loop
25125 Collect_Global_List
25126 (List
=> Expression
(Assoc
),
25127 Mode
=> Chars
(First
(Choices
(Assoc
))));
25132 -- To accomodate partial decoration of disabled SPARK features, this
25133 -- routine may be called with illegal input. If this is the case, do
25134 -- not raise Program_Error.
25139 end Collect_Global_List
;
25143 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
25147 Formal
: Entity_Id
;
25150 Spec_Id
: Entity_Id
;
25152 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25155 Global_Seen
:= False;
25157 -- Find the entity of the corresponding spec when processing a body
25159 if Nkind
(Subp_Decl
) = N_Subprogram_Body
25160 and then Present
(Corresponding_Spec
(Subp_Decl
))
25162 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
25164 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25165 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25167 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
25170 Spec_Id
:= Subp_Id
;
25173 -- Process all formal parameters
25175 Formal
:= First_Formal
(Spec_Id
);
25176 while Present
(Formal
) loop
25177 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
25178 Add_Item
(Formal
, Subp_Inputs
);
25181 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
25182 Add_Item
(Formal
, Subp_Outputs
);
25184 -- Out parameters can act as inputs when the related type is
25185 -- tagged, unconstrained array, unconstrained record or record
25186 -- with unconstrained components.
25188 if Ekind
(Formal
) = E_Out_Parameter
25189 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25191 Add_Item
(Formal
, Subp_Inputs
);
25195 Next_Formal
(Formal
);
25198 -- When processing a subprogram body, look for pragmas Refined_Depends
25199 -- and Refined_Global as they specify the inputs and outputs.
25201 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25202 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
25203 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25205 -- Subprogram declaration case, look for pragmas Depends and Global
25208 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25209 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25212 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
25213 -- because it provides finer granularity of inputs and outputs.
25215 if Present
(Global
) then
25216 Global_Seen
:= True;
25217 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
25219 -- The pragma may not have been analyzed because of the arbitrary
25220 -- declaration order of aspects. Make sure that it is analyzed for
25221 -- the purposes of item extraction.
25223 if not Analyzed
(List
) then
25224 if Pragma_Name
(Global
) = Name_Refined_Global
then
25225 Analyze_Refined_Global_In_Decl_Part
(Global
);
25227 Analyze_Global_In_Decl_Part
(Global
);
25231 Collect_Global_List
(List
);
25233 -- When the related subprogram lacks pragma [Refined_]Global, fall back
25234 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
25235 -- the inputs and outputs from [Refined_]Depends.
25237 elsif Synthesize
and then Present
(Depends
) then
25239 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
25241 -- Multiple dependency clauses appear as an aggregate
25243 if Nkind
(Clauses
) = N_Aggregate
then
25244 Clause
:= First
(Component_Associations
(Clauses
));
25245 while Present
(Clause
) loop
25246 Collect_Dependency_Clause
(Clause
);
25250 -- Otherwise this is a single dependency clause
25253 Collect_Dependency_Clause
(Clauses
);
25256 end Collect_Subprogram_Inputs_Outputs
;
25258 ---------------------------------
25259 -- Delay_Config_Pragma_Analyze --
25260 ---------------------------------
25262 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25264 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25265 Name_Priority_Specific_Dispatching
);
25266 end Delay_Config_Pragma_Analyze
;
25268 -------------------------------------
25269 -- Find_Related_Subprogram_Or_Body --
25270 -------------------------------------
25272 function Find_Related_Subprogram_Or_Body
25274 Do_Checks
: Boolean := False) return Node_Id
25276 Context
: constant Node_Id
:= Parent
(Prag
);
25277 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25280 Look_For_Body
: constant Boolean :=
25281 Nam_In
(Nam
, Name_Refined_Depends
,
25282 Name_Refined_Global
,
25283 Name_Refined_Post
);
25284 -- Refinement pragmas must be associated with a subprogram body [stub]
25287 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
25289 -- If the pragma is a byproduct of aspect expansion, return the related
25290 -- context of the original aspect.
25292 if Present
(Corresponding_Aspect
(Prag
)) then
25293 return Parent
(Corresponding_Aspect
(Prag
));
25296 -- Otherwise the pragma is a source construct, most likely part of a
25297 -- declarative list. Skip preceding declarations while looking for a
25298 -- proper subprogram declaration.
25300 pragma Assert
(Is_List_Member
(Prag
));
25302 Stmt
:= Prev
(Prag
);
25303 while Present
(Stmt
) loop
25305 -- Skip prior pragmas, but check for duplicates
25307 if Nkind
(Stmt
) = N_Pragma
then
25308 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
25309 Error_Msg_Name_1
:= Nam
;
25310 Error_Msg_Sloc
:= Sloc
(Stmt
);
25311 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25314 -- Emit an error when a refinement pragma appears on an expression
25315 -- function without a completion.
25318 and then Look_For_Body
25319 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25320 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25321 and then not Has_Completion
(Defining_Entity
(Stmt
))
25323 Error_Msg_Name_1
:= Nam
;
25325 ("pragma % cannot apply to a stand alone expression function",
25330 -- The refinement pragma applies to a subprogram body stub
25332 elsif Look_For_Body
25333 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25337 -- Skip internally generated code
25339 elsif not Comes_From_Source
(Stmt
) then
25342 -- Return the current construct which is either a subprogram body,
25343 -- a subprogram declaration or is illegal.
25352 -- If we fall through, then the pragma was either the first declaration
25353 -- or it was preceded by other pragmas and no source constructs.
25355 -- The pragma is associated with a library-level subprogram
25357 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25358 return Unit
(Parent
(Context
));
25360 -- The pragma appears inside the declarative part of a subprogram body
25362 elsif Nkind
(Context
) = N_Subprogram_Body
then
25365 -- No candidate subprogram [body] found
25370 end Find_Related_Subprogram_Or_Body
;
25372 -------------------------
25373 -- Get_Base_Subprogram --
25374 -------------------------
25376 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25377 Result
: Entity_Id
;
25380 -- Follow subprogram renaming chain
25384 if Is_Subprogram
(Result
)
25386 Nkind
(Parent
(Declaration_Node
(Result
))) =
25387 N_Subprogram_Renaming_Declaration
25388 and then Present
(Alias
(Result
))
25390 Result
:= Alias
(Result
);
25394 end Get_Base_Subprogram
;
25396 -----------------------
25397 -- Get_SPARK_Mode_Type --
25398 -----------------------
25400 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25402 if N
= Name_On
then
25404 elsif N
= Name_Off
then
25407 -- Any other argument is illegal
25410 raise Program_Error
;
25412 end Get_SPARK_Mode_Type
;
25414 --------------------------------
25415 -- Get_SPARK_Mode_From_Pragma --
25416 --------------------------------
25418 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25423 pragma Assert
(Nkind
(N
) = N_Pragma
);
25424 Args
:= Pragma_Argument_Associations
(N
);
25426 -- Extract the mode from the argument list
25428 if Present
(Args
) then
25429 Mode
:= First
(Pragma_Argument_Associations
(N
));
25430 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25432 -- If SPARK_Mode pragma has no argument, default is ON
25437 end Get_SPARK_Mode_From_Pragma
;
25439 ---------------------------
25440 -- Has_Extra_Parentheses --
25441 ---------------------------
25443 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25447 -- The aggregate should not have an expression list because a clause
25448 -- is always interpreted as a component association. The only way an
25449 -- expression list can sneak in is by adding extra parentheses around
25450 -- the individual clauses:
25452 -- Depends (Output => Input) -- proper form
25453 -- Depends ((Output => Input)) -- extra parentheses
25455 -- Since the extra parentheses are not allowed by the syntax of the
25456 -- pragma, flag them now to avoid emitting misleading errors down the
25459 if Nkind
(Clause
) = N_Aggregate
25460 and then Present
(Expressions
(Clause
))
25462 Expr
:= First
(Expressions
(Clause
));
25463 while Present
(Expr
) loop
25465 -- A dependency clause surrounded by extra parentheses appears
25466 -- as an aggregate of component associations with an optional
25467 -- Paren_Count set.
25469 if Nkind
(Expr
) = N_Aggregate
25470 and then Present
(Component_Associations
(Expr
))
25473 ("dependency clause contains extra parentheses", Expr
);
25475 -- Otherwise the expression is a malformed construct
25478 SPARK_Msg_N
("malformed dependency clause", Expr
);
25488 end Has_Extra_Parentheses
;
25494 procedure Initialize
is
25505 Dummy
:= Dummy
+ 1;
25508 -----------------------------
25509 -- Is_Config_Static_String --
25510 -----------------------------
25512 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25514 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25515 -- This is an internal recursive function that is just like the outer
25516 -- function except that it adds the string to the name buffer rather
25517 -- than placing the string in the name buffer.
25519 ------------------------------
25520 -- Add_Config_Static_String --
25521 ------------------------------
25523 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25530 if Nkind
(N
) = N_Op_Concat
then
25531 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25532 N
:= Right_Opnd
(N
);
25538 if Nkind
(N
) /= N_String_Literal
then
25539 Error_Msg_N
("string literal expected for pragma argument", N
);
25543 for J
in 1 .. String_Length
(Strval
(N
)) loop
25544 C
:= Get_String_Char
(Strval
(N
), J
);
25546 if not In_Character_Range
(C
) then
25548 ("string literal contains invalid wide character",
25549 Sloc
(N
) + 1 + Source_Ptr
(J
));
25553 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25558 end Add_Config_Static_String
;
25560 -- Start of processing for Is_Config_Static_String
25565 return Add_Config_Static_String
(Arg
);
25566 end Is_Config_Static_String
;
25568 -------------------------------
25569 -- Is_Elaboration_SPARK_Mode --
25570 -------------------------------
25572 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
25575 (Nkind
(N
) = N_Pragma
25576 and then Pragma_Name
(N
) = Name_SPARK_Mode
25577 and then Is_List_Member
(N
));
25579 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25580 -- appears in the statement part of the body.
25583 Present
(Parent
(N
))
25584 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
25585 and then List_Containing
(N
) = Statements
(Parent
(N
))
25586 and then Present
(Parent
(Parent
(N
)))
25587 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
25588 end Is_Elaboration_SPARK_Mode
;
25590 -----------------------------------------
25591 -- Is_Non_Significant_Pragma_Reference --
25592 -----------------------------------------
25594 -- This function makes use of the following static table which indicates
25595 -- whether appearance of some name in a given pragma is to be considered
25596 -- as a reference for the purposes of warnings about unreferenced objects.
25598 -- -1 indicates that appearence in any argument is significant
25599 -- 0 indicates that appearance in any argument is not significant
25600 -- +n indicates that appearance as argument n is significant, but all
25601 -- other arguments are not significant
25602 -- 9n arguments from n on are significant, before n inisignificant
25604 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
25605 (Pragma_Abort_Defer
=> -1,
25606 Pragma_Abstract_State
=> -1,
25607 Pragma_Ada_83
=> -1,
25608 Pragma_Ada_95
=> -1,
25609 Pragma_Ada_05
=> -1,
25610 Pragma_Ada_2005
=> -1,
25611 Pragma_Ada_12
=> -1,
25612 Pragma_Ada_2012
=> -1,
25613 Pragma_All_Calls_Remote
=> -1,
25614 Pragma_Allow_Integer_Address
=> -1,
25615 Pragma_Annotate
=> 93,
25616 Pragma_Assert
=> -1,
25617 Pragma_Assert_And_Cut
=> -1,
25618 Pragma_Assertion_Policy
=> 0,
25619 Pragma_Assume
=> -1,
25620 Pragma_Assume_No_Invalid_Values
=> 0,
25621 Pragma_Async_Readers
=> 0,
25622 Pragma_Async_Writers
=> 0,
25623 Pragma_Asynchronous
=> 0,
25624 Pragma_Atomic
=> 0,
25625 Pragma_Atomic_Components
=> 0,
25626 Pragma_Attach_Handler
=> -1,
25627 Pragma_Attribute_Definition
=> 92,
25628 Pragma_Check
=> -1,
25629 Pragma_Check_Float_Overflow
=> 0,
25630 Pragma_Check_Name
=> 0,
25631 Pragma_Check_Policy
=> 0,
25632 Pragma_CIL_Constructor
=> 0,
25633 Pragma_CPP_Class
=> 0,
25634 Pragma_CPP_Constructor
=> 0,
25635 Pragma_CPP_Virtual
=> 0,
25636 Pragma_CPP_Vtable
=> 0,
25638 Pragma_C_Pass_By_Copy
=> 0,
25639 Pragma_Comment
=> -1,
25640 Pragma_Common_Object
=> 0,
25641 Pragma_Compile_Time_Error
=> -1,
25642 Pragma_Compile_Time_Warning
=> -1,
25643 Pragma_Compiler_Unit
=> -1,
25644 Pragma_Compiler_Unit_Warning
=> -1,
25645 Pragma_Complete_Representation
=> 0,
25646 Pragma_Complex_Representation
=> 0,
25647 Pragma_Component_Alignment
=> 0,
25648 Pragma_Contract_Cases
=> -1,
25649 Pragma_Controlled
=> 0,
25650 Pragma_Convention
=> 0,
25651 Pragma_Convention_Identifier
=> 0,
25652 Pragma_Debug
=> -1,
25653 Pragma_Debug_Policy
=> 0,
25654 Pragma_Detect_Blocking
=> 0,
25655 Pragma_Default_Initial_Condition
=> -1,
25656 Pragma_Default_Scalar_Storage_Order
=> 0,
25657 Pragma_Default_Storage_Pool
=> 0,
25658 Pragma_Depends
=> -1,
25659 Pragma_Disable_Atomic_Synchronization
=> 0,
25660 Pragma_Discard_Names
=> 0,
25661 Pragma_Dispatching_Domain
=> -1,
25662 Pragma_Effective_Reads
=> 0,
25663 Pragma_Effective_Writes
=> 0,
25664 Pragma_Elaborate
=> 0,
25665 Pragma_Elaborate_All
=> 0,
25666 Pragma_Elaborate_Body
=> 0,
25667 Pragma_Elaboration_Checks
=> 0,
25668 Pragma_Eliminate
=> 0,
25669 Pragma_Enable_Atomic_Synchronization
=> 0,
25670 Pragma_Export
=> -1,
25671 Pragma_Export_Function
=> -1,
25672 Pragma_Export_Object
=> -1,
25673 Pragma_Export_Procedure
=> -1,
25674 Pragma_Export_Value
=> -1,
25675 Pragma_Export_Valued_Procedure
=> -1,
25676 Pragma_Extend_System
=> -1,
25677 Pragma_Extensions_Allowed
=> 0,
25678 Pragma_Extensions_Visible
=> 0,
25679 Pragma_External
=> -1,
25680 Pragma_Favor_Top_Level
=> 0,
25681 Pragma_External_Name_Casing
=> 0,
25682 Pragma_Fast_Math
=> 0,
25683 Pragma_Finalize_Storage_Only
=> 0,
25685 Pragma_Global
=> -1,
25686 Pragma_Ident
=> -1,
25687 Pragma_Implementation_Defined
=> -1,
25688 Pragma_Implemented
=> -1,
25689 Pragma_Implicit_Packing
=> 0,
25690 Pragma_Import
=> 93,
25691 Pragma_Import_Function
=> 0,
25692 Pragma_Import_Object
=> 0,
25693 Pragma_Import_Procedure
=> 0,
25694 Pragma_Import_Valued_Procedure
=> 0,
25695 Pragma_Independent
=> 0,
25696 Pragma_Independent_Components
=> 0,
25697 Pragma_Initial_Condition
=> -1,
25698 Pragma_Initialize_Scalars
=> 0,
25699 Pragma_Initializes
=> -1,
25700 Pragma_Inline
=> 0,
25701 Pragma_Inline_Always
=> 0,
25702 Pragma_Inline_Generic
=> 0,
25703 Pragma_Inspection_Point
=> -1,
25704 Pragma_Interface
=> 92,
25705 Pragma_Interface_Name
=> 0,
25706 Pragma_Interrupt_Handler
=> -1,
25707 Pragma_Interrupt_Priority
=> -1,
25708 Pragma_Interrupt_State
=> -1,
25709 Pragma_Invariant
=> -1,
25710 Pragma_Java_Constructor
=> -1,
25711 Pragma_Java_Interface
=> -1,
25712 Pragma_Keep_Names
=> 0,
25713 Pragma_License
=> 0,
25714 Pragma_Link_With
=> -1,
25715 Pragma_Linker_Alias
=> -1,
25716 Pragma_Linker_Constructor
=> -1,
25717 Pragma_Linker_Destructor
=> -1,
25718 Pragma_Linker_Options
=> -1,
25719 Pragma_Linker_Section
=> 0,
25721 Pragma_Lock_Free
=> 0,
25722 Pragma_Locking_Policy
=> 0,
25723 Pragma_Loop_Invariant
=> -1,
25724 Pragma_Loop_Optimize
=> 0,
25725 Pragma_Loop_Variant
=> -1,
25726 Pragma_Machine_Attribute
=> -1,
25728 Pragma_Main_Storage
=> -1,
25729 Pragma_Memory_Size
=> 0,
25730 Pragma_No_Return
=> 0,
25731 Pragma_No_Body
=> 0,
25732 Pragma_No_Elaboration_Code_All
=> 0,
25733 Pragma_No_Inline
=> 0,
25734 Pragma_No_Run_Time
=> -1,
25735 Pragma_No_Strict_Aliasing
=> -1,
25736 Pragma_No_Tagged_Streams
=> 0,
25737 Pragma_Normalize_Scalars
=> 0,
25738 Pragma_Obsolescent
=> 0,
25739 Pragma_Optimize
=> 0,
25740 Pragma_Optimize_Alignment
=> 0,
25741 Pragma_Overflow_Mode
=> 0,
25742 Pragma_Overriding_Renamings
=> 0,
25743 Pragma_Ordered
=> 0,
25746 Pragma_Part_Of
=> 0,
25747 Pragma_Partition_Elaboration_Policy
=> 0,
25748 Pragma_Passive
=> 0,
25749 Pragma_Persistent_BSS
=> 0,
25750 Pragma_Polling
=> 0,
25751 Pragma_Prefix_Exception_Messages
=> 0,
25753 Pragma_Postcondition
=> -1,
25754 Pragma_Post_Class
=> -1,
25756 Pragma_Precondition
=> -1,
25757 Pragma_Predicate
=> -1,
25758 Pragma_Preelaborable_Initialization
=> -1,
25759 Pragma_Preelaborate
=> 0,
25760 Pragma_Pre_Class
=> -1,
25761 Pragma_Priority
=> -1,
25762 Pragma_Priority_Specific_Dispatching
=> 0,
25763 Pragma_Profile
=> 0,
25764 Pragma_Profile_Warnings
=> 0,
25765 Pragma_Propagate_Exceptions
=> 0,
25766 Pragma_Provide_Shift_Operators
=> 0,
25767 Pragma_Psect_Object
=> 0,
25769 Pragma_Pure_Function
=> 0,
25770 Pragma_Queuing_Policy
=> 0,
25771 Pragma_Rational
=> 0,
25772 Pragma_Ravenscar
=> 0,
25773 Pragma_Refined_Depends
=> -1,
25774 Pragma_Refined_Global
=> -1,
25775 Pragma_Refined_Post
=> -1,
25776 Pragma_Refined_State
=> -1,
25777 Pragma_Relative_Deadline
=> 0,
25778 Pragma_Remote_Access_Type
=> -1,
25779 Pragma_Remote_Call_Interface
=> -1,
25780 Pragma_Remote_Types
=> -1,
25781 Pragma_Restricted_Run_Time
=> 0,
25782 Pragma_Restriction_Warnings
=> 0,
25783 Pragma_Restrictions
=> 0,
25784 Pragma_Reviewable
=> -1,
25785 Pragma_Short_Circuit_And_Or
=> 0,
25786 Pragma_Share_Generic
=> 0,
25787 Pragma_Shared
=> 0,
25788 Pragma_Shared_Passive
=> 0,
25789 Pragma_Short_Descriptors
=> 0,
25790 Pragma_Simple_Storage_Pool_Type
=> 0,
25791 Pragma_Source_File_Name
=> 0,
25792 Pragma_Source_File_Name_Project
=> 0,
25793 Pragma_Source_Reference
=> 0,
25794 Pragma_SPARK_Mode
=> 0,
25795 Pragma_Storage_Size
=> -1,
25796 Pragma_Storage_Unit
=> 0,
25797 Pragma_Static_Elaboration_Desired
=> 0,
25798 Pragma_Stream_Convert
=> 0,
25799 Pragma_Style_Checks
=> 0,
25800 Pragma_Subtitle
=> 0,
25801 Pragma_Suppress
=> 0,
25802 Pragma_Suppress_Exception_Locations
=> 0,
25803 Pragma_Suppress_All
=> 0,
25804 Pragma_Suppress_Debug_Info
=> 0,
25805 Pragma_Suppress_Initialization
=> 0,
25806 Pragma_System_Name
=> 0,
25807 Pragma_Task_Dispatching_Policy
=> 0,
25808 Pragma_Task_Info
=> -1,
25809 Pragma_Task_Name
=> -1,
25810 Pragma_Task_Storage
=> -1,
25811 Pragma_Test_Case
=> -1,
25812 Pragma_Thread_Local_Storage
=> -1,
25813 Pragma_Time_Slice
=> -1,
25815 Pragma_Type_Invariant
=> -1,
25816 Pragma_Type_Invariant_Class
=> -1,
25817 Pragma_Unchecked_Union
=> 0,
25818 Pragma_Unimplemented_Unit
=> 0,
25819 Pragma_Universal_Aliasing
=> 0,
25820 Pragma_Universal_Data
=> 0,
25821 Pragma_Unmodified
=> 0,
25822 Pragma_Unreferenced
=> 0,
25823 Pragma_Unreferenced_Objects
=> 0,
25824 Pragma_Unreserve_All_Interrupts
=> 0,
25825 Pragma_Unsuppress
=> 0,
25826 Pragma_Unevaluated_Use_Of_Old
=> 0,
25827 Pragma_Use_VADS_Size
=> 0,
25828 Pragma_Validity_Checks
=> 0,
25829 Pragma_Volatile
=> 0,
25830 Pragma_Volatile_Components
=> 0,
25831 Pragma_Warning_As_Error
=> 0,
25832 Pragma_Warnings
=> 0,
25833 Pragma_Weak_External
=> 0,
25834 Pragma_Wide_Character_Encoding
=> 0,
25835 Unknown_Pragma
=> 0);
25837 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25843 function Arg_No
return Nat
;
25844 -- Returns an integer showing what argument we are in. A value of
25845 -- zero means we are not in any of the arguments.
25851 function Arg_No
return Nat
is
25856 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25870 -- Start of processing for Non_Significant_Pragma_Reference
25875 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25879 Id
:= Get_Pragma_Id
(Parent
(P
));
25880 C
:= Sig_Flags
(Id
);
25895 return AN
< (C
- 90);
25901 end Is_Non_Significant_Pragma_Reference
;
25903 ------------------------------
25904 -- Is_Pragma_String_Literal --
25905 ------------------------------
25907 -- This function returns true if the corresponding pragma argument is a
25908 -- static string expression. These are the only cases in which string
25909 -- literals can appear as pragma arguments. We also allow a string literal
25910 -- as the first argument to pragma Assert (although it will of course
25911 -- always generate a type error).
25913 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
25914 Pragn
: constant Node_Id
:= Parent
(Par
);
25915 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
25916 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
25922 N
:= First
(Assoc
);
25929 if Pname
= Name_Assert
then
25932 elsif Pname
= Name_Export
then
25935 elsif Pname
= Name_Ident
then
25938 elsif Pname
= Name_Import
then
25941 elsif Pname
= Name_Interface_Name
then
25944 elsif Pname
= Name_Linker_Alias
then
25947 elsif Pname
= Name_Linker_Section
then
25950 elsif Pname
= Name_Machine_Attribute
then
25953 elsif Pname
= Name_Source_File_Name
then
25956 elsif Pname
= Name_Source_Reference
then
25959 elsif Pname
= Name_Title
then
25962 elsif Pname
= Name_Subtitle
then
25968 end Is_Pragma_String_Literal
;
25970 ---------------------------
25971 -- Is_Private_SPARK_Mode --
25972 ---------------------------
25974 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
25977 (Nkind
(N
) = N_Pragma
25978 and then Pragma_Name
(N
) = Name_SPARK_Mode
25979 and then Is_List_Member
(N
));
25981 -- For pragma SPARK_Mode to be private, it has to appear in the private
25982 -- declarations of a package.
25985 Present
(Parent
(N
))
25986 and then Nkind
(Parent
(N
)) = N_Package_Specification
25987 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
25988 end Is_Private_SPARK_Mode
;
25990 -------------------------------------
25991 -- Is_Unconstrained_Or_Tagged_Item --
25992 -------------------------------------
25994 function Is_Unconstrained_Or_Tagged_Item
25995 (Item
: Entity_Id
) return Boolean
25997 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
25998 -- Determine whether record type Typ has at least one unconstrained
26001 ---------------------------------
26002 -- Has_Unconstrained_Component --
26003 ---------------------------------
26005 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
26009 Comp
:= First_Component
(Typ
);
26010 while Present
(Comp
) loop
26011 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
26015 Next_Component
(Comp
);
26019 end Has_Unconstrained_Component
;
26023 Typ
: constant Entity_Id
:= Etype
(Item
);
26025 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26028 if Is_Tagged_Type
(Typ
) then
26031 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
26034 elsif Is_Record_Type
(Typ
) then
26035 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
26038 return Has_Unconstrained_Component
(Typ
);
26041 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
26047 end Is_Unconstrained_Or_Tagged_Item
;
26049 -----------------------------
26050 -- Is_Valid_Assertion_Kind --
26051 -----------------------------
26053 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
26060 Name_Static_Predicate |
26061 Name_Dynamic_Predicate |
26066 Name_Type_Invariant |
26067 Name_uType_Invariant |
26071 Name_Assert_And_Cut |
26073 Name_Contract_Cases |
26075 Name_Default_Initial_Condition |
26077 Name_Initial_Condition |
26080 Name_Loop_Invariant |
26081 Name_Loop_Variant |
26082 Name_Postcondition |
26083 Name_Precondition |
26085 Name_Refined_Post |
26086 Name_Statement_Assertions
=> return True;
26088 when others => return False;
26090 end Is_Valid_Assertion_Kind
;
26092 -----------------------------------------
26093 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
26094 -----------------------------------------
26096 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
26097 Aspects
: constant List_Id
:= New_List
;
26098 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
26099 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
26101 Original_Aspects
: List_Id
;
26102 -- To capture global references, a copy of the created aspects must be
26103 -- inserted in the original tree.
26106 Prag_Arg_Ass
: Node_Id
;
26107 Prag_Id
: Pragma_Id
;
26110 -- Check for any PPC pragmas that appear within Decl
26112 Prag
:= Next
(Decl
);
26113 while Nkind
(Prag
) = N_Pragma
loop
26114 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
26117 when Pragma_Postcondition | Pragma_Precondition
=>
26118 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
26120 -- Make an aspect from any PPC pragma
26122 Append_To
(Aspects
,
26123 Make_Aspect_Specification
(Loc
,
26125 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
26127 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
26129 -- Generate the analysis information in the pragma expression
26130 -- and then set the pragma node analyzed to avoid any further
26133 Analyze
(Expression
(Prag_Arg_Ass
));
26134 Set_Analyzed
(Prag
, True);
26136 when others => null;
26142 -- Set all new aspects into the generic declaration node
26144 if Is_Non_Empty_List
(Aspects
) then
26146 -- Create the list of aspects to be inserted in the original tree
26148 Original_Aspects
:= Copy_Separate_List
(Aspects
);
26150 -- Check if Decl already has aspects
26152 -- Attach the new lists of aspects to both the generic copy and the
26155 if Has_Aspects
(Decl
) then
26156 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
26157 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
26160 Set_Parent
(Aspects
, Decl
);
26161 Set_Aspect_Specifications
(Decl
, Aspects
);
26162 Set_Parent
(Original_Aspects
, Or_Decl
);
26163 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
26166 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
26168 -------------------------
26169 -- Preanalyze_CTC_Args --
26170 -------------------------
26172 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
26174 -- Preanalyze the boolean expressions, we treat these as spec
26175 -- expressions (i.e. similar to a default expression).
26177 if Present
(Arg_Req
) then
26178 Preanalyze_Assert_Expression
26179 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
26181 -- In ASIS mode, for a pragma generated from a source aspect, also
26182 -- analyze the original aspect expression.
26184 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26185 Preanalyze_Assert_Expression
26186 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
26190 if Present
(Arg_Ens
) then
26191 Preanalyze_Assert_Expression
26192 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
26194 -- In ASIS mode, for a pragma generated from a source aspect, also
26195 -- analyze the original aspect expression.
26197 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26198 Preanalyze_Assert_Expression
26199 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
26202 end Preanalyze_CTC_Args
;
26204 --------------------------------------
26205 -- Process_Compilation_Unit_Pragmas --
26206 --------------------------------------
26208 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26210 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26211 -- strange because it comes at the end of the unit. Rational has the
26212 -- same name for a pragma, but treats it as a program unit pragma, In
26213 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26214 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26215 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26216 -- the context clause to ensure the correct processing.
26218 if Has_Pragma_Suppress_All
(N
) then
26219 Prepend_To
(Context_Items
(N
),
26220 Make_Pragma
(Sloc
(N
),
26221 Chars
=> Name_Suppress
,
26222 Pragma_Argument_Associations
=> New_List
(
26223 Make_Pragma_Argument_Association
(Sloc
(N
),
26224 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26227 -- Nothing else to do at the current time
26229 end Process_Compilation_Unit_Pragmas
;
26231 ------------------------------------
26232 -- Record_Possible_Body_Reference --
26233 ------------------------------------
26235 procedure Record_Possible_Body_Reference
26236 (State_Id
: Entity_Id
;
26240 Spec_Id
: Entity_Id
;
26243 -- Ensure that we are dealing with a reference to a state
26245 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26247 -- Climb the tree starting from the reference looking for a package body
26248 -- whose spec declares the referenced state. This criteria automatically
26249 -- excludes references in package specs which are legal. Note that it is
26250 -- not wise to emit an error now as the package body may lack pragma
26251 -- Refined_State or the referenced state may not be mentioned in the
26252 -- refinement. This approach avoids the generation of misleading errors.
26255 while Present
(Context
) loop
26256 if Nkind
(Context
) = N_Package_Body
then
26257 Spec_Id
:= Corresponding_Spec
(Context
);
26259 if Present
(Abstract_States
(Spec_Id
))
26260 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26262 if No
(Body_References
(State_Id
)) then
26263 Set_Body_References
(State_Id
, New_Elmt_List
);
26266 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
26271 Context
:= Parent
(Context
);
26273 end Record_Possible_Body_Reference
;
26275 ------------------------------
26276 -- Relocate_Pragmas_To_Body --
26277 ------------------------------
26279 procedure Relocate_Pragmas_To_Body
26280 (Subp_Body
: Node_Id
;
26281 Target_Body
: Node_Id
:= Empty
)
26283 procedure Relocate_Pragma
(Prag
: Node_Id
);
26284 -- Remove a single pragma from its current list and add it to the
26285 -- declarations of the proper body (either Subp_Body or Target_Body).
26287 ---------------------
26288 -- Relocate_Pragma --
26289 ---------------------
26291 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26296 -- When subprogram stubs or expression functions are involves, the
26297 -- destination declaration list belongs to the proper body.
26299 if Present
(Target_Body
) then
26300 Target
:= Target_Body
;
26302 Target
:= Subp_Body
;
26305 Decls
:= Declarations
(Target
);
26309 Set_Declarations
(Target
, Decls
);
26312 -- Unhook the pragma from its current list
26315 Prepend
(Prag
, Decls
);
26316 end Relocate_Pragma
;
26320 Body_Id
: constant Entity_Id
:=
26321 Defining_Unit_Name
(Specification
(Subp_Body
));
26322 Next_Stmt
: Node_Id
;
26325 -- Start of processing for Relocate_Pragmas_To_Body
26328 -- Do not process a body that comes from a separate unit as no construct
26329 -- can possibly follow it.
26331 if not Is_List_Member
(Subp_Body
) then
26334 -- Do not relocate pragmas that follow a stub if the stub does not have
26337 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26338 and then No
(Target_Body
)
26342 -- Do not process internally generated routine _Postconditions
26344 elsif Ekind
(Body_Id
) = E_Procedure
26345 and then Chars
(Body_Id
) = Name_uPostconditions
26350 -- Look at what is following the body. We are interested in certain kind
26351 -- of pragmas (either from source or byproducts of expansion) that can
26352 -- apply to a body [stub].
26354 Stmt
:= Next
(Subp_Body
);
26355 while Present
(Stmt
) loop
26357 -- Preserve the following statement for iteration purposes due to a
26358 -- possible relocation of a pragma.
26360 Next_Stmt
:= Next
(Stmt
);
26362 -- Move a candidate pragma following the body to the declarations of
26365 if Nkind
(Stmt
) = N_Pragma
26366 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26368 Relocate_Pragma
(Stmt
);
26370 -- Skip internally generated code
26372 elsif not Comes_From_Source
(Stmt
) then
26375 -- No candidate pragmas are available for relocation
26383 end Relocate_Pragmas_To_Body
;
26385 -------------------
26386 -- Resolve_State --
26387 -------------------
26389 procedure Resolve_State
(N
: Node_Id
) is
26394 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26395 Func
:= Entity
(N
);
26397 -- Handle overloading of state names by functions. Traverse the
26398 -- homonym chain looking for an abstract state.
26400 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26401 State
:= Homonym
(Func
);
26402 while Present
(State
) loop
26404 -- Resolve the overloading by setting the proper entity of the
26405 -- reference to that of the state.
26407 if Ekind
(State
) = E_Abstract_State
then
26408 Set_Etype
(N
, Standard_Void_Type
);
26409 Set_Entity
(N
, State
);
26410 Set_Associated_Node
(N
, State
);
26414 State
:= Homonym
(State
);
26417 -- A function can never act as a state. If the homonym chain does
26418 -- not contain a corresponding state, then something went wrong in
26419 -- the overloading mechanism.
26421 raise Program_Error
;
26426 ----------------------------
26427 -- Rewrite_Assertion_Kind --
26428 ----------------------------
26430 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26434 if Nkind
(N
) = N_Attribute_Reference
26435 and then Attribute_Name
(N
) = Name_Class
26436 and then Nkind
(Prefix
(N
)) = N_Identifier
26438 case Chars
(Prefix
(N
)) is
26443 when Name_Type_Invariant
=>
26444 Nam
:= Name_uType_Invariant
;
26445 when Name_Invariant
=>
26446 Nam
:= Name_uInvariant
;
26451 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26453 end Rewrite_Assertion_Kind
;
26461 Dummy
:= Dummy
+ 1;
26464 --------------------------------
26465 -- Set_Encoded_Interface_Name --
26466 --------------------------------
26468 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26469 Str
: constant String_Id
:= Strval
(S
);
26470 Len
: constant Int
:= String_Length
(Str
);
26475 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26478 -- Stores encoded value of character code CC. The encoding we use an
26479 -- underscore followed by four lower case hex digits.
26485 procedure Encode
is
26487 Store_String_Char
(Get_Char_Code
('_'));
26489 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26491 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26493 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26495 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26498 -- Start of processing for Set_Encoded_Interface_Name
26501 -- If first character is asterisk, this is a link name, and we leave it
26502 -- completely unmodified. We also ignore null strings (the latter case
26503 -- happens only in error cases) and no encoding should occur for Java or
26504 -- AAMP interface names.
26507 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26508 or else VM_Target
/= No_VM
26509 or else AAMP_On_Target
26511 Set_Interface_Name
(E
, S
);
26516 CC
:= Get_String_Char
(Str
, J
);
26518 exit when not In_Character_Range
(CC
);
26520 C
:= Get_Character
(CC
);
26522 exit when C
/= '_' and then C
/= '$'
26523 and then C
not in '0' .. '9'
26524 and then C
not in 'a' .. 'z'
26525 and then C
not in 'A' .. 'Z';
26528 Set_Interface_Name
(E
, S
);
26536 -- Here we need to encode. The encoding we use as follows:
26537 -- three underscores + four hex digits (lower case)
26541 for J
in 1 .. String_Length
(Str
) loop
26542 CC
:= Get_String_Char
(Str
, J
);
26544 if not In_Character_Range
(CC
) then
26547 C
:= Get_Character
(CC
);
26549 if C
= '_' or else C
= '$'
26550 or else C
in '0' .. '9'
26551 or else C
in 'a' .. 'z'
26552 or else C
in 'A' .. 'Z'
26554 Store_String_Char
(CC
);
26561 Set_Interface_Name
(E
,
26562 Make_String_Literal
(Sloc
(S
),
26563 Strval
=> End_String
));
26565 end Set_Encoded_Interface_Name
;
26567 -------------------
26568 -- Set_Unit_Name --
26569 -------------------
26571 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26576 if Nkind
(N
) = N_Identifier
26577 and then Nkind
(With_Item
) = N_Identifier
26579 Set_Entity
(N
, Entity
(With_Item
));
26581 elsif Nkind
(N
) = N_Selected_Component
then
26582 Change_Selected_Component_To_Expanded_Name
(N
);
26583 Set_Entity
(N
, Entity
(With_Item
));
26584 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26586 Pref
:= Prefix
(N
);
26587 Scop
:= Scope
(Entity
(N
));
26588 while Nkind
(Pref
) = N_Selected_Component
loop
26589 Change_Selected_Component_To_Expanded_Name
(Pref
);
26590 Set_Entity
(Selector_Name
(Pref
), Scop
);
26591 Set_Entity
(Pref
, Scop
);
26592 Pref
:= Prefix
(Pref
);
26593 Scop
:= Scope
(Scop
);
26596 Set_Entity
(Pref
, Scop
);