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 the null input and replace it with a copy of the
1388 -- (Output => Output)
1390 if Nkind
(Inputs
) = N_Null
then
1391 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1393 -- The clause is of the form:
1395 -- (Output =>+ (Input1, ..., InputN))
1397 -- Determine whether the output is not already mentioned in the
1398 -- input list and if not, add it to the list of inputs:
1400 -- (Output => (Output, Input1, ..., InputN))
1402 elsif Nkind
(Inputs
) = N_Aggregate
then
1403 Grouped
:= Expressions
(Inputs
);
1405 if not In_Input_List
1409 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1412 -- The clause is of the form:
1414 -- (Output =>+ Input)
1416 -- If the input does not mention the output, group the two
1419 -- (Output => (Output, Input))
1421 elsif Entity_Of
(Inputs
) /= Output_Id
then
1423 Make_Aggregate
(Loc
,
1424 Expressions
=> New_List
(
1425 New_Copy_Tree
(Output
),
1426 New_Copy_Tree
(Inputs
))));
1428 end Propagate_Output
;
1432 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1433 New_Clause
: Node_Id
;
1435 -- Start of processing for Create_Or_Modify_Clause
1438 -- A null output depending on itself does not require any
1441 if Nkind
(Output
) = N_Null
then
1444 -- A function result cannot depend on itself because it cannot
1445 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1447 elsif Is_Attribute_Result
(Output
) then
1448 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1452 -- When performing the transformation in place, simply add the
1453 -- output to the list of inputs (if not already there). This case
1454 -- arises when dealing with the last output of an output list -
1455 -- we perform the normalization in place to avoid generating a
1459 Propagate_Output
(Output
, Inputs
);
1461 -- A list with multiple outputs is slowly trimmed until only
1462 -- one element remains. When this happens, replace the
1463 -- aggregate with the element itself.
1467 Rewrite
(Outputs
, Output
);
1473 -- Unchain the output from its output list as it will appear in
1474 -- a new clause. Note that we cannot simply rewrite the output
1475 -- as null because this will violate the semantics of pragma
1480 -- Generate a new clause of the form:
1481 -- (Output => Inputs)
1484 Make_Component_Association
(Loc
,
1485 Choices
=> New_List
(Output
),
1486 Expression
=> New_Copy_Tree
(Inputs
));
1488 -- The new clause contains replicated content that has already
1489 -- been analyzed. There is not need to reanalyze it or
1490 -- renormalize it again.
1492 Set_Analyzed
(New_Clause
);
1495 (Output
=> First
(Choices
(New_Clause
)),
1496 Inputs
=> Expression
(New_Clause
));
1498 Insert_After
(After
, New_Clause
);
1500 end Create_Or_Modify_Clause
;
1504 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1506 Last_Output
: Node_Id
;
1507 Next_Output
: Node_Id
;
1510 -- Start of processing for Normalize_Clause
1513 -- A self-dependency appears as operator "+". Remove the "+" from the
1514 -- tree by moving the real inputs to their proper place.
1516 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1517 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1518 Inputs
:= Expression
(Clause
);
1520 -- Multiple outputs appear as an aggregate
1522 if Nkind
(Outputs
) = N_Aggregate
then
1523 Last_Output
:= Last
(Expressions
(Outputs
));
1525 Output
:= First
(Expressions
(Outputs
));
1526 while Present
(Output
) loop
1528 -- Normalization may remove an output from its list,
1529 -- preserve the subsequent output now.
1531 Next_Output
:= Next
(Output
);
1533 Create_Or_Modify_Clause
1538 In_Place
=> Output
= Last_Output
,
1541 Output
:= Next_Output
;
1547 Create_Or_Modify_Clause
1556 end Normalize_Clause
;
1560 Deps
: constant Node_Id
:=
1562 (First
(Pragma_Argument_Associations
(N
)));
1565 Last_Clause
: Node_Id
;
1566 Subp_Decl
: Node_Id
;
1568 Restore_Scope
: Boolean := False;
1569 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1571 -- Start of processing for Analyze_Depends_In_Decl_Part
1576 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
1577 Subp_Id
:= Defining_Entity
(Subp_Decl
);
1579 -- The logic in this routine is used to analyze both pragma Depends and
1580 -- pragma Refined_Depends since they have the same syntax and base
1581 -- semantics. Find the entity of the corresponding spec when analyzing
1584 if Nkind
(Subp_Decl
) = N_Subprogram_Body
1585 and then Present
(Corresponding_Spec
(Subp_Decl
))
1587 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
1589 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
1590 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
1592 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
1598 -- Empty dependency list
1600 if Nkind
(Deps
) = N_Null
then
1602 -- Gather all states, variables and formal parameters that the
1603 -- subprogram may depend on. These items are obtained from the
1604 -- parameter profile or pragma [Refined_]Global (if available).
1606 Collect_Subprogram_Inputs_Outputs
1607 (Subp_Id
=> Subp_Id
,
1608 Subp_Inputs
=> Subp_Inputs
,
1609 Subp_Outputs
=> Subp_Outputs
,
1610 Global_Seen
=> Global_Seen
);
1612 -- Verify that every input or output of the subprogram appear in a
1615 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1616 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1617 Check_Function_Return
;
1619 -- Dependency clauses appear as component associations of an aggregate
1621 elsif Nkind
(Deps
) = N_Aggregate
then
1623 -- Do not attempt to perform analysis of a syntactically illegal
1624 -- clause as this will lead to misleading errors.
1626 if Has_Extra_Parentheses
(Deps
) then
1630 if Present
(Component_Associations
(Deps
)) then
1631 Last_Clause
:= Last
(Component_Associations
(Deps
));
1633 -- Gather all states, variables and formal parameters that the
1634 -- subprogram may depend on. These items are obtained from the
1635 -- parameter profile or pragma [Refined_]Global (if available).
1637 Collect_Subprogram_Inputs_Outputs
1638 (Subp_Id
=> Subp_Id
,
1639 Subp_Inputs
=> Subp_Inputs
,
1640 Subp_Outputs
=> Subp_Outputs
,
1641 Global_Seen
=> Global_Seen
);
1643 -- Ensure that the formal parameters are visible when analyzing
1644 -- all clauses. This falls out of the general rule of aspects
1645 -- pertaining to subprogram declarations. Skip the installation
1646 -- for subprogram bodies because the formals are already visible.
1648 if not In_Open_Scopes
(Spec_Id
) then
1649 Restore_Scope
:= True;
1650 Push_Scope
(Spec_Id
);
1651 Install_Formals
(Spec_Id
);
1654 Clause
:= First
(Component_Associations
(Deps
));
1655 while Present
(Clause
) loop
1656 Errors
:= Serious_Errors_Detected
;
1658 -- Normalization may create extra clauses that contain
1659 -- replicated input and output names. There is no need to
1662 if not Analyzed
(Clause
) then
1663 Set_Analyzed
(Clause
);
1665 Analyze_Dependency_Clause
1667 Is_Last
=> Clause
= Last_Clause
);
1670 -- Do not normalize a clause if errors were detected (count
1671 -- of Serious_Errors has increased) because the inputs and/or
1672 -- outputs may denote illegal items. Normalization is disabled
1673 -- in ASIS mode as it alters the tree by introducing new nodes
1674 -- similar to expansion.
1676 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1677 Normalize_Clause
(Clause
);
1683 if Restore_Scope
then
1687 -- Verify that every input or output of the subprogram appear in a
1690 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1691 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1692 Check_Function_Return
;
1694 -- The dependency list is malformed. This is a syntax error, always
1698 Error_Msg_N
("malformed dependency relation", Deps
);
1702 -- The top level dependency relation is malformed. This is a syntax
1703 -- error, always report.
1706 Error_Msg_N
("malformed dependency relation", Deps
);
1710 -- Ensure that a state and a corresponding constituent do not appear
1711 -- together in pragma [Refined_]Depends.
1713 Check_State_And_Constituent_Use
1714 (States
=> States_Seen
,
1715 Constits
=> Constits_Seen
,
1717 end Analyze_Depends_In_Decl_Part
;
1719 --------------------------------------------
1720 -- Analyze_External_Property_In_Decl_Part --
1721 --------------------------------------------
1723 procedure Analyze_External_Property_In_Decl_Part
1725 Expr_Val
: out Boolean)
1727 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1728 Obj_Id
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
1729 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Next
(Arg1
));
1732 Error_Msg_Name_1
:= Pragma_Name
(N
);
1734 -- An external property pragma must apply to an effectively volatile
1735 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1736 -- The check is performed at the end of the declarative region due to a
1737 -- possible out-of-order arrangement of pragmas:
1740 -- pragma Async_Readers (Obj);
1741 -- pragma Volatile (Obj);
1743 if not Is_Effectively_Volatile
(Obj_Id
) then
1745 ("external property % must apply to a volatile object", N
);
1748 -- Ensure that the Boolean expression (if present) is static. A missing
1749 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1753 if Present
(Expr
) then
1754 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
1756 if Is_OK_Static_Expression
(Expr
) then
1757 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1759 SPARK_Msg_N
("expression of % must be static", Expr
);
1762 end Analyze_External_Property_In_Decl_Part
;
1764 ---------------------------------
1765 -- Analyze_Global_In_Decl_Part --
1766 ---------------------------------
1768 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1769 Constits_Seen
: Elist_Id
:= No_Elist
;
1770 -- A list containing the entities of all constituents processed so far.
1771 -- It aids in detecting illegal usage of a state and a corresponding
1772 -- constituent in pragma [Refinde_]Global.
1774 Seen
: Elist_Id
:= No_Elist
;
1775 -- A list containing the entities of all the items processed so far. It
1776 -- plays a role in detecting distinct entities.
1778 Spec_Id
: Entity_Id
;
1779 -- The entity of the subprogram subject to pragma [Refined_]Global
1781 States_Seen
: Elist_Id
:= No_Elist
;
1782 -- A list containing the entities of all states processed so far. It
1783 -- helps in detecting illegal usage of a state and a corresponding
1784 -- constituent in pragma [Refined_]Global.
1786 Subp_Id
: Entity_Id
;
1787 -- The entity of the subprogram [body or stub] subject to pragma
1788 -- [Refined_]Global.
1790 In_Out_Seen
: Boolean := False;
1791 Input_Seen
: Boolean := False;
1792 Output_Seen
: Boolean := False;
1793 Proof_Seen
: Boolean := False;
1794 -- Flags used to verify the consistency of modes
1796 procedure Analyze_Global_List
1798 Global_Mode
: Name_Id
:= Name_Input
);
1799 -- Verify the legality of a single global list declaration. Global_Mode
1800 -- denotes the current mode in effect.
1802 -------------------------
1803 -- Analyze_Global_List --
1804 -------------------------
1806 procedure Analyze_Global_List
1808 Global_Mode
: Name_Id
:= Name_Input
)
1810 procedure Analyze_Global_Item
1812 Global_Mode
: Name_Id
);
1813 -- Verify the legality of a single global item declaration.
1814 -- Global_Mode denotes the current mode in effect.
1816 procedure Check_Duplicate_Mode
1818 Status
: in out Boolean);
1819 -- Flag Status denotes whether a particular mode has been seen while
1820 -- processing a global list. This routine verifies that Mode is not a
1821 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1823 procedure Check_Mode_Restriction_In_Enclosing_Context
1825 Item_Id
: Entity_Id
);
1826 -- Verify that an item of mode In_Out or Output does not appear as an
1827 -- input in the Global aspect of an enclosing subprogram. If this is
1828 -- the case, emit an error. Item and Item_Id are respectively the
1829 -- item and its entity.
1831 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1832 -- Mode denotes either In_Out or Output. Depending on the kind of the
1833 -- related subprogram, emit an error if those two modes apply to a
1834 -- function (SPARK RM 6.1.4(10)).
1836 -------------------------
1837 -- Analyze_Global_Item --
1838 -------------------------
1840 procedure Analyze_Global_Item
1842 Global_Mode
: Name_Id
)
1844 Item_Id
: Entity_Id
;
1847 -- Detect one of the following cases
1849 -- with Global => (null, Name)
1850 -- with Global => (Name_1, null, Name_2)
1851 -- with Global => (Name, null)
1853 if Nkind
(Item
) = N_Null
then
1854 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
1859 Resolve_State
(Item
);
1861 -- Find the entity of the item. If this is a renaming, climb the
1862 -- renaming chain to reach the root object. Renamings of non-
1863 -- entire objects do not yield an entity (Empty).
1865 Item_Id
:= Entity_Of
(Item
);
1867 if Present
(Item_Id
) then
1869 -- A global item may denote a formal parameter of an enclosing
1870 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1871 -- provide a better error diagnostic.
1873 if Is_Formal
(Item_Id
) then
1874 if Scope
(Item_Id
) = Spec_Id
then
1876 ("global item cannot reference parameter of subprogram",
1881 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1882 -- Do this check first to provide a better error diagnostic.
1884 elsif Ekind
(Item_Id
) = E_Constant
then
1885 SPARK_Msg_N
("global item cannot denote a constant", Item
);
1887 -- A formal object may act as a global item inside a generic
1889 elsif Is_Formal_Object
(Item_Id
) then
1892 -- The only legal references are those to abstract states and
1893 -- variables (SPARK RM 6.1.4(4)).
1895 elsif not Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
1897 ("global item must denote variable or state", Item
);
1901 -- State related checks
1903 if Ekind
(Item_Id
) = E_Abstract_State
then
1905 -- An abstract state with visible refinement cannot appear
1906 -- in pragma [Refined_]Global as its place must be taken by
1907 -- some of its constituents (SPARK RM 6.1.4(8)).
1909 if Has_Visible_Refinement
(Item_Id
) then
1911 ("cannot mention state & in global refinement",
1913 SPARK_Msg_N
("\use its constituents instead", Item
);
1916 -- If the reference to the abstract state appears in an
1917 -- enclosing package body that will eventually refine the
1918 -- state, record the reference for future checks.
1921 Record_Possible_Body_Reference
1922 (State_Id
=> Item_Id
,
1926 -- Variable related checks. These are only relevant when
1927 -- SPARK_Mode is on as they are not standard Ada legality
1930 elsif SPARK_Mode
= On
1931 and then Is_Effectively_Volatile
(Item_Id
)
1933 -- An effectively volatile object cannot appear as a global
1934 -- item of a function (SPARK RM 7.1.3(9)).
1936 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
1938 ("volatile object & cannot act as global item of a "
1939 & "function", Item
, Item_Id
);
1942 -- An effectively volatile object with external property
1943 -- Effective_Reads set to True must have mode Output or
1946 elsif Effective_Reads_Enabled
(Item_Id
)
1947 and then Global_Mode
= Name_Input
1950 ("volatile object & with property Effective_Reads must "
1951 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
1957 -- When the item renames an entire object, replace the item
1958 -- with a reference to the object.
1960 if Present
(Renamed_Object
(Entity
(Item
))) then
1961 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1965 -- Some form of illegal construct masquerading as a name
1966 -- (SPARK RM 6.1.4(4)).
1969 Error_Msg_N
("global item must denote variable or state", Item
);
1973 -- Verify that an output does not appear as an input in an
1974 -- enclosing subprogram.
1976 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
1977 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
1980 -- The same entity might be referenced through various way.
1981 -- Check the entity of the item rather than the item itself
1982 -- (SPARK RM 6.1.4(11)).
1984 if Contains
(Seen
, Item_Id
) then
1985 SPARK_Msg_N
("duplicate global item", Item
);
1987 -- Add the entity of the current item to the list of processed
1991 Add_Item
(Item_Id
, Seen
);
1993 if Ekind
(Item_Id
) = E_Abstract_State
then
1994 Add_Item
(Item_Id
, States_Seen
);
1997 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
1998 and then Present
(Encapsulating_State
(Item_Id
))
2000 Add_Item
(Item_Id
, Constits_Seen
);
2003 end Analyze_Global_Item
;
2005 --------------------------
2006 -- Check_Duplicate_Mode --
2007 --------------------------
2009 procedure Check_Duplicate_Mode
2011 Status
: in out Boolean)
2015 SPARK_Msg_N
("duplicate global mode", Mode
);
2019 end Check_Duplicate_Mode
;
2021 -------------------------------------------------
2022 -- Check_Mode_Restriction_In_Enclosing_Context --
2023 -------------------------------------------------
2025 procedure Check_Mode_Restriction_In_Enclosing_Context
2027 Item_Id
: Entity_Id
)
2029 Context
: Entity_Id
;
2031 Inputs
: Elist_Id
:= No_Elist
;
2032 Outputs
: Elist_Id
:= No_Elist
;
2035 -- Traverse the scope stack looking for enclosing subprograms
2036 -- subject to pragma [Refined_]Global.
2038 Context
:= Scope
(Subp_Id
);
2039 while Present
(Context
) and then Context
/= Standard_Standard
loop
2040 if Is_Subprogram
(Context
)
2042 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2044 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2046 Collect_Subprogram_Inputs_Outputs
2047 (Subp_Id
=> Context
,
2048 Subp_Inputs
=> Inputs
,
2049 Subp_Outputs
=> Outputs
,
2050 Global_Seen
=> Dummy
);
2052 -- The item is classified as In_Out or Output but appears as
2053 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2055 if Appears_In
(Inputs
, Item_Id
)
2056 and then not Appears_In
(Outputs
, Item_Id
)
2059 ("global item & cannot have mode In_Out or Output",
2062 ("\item already appears as input of subprogram &",
2065 -- Stop the traversal once an error has been detected
2071 Context
:= Scope
(Context
);
2073 end Check_Mode_Restriction_In_Enclosing_Context
;
2075 ----------------------------------------
2076 -- Check_Mode_Restriction_In_Function --
2077 ----------------------------------------
2079 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2081 if Ekind
(Spec_Id
) = E_Function
then
2083 ("global mode & is not applicable to functions", Mode
);
2085 end Check_Mode_Restriction_In_Function
;
2093 -- Start of processing for Analyze_Global_List
2096 if Nkind
(List
) = N_Null
then
2097 Set_Analyzed
(List
);
2099 -- Single global item declaration
2101 elsif Nkind_In
(List
, N_Expanded_Name
,
2103 N_Selected_Component
)
2105 Analyze_Global_Item
(List
, Global_Mode
);
2107 -- Simple global list or moded global list declaration
2109 elsif Nkind
(List
) = N_Aggregate
then
2110 Set_Analyzed
(List
);
2112 -- The declaration of a simple global list appear as a collection
2115 if Present
(Expressions
(List
)) then
2116 if Present
(Component_Associations
(List
)) then
2118 ("cannot mix moded and non-moded global lists", List
);
2121 Item
:= First
(Expressions
(List
));
2122 while Present
(Item
) loop
2123 Analyze_Global_Item
(Item
, Global_Mode
);
2128 -- The declaration of a moded global list appears as a collection
2129 -- of component associations where individual choices denote
2132 elsif Present
(Component_Associations
(List
)) then
2133 if Present
(Expressions
(List
)) then
2135 ("cannot mix moded and non-moded global lists", List
);
2138 Assoc
:= First
(Component_Associations
(List
));
2139 while Present
(Assoc
) loop
2140 Mode
:= First
(Choices
(Assoc
));
2142 if Nkind
(Mode
) = N_Identifier
then
2143 if Chars
(Mode
) = Name_In_Out
then
2144 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2145 Check_Mode_Restriction_In_Function
(Mode
);
2147 elsif Chars
(Mode
) = Name_Input
then
2148 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2150 elsif Chars
(Mode
) = Name_Output
then
2151 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2152 Check_Mode_Restriction_In_Function
(Mode
);
2154 elsif Chars
(Mode
) = Name_Proof_In
then
2155 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2158 SPARK_Msg_N
("invalid mode selector", Mode
);
2162 SPARK_Msg_N
("invalid mode selector", Mode
);
2165 -- Items in a moded list appear as a collection of
2166 -- expressions. Reuse the existing machinery to analyze
2170 (List
=> Expression
(Assoc
),
2171 Global_Mode
=> Chars
(Mode
));
2179 raise Program_Error
;
2182 -- Any other attempt to declare a global item is illegal. This is a
2183 -- syntax error, always report.
2186 Error_Msg_N
("malformed global list", List
);
2188 end Analyze_Global_List
;
2192 Items
: constant Node_Id
:=
2193 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2194 Subp_Decl
: Node_Id
;
2196 Restore_Scope
: Boolean := False;
2197 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2199 -- Start of processing for Analyze_Global_In_Decl_List
2203 Check_SPARK_Aspect_For_ASIS
(N
);
2205 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
2206 Subp_Id
:= Defining_Entity
(Subp_Decl
);
2208 -- The logic in this routine is used to analyze both pragma Global and
2209 -- pragma Refined_Global since they have the same syntax and base
2210 -- semantics. Find the entity of the corresponding spec when analyzing
2213 if Nkind
(Subp_Decl
) = N_Subprogram_Body
2214 and then Present
(Corresponding_Spec
(Subp_Decl
))
2216 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
2218 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
2219 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
2221 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
2227 -- There is nothing to be done for a null global list
2229 if Nkind
(Items
) = N_Null
then
2230 Set_Analyzed
(Items
);
2232 -- Analyze the various forms of global lists and items. Note that some
2233 -- of these may be malformed in which case the analysis emits error
2237 -- Ensure that the formal parameters are visible when processing an
2238 -- item. This falls out of the general rule of aspects pertaining to
2239 -- subprogram declarations.
2241 if not In_Open_Scopes
(Spec_Id
) then
2242 Restore_Scope
:= True;
2243 Push_Scope
(Spec_Id
);
2244 Install_Formals
(Spec_Id
);
2247 Analyze_Global_List
(Items
);
2249 if Restore_Scope
then
2254 -- Ensure that a state and a corresponding constituent do not appear
2255 -- together in pragma [Refined_]Global.
2257 Check_State_And_Constituent_Use
2258 (States
=> States_Seen
,
2259 Constits
=> Constits_Seen
,
2261 end Analyze_Global_In_Decl_Part
;
2263 --------------------------------------------
2264 -- Analyze_Initial_Condition_In_Decl_Part --
2265 --------------------------------------------
2267 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2268 Expr
: constant Node_Id
:=
2269 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2274 -- The expression is preanalyzed because it has not been moved to its
2275 -- final place yet. A direct analysis may generate side effects and this
2276 -- is not desired at this point.
2278 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2279 end Analyze_Initial_Condition_In_Decl_Part
;
2281 --------------------------------------
2282 -- Analyze_Initializes_In_Decl_Part --
2283 --------------------------------------
2285 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2286 Pack_Spec
: constant Node_Id
:= Parent
(N
);
2287 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Parent
(Pack_Spec
));
2289 Constits_Seen
: Elist_Id
:= No_Elist
;
2290 -- A list containing the entities of all constituents processed so far.
2291 -- It aids in detecting illegal usage of a state and a corresponding
2292 -- constituent in pragma Initializes.
2294 Items_Seen
: Elist_Id
:= No_Elist
;
2295 -- A list of all initialization items processed so far. This list is
2296 -- used to detect duplicate items.
2298 Non_Null_Seen
: Boolean := False;
2299 Null_Seen
: Boolean := False;
2300 -- Flags used to check the legality of a null initialization list
2302 States_And_Vars
: Elist_Id
:= No_Elist
;
2303 -- A list of all abstract states and variables declared in the visible
2304 -- declarations of the related package. This list is used to detect the
2305 -- legality of initialization items.
2307 States_Seen
: Elist_Id
:= No_Elist
;
2308 -- A list containing the entities of all states processed so far. It
2309 -- helps in detecting illegal usage of a state and a corresponding
2310 -- constituent in pragma Initializes.
2312 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2313 -- Verify the legality of a single initialization item
2315 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2316 -- Verify the legality of a single initialization item followed by a
2317 -- list of input items.
2319 procedure Collect_States_And_Variables
;
2320 -- Inspect the visible declarations of the related package and gather
2321 -- the entities of all abstract states and variables in States_And_Vars.
2323 ---------------------------------
2324 -- Analyze_Initialization_Item --
2325 ---------------------------------
2327 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2328 Item_Id
: Entity_Id
;
2331 -- Null initialization list
2333 if Nkind
(Item
) = N_Null
then
2335 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2337 elsif Non_Null_Seen
then
2339 ("cannot mix null and non-null initialization items", Item
);
2344 -- Initialization item
2347 Non_Null_Seen
:= True;
2351 ("cannot mix null and non-null initialization items", Item
);
2355 Resolve_State
(Item
);
2357 if Is_Entity_Name
(Item
) then
2358 Item_Id
:= Entity_Of
(Item
);
2360 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
2362 -- The state or variable must be declared in the visible
2363 -- declarations of the package (SPARK RM 7.1.5(7)).
2365 if not Contains
(States_And_Vars
, Item_Id
) then
2366 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2368 ("initialization item & must appear in the visible "
2369 & "declarations of package %", Item
, Item_Id
);
2371 -- Detect a duplicate use of the same initialization item
2372 -- (SPARK RM 7.1.5(5)).
2374 elsif Contains
(Items_Seen
, Item_Id
) then
2375 SPARK_Msg_N
("duplicate initialization item", Item
);
2377 -- The item is legal, add it to the list of processed states
2381 Add_Item
(Item_Id
, Items_Seen
);
2383 if Ekind
(Item_Id
) = E_Abstract_State
then
2384 Add_Item
(Item_Id
, States_Seen
);
2387 if Present
(Encapsulating_State
(Item_Id
)) then
2388 Add_Item
(Item_Id
, Constits_Seen
);
2392 -- The item references something that is not a state or a
2393 -- variable (SPARK RM 7.1.5(3)).
2397 ("initialization item must denote variable or state",
2401 -- Some form of illegal construct masquerading as a name
2402 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2406 ("initialization item must denote variable or state", Item
);
2409 end Analyze_Initialization_Item
;
2411 ---------------------------------------------
2412 -- Analyze_Initialization_Item_With_Inputs --
2413 ---------------------------------------------
2415 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2416 Inputs_Seen
: Elist_Id
:= No_Elist
;
2417 -- A list of all inputs processed so far. This list is used to detect
2418 -- duplicate uses of an input.
2420 Non_Null_Seen
: Boolean := False;
2421 Null_Seen
: Boolean := False;
2422 -- Flags used to check the legality of an input list
2424 procedure Analyze_Input_Item
(Input
: Node_Id
);
2425 -- Verify the legality of a single input item
2427 ------------------------
2428 -- Analyze_Input_Item --
2429 ------------------------
2431 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2432 Input_Id
: Entity_Id
;
2437 if Nkind
(Input
) = N_Null
then
2440 ("multiple null initializations not allowed", Item
);
2442 elsif Non_Null_Seen
then
2444 ("cannot mix null and non-null initialization item", Item
);
2452 Non_Null_Seen
:= True;
2456 ("cannot mix null and non-null initialization item", Item
);
2460 Resolve_State
(Input
);
2462 if Is_Entity_Name
(Input
) then
2463 Input_Id
:= Entity_Of
(Input
);
2465 if Ekind_In
(Input_Id
, E_Abstract_State
,
2471 -- The input cannot denote states or variables declared
2472 -- within the related package.
2474 if Within_Scope
(Input_Id
, Current_Scope
) then
2475 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2477 ("input item & cannot denote a visible variable or "
2478 & "state of package % (SPARK RM 7.1.5(4))",
2481 -- Detect a duplicate use of the same input item
2482 -- (SPARK RM 7.1.5(5)).
2484 elsif Contains
(Inputs_Seen
, Input_Id
) then
2485 SPARK_Msg_N
("duplicate input item", Input
);
2487 -- Input is legal, add it to the list of processed inputs
2490 Add_Item
(Input_Id
, Inputs_Seen
);
2492 if Ekind
(Input_Id
) = E_Abstract_State
then
2493 Add_Item
(Input_Id
, States_Seen
);
2496 if Ekind_In
(Input_Id
, E_Abstract_State
, E_Variable
)
2497 and then Present
(Encapsulating_State
(Input_Id
))
2499 Add_Item
(Input_Id
, Constits_Seen
);
2503 -- The input references something that is not a state or a
2504 -- variable (SPARK RM 7.1.5(3)).
2508 ("input item must denote variable or state", Input
);
2511 -- Some form of illegal construct masquerading as a name
2512 -- (SPARK RM 7.1.5(3)).
2516 ("input item must denote variable or state", Input
);
2519 end Analyze_Input_Item
;
2523 Inputs
: constant Node_Id
:= Expression
(Item
);
2527 Name_Seen
: Boolean := False;
2528 -- A flag used to detect multiple item names
2530 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2533 -- Inspect the name of an item with inputs
2535 Elmt
:= First
(Choices
(Item
));
2536 while Present
(Elmt
) loop
2538 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2541 Analyze_Initialization_Item
(Elmt
);
2547 -- Multiple input items appear as an aggregate
2549 if Nkind
(Inputs
) = N_Aggregate
then
2550 if Present
(Expressions
(Inputs
)) then
2551 Input
:= First
(Expressions
(Inputs
));
2552 while Present
(Input
) loop
2553 Analyze_Input_Item
(Input
);
2558 if Present
(Component_Associations
(Inputs
)) then
2560 ("inputs must appear in named association form", Inputs
);
2563 -- Single input item
2566 Analyze_Input_Item
(Inputs
);
2568 end Analyze_Initialization_Item_With_Inputs
;
2570 ----------------------------------
2571 -- Collect_States_And_Variables --
2572 ----------------------------------
2574 procedure Collect_States_And_Variables
is
2578 -- Collect the abstract states defined in the package (if any)
2580 if Present
(Abstract_States
(Pack_Id
)) then
2581 States_And_Vars
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2584 -- Collect all variables the appear in the visible declarations of
2585 -- the related package.
2587 if Present
(Visible_Declarations
(Pack_Spec
)) then
2588 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2589 while Present
(Decl
) loop
2590 if Nkind
(Decl
) = N_Object_Declaration
2591 and then Ekind
(Defining_Entity
(Decl
)) = E_Variable
2592 and then Comes_From_Source
(Decl
)
2594 Add_Item
(Defining_Entity
(Decl
), States_And_Vars
);
2600 end Collect_States_And_Variables
;
2604 Inits
: constant Node_Id
:=
2605 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
2608 -- Start of processing for Analyze_Initializes_In_Decl_Part
2613 Check_SPARK_Aspect_For_ASIS
(N
);
2615 -- Nothing to do when the initialization list is empty
2617 if Nkind
(Inits
) = N_Null
then
2621 -- Single and multiple initialization clauses appear as an aggregate. If
2622 -- this is not the case, then either the parser or the analysis of the
2623 -- pragma failed to produce an aggregate.
2625 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2627 -- Initialize the various lists used during analysis
2629 Collect_States_And_Variables
;
2631 if Present
(Expressions
(Inits
)) then
2632 Init
:= First
(Expressions
(Inits
));
2633 while Present
(Init
) loop
2634 Analyze_Initialization_Item
(Init
);
2639 if Present
(Component_Associations
(Inits
)) then
2640 Init
:= First
(Component_Associations
(Inits
));
2641 while Present
(Init
) loop
2642 Analyze_Initialization_Item_With_Inputs
(Init
);
2647 -- Ensure that a state and a corresponding constituent do not appear
2648 -- together in pragma Initializes.
2650 Check_State_And_Constituent_Use
2651 (States
=> States_Seen
,
2652 Constits
=> Constits_Seen
,
2654 end Analyze_Initializes_In_Decl_Part
;
2656 --------------------
2657 -- Analyze_Pragma --
2658 --------------------
2660 procedure Analyze_Pragma
(N
: Node_Id
) is
2661 Loc
: constant Source_Ptr
:= Sloc
(N
);
2662 Prag_Id
: Pragma_Id
;
2665 -- Name of the source pragma, or name of the corresponding aspect for
2666 -- pragmas which originate in a source aspect. In the latter case, the
2667 -- name may be different from the pragma name.
2669 Pragma_Exit
: exception;
2670 -- This exception is used to exit pragma processing completely. It
2671 -- is used when an error is detected, and no further processing is
2672 -- required. It is also used if an earlier error has left the tree in
2673 -- a state where the pragma should not be processed.
2676 -- Number of pragma argument associations
2682 -- First four pragma arguments (pragma argument association nodes, or
2683 -- Empty if the corresponding argument does not exist).
2685 type Name_List
is array (Natural range <>) of Name_Id
;
2686 type Args_List
is array (Natural range <>) of Node_Id
;
2687 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2689 -----------------------
2690 -- Local Subprograms --
2691 -----------------------
2693 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
2694 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2695 -- get the given string argument, and place it in Name_Buffer, adding
2696 -- leading and trailing asterisks if they are not already present. The
2697 -- caller has already checked that Arg is a static string expression.
2699 procedure Ada_2005_Pragma
;
2700 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2701 -- Ada 95 mode, these are implementation defined pragmas, so should be
2702 -- caught by the No_Implementation_Pragmas restriction.
2704 procedure Ada_2012_Pragma
;
2705 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2706 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2707 -- should be caught by the No_Implementation_Pragmas restriction.
2709 procedure Analyze_Part_Of
2710 (Item_Id
: Entity_Id
;
2713 Legal
: out Boolean);
2714 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2715 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2716 -- an abstract state, variable or package instantiation. State is the
2717 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2718 -- set when the indicator is legal.
2720 procedure Analyze_Refined_Pragma
2721 (Spec_Id
: out Entity_Id
;
2722 Body_Id
: out Entity_Id
;
2723 Legal
: out Boolean);
2724 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2725 -- Refined_Global and Refined_Post. Check the placement and related
2726 -- context of the pragma. Spec_Id is the entity of the related
2727 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2728 -- Legal is set when the pragma is properly placed.
2730 procedure Check_Ada_83_Warning
;
2731 -- Issues a warning message for the current pragma if operating in Ada
2732 -- 83 mode (used for language pragmas that are not a standard part of
2733 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
2736 procedure Check_Arg_Count
(Required
: Nat
);
2737 -- Check argument count for pragma is equal to given parameter. If not,
2738 -- then issue an error message and raise Pragma_Exit.
2740 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2741 -- Arg which can either be a pragma argument association, in which case
2742 -- the check is applied to the expression of the association or an
2743 -- expression directly.
2745 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
2746 -- Check that an argument has the right form for an EXTERNAL_NAME
2747 -- parameter of an extended import/export pragma. The rule is that the
2748 -- name must be an identifier or string literal (in Ada 83 mode) or a
2749 -- static string expression (in Ada 95 mode).
2751 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
2752 -- Check the specified argument Arg to make sure that it is an
2753 -- identifier. If not give error and raise Pragma_Exit.
2755 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
2756 -- Check the specified argument Arg to make sure that it is an integer
2757 -- literal. If not give error and raise Pragma_Exit.
2759 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
2760 -- Check the specified argument Arg to make sure that it has the proper
2761 -- syntactic form for a local name and meets the semantic requirements
2762 -- for a local name. The local name is analyzed as part of the
2763 -- processing for this call. In addition, the local name is required
2764 -- to represent an entity at the library level.
2766 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
2767 -- Check the specified argument Arg to make sure that it has the proper
2768 -- syntactic form for a local name and meets the semantic requirements
2769 -- for a local name. The local name is analyzed as part of the
2770 -- processing for this call.
2772 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
2773 -- Check the specified argument Arg to make sure that it is a valid
2774 -- locking policy name. If not give error and raise Pragma_Exit.
2776 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
2777 -- Check the specified argument Arg to make sure that it is a valid
2778 -- elaboration policy name. If not give error and raise Pragma_Exit.
2780 procedure Check_Arg_Is_One_Of
2783 procedure Check_Arg_Is_One_Of
2785 N1
, N2
, N3
: Name_Id
);
2786 procedure Check_Arg_Is_One_Of
2788 N1
, N2
, N3
, N4
: Name_Id
);
2789 procedure Check_Arg_Is_One_Of
2791 N1
, N2
, N3
, N4
, N5
: Name_Id
);
2792 -- Check the specified argument Arg to make sure that it is an
2793 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2794 -- present). If not then give error and raise Pragma_Exit.
2796 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
2797 -- Check the specified argument Arg to make sure that it is a valid
2798 -- queuing policy name. If not give error and raise Pragma_Exit.
2800 procedure Check_Arg_Is_OK_Static_Expression
2802 Typ
: Entity_Id
:= Empty
);
2803 -- Check the specified argument Arg to make sure that it is a static
2804 -- expression of the given type (i.e. it will be analyzed and resolved
2805 -- using this type, which can be any valid argument to Resolve, e.g.
2806 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2807 -- Typ is left Empty, then any static expression is allowed. Includes
2808 -- checking that the argument does not raise Constraint_Error.
2810 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
2811 -- Check the specified argument Arg to make sure that it is a valid task
2812 -- dispatching policy name. If not give error and raise Pragma_Exit.
2814 procedure Check_Arg_Order
(Names
: Name_List
);
2815 -- Checks for an instance of two arguments with identifiers for the
2816 -- current pragma which are not in the sequence indicated by Names,
2817 -- and if so, generates a fatal message about bad order of arguments.
2819 procedure Check_At_Least_N_Arguments
(N
: Nat
);
2820 -- Check there are at least N arguments present
2822 procedure Check_At_Most_N_Arguments
(N
: Nat
);
2823 -- Check there are no more than N arguments present
2825 procedure Check_Component
2828 In_Variant_Part
: Boolean := False);
2829 -- Examine an Unchecked_Union component for correct use of per-object
2830 -- constrained subtypes, and for restrictions on finalizable components.
2831 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2832 -- should be set when Comp comes from a record variant.
2834 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
);
2835 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2836 -- Initial_Condition and Initializes. Determine whether pragma First
2837 -- appears before pragma Second. If this is not the case, emit an error.
2839 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
2840 -- Check if a rep item of the same name as the current pragma is already
2841 -- chained as a rep pragma to the given entity. If so give a message
2842 -- about the duplicate, and then raise Pragma_Exit so does not return.
2843 -- Note that if E is a type, then this routine avoids flagging a pragma
2844 -- which applies to a parent type from which E is derived.
2846 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
2847 -- Nam is an N_String_Literal node containing the external name set by
2848 -- an Import or Export pragma (or extended Import or Export pragma).
2849 -- This procedure checks for possible duplications if this is the export
2850 -- case, and if found, issues an appropriate error message.
2852 procedure Check_Expr_Is_OK_Static_Expression
2854 Typ
: Entity_Id
:= Empty
);
2855 -- Check the specified expression Expr to make sure that it is a static
2856 -- expression of the given type (i.e. it will be analyzed and resolved
2857 -- using this type, which can be any valid argument to Resolve, e.g.
2858 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2859 -- Typ is left Empty, then any static expression is allowed. Includes
2860 -- checking that the expression does not raise Constraint_Error.
2862 procedure Check_First_Subtype
(Arg
: Node_Id
);
2863 -- Checks that Arg, whose expression is an entity name, references a
2866 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2867 -- Checks that the given argument has an identifier, and if so, requires
2868 -- it to match the given identifier name. If there is no identifier, or
2869 -- a non-matching identifier, then an error message is given and
2870 -- Pragma_Exit is raised.
2872 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
2873 -- Checks that the given argument has an identifier, and if so, requires
2874 -- it to match one of the given identifier names. If there is no
2875 -- identifier, or a non-matching identifier, then an error message is
2876 -- given and Pragma_Exit is raised.
2878 procedure Check_In_Main_Program
;
2879 -- Common checks for pragmas that appear within a main program
2880 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2882 procedure Check_Interrupt_Or_Attach_Handler
;
2883 -- Common processing for first argument of pragma Interrupt_Handler or
2884 -- pragma Attach_Handler.
2886 procedure Check_Loop_Pragma_Placement
;
2887 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2888 -- appear immediately within a construct restricted to loops, and that
2889 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2891 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
2892 -- Check that pragma appears in a declarative part, or in a package
2893 -- specification, i.e. that it does not occur in a statement sequence
2896 procedure Check_No_Identifier
(Arg
: Node_Id
);
2897 -- Checks that the given argument does not have an identifier. If
2898 -- an identifier is present, then an error message is issued, and
2899 -- Pragma_Exit is raised.
2901 procedure Check_No_Identifiers
;
2902 -- Checks that none of the arguments to the pragma has an identifier.
2903 -- If any argument has an identifier, then an error message is issued,
2904 -- and Pragma_Exit is raised.
2906 procedure Check_No_Link_Name
;
2907 -- Checks that no link name is specified
2909 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2910 -- Checks if the given argument has an identifier, and if so, requires
2911 -- it to match the given identifier name. If there is a non-matching
2912 -- identifier, then an error message is given and Pragma_Exit is raised.
2914 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
2915 -- Checks if the given argument has an identifier, and if so, requires
2916 -- it to match the given identifier name. If there is a non-matching
2917 -- identifier, then an error message is given and Pragma_Exit is raised.
2918 -- In this version of the procedure, the identifier name is given as
2919 -- a string with lower case letters.
2921 procedure Check_Pre_Post
;
2922 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
2923 -- pragmas. These are processed by transformation to equivalent
2924 -- Precondition and Postcondition pragmas, but Pre and Post need an
2925 -- additional check that they are not used in a subprogram body when
2926 -- there is a separate spec present.
2928 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
2929 -- Called to process a precondition or postcondition pragma. There are
2932 -- The pragma appears after a subprogram spec
2934 -- If the corresponding check is not enabled, the pragma is analyzed
2935 -- but otherwise ignored and control returns with In_Body set False.
2937 -- If the check is enabled, then the first step is to analyze the
2938 -- pragma, but this is skipped if the subprogram spec appears within
2939 -- a package specification (because this is the case where we delay
2940 -- analysis till the end of the spec). Then (whether or not it was
2941 -- analyzed), the pragma is chained to the subprogram in question
2942 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
2943 -- to the caller with In_Body set False.
2945 -- The pragma appears at the start of subprogram body declarations
2947 -- In this case an immediate return to the caller is made with
2948 -- In_Body set True, and the pragma is NOT analyzed.
2950 -- In all other cases, an error message for bad placement is given
2952 procedure Check_Static_Constraint
(Constr
: Node_Id
);
2953 -- Constr is a constraint from an N_Subtype_Indication node from a
2954 -- component constraint in an Unchecked_Union type. This routine checks
2955 -- that the constraint is static as required by the restrictions for
2958 procedure Check_Test_Case
;
2959 -- Called to process a test-case pragma. It starts with checking pragma
2960 -- arguments, and the rest of the treatment is similar to the one for
2961 -- pre- and postcondition in Check_Precondition_Postcondition, except
2962 -- the placement rules for the test-case pragma are stricter. These
2963 -- pragmas may only occur after a subprogram spec declared directly
2964 -- in a package spec unit. In this case, the pragma is chained to the
2965 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
2966 -- and analysis of the pragma is delayed till the end of the spec. In
2967 -- all other cases, an error message for bad placement is given.
2969 procedure Check_Valid_Configuration_Pragma
;
2970 -- Legality checks for placement of a configuration pragma
2972 procedure Check_Valid_Library_Unit_Pragma
;
2973 -- Legality checks for library unit pragmas. A special case arises for
2974 -- pragmas in generic instances that come from copies of the original
2975 -- library unit pragmas in the generic templates. In the case of other
2976 -- than library level instantiations these can appear in contexts which
2977 -- would normally be invalid (they only apply to the original template
2978 -- and to library level instantiations), and they are simply ignored,
2979 -- which is implemented by rewriting them as null statements.
2981 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
2982 -- Check an Unchecked_Union variant for lack of nested variants and
2983 -- presence of at least one component. UU_Typ is the related Unchecked_
2986 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
2987 -- Subsidiary routine to the processing of pragmas Abstract_State,
2988 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
2989 -- Refined_Global and Refined_State. Transform argument Arg into an
2990 -- aggregate if not one already. N_Null is never transformed.
2992 procedure Error_Pragma
(Msg
: String);
2993 pragma No_Return
(Error_Pragma
);
2994 -- Outputs error message for current pragma. The message contains a %
2995 -- that will be replaced with the pragma name, and the flag is placed
2996 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2997 -- calls Fix_Error (see spec of that procedure for details).
2999 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3000 pragma No_Return
(Error_Pragma_Arg
);
3001 -- Outputs error message for current pragma. The message may contain
3002 -- a % that will be replaced with the pragma name. The parameter Arg
3003 -- may either be a pragma argument association, in which case the flag
3004 -- is placed on the expression of this association, or an expression,
3005 -- in which case the flag is placed directly on the expression. The
3006 -- message is placed using Error_Msg_N, so the message may also contain
3007 -- an & insertion character which will reference the given Arg value.
3008 -- After placing the message, Pragma_Exit is raised. Note: this routine
3009 -- calls Fix_Error (see spec of that procedure for details).
3011 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3012 pragma No_Return
(Error_Pragma_Arg
);
3013 -- Similar to above form of Error_Pragma_Arg except that two messages
3014 -- are provided, the second is a continuation comment starting with \.
3016 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3017 pragma No_Return
(Error_Pragma_Arg_Ident
);
3018 -- Outputs error message for current pragma. The message may contain a %
3019 -- that will be replaced with the pragma name. The parameter Arg must be
3020 -- a pragma argument association with a non-empty identifier (i.e. its
3021 -- Chars field must be set), and the error message is placed on the
3022 -- identifier. The message is placed using Error_Msg_N so the message
3023 -- may also contain an & insertion character which will reference
3024 -- the identifier. After placing the message, Pragma_Exit is raised.
3025 -- Note: this routine calls Fix_Error (see spec of that procedure for
3028 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3029 pragma No_Return
(Error_Pragma_Ref
);
3030 -- Outputs error message for current pragma. The message may contain
3031 -- a % that will be replaced with the pragma name. The parameter Ref
3032 -- must be an entity whose name can be referenced by & and sloc by #.
3033 -- After placing the message, Pragma_Exit is raised. Note: this routine
3034 -- calls Fix_Error (see spec of that procedure for details).
3036 function Find_Lib_Unit_Name
return Entity_Id
;
3037 -- Used for a library unit pragma to find the entity to which the
3038 -- library unit pragma applies, returns the entity found.
3040 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3041 -- If the pragma is a compilation unit pragma, the id must denote the
3042 -- compilation unit in the same compilation, and the pragma must appear
3043 -- in the list of preceding or trailing pragmas. If it is a program
3044 -- unit pragma that is not a compilation unit pragma, then the
3045 -- identifier must be visible.
3047 function Find_Unique_Parameterless_Procedure
3049 Arg
: Node_Id
) return Entity_Id
;
3050 -- Used for a procedure pragma to find the unique parameterless
3051 -- procedure identified by Name, returns it if it exists, otherwise
3052 -- errors out and uses Arg as the pragma argument for the message.
3054 function Fix_Error
(Msg
: String) return String;
3055 -- This is called prior to issuing an error message. Msg is the normal
3056 -- error message issued in the pragma case. This routine checks for the
3057 -- case of a pragma coming from an aspect in the source, and returns a
3058 -- message suitable for the aspect case as follows:
3060 -- Each substring "pragma" is replaced by "aspect"
3062 -- If "argument of" is at the start of the error message text, it is
3063 -- replaced by "entity for".
3065 -- If "argument" is at the start of the error message text, it is
3066 -- replaced by "entity".
3068 -- So for example, "argument of pragma X must be discrete type"
3069 -- returns "entity for aspect X must be a discrete type".
3071 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3072 -- be different from the pragma name). If the current pragma results
3073 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3074 -- original pragma name.
3076 procedure Gather_Associations
3078 Args
: out Args_List
);
3079 -- This procedure is used to gather the arguments for a pragma that
3080 -- permits arbitrary ordering of parameters using the normal rules
3081 -- for named and positional parameters. The Names argument is a list
3082 -- of Name_Id values that corresponds to the allowed pragma argument
3083 -- association identifiers in order. The result returned in Args is
3084 -- a list of corresponding expressions that are the pragma arguments.
3085 -- Note that this is a list of expressions, not of pragma argument
3086 -- associations (Gather_Associations has completely checked all the
3087 -- optional identifiers when it returns). An entry in Args is Empty
3088 -- on return if the corresponding argument is not present.
3090 procedure GNAT_Pragma
;
3091 -- Called for all GNAT defined pragmas to check the relevant restriction
3092 -- (No_Implementation_Pragmas).
3094 function Is_Before_First_Decl
3095 (Pragma_Node
: Node_Id
;
3096 Decls
: List_Id
) return Boolean;
3097 -- Return True if Pragma_Node is before the first declarative item in
3098 -- Decls where Decls is the list of declarative items.
3100 function Is_Configuration_Pragma
return Boolean;
3101 -- Determines if the placement of the current pragma is appropriate
3102 -- for a configuration pragma.
3104 function Is_In_Context_Clause
return Boolean;
3105 -- Returns True if pragma appears within the context clause of a unit,
3106 -- and False for any other placement (does not generate any messages).
3108 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3109 -- Analyzes the argument, and determines if it is a static string
3110 -- expression, returns True if so, False if non-static or not String.
3111 -- A special case is that a string literal returns True in Ada 83 mode
3112 -- (which has no such thing as static string expressions).
3114 procedure Pragma_Misplaced
;
3115 pragma No_Return
(Pragma_Misplaced
);
3116 -- Issue fatal error message for misplaced pragma
3118 procedure Process_Atomic_Shared_Volatile
;
3119 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3120 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3121 -- in effect to pragma Atomic.
3123 procedure Process_Compile_Time_Warning_Or_Error
;
3124 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3126 procedure Process_Convention
3127 (C
: out Convention_Id
;
3128 Ent
: out Entity_Id
);
3129 -- Common processing for Convention, Interface, Import and Export.
3130 -- Checks first two arguments of pragma, and sets the appropriate
3131 -- convention value in the specified entity or entities. On return
3132 -- C is the convention, Ent is the referenced entity.
3134 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3135 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3136 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3138 procedure Process_Extended_Import_Export_Object_Pragma
3139 (Arg_Internal
: Node_Id
;
3140 Arg_External
: Node_Id
;
3141 Arg_Size
: Node_Id
);
3142 -- Common processing for the pragmas Import/Export_Object. The three
3143 -- arguments correspond to the three named parameters of the pragmas. An
3144 -- argument is empty if the corresponding parameter is not present in
3147 procedure Process_Extended_Import_Export_Internal_Arg
3148 (Arg_Internal
: Node_Id
:= Empty
);
3149 -- Common processing for all extended Import and Export pragmas. The
3150 -- argument is the pragma parameter for the Internal argument. If
3151 -- Arg_Internal is empty or inappropriate, an error message is posted.
3152 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3153 -- set to identify the referenced entity.
3155 procedure Process_Extended_Import_Export_Subprogram_Pragma
3156 (Arg_Internal
: Node_Id
;
3157 Arg_External
: Node_Id
;
3158 Arg_Parameter_Types
: Node_Id
;
3159 Arg_Result_Type
: Node_Id
:= Empty
;
3160 Arg_Mechanism
: Node_Id
;
3161 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3162 -- Common processing for all extended Import and Export pragmas applying
3163 -- to subprograms. The caller omits any arguments that do not apply to
3164 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3165 -- only in the Import_Function and Export_Function cases). The argument
3166 -- names correspond to the allowed pragma association identifiers.
3168 procedure Process_Generic_List
;
3169 -- Common processing for Share_Generic and Inline_Generic
3171 procedure Process_Import_Or_Interface
;
3172 -- Common processing for Import of Interface
3174 procedure Process_Import_Predefined_Type
;
3175 -- Processing for completing a type with pragma Import. This is used
3176 -- to declare types that match predefined C types, especially for cases
3177 -- without corresponding Ada predefined type.
3179 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3180 -- Inline status of a subprogram, indicated as follows:
3181 -- Suppressed: inlining is suppressed for the subprogram
3182 -- Disabled: no inlining is requested for the subprogram
3183 -- Enabled: inlining is requested/required for the subprogram
3185 procedure Process_Inline
(Status
: Inline_Status
);
3186 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3187 -- indicates the inline status specified by the pragma.
3189 procedure Process_Interface_Name
3190 (Subprogram_Def
: Entity_Id
;
3192 Link_Arg
: Node_Id
);
3193 -- Given the last two arguments of pragma Import, pragma Export, or
3194 -- pragma Interface_Name, performs validity checks and sets the
3195 -- Interface_Name field of the given subprogram entity to the
3196 -- appropriate external or link name, depending on the arguments given.
3197 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3198 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3199 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3200 -- nor Link_Arg is present, the interface name is set to the default
3201 -- from the subprogram name.
3203 procedure Process_Interrupt_Or_Attach_Handler
;
3204 -- Common processing for Interrupt and Attach_Handler pragmas
3206 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3207 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3208 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3209 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3210 -- is not set in the Restrictions case.
3212 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3213 -- Common processing for Suppress and Unsuppress. The boolean parameter
3214 -- Suppress_Case is True for the Suppress case, and False for the
3217 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3218 -- This procedure sets the Is_Exported flag for the given entity,
3219 -- checking that the entity was not previously imported. Arg is
3220 -- the argument that specified the entity. A check is also made
3221 -- for exporting inappropriate entities.
3223 procedure Set_Extended_Import_Export_External_Name
3224 (Internal_Ent
: Entity_Id
;
3225 Arg_External
: Node_Id
);
3226 -- Common processing for all extended import export pragmas. The first
3227 -- argument, Internal_Ent, is the internal entity, which has already
3228 -- been checked for validity by the caller. Arg_External is from the
3229 -- Import or Export pragma, and may be null if no External parameter
3230 -- was present. If Arg_External is present and is a non-null string
3231 -- (a null string is treated as the default), then the Interface_Name
3232 -- field of Internal_Ent is set appropriately.
3234 procedure Set_Imported
(E
: Entity_Id
);
3235 -- This procedure sets the Is_Imported flag for the given entity,
3236 -- checking that it is not previously exported or imported.
3238 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3239 -- Mech is a parameter passing mechanism (see Import_Function syntax
3240 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3241 -- has the right form, and if not issues an error message. If the
3242 -- argument has the right form then the Mechanism field of Ent is
3243 -- set appropriately.
3245 procedure Set_Rational_Profile
;
3246 -- Activate the set of configuration pragmas and permissions that make
3247 -- up the Rational profile.
3249 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3250 -- Activate the set of configuration pragmas and restrictions that make
3251 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3252 -- is used for error messages on any constructs violating the profile.
3254 ----------------------------------
3255 -- Acquire_Warning_Match_String --
3256 ----------------------------------
3258 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3260 String_To_Name_Buffer
3261 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3263 -- Add asterisk at start if not already there
3265 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3266 Name_Buffer
(2 .. Name_Len
+ 1) :=
3267 Name_Buffer
(1 .. Name_Len
);
3268 Name_Buffer
(1) := '*';
3269 Name_Len
:= Name_Len
+ 1;
3272 -- Add asterisk at end if not already there
3274 if Name_Buffer
(Name_Len
) /= '*' then
3275 Name_Len
:= Name_Len
+ 1;
3276 Name_Buffer
(Name_Len
) := '*';
3278 end Acquire_Warning_Match_String
;
3280 ---------------------
3281 -- Ada_2005_Pragma --
3282 ---------------------
3284 procedure Ada_2005_Pragma
is
3286 if Ada_Version
<= Ada_95
then
3287 Check_Restriction
(No_Implementation_Pragmas
, N
);
3289 end Ada_2005_Pragma
;
3291 ---------------------
3292 -- Ada_2012_Pragma --
3293 ---------------------
3295 procedure Ada_2012_Pragma
is
3297 if Ada_Version
<= Ada_2005
then
3298 Check_Restriction
(No_Implementation_Pragmas
, N
);
3300 end Ada_2012_Pragma
;
3302 ---------------------
3303 -- Analyze_Part_Of --
3304 ---------------------
3306 procedure Analyze_Part_Of
3307 (Item_Id
: Entity_Id
;
3310 Legal
: out Boolean)
3312 Pack_Id
: Entity_Id
;
3313 Placement
: State_Space_Kind
;
3314 Parent_Unit
: Entity_Id
;
3315 State_Id
: Entity_Id
;
3318 -- Assume that the pragma/option is illegal
3322 if Nkind_In
(State
, N_Expanded_Name
,
3324 N_Selected_Component
)
3327 Resolve_State
(State
);
3329 if Is_Entity_Name
(State
)
3330 and then Ekind
(Entity
(State
)) = E_Abstract_State
3332 State_Id
:= Entity
(State
);
3336 ("indicator Part_Of must denote an abstract state", State
);
3340 -- This is a syntax error, always report
3344 ("indicator Part_Of must denote an abstract state", State
);
3348 -- Determine where the state, variable or the package instantiation
3349 -- lives with respect to the enclosing packages or package bodies (if
3350 -- any). This placement dictates the legality of the encapsulating
3353 Find_Placement_In_State_Space
3354 (Item_Id
=> Item_Id
,
3355 Placement
=> Placement
,
3356 Pack_Id
=> Pack_Id
);
3358 -- The item appears in a non-package construct with a declarative
3359 -- part (subprogram, block, etc). As such, the item is not allowed
3360 -- to be a part of an encapsulating state because the item is not
3363 if Placement
= Not_In_Package
then
3365 ("indicator Part_Of cannot appear in this context "
3366 & "(SPARK RM 7.2.6(5))", Indic
);
3367 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3369 ("\& is not part of the hidden state of package %",
3372 -- The item appears in the visible state space of some package. In
3373 -- general this scenario does not warrant Part_Of except when the
3374 -- package is a private child unit and the encapsulating state is
3375 -- declared in a parent unit or a public descendant of that parent
3378 elsif Placement
= Visible_State_Space
then
3379 if Is_Child_Unit
(Pack_Id
)
3380 and then Is_Private_Descendant
(Pack_Id
)
3382 -- A variable or state abstraction which is part of the
3383 -- visible state of a private child unit (or one of its public
3384 -- descendants) must have its Part_Of indicator specified. The
3385 -- Part_Of indicator must denote a state abstraction declared
3386 -- by either the parent unit of the private unit or by a public
3387 -- descendant of that parent unit.
3389 -- Find nearest private ancestor (which can be the current unit
3392 Parent_Unit
:= Pack_Id
;
3393 while Present
(Parent_Unit
) loop
3394 exit when Private_Present
3395 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3396 Parent_Unit
:= Scope
(Parent_Unit
);
3399 Parent_Unit
:= Scope
(Parent_Unit
);
3401 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3403 ("indicator Part_Of must denote an abstract state of& "
3404 & "or public descendant (SPARK RM 7.2.6(3))",
3405 Indic
, Parent_Unit
);
3407 elsif Scope
(State_Id
) = Parent_Unit
3408 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3410 not Is_Private_Descendant
(Scope
(State_Id
)))
3416 ("indicator Part_Of must denote an abstract state of& "
3417 & "or public descendant (SPARK RM 7.2.6(3))",
3418 Indic
, Parent_Unit
);
3421 -- Indicator Part_Of is not needed when the related package is not
3422 -- a private child unit or a public descendant thereof.
3426 ("indicator Part_Of cannot appear in this context "
3427 & "(SPARK RM 7.2.6(5))", Indic
);
3428 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3430 ("\& is declared in the visible part of package %",
3434 -- When the item appears in the private state space of a package, the
3435 -- encapsulating state must be declared in the same package.
3437 elsif Placement
= Private_State_Space
then
3438 if Scope
(State_Id
) /= Pack_Id
then
3440 ("indicator Part_Of must designate an abstract state of "
3441 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3442 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3444 ("\& is declared in the private part of package %",
3448 -- Items declared in the body state space of a package do not need
3449 -- Part_Of indicators as the refinement has already been seen.
3453 ("indicator Part_Of cannot appear in this context "
3454 & "(SPARK RM 7.2.6(5))", Indic
);
3456 if Scope
(State_Id
) = Pack_Id
then
3457 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3459 ("\& is declared in the body of package %", Indic
, Item_Id
);
3464 end Analyze_Part_Of
;
3466 ----------------------------
3467 -- Analyze_Refined_Pragma --
3468 ----------------------------
3470 procedure Analyze_Refined_Pragma
3471 (Spec_Id
: out Entity_Id
;
3472 Body_Id
: out Entity_Id
;
3473 Legal
: out Boolean)
3475 Body_Decl
: Node_Id
;
3476 Spec_Decl
: Node_Id
;
3479 -- Assume that the pragma is illegal
3486 Check_Arg_Count
(1);
3487 Check_No_Identifiers
;
3489 if Nam_In
(Pname
, Name_Refined_Depends
,
3490 Name_Refined_Global
,
3493 Ensure_Aggregate_Form
(Arg1
);
3496 -- Verify the placement of the pragma and check for duplicates. The
3497 -- pragma must apply to a subprogram body [stub].
3499 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3501 -- Extract the entities of the spec and body
3503 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3504 Body_Id
:= Defining_Entity
(Body_Decl
);
3505 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3507 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3508 Body_Id
:= Defining_Entity
(Body_Decl
);
3509 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3516 -- The pragma must apply to the second declaration of a subprogram.
3517 -- In other words, the body [stub] cannot acts as a spec.
3519 if No
(Spec_Id
) then
3520 Error_Pragma
("pragma % cannot apply to a stand alone body");
3523 -- Catch the case where the subprogram body is a subunit and acts as
3524 -- the third declaration of the subprogram.
3526 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3527 Error_Pragma
("pragma % cannot apply to a subunit");
3531 -- The pragma can only apply to the body [stub] of a subprogram
3532 -- declared in the visible part of a package. Retrieve the context of
3533 -- the subprogram declaration.
3535 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3537 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3539 ("pragma % must apply to the body of a subprogram declared in a "
3540 & "package specification");
3544 -- If we get here, then the pragma is legal
3547 end Analyze_Refined_Pragma
;
3549 --------------------------
3550 -- Check_Ada_83_Warning --
3551 --------------------------
3553 procedure Check_Ada_83_Warning
is
3555 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3556 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3558 end Check_Ada_83_Warning
;
3560 ---------------------
3561 -- Check_Arg_Count --
3562 ---------------------
3564 procedure Check_Arg_Count
(Required
: Nat
) is
3566 if Arg_Count
/= Required
then
3567 Error_Pragma
("wrong number of arguments for pragma%");
3569 end Check_Arg_Count
;
3571 --------------------------------
3572 -- Check_Arg_Is_External_Name --
3573 --------------------------------
3575 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3576 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3579 if Nkind
(Argx
) = N_Identifier
then
3583 Analyze_And_Resolve
(Argx
, Standard_String
);
3585 if Is_OK_Static_Expression
(Argx
) then
3588 elsif Etype
(Argx
) = Any_Type
then
3591 -- An interesting special case, if we have a string literal and
3592 -- we are in Ada 83 mode, then we allow it even though it will
3593 -- not be flagged as static. This allows expected Ada 83 mode
3594 -- use of external names which are string literals, even though
3595 -- technically these are not static in Ada 83.
3597 elsif Ada_Version
= Ada_83
3598 and then Nkind
(Argx
) = N_String_Literal
3602 -- Static expression that raises Constraint_Error. This has
3603 -- already been flagged, so just exit from pragma processing.
3605 elsif Is_OK_Static_Expression
(Argx
) then
3608 -- Here we have a real error (non-static expression)
3611 Error_Msg_Name_1
:= Pname
;
3614 Msg
: constant String :=
3615 "argument for pragma% must be a identifier or "
3616 & "static string expression!";
3618 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3623 end Check_Arg_Is_External_Name
;
3625 -----------------------------
3626 -- Check_Arg_Is_Identifier --
3627 -----------------------------
3629 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3630 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3632 if Nkind
(Argx
) /= N_Identifier
then
3634 ("argument for pragma% must be identifier", Argx
);
3636 end Check_Arg_Is_Identifier
;
3638 ----------------------------------
3639 -- Check_Arg_Is_Integer_Literal --
3640 ----------------------------------
3642 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3643 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3645 if Nkind
(Argx
) /= N_Integer_Literal
then
3647 ("argument for pragma% must be integer literal", Argx
);
3649 end Check_Arg_Is_Integer_Literal
;
3651 -------------------------------------------
3652 -- Check_Arg_Is_Library_Level_Local_Name --
3653 -------------------------------------------
3657 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3658 -- | library_unit_NAME
3660 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3662 Check_Arg_Is_Local_Name
(Arg
);
3664 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3665 and then Comes_From_Source
(N
)
3668 ("argument for pragma% must be library level entity", Arg
);
3670 end Check_Arg_Is_Library_Level_Local_Name
;
3672 -----------------------------
3673 -- Check_Arg_Is_Local_Name --
3674 -----------------------------
3678 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3679 -- | library_unit_NAME
3681 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3682 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3687 if Nkind
(Argx
) not in N_Direct_Name
3688 and then (Nkind
(Argx
) /= N_Attribute_Reference
3689 or else Present
(Expressions
(Argx
))
3690 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3691 and then (not Is_Entity_Name
(Argx
)
3692 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3694 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3697 -- No further check required if not an entity name
3699 if not Is_Entity_Name
(Argx
) then
3705 Ent
: constant Entity_Id
:= Entity
(Argx
);
3706 Scop
: constant Entity_Id
:= Scope
(Ent
);
3709 -- Case of a pragma applied to a compilation unit: pragma must
3710 -- occur immediately after the program unit in the compilation.
3712 if Is_Compilation_Unit
(Ent
) then
3714 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3717 -- Case of pragma placed immediately after spec
3719 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3722 -- Case of pragma placed immediately after body
3724 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3725 and then Present
(Corresponding_Body
(Decl
))
3729 (Parent
(Unit_Declaration_Node
3730 (Corresponding_Body
(Decl
))));
3732 -- All other cases are illegal
3739 -- Special restricted placement rule from 10.2.1(11.8/2)
3741 elsif Is_Generic_Formal
(Ent
)
3742 and then Prag_Id
= Pragma_Preelaborable_Initialization
3744 OK
:= List_Containing
(N
) =
3745 Generic_Formal_Declarations
3746 (Unit_Declaration_Node
(Scop
));
3748 -- If this is an aspect applied to a subprogram body, the
3749 -- pragma is inserted in its declarative part.
3751 elsif From_Aspect_Specification
(N
)
3752 and then Ent
= Current_Scope
3754 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3758 -- If the aspect is a predicate (possibly others ???) and the
3759 -- context is a record type, this is a discriminant expression
3760 -- within a type declaration, that freezes the predicated
3763 elsif From_Aspect_Specification
(N
)
3764 and then Prag_Id
= Pragma_Predicate
3765 and then Ekind
(Current_Scope
) = E_Record_Type
3766 and then Scop
= Scope
(Current_Scope
)
3770 -- Default case, just check that the pragma occurs in the scope
3771 -- of the entity denoted by the name.
3774 OK
:= Current_Scope
= Scop
;
3779 ("pragma% argument must be in same declarative part", Arg
);
3783 end Check_Arg_Is_Local_Name
;
3785 ---------------------------------
3786 -- Check_Arg_Is_Locking_Policy --
3787 ---------------------------------
3789 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3790 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3793 Check_Arg_Is_Identifier
(Argx
);
3795 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3796 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3798 end Check_Arg_Is_Locking_Policy
;
3800 -----------------------------------------------
3801 -- Check_Arg_Is_Partition_Elaboration_Policy --
3802 -----------------------------------------------
3804 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3805 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3808 Check_Arg_Is_Identifier
(Argx
);
3810 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3812 ("& is not a valid partition elaboration policy name", Argx
);
3814 end Check_Arg_Is_Partition_Elaboration_Policy
;
3816 -------------------------
3817 -- Check_Arg_Is_One_Of --
3818 -------------------------
3820 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3821 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3824 Check_Arg_Is_Identifier
(Argx
);
3826 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3827 Error_Msg_Name_2
:= N1
;
3828 Error_Msg_Name_3
:= N2
;
3829 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3831 end Check_Arg_Is_One_Of
;
3833 procedure Check_Arg_Is_One_Of
3835 N1
, N2
, N3
: Name_Id
)
3837 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3840 Check_Arg_Is_Identifier
(Argx
);
3842 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3843 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3845 end Check_Arg_Is_One_Of
;
3847 procedure Check_Arg_Is_One_Of
3849 N1
, N2
, N3
, N4
: Name_Id
)
3851 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3854 Check_Arg_Is_Identifier
(Argx
);
3856 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3857 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3859 end Check_Arg_Is_One_Of
;
3861 procedure Check_Arg_Is_One_Of
3863 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3865 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3868 Check_Arg_Is_Identifier
(Argx
);
3870 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3871 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3873 end Check_Arg_Is_One_Of
;
3875 ---------------------------------
3876 -- Check_Arg_Is_Queuing_Policy --
3877 ---------------------------------
3879 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3880 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3883 Check_Arg_Is_Identifier
(Argx
);
3885 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3886 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3888 end Check_Arg_Is_Queuing_Policy
;
3890 ---------------------------------------
3891 -- Check_Arg_Is_OK_Static_Expression --
3892 ---------------------------------------
3894 procedure Check_Arg_Is_OK_Static_Expression
3896 Typ
: Entity_Id
:= Empty
)
3899 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
3900 end Check_Arg_Is_OK_Static_Expression
;
3902 ------------------------------------------
3903 -- Check_Arg_Is_Task_Dispatching_Policy --
3904 ------------------------------------------
3906 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
3907 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3910 Check_Arg_Is_Identifier
(Argx
);
3912 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
3914 ("& is not an allowed task dispatching policy name", Argx
);
3916 end Check_Arg_Is_Task_Dispatching_Policy
;
3918 ---------------------
3919 -- Check_Arg_Order --
3920 ---------------------
3922 procedure Check_Arg_Order
(Names
: Name_List
) is
3925 Highest_So_Far
: Natural := 0;
3926 -- Highest index in Names seen do far
3930 for J
in 1 .. Arg_Count
loop
3931 if Chars
(Arg
) /= No_Name
then
3932 for K
in Names
'Range loop
3933 if Chars
(Arg
) = Names
(K
) then
3934 if K
< Highest_So_Far
then
3935 Error_Msg_Name_1
:= Pname
;
3937 ("parameters out of order for pragma%", Arg
);
3938 Error_Msg_Name_1
:= Names
(K
);
3939 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
3940 Error_Msg_N
("\% must appear before %", Arg
);
3944 Highest_So_Far
:= K
;
3952 end Check_Arg_Order
;
3954 --------------------------------
3955 -- Check_At_Least_N_Arguments --
3956 --------------------------------
3958 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
3960 if Arg_Count
< N
then
3961 Error_Pragma
("too few arguments for pragma%");
3963 end Check_At_Least_N_Arguments
;
3965 -------------------------------
3966 -- Check_At_Most_N_Arguments --
3967 -------------------------------
3969 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
3972 if Arg_Count
> N
then
3974 for J
in 1 .. N
loop
3976 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
3979 end Check_At_Most_N_Arguments
;
3981 ---------------------
3982 -- Check_Component --
3983 ---------------------
3985 procedure Check_Component
3988 In_Variant_Part
: Boolean := False)
3990 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
3991 Sindic
: constant Node_Id
:=
3992 Subtype_Indication
(Component_Definition
(Comp
));
3993 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
3996 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
3997 -- object constraint, then the component type shall be an Unchecked_
4000 if Nkind
(Sindic
) = N_Subtype_Indication
4001 and then Has_Per_Object_Constraint
(Comp_Id
)
4002 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4005 ("component subtype subject to per-object constraint "
4006 & "must be an Unchecked_Union", Comp
);
4008 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4009 -- the body of a generic unit, or within the body of any of its
4010 -- descendant library units, no part of the type of a component
4011 -- declared in a variant_part of the unchecked union type shall be of
4012 -- a formal private type or formal private extension declared within
4013 -- the formal part of the generic unit.
4015 elsif Ada_Version
>= Ada_2012
4016 and then In_Generic_Body
(UU_Typ
)
4017 and then In_Variant_Part
4018 and then Is_Private_Type
(Typ
)
4019 and then Is_Generic_Type
(Typ
)
4022 ("component of unchecked union cannot be of generic type", Comp
);
4024 elsif Needs_Finalization
(Typ
) then
4026 ("component of unchecked union cannot be controlled", Comp
);
4028 elsif Has_Task
(Typ
) then
4030 ("component of unchecked union cannot have tasks", Comp
);
4032 end Check_Component
;
4034 -----------------------------
4035 -- Check_Declaration_Order --
4036 -----------------------------
4038 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4039 procedure Check_Aspect_Specification_Order
;
4040 -- Inspect the aspect specifications of the context to determine the
4043 --------------------------------------
4044 -- Check_Aspect_Specification_Order --
4045 --------------------------------------
4047 procedure Check_Aspect_Specification_Order
is
4048 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4049 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4053 -- Both aspects must be part of the same aspect specification list
4056 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4058 -- Try to reach Second starting from First in a left to right
4059 -- traversal of the aspect specifications.
4061 Asp
:= Next
(Asp_First
);
4062 while Present
(Asp
) loop
4064 -- The order is ok, First is followed by Second
4066 if Asp
= Asp_Second
then
4073 -- If we get here, then the aspects are out of order
4075 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4076 end Check_Aspect_Specification_Order
;
4082 -- Start of processing for Check_Declaration_Order
4085 -- Cannot check the order if one of the pragmas is missing
4087 if No
(First
) or else No
(Second
) then
4091 -- Set up the error names in case the order is incorrect
4093 Error_Msg_Name_1
:= Pragma_Name
(First
);
4094 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4096 if From_Aspect_Specification
(First
) then
4098 -- Both pragmas are actually aspects, check their declaration
4099 -- order in the associated aspect specification list. Otherwise
4100 -- First is an aspect and Second a source pragma.
4102 if From_Aspect_Specification
(Second
) then
4103 Check_Aspect_Specification_Order
;
4106 -- Abstract_States is a source pragma
4109 if From_Aspect_Specification
(Second
) then
4110 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4112 -- Both pragmas are source constructs. Try to reach First from
4113 -- Second by traversing the declarations backwards.
4116 Stmt
:= Prev
(Second
);
4117 while Present
(Stmt
) loop
4119 -- The order is ok, First is followed by Second
4121 if Stmt
= First
then
4128 -- If we get here, then the pragmas are out of order
4130 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4133 end Check_Declaration_Order
;
4135 ----------------------------
4136 -- Check_Duplicate_Pragma --
4137 ----------------------------
4139 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4140 Id
: Entity_Id
:= E
;
4144 -- Nothing to do if this pragma comes from an aspect specification,
4145 -- since we could not be duplicating a pragma, and we dealt with the
4146 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4148 if From_Aspect_Specification
(N
) then
4152 -- Otherwise current pragma may duplicate previous pragma or a
4153 -- previously given aspect specification or attribute definition
4154 -- clause for the same pragma.
4156 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4160 -- If the entity is a type, then we have to make sure that the
4161 -- ostensible duplicate is not for a parent type from which this
4165 if Nkind
(P
) = N_Pragma
then
4167 Args
: constant List_Id
:=
4168 Pragma_Argument_Associations
(P
);
4171 and then Is_Entity_Name
(Expression
(First
(Args
)))
4172 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4173 and then Entity
(Expression
(First
(Args
))) /= E
4179 elsif Nkind
(P
) = N_Aspect_Specification
4180 and then Is_Type
(Entity
(P
))
4181 and then Entity
(P
) /= E
4187 -- Here we have a definite duplicate
4189 Error_Msg_Name_1
:= Pragma_Name
(N
);
4190 Error_Msg_Sloc
:= Sloc
(P
);
4192 -- For a single protected or a single task object, the error is
4193 -- issued on the original entity.
4195 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4196 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4199 if Nkind
(P
) = N_Aspect_Specification
4200 or else From_Aspect_Specification
(P
)
4202 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4204 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4209 end Check_Duplicate_Pragma
;
4211 ----------------------------------
4212 -- Check_Duplicated_Export_Name --
4213 ----------------------------------
4215 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4216 String_Val
: constant String_Id
:= Strval
(Nam
);
4219 -- We are only interested in the export case, and in the case of
4220 -- generics, it is the instance, not the template, that is the
4221 -- problem (the template will generate a warning in any case).
4223 if not Inside_A_Generic
4224 and then (Prag_Id
= Pragma_Export
4226 Prag_Id
= Pragma_Export_Procedure
4228 Prag_Id
= Pragma_Export_Valued_Procedure
4230 Prag_Id
= Pragma_Export_Function
)
4232 for J
in Externals
.First
.. Externals
.Last
loop
4233 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4234 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4235 Error_Msg_N
("external name duplicates name given#", Nam
);
4240 Externals
.Append
(Nam
);
4242 end Check_Duplicated_Export_Name
;
4244 ----------------------------------------
4245 -- Check_Expr_Is_OK_Static_Expression --
4246 ----------------------------------------
4248 procedure Check_Expr_Is_OK_Static_Expression
4250 Typ
: Entity_Id
:= Empty
)
4253 if Present
(Typ
) then
4254 Analyze_And_Resolve
(Expr
, Typ
);
4256 Analyze_And_Resolve
(Expr
);
4259 if Is_OK_Static_Expression
(Expr
) then
4262 elsif Etype
(Expr
) = Any_Type
then
4265 -- An interesting special case, if we have a string literal and we
4266 -- are in Ada 83 mode, then we allow it even though it will not be
4267 -- flagged as static. This allows the use of Ada 95 pragmas like
4268 -- Import in Ada 83 mode. They will of course be flagged with
4269 -- warnings as usual, but will not cause errors.
4271 elsif Ada_Version
= Ada_83
4272 and then Nkind
(Expr
) = N_String_Literal
4276 -- Static expression that raises Constraint_Error. This has already
4277 -- been flagged, so just exit from pragma processing.
4279 elsif Is_OK_Static_Expression
(Expr
) then
4282 -- Finally, we have a real error
4285 Error_Msg_Name_1
:= Pname
;
4286 Flag_Non_Static_Expr
4287 (Fix_Error
("argument for pragma% must be a static expression!"),
4291 end Check_Expr_Is_OK_Static_Expression
;
4293 -------------------------
4294 -- Check_First_Subtype --
4295 -------------------------
4297 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4298 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4299 Ent
: constant Entity_Id
:= Entity
(Argx
);
4302 if Is_First_Subtype
(Ent
) then
4305 elsif Is_Type
(Ent
) then
4307 ("pragma% cannot apply to subtype", Argx
);
4309 elsif Is_Object
(Ent
) then
4311 ("pragma% cannot apply to object, requires a type", Argx
);
4315 ("pragma% cannot apply to&, requires a type", Argx
);
4317 end Check_First_Subtype
;
4319 ----------------------
4320 -- Check_Identifier --
4321 ----------------------
4323 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4326 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4328 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4329 Error_Msg_Name_1
:= Pname
;
4330 Error_Msg_Name_2
:= Id
;
4331 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4335 end Check_Identifier
;
4337 --------------------------------
4338 -- Check_Identifier_Is_One_Of --
4339 --------------------------------
4341 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4344 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4346 if Chars
(Arg
) = No_Name
then
4347 Error_Msg_Name_1
:= Pname
;
4348 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4351 elsif Chars
(Arg
) /= N1
4352 and then Chars
(Arg
) /= N2
4354 Error_Msg_Name_1
:= Pname
;
4355 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4359 end Check_Identifier_Is_One_Of
;
4361 ---------------------------
4362 -- Check_In_Main_Program --
4363 ---------------------------
4365 procedure Check_In_Main_Program
is
4366 P
: constant Node_Id
:= Parent
(N
);
4369 -- Must be at in subprogram body
4371 if Nkind
(P
) /= N_Subprogram_Body
then
4372 Error_Pragma
("% pragma allowed only in subprogram");
4374 -- Otherwise warn if obviously not main program
4376 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4377 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4379 Error_Msg_Name_1
:= Pname
;
4381 ("??pragma% is only effective in main program", N
);
4383 end Check_In_Main_Program
;
4385 ---------------------------------------
4386 -- Check_Interrupt_Or_Attach_Handler --
4387 ---------------------------------------
4389 procedure Check_Interrupt_Or_Attach_Handler
is
4390 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4391 Handler_Proc
, Proc_Scope
: Entity_Id
;
4396 if Prag_Id
= Pragma_Interrupt_Handler
then
4397 Check_Restriction
(No_Dynamic_Attachment
, N
);
4400 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4401 Proc_Scope
:= Scope
(Handler_Proc
);
4403 -- On AAMP only, a pragma Interrupt_Handler is supported for
4404 -- nonprotected parameterless procedures.
4406 if not AAMP_On_Target
4407 or else Prag_Id
= Pragma_Attach_Handler
4409 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4411 ("argument of pragma% must be protected procedure", Arg1
);
4414 -- For pragma case (as opposed to access case), check placement.
4415 -- We don't need to do that for aspects, because we have the
4416 -- check that they aspect applies an appropriate procedure.
4418 if not From_Aspect_Specification
(N
)
4419 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4421 Error_Pragma
("pragma% must be in protected definition");
4425 if not Is_Library_Level_Entity
(Proc_Scope
)
4426 or else (AAMP_On_Target
4427 and then not Is_Library_Level_Entity
(Handler_Proc
))
4430 ("argument for pragma% must be library level entity", Arg1
);
4433 -- AI05-0033: A pragma cannot appear within a generic body, because
4434 -- instance can be in a nested scope. The check that protected type
4435 -- is itself a library-level declaration is done elsewhere.
4437 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4438 -- handle code prior to AI-0033. Analysis tools typically are not
4439 -- interested in this pragma in any case, so no need to worry too
4440 -- much about its placement.
4442 if Inside_A_Generic
then
4443 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4444 and then In_Package_Body
(Scope
(Current_Scope
))
4445 and then not Relaxed_RM_Semantics
4447 Error_Pragma
("pragma% cannot be used inside a generic");
4450 end Check_Interrupt_Or_Attach_Handler
;
4452 ---------------------------------
4453 -- Check_Loop_Pragma_Placement --
4454 ---------------------------------
4456 procedure Check_Loop_Pragma_Placement
is
4457 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4458 -- Verify whether the current pragma is properly grouped with other
4459 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4460 -- related loop where the pragma appears.
4462 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4463 -- Determine whether an arbitrary statement Stmt denotes pragma
4464 -- Loop_Invariant or Loop_Variant.
4466 procedure Placement_Error
(Constr
: Node_Id
);
4467 pragma No_Return
(Placement_Error
);
4468 -- Node Constr denotes the last loop restricted construct before we
4469 -- encountered an illegal relation between enclosing constructs. Emit
4470 -- an error depending on what Constr was.
4472 --------------------------------
4473 -- Check_Loop_Pragma_Grouping --
4474 --------------------------------
4476 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4477 Stop_Search
: exception;
4478 -- This exception is used to terminate the recursive descent of
4479 -- routine Check_Grouping.
4481 procedure Check_Grouping
(L
: List_Id
);
4482 -- Find the first group of pragmas in list L and if successful,
4483 -- ensure that the current pragma is part of that group. The
4484 -- routine raises Stop_Search once such a check is performed to
4485 -- halt the recursive descent.
4487 procedure Grouping_Error
(Prag
: Node_Id
);
4488 pragma No_Return
(Grouping_Error
);
4489 -- Emit an error concerning the current pragma indicating that it
4490 -- should be placed after pragma Prag.
4492 --------------------
4493 -- Check_Grouping --
4494 --------------------
4496 procedure Check_Grouping
(L
: List_Id
) is
4502 -- Inspect the list of declarations or statements looking for
4503 -- the first grouping of pragmas:
4506 -- pragma Loop_Invariant ...;
4507 -- pragma Loop_Variant ...;
4509 -- pragma Loop_Variant ...; -- current pragma
4511 -- If the current pragma is not in the grouping, then it must
4512 -- either appear in a different declarative or statement list
4513 -- or the construct at (1) is separating the pragma from the
4517 while Present
(Stmt
) loop
4519 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4520 -- inside a loop or a block housed inside a loop. Inspect
4521 -- the declarations and statements of the block as they may
4522 -- contain the first grouping.
4524 if Nkind
(Stmt
) = N_Block_Statement
then
4525 HSS
:= Handled_Statement_Sequence
(Stmt
);
4527 Check_Grouping
(Declarations
(Stmt
));
4529 if Present
(HSS
) then
4530 Check_Grouping
(Statements
(HSS
));
4533 -- First pragma of the first topmost grouping has been found
4535 elsif Is_Loop_Pragma
(Stmt
) then
4537 -- The group and the current pragma are not in the same
4538 -- declarative or statement list.
4540 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4541 Grouping_Error
(Stmt
);
4543 -- Try to reach the current pragma from the first pragma
4544 -- of the grouping while skipping other members:
4546 -- pragma Loop_Invariant ...; -- first pragma
4547 -- pragma Loop_Variant ...; -- member
4549 -- pragma Loop_Variant ...; -- current pragma
4552 while Present
(Stmt
) loop
4554 -- The current pragma is either the first pragma
4555 -- of the group or is a member of the group. Stop
4556 -- the search as the placement is legal.
4561 -- Skip group members, but keep track of the last
4562 -- pragma in the group.
4564 elsif Is_Loop_Pragma
(Stmt
) then
4567 -- A non-pragma is separating the group from the
4568 -- current pragma, the placement is illegal.
4571 Grouping_Error
(Prag
);
4577 -- If the traversal did not reach the current pragma,
4578 -- then the list must be malformed.
4580 raise Program_Error
;
4588 --------------------
4589 -- Grouping_Error --
4590 --------------------
4592 procedure Grouping_Error
(Prag
: Node_Id
) is
4594 Error_Msg_Sloc
:= Sloc
(Prag
);
4595 Error_Pragma
("pragma% must appear next to pragma#");
4598 -- Start of processing for Check_Loop_Pragma_Grouping
4601 -- Inspect the statements of the loop or nested blocks housed
4602 -- within to determine whether the current pragma is part of the
4603 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4605 Check_Grouping
(Statements
(Loop_Stmt
));
4608 when Stop_Search
=> null;
4609 end Check_Loop_Pragma_Grouping
;
4611 --------------------
4612 -- Is_Loop_Pragma --
4613 --------------------
4615 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4617 -- Inspect the original node as Loop_Invariant and Loop_Variant
4618 -- pragmas are rewritten to null when assertions are disabled.
4620 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4622 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4623 Name_Loop_Invariant
,
4630 ---------------------
4631 -- Placement_Error --
4632 ---------------------
4634 procedure Placement_Error
(Constr
: Node_Id
) is
4635 LA
: constant String := " with Loop_Entry";
4638 if Prag_Id
= Pragma_Assert
then
4639 Error_Msg_String
(1 .. LA
'Length) := LA
;
4640 Error_Msg_Strlen
:= LA
'Length;
4642 Error_Msg_Strlen
:= 0;
4645 if Nkind
(Constr
) = N_Pragma
then
4647 ("pragma %~ must appear immediately within the statements "
4651 ("block containing pragma %~ must appear immediately within "
4652 & "the statements of a loop", Constr
);
4654 end Placement_Error
;
4656 -- Local declarations
4661 -- Start of processing for Check_Loop_Pragma_Placement
4664 -- Check that pragma appears immediately within a loop statement,
4665 -- ignoring intervening block statements.
4669 while Present
(Stmt
) loop
4671 -- The pragma or previous block must appear immediately within the
4672 -- current block's declarative or statement part.
4674 if Nkind
(Stmt
) = N_Block_Statement
then
4675 if (No
(Declarations
(Stmt
))
4676 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4678 List_Containing
(Prev
) /=
4679 Statements
(Handled_Statement_Sequence
(Stmt
))
4681 Placement_Error
(Prev
);
4684 -- Keep inspecting the parents because we are now within a
4685 -- chain of nested blocks.
4689 Stmt
:= Parent
(Stmt
);
4692 -- The pragma or previous block must appear immediately within the
4693 -- statements of the loop.
4695 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4696 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4697 Placement_Error
(Prev
);
4700 -- Stop the traversal because we reached the innermost loop
4701 -- regardless of whether we encountered an error or not.
4705 -- Ignore a handled statement sequence. Note that this node may
4706 -- be related to a subprogram body in which case we will emit an
4707 -- error on the next iteration of the search.
4709 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4710 Stmt
:= Parent
(Stmt
);
4712 -- Any other statement breaks the chain from the pragma to the
4716 Placement_Error
(Prev
);
4721 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4722 -- grouped together with other such pragmas.
4724 if Is_Loop_Pragma
(N
) then
4726 -- The previous check should have located the related loop
4728 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4729 Check_Loop_Pragma_Grouping
(Stmt
);
4731 end Check_Loop_Pragma_Placement
;
4733 -------------------------------------------
4734 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4735 -------------------------------------------
4737 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4746 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4749 elsif Nkind_In
(P
, N_Package_Specification
,
4754 -- Note: the following tests seem a little peculiar, because
4755 -- they test for bodies, but if we were in the statement part
4756 -- of the body, we would already have hit the handled statement
4757 -- sequence, so the only way we get here is by being in the
4758 -- declarative part of the body.
4760 elsif Nkind_In
(P
, N_Subprogram_Body
,
4771 Error_Pragma
("pragma% is not in declarative part or package spec");
4772 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4774 -------------------------
4775 -- Check_No_Identifier --
4776 -------------------------
4778 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4780 if Nkind
(Arg
) = N_Pragma_Argument_Association
4781 and then Chars
(Arg
) /= No_Name
4783 Error_Pragma_Arg_Ident
4784 ("pragma% does not permit identifier& here", Arg
);
4786 end Check_No_Identifier
;
4788 --------------------------
4789 -- Check_No_Identifiers --
4790 --------------------------
4792 procedure Check_No_Identifiers
is
4796 for J
in 1 .. Arg_Count
loop
4797 Check_No_Identifier
(Arg_Node
);
4800 end Check_No_Identifiers
;
4802 ------------------------
4803 -- Check_No_Link_Name --
4804 ------------------------
4806 procedure Check_No_Link_Name
is
4808 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4812 if Present
(Arg4
) then
4814 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4816 end Check_No_Link_Name
;
4818 -------------------------------
4819 -- Check_Optional_Identifier --
4820 -------------------------------
4822 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4825 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4826 and then Chars
(Arg
) /= No_Name
4828 if Chars
(Arg
) /= Id
then
4829 Error_Msg_Name_1
:= Pname
;
4830 Error_Msg_Name_2
:= Id
;
4831 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4835 end Check_Optional_Identifier
;
4837 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4839 Name_Buffer
(1 .. Id
'Length) := Id
;
4840 Name_Len
:= Id
'Length;
4841 Check_Optional_Identifier
(Arg
, Name_Find
);
4842 end Check_Optional_Identifier
;
4844 --------------------
4845 -- Check_Pre_Post --
4846 --------------------
4848 procedure Check_Pre_Post
is
4853 if not Is_List_Member
(N
) then
4857 -- If we are within an inlined body, the legality of the pragma
4858 -- has been checked already.
4860 if In_Inlined_Body
then
4864 -- Search prior declarations
4867 while Present
(Prev
(P
)) loop
4870 -- If the previous node is a generic subprogram, do not go to to
4871 -- the original node, which is the unanalyzed tree: we need to
4872 -- attach the pre/postconditions to the analyzed version at this
4873 -- point. They get propagated to the original tree when analyzing
4874 -- the corresponding body.
4876 if Nkind
(P
) not in N_Generic_Declaration
then
4877 PO
:= Original_Node
(P
);
4882 -- Skip past prior pragma
4884 if Nkind
(PO
) = N_Pragma
then
4887 -- Skip stuff not coming from source
4889 elsif not Comes_From_Source
(PO
) then
4891 -- The condition may apply to a subprogram instantiation
4893 if Nkind
(PO
) = N_Subprogram_Declaration
4894 and then Present
(Generic_Parent
(Specification
(PO
)))
4898 elsif Nkind
(PO
) = N_Subprogram_Declaration
4899 and then In_Instance
4903 -- For all other cases of non source code, do nothing
4909 -- Only remaining possibility is subprogram declaration
4916 -- If we fall through loop, pragma is at start of list, so see if it
4917 -- is at the start of declarations of a subprogram body.
4921 if Nkind
(PO
) = N_Subprogram_Body
4922 and then List_Containing
(N
) = Declarations
(PO
)
4924 -- This is only allowed if there is no separate specification
4926 if Present
(Corresponding_Spec
(PO
)) then
4928 ("pragma% must apply to subprogram specification");
4935 --------------------------------------
4936 -- Check_Precondition_Postcondition --
4937 --------------------------------------
4939 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
4943 procedure Chain_PPC
(PO
: Node_Id
);
4944 -- If PO is an entry or a [generic] subprogram declaration node, then
4945 -- the precondition/postcondition applies to this subprogram and the
4946 -- processing for the pragma is completed. Otherwise the pragma is
4953 procedure Chain_PPC
(PO
: Node_Id
) is
4957 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
4958 if not From_Aspect_Specification
(N
) then
4960 ("pragma% cannot be applied to abstract subprogram");
4962 elsif Class_Present
(N
) then
4967 ("aspect % requires ''Class for abstract subprogram");
4970 -- AI05-0230: The same restriction applies to null procedures. For
4971 -- compatibility with earlier uses of the Ada pragma, apply this
4972 -- rule only to aspect specifications.
4974 -- The above discrepency needs documentation. Robert is dubious
4975 -- about whether it is a good idea ???
4977 elsif Nkind
(PO
) = N_Subprogram_Declaration
4978 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
4979 and then Null_Present
(Specification
(PO
))
4980 and then From_Aspect_Specification
(N
)
4981 and then not Class_Present
(N
)
4984 ("aspect % requires ''Class for null procedure");
4986 -- Pre/postconditions are legal on a subprogram body if it is not
4987 -- a completion of a declaration. They are also legal on a stub
4988 -- with no previous declarations (this is checked when processing
4989 -- the corresponding aspects).
4991 elsif Nkind
(PO
) = N_Subprogram_Body
4992 and then Acts_As_Spec
(PO
)
4996 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
4999 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5000 N_Expression_Function
,
5001 N_Generic_Subprogram_Declaration
,
5002 N_Entry_Declaration
)
5007 -- Here if we have [generic] subprogram or entry declaration
5009 if Nkind
(PO
) = N_Entry_Declaration
then
5010 S
:= Defining_Entity
(PO
);
5012 S
:= Defining_Unit_Name
(Specification
(PO
));
5014 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5015 S
:= Defining_Identifier
(S
);
5019 -- Note: we do not analyze the pragma at this point. Instead we
5020 -- delay this analysis until the end of the declarative part in
5021 -- which the pragma appears. This implements the required delay
5022 -- in this analysis, allowing forward references. The analysis
5023 -- happens at the end of Analyze_Declarations.
5025 -- Chain spec PPC pragma to list for subprogram
5027 Add_Contract_Item
(N
, S
);
5029 -- Return indicating spec case
5035 -- Start of processing for Check_Precondition_Postcondition
5038 if not Is_List_Member
(N
) then
5042 -- Preanalyze message argument if present. Visibility in this
5043 -- argument is established at the point of pragma occurrence.
5045 if Arg_Count
= 2 then
5046 Check_Optional_Identifier
(Arg2
, Name_Message
);
5047 Preanalyze_Spec_Expression
5048 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5051 -- For a pragma PPC in the extended main source unit, record enabled
5054 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5055 Set_SCO_Pragma_Enabled
(Loc
);
5058 -- If we are within an inlined body, the legality of the pragma
5059 -- has been checked already.
5061 if In_Inlined_Body
then
5066 -- Search prior declarations
5069 while Present
(Prev
(P
)) loop
5072 -- If the previous node is a generic subprogram, do not go to to
5073 -- the original node, which is the unanalyzed tree: we need to
5074 -- attach the pre/postconditions to the analyzed version at this
5075 -- point. They get propagated to the original tree when analyzing
5076 -- the corresponding body.
5078 if Nkind
(P
) not in N_Generic_Declaration
then
5079 PO
:= Original_Node
(P
);
5084 -- Skip past prior pragma
5086 if Nkind
(PO
) = N_Pragma
then
5089 -- Skip stuff not coming from source
5091 elsif not Comes_From_Source
(PO
) then
5093 -- The condition may apply to a subprogram instantiation
5095 if Nkind
(PO
) = N_Subprogram_Declaration
5096 and then Present
(Generic_Parent
(Specification
(PO
)))
5101 elsif Nkind
(PO
) = N_Subprogram_Declaration
5102 and then In_Instance
5107 -- For all other cases of non source code, do nothing
5113 -- Only remaining possibility is subprogram declaration
5121 -- If we fall through loop, pragma is at start of list, so see if it
5122 -- is at the start of declarations of a subprogram body.
5126 if Nkind
(PO
) = N_Subprogram_Body
5127 and then List_Containing
(N
) = Declarations
(PO
)
5129 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5131 -- Analyze pragma expression for correctness and for ASIS use
5133 Preanalyze_Assert_Expression
5134 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5136 -- In ASIS mode, for a pragma generated from a source aspect,
5137 -- also analyze the original aspect expression.
5139 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5140 Preanalyze_Assert_Expression
5141 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5145 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5146 -- The copy is needed because the pragma is expanded into other
5147 -- constructs which are not acceptable in the N_Contract node.
5149 if Acts_As_Spec
(PO
) and then GNATprove_Mode
then
5151 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5154 -- Preanalyze the pragma
5156 Preanalyze_Assert_Expression
5158 (First
(Pragma_Argument_Associations
(Prag
))),
5161 -- Preanalyze the corresponding aspect (if any)
5163 if Present
(Corresponding_Aspect
(Prag
)) then
5164 Preanalyze_Assert_Expression
5165 (Expression
(Corresponding_Aspect
(Prag
)),
5169 -- Chain the copy on the contract of the body
5172 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5179 -- See if it is in the pragmas after a library level subprogram
5181 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5183 -- In GNATprove mode, analyze pragma expression for correctness,
5184 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5185 -- no later point at which the aspect will be analyzed.
5187 if GNATprove_Mode
or ASIS_Mode
then
5188 Analyze_Pre_Post_Condition_In_Decl_Part
5189 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5192 Chain_PPC
(Unit
(Parent
(PO
)));
5196 -- If we fall through, pragma was misplaced
5199 end Check_Precondition_Postcondition
;
5201 -----------------------------
5202 -- Check_Static_Constraint --
5203 -----------------------------
5205 -- Note: for convenience in writing this procedure, in addition to
5206 -- the officially (i.e. by spec) allowed argument which is always a
5207 -- constraint, it also allows ranges and discriminant associations.
5208 -- Above is not clear ???
5210 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5212 procedure Require_Static
(E
: Node_Id
);
5213 -- Require given expression to be static expression
5215 --------------------
5216 -- Require_Static --
5217 --------------------
5219 procedure Require_Static
(E
: Node_Id
) is
5221 if not Is_OK_Static_Expression
(E
) then
5222 Flag_Non_Static_Expr
5223 ("non-static constraint not allowed in Unchecked_Union!", E
);
5228 -- Start of processing for Check_Static_Constraint
5231 case Nkind
(Constr
) is
5232 when N_Discriminant_Association
=>
5233 Require_Static
(Expression
(Constr
));
5236 Require_Static
(Low_Bound
(Constr
));
5237 Require_Static
(High_Bound
(Constr
));
5239 when N_Attribute_Reference
=>
5240 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5241 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5243 when N_Range_Constraint
=>
5244 Check_Static_Constraint
(Range_Expression
(Constr
));
5246 when N_Index_Or_Discriminant_Constraint
=>
5250 IDC
:= First
(Constraints
(Constr
));
5251 while Present
(IDC
) loop
5252 Check_Static_Constraint
(IDC
);
5260 end Check_Static_Constraint
;
5262 ---------------------
5263 -- Check_Test_Case --
5264 ---------------------
5266 procedure Check_Test_Case
is
5270 procedure Chain_CTC
(PO
: Node_Id
);
5271 -- If PO is a [generic] subprogram declaration node, then the
5272 -- test-case applies to this subprogram and the processing for
5273 -- the pragma is completed. Otherwise the pragma is misplaced.
5279 procedure Chain_CTC
(PO
: Node_Id
) is
5280 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5285 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5287 ("pragma% cannot be applied to abstract subprogram");
5289 elsif Nkind
(PO
) = N_Entry_Declaration
then
5290 Error_Pragma
("pragma% cannot be applied to entry");
5292 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5293 N_Generic_Subprogram_Declaration
)
5298 -- Here if we have [generic] subprogram declaration
5300 S
:= Defining_Unit_Name
(Specification
(PO
));
5302 -- Note: we do not analyze the pragma at this point. Instead we
5303 -- delay this analysis until the end of the declarative part in
5304 -- which the pragma appears. This implements the required delay
5305 -- in this analysis, allowing forward references. The analysis
5306 -- happens at the end of Analyze_Declarations.
5308 -- There should not be another test-case with the same name
5309 -- associated to this subprogram.
5311 CTC
:= Contract_Test_Cases
(Contract
(S
));
5312 while Present
(CTC
) loop
5314 -- Omit pragma Contract_Cases because it does not introduce
5315 -- a unique case name and it does not follow the syntax of
5318 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5321 elsif String_Equal
(Name
, Get_Name_From_CTC_Pragma
(CTC
)) then
5322 Error_Msg_Sloc
:= Sloc
(CTC
);
5323 Error_Pragma
("name for pragma% is already used#");
5326 CTC
:= Next_Pragma
(CTC
);
5329 -- Chain spec CTC pragma to list for subprogram
5331 Add_Contract_Item
(N
, S
);
5334 -- Start of processing for Check_Test_Case
5337 -- First check pragma arguments
5339 Check_At_Least_N_Arguments
(2);
5340 Check_At_Most_N_Arguments
(4);
5342 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5344 Check_Optional_Identifier
(Arg1
, Name_Name
);
5345 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
5347 -- In ASIS mode, for a pragma generated from a source aspect, also
5348 -- analyze the original aspect expression.
5350 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5351 Check_Expr_Is_OK_Static_Expression
5352 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5355 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5356 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5358 if Arg_Count
= 4 then
5359 Check_Identifier
(Arg3
, Name_Requires
);
5360 Check_Identifier
(Arg4
, Name_Ensures
);
5362 elsif Arg_Count
= 3 then
5363 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5366 -- Check pragma placement
5368 if not Is_List_Member
(N
) then
5372 -- Test-case should only appear in package spec unit
5374 if Get_Source_Unit
(N
) = No_Unit
5375 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Current_Sem_Unit
)),
5376 N_Package_Declaration
,
5377 N_Generic_Package_Declaration
)
5382 -- Search prior declarations
5385 while Present
(Prev
(P
)) loop
5388 -- If the previous node is a generic subprogram, do not go to to
5389 -- the original node, which is the unanalyzed tree: we need to
5390 -- attach the test-case to the analyzed version at this point.
5391 -- They get propagated to the original tree when analyzing the
5392 -- corresponding body.
5394 if Nkind
(P
) not in N_Generic_Declaration
then
5395 PO
:= Original_Node
(P
);
5400 -- Skip past prior pragma
5402 if Nkind
(PO
) = N_Pragma
then
5405 -- Skip stuff not coming from source
5407 elsif not Comes_From_Source
(PO
) then
5410 -- Only remaining possibility is subprogram declaration. First
5411 -- check that it is declared directly in a package declaration.
5412 -- This may be either the package declaration for the current unit
5413 -- being defined or a local package declaration.
5415 elsif not Present
(Parent
(Parent
(PO
)))
5416 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5417 or else not Nkind_In
(Parent
(Parent
(PO
)),
5418 N_Package_Declaration
,
5419 N_Generic_Package_Declaration
)
5429 -- If we fall through, pragma was misplaced
5432 end Check_Test_Case
;
5434 --------------------------------------
5435 -- Check_Valid_Configuration_Pragma --
5436 --------------------------------------
5438 -- A configuration pragma must appear in the context clause of a
5439 -- compilation unit, and only other pragmas may precede it. Note that
5440 -- the test also allows use in a configuration pragma file.
5442 procedure Check_Valid_Configuration_Pragma
is
5444 if not Is_Configuration_Pragma
then
5445 Error_Pragma
("incorrect placement for configuration pragma%");
5447 end Check_Valid_Configuration_Pragma
;
5449 -------------------------------------
5450 -- Check_Valid_Library_Unit_Pragma --
5451 -------------------------------------
5453 procedure Check_Valid_Library_Unit_Pragma
is
5455 Parent_Node
: Node_Id
;
5456 Unit_Name
: Entity_Id
;
5457 Unit_Kind
: Node_Kind
;
5458 Unit_Node
: Node_Id
;
5459 Sindex
: Source_File_Index
;
5462 if not Is_List_Member
(N
) then
5466 Plist
:= List_Containing
(N
);
5467 Parent_Node
:= Parent
(Plist
);
5469 if Parent_Node
= Empty
then
5472 -- Case of pragma appearing after a compilation unit. In this case
5473 -- it must have an argument with the corresponding name and must
5474 -- be part of the following pragmas of its parent.
5476 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5477 if Plist
/= Pragmas_After
(Parent_Node
) then
5480 elsif Arg_Count
= 0 then
5482 ("argument required if outside compilation unit");
5485 Check_No_Identifiers
;
5486 Check_Arg_Count
(1);
5487 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5488 Unit_Kind
:= Nkind
(Unit_Node
);
5490 Analyze
(Get_Pragma_Arg
(Arg1
));
5492 if Unit_Kind
= N_Generic_Subprogram_Declaration
5493 or else Unit_Kind
= N_Subprogram_Declaration
5495 Unit_Name
:= Defining_Entity
(Unit_Node
);
5497 elsif Unit_Kind
in N_Generic_Instantiation
then
5498 Unit_Name
:= Defining_Entity
(Unit_Node
);
5501 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5504 if Chars
(Unit_Name
) /=
5505 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5508 ("pragma% argument is not current unit name", Arg1
);
5511 if Ekind
(Unit_Name
) = E_Package
5512 and then Present
(Renamed_Entity
(Unit_Name
))
5514 Error_Pragma
("pragma% not allowed for renamed package");
5518 -- Pragma appears other than after a compilation unit
5521 -- Here we check for the generic instantiation case and also
5522 -- for the case of processing a generic formal package. We
5523 -- detect these cases by noting that the Sloc on the node
5524 -- does not belong to the current compilation unit.
5526 Sindex
:= Source_Index
(Current_Sem_Unit
);
5528 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5529 Rewrite
(N
, Make_Null_Statement
(Loc
));
5532 -- If before first declaration, the pragma applies to the
5533 -- enclosing unit, and the name if present must be this name.
5535 elsif Is_Before_First_Decl
(N
, Plist
) then
5536 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5537 Unit_Kind
:= Nkind
(Unit_Node
);
5539 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5542 elsif Unit_Kind
= N_Subprogram_Body
5543 and then not Acts_As_Spec
(Unit_Node
)
5547 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5550 elsif Nkind
(Parent_Node
) = N_Package_Specification
5551 and then Plist
= Private_Declarations
(Parent_Node
)
5555 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5556 or else Nkind
(Parent_Node
) =
5557 N_Generic_Subprogram_Declaration
)
5558 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5562 elsif Arg_Count
> 0 then
5563 Analyze
(Get_Pragma_Arg
(Arg1
));
5565 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5567 ("name in pragma% must be enclosing unit", Arg1
);
5570 -- It is legal to have no argument in this context
5576 -- Error if not before first declaration. This is because a
5577 -- library unit pragma argument must be the name of a library
5578 -- unit (RM 10.1.5(7)), but the only names permitted in this
5579 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5580 -- generic subprogram declarations or generic instantiations.
5584 ("pragma% misplaced, must be before first declaration");
5588 end Check_Valid_Library_Unit_Pragma
;
5594 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5595 Clist
: constant Node_Id
:= Component_List
(Variant
);
5599 Comp
:= First
(Component_Items
(Clist
));
5600 while Present
(Comp
) loop
5601 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5606 ---------------------------
5607 -- Ensure_Aggregate_Form --
5608 ---------------------------
5610 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5611 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5612 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5613 Nam
: constant Name_Id
:= Chars
(Arg
);
5614 Comps
: List_Id
:= No_List
;
5615 Exprs
: List_Id
:= No_List
;
5617 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5618 -- Used to restore Comes_From_Source_Default
5621 -- The argument is already in aggregate form, but the presence of a
5622 -- name causes this to be interpreted as a named association which in
5623 -- turn must be converted into an aggregate.
5625 -- pragma Global (In_Out => (A, B, C))
5629 -- pragma Global ((In_Out => (A, B, C)))
5631 -- aggregate aggregate
5633 if Nkind
(Expr
) = N_Aggregate
then
5634 if Nam
= No_Name
then
5638 -- Do not transform a null argument into an aggregate as N_Null has
5639 -- special meaning in formal verification pragmas.
5641 elsif Nkind
(Expr
) = N_Null
then
5645 -- Everything comes from source if the original comes from source
5647 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5649 -- Positional argument is transformed into an aggregate with an
5650 -- Expressions list.
5652 if Nam
= No_Name
then
5653 Exprs
:= New_List
(Relocate_Node
(Expr
));
5655 -- An associative argument is transformed into an aggregate with
5656 -- Component_Associations.
5660 Make_Component_Association
(Loc
,
5661 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5662 Expression
=> Relocate_Node
(Expr
)));
5665 -- Remove the pragma argument name as this information has been
5666 -- captured in the aggregate.
5668 Set_Chars
(Arg
, No_Name
);
5670 Set_Expression
(Arg
,
5671 Make_Aggregate
(Loc
,
5672 Component_Associations
=> Comps
,
5673 Expressions
=> Exprs
));
5675 -- Restore Comes_From_Source default
5677 Set_Comes_From_Source_Default
(CFSD
);
5678 end Ensure_Aggregate_Form
;
5684 procedure Error_Pragma
(Msg
: String) is
5686 Error_Msg_Name_1
:= Pname
;
5687 Error_Msg_N
(Fix_Error
(Msg
), N
);
5691 ----------------------
5692 -- Error_Pragma_Arg --
5693 ----------------------
5695 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5697 Error_Msg_Name_1
:= Pname
;
5698 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5700 end Error_Pragma_Arg
;
5702 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5704 Error_Msg_Name_1
:= Pname
;
5705 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5706 Error_Pragma_Arg
(Msg2
, Arg
);
5707 end Error_Pragma_Arg
;
5709 ----------------------------
5710 -- Error_Pragma_Arg_Ident --
5711 ----------------------------
5713 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5715 Error_Msg_Name_1
:= Pname
;
5716 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5718 end Error_Pragma_Arg_Ident
;
5720 ----------------------
5721 -- Error_Pragma_Ref --
5722 ----------------------
5724 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5726 Error_Msg_Name_1
:= Pname
;
5727 Error_Msg_Sloc
:= Sloc
(Ref
);
5728 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5730 end Error_Pragma_Ref
;
5732 ------------------------
5733 -- Find_Lib_Unit_Name --
5734 ------------------------
5736 function Find_Lib_Unit_Name
return Entity_Id
is
5738 -- Return inner compilation unit entity, for case of nested
5739 -- categorization pragmas. This happens in generic unit.
5741 if Nkind
(Parent
(N
)) = N_Package_Specification
5742 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5744 return Defining_Entity
(Parent
(N
));
5746 return Current_Scope
;
5748 end Find_Lib_Unit_Name
;
5750 ----------------------------
5751 -- Find_Program_Unit_Name --
5752 ----------------------------
5754 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5755 Unit_Name
: Entity_Id
;
5756 Unit_Kind
: Node_Kind
;
5757 P
: constant Node_Id
:= Parent
(N
);
5760 if Nkind
(P
) = N_Compilation_Unit
then
5761 Unit_Kind
:= Nkind
(Unit
(P
));
5763 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5764 N_Package_Declaration
)
5765 or else Unit_Kind
in N_Generic_Declaration
5767 Unit_Name
:= Defining_Entity
(Unit
(P
));
5769 if Chars
(Id
) = Chars
(Unit_Name
) then
5770 Set_Entity
(Id
, Unit_Name
);
5771 Set_Etype
(Id
, Etype
(Unit_Name
));
5773 Set_Etype
(Id
, Any_Type
);
5775 ("cannot find program unit referenced by pragma%");
5779 Set_Etype
(Id
, Any_Type
);
5780 Error_Pragma
("pragma% inapplicable to this unit");
5786 end Find_Program_Unit_Name
;
5788 -----------------------------------------
5789 -- Find_Unique_Parameterless_Procedure --
5790 -----------------------------------------
5792 function Find_Unique_Parameterless_Procedure
5794 Arg
: Node_Id
) return Entity_Id
5796 Proc
: Entity_Id
:= Empty
;
5799 -- The body of this procedure needs some comments ???
5801 if not Is_Entity_Name
(Name
) then
5803 ("argument of pragma% must be entity name", Arg
);
5805 elsif not Is_Overloaded
(Name
) then
5806 Proc
:= Entity
(Name
);
5808 if Ekind
(Proc
) /= E_Procedure
5809 or else Present
(First_Formal
(Proc
))
5812 ("argument of pragma% must be parameterless procedure", Arg
);
5817 Found
: Boolean := False;
5819 Index
: Interp_Index
;
5822 Get_First_Interp
(Name
, Index
, It
);
5823 while Present
(It
.Nam
) loop
5826 if Ekind
(Proc
) = E_Procedure
5827 and then No
(First_Formal
(Proc
))
5831 Set_Entity
(Name
, Proc
);
5832 Set_Is_Overloaded
(Name
, False);
5835 ("ambiguous handler name for pragma% ", Arg
);
5839 Get_Next_Interp
(Index
, It
);
5844 ("argument of pragma% must be parameterless procedure",
5847 Proc
:= Entity
(Name
);
5853 end Find_Unique_Parameterless_Procedure
;
5859 function Fix_Error
(Msg
: String) return String is
5860 Res
: String (Msg
'Range) := Msg
;
5861 Res_Last
: Natural := Msg
'Last;
5865 -- If we have a rewriting of another pragma, go to that pragma
5867 if Is_Rewrite_Substitution
(N
)
5868 and then Nkind
(Original_Node
(N
)) = N_Pragma
5870 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5873 -- Case where pragma comes from an aspect specification
5875 if From_Aspect_Specification
(N
) then
5877 -- Change appearence of "pragma" in message to "aspect"
5880 while J
<= Res_Last
- 5 loop
5881 if Res
(J
.. J
+ 5) = "pragma" then
5882 Res
(J
.. J
+ 5) := "aspect";
5890 -- Change "argument of" at start of message to "entity for"
5893 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5895 Res
(Res
'First .. Res
'First + 9) := "entity for";
5896 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5897 Res
(Res
'First + 11 .. Res_Last
);
5898 Res_Last
:= Res_Last
- 1;
5901 -- Change "argument" at start of message to "entity"
5904 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5906 Res
(Res
'First .. Res
'First + 5) := "entity";
5907 Res
(Res
'First + 6 .. Res_Last
- 2) :=
5908 Res
(Res
'First + 8 .. Res_Last
);
5909 Res_Last
:= Res_Last
- 2;
5912 -- Get name from corresponding aspect
5914 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
5917 -- Return possibly modified message
5919 return Res
(Res
'First .. Res_Last
);
5922 -------------------------
5923 -- Gather_Associations --
5924 -------------------------
5926 procedure Gather_Associations
5928 Args
: out Args_List
)
5933 -- Initialize all parameters to Empty
5935 for J
in Args
'Range loop
5939 -- That's all we have to do if there are no argument associations
5941 if No
(Pragma_Argument_Associations
(N
)) then
5945 -- Otherwise first deal with any positional parameters present
5947 Arg
:= First
(Pragma_Argument_Associations
(N
));
5948 for Index
in Args
'Range loop
5949 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
5950 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5954 -- Positional parameters all processed, if any left, then we
5955 -- have too many positional parameters.
5957 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
5959 ("too many positional associations for pragma%", Arg
);
5962 -- Process named parameters if any are present
5964 while Present
(Arg
) loop
5965 if Chars
(Arg
) = No_Name
then
5967 ("positional association cannot follow named association",
5971 for Index
in Names
'Range loop
5972 if Names
(Index
) = Chars
(Arg
) then
5973 if Present
(Args
(Index
)) then
5975 ("duplicate argument association for pragma%", Arg
);
5977 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5982 if Index
= Names
'Last then
5983 Error_Msg_Name_1
:= Pname
;
5984 Error_Msg_N
("pragma% does not allow & argument", Arg
);
5986 -- Check for possible misspelling
5988 for Index1
in Names
'Range loop
5989 if Is_Bad_Spelling_Of
5990 (Chars
(Arg
), Names
(Index1
))
5992 Error_Msg_Name_1
:= Names
(Index1
);
5993 Error_Msg_N
-- CODEFIX
5994 ("\possible misspelling of%", Arg
);
6006 end Gather_Associations
;
6012 procedure GNAT_Pragma
is
6014 -- We need to check the No_Implementation_Pragmas restriction for
6015 -- the case of a pragma from source. Note that the case of aspects
6016 -- generating corresponding pragmas marks these pragmas as not being
6017 -- from source, so this test also catches that case.
6019 if Comes_From_Source
(N
) then
6020 Check_Restriction
(No_Implementation_Pragmas
, N
);
6024 --------------------------
6025 -- Is_Before_First_Decl --
6026 --------------------------
6028 function Is_Before_First_Decl
6029 (Pragma_Node
: Node_Id
;
6030 Decls
: List_Id
) return Boolean
6032 Item
: Node_Id
:= First
(Decls
);
6035 -- Only other pragmas can come before this pragma
6038 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6041 elsif Item
= Pragma_Node
then
6047 end Is_Before_First_Decl
;
6049 -----------------------------
6050 -- Is_Configuration_Pragma --
6051 -----------------------------
6053 -- A configuration pragma must appear in the context clause of a
6054 -- compilation unit, and only other pragmas may precede it. Note that
6055 -- the test below also permits use in a configuration pragma file.
6057 function Is_Configuration_Pragma
return Boolean is
6058 Lis
: constant List_Id
:= List_Containing
(N
);
6059 Par
: constant Node_Id
:= Parent
(N
);
6063 -- If no parent, then we are in the configuration pragma file,
6064 -- so the placement is definitely appropriate.
6069 -- Otherwise we must be in the context clause of a compilation unit
6070 -- and the only thing allowed before us in the context list is more
6071 -- configuration pragmas.
6073 elsif Nkind
(Par
) = N_Compilation_Unit
6074 and then Context_Items
(Par
) = Lis
6081 elsif Nkind
(Prg
) /= N_Pragma
then
6091 end Is_Configuration_Pragma
;
6093 --------------------------
6094 -- Is_In_Context_Clause --
6095 --------------------------
6097 function Is_In_Context_Clause
return Boolean is
6099 Parent_Node
: Node_Id
;
6102 if not Is_List_Member
(N
) then
6106 Plist
:= List_Containing
(N
);
6107 Parent_Node
:= Parent
(Plist
);
6109 if Parent_Node
= Empty
6110 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6111 or else Context_Items
(Parent_Node
) /= Plist
6118 end Is_In_Context_Clause
;
6120 ---------------------------------
6121 -- Is_Static_String_Expression --
6122 ---------------------------------
6124 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6125 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6126 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6129 Analyze_And_Resolve
(Argx
);
6131 -- Special case Ada 83, where the expression will never be static,
6132 -- but we will return true if we had a string literal to start with.
6134 if Ada_Version
= Ada_83
then
6137 -- Normal case, true only if we end up with a string literal that
6138 -- is marked as being the result of evaluating a static expression.
6141 return Is_OK_Static_Expression
(Argx
)
6142 and then Nkind
(Argx
) = N_String_Literal
;
6145 end Is_Static_String_Expression
;
6147 ----------------------
6148 -- Pragma_Misplaced --
6149 ----------------------
6151 procedure Pragma_Misplaced
is
6153 Error_Pragma
("incorrect placement of pragma%");
6154 end Pragma_Misplaced
;
6156 ------------------------------------
6157 -- Process_Atomic_Shared_Volatile --
6158 ------------------------------------
6160 procedure Process_Atomic_Shared_Volatile
is
6167 procedure Set_Atomic
(E
: Entity_Id
);
6168 -- Set given type as atomic, and if no explicit alignment was given,
6169 -- set alignment to unknown, since back end knows what the alignment
6170 -- requirements are for atomic arrays. Note: this step is necessary
6171 -- for derived types.
6177 procedure Set_Atomic
(E
: Entity_Id
) is
6181 if not Has_Alignment_Clause
(E
) then
6182 Set_Alignment
(E
, Uint_0
);
6186 -- Start of processing for Process_Atomic_Shared_Volatile
6189 Check_Ada_83_Warning
;
6190 Check_No_Identifiers
;
6191 Check_Arg_Count
(1);
6192 Check_Arg_Is_Local_Name
(Arg1
);
6193 E_Id
:= Get_Pragma_Arg
(Arg1
);
6195 if Etype
(E_Id
) = Any_Type
then
6200 D
:= Declaration_Node
(E
);
6203 -- Check duplicate before we chain ourselves
6205 Check_Duplicate_Pragma
(E
);
6207 -- Now check appropriateness of the entity
6210 if Rep_Item_Too_Early
(E
, N
)
6212 Rep_Item_Too_Late
(E
, N
)
6216 Check_First_Subtype
(Arg1
);
6219 if Prag_Id
/= Pragma_Volatile
then
6221 Set_Atomic
(Underlying_Type
(E
));
6222 Set_Atomic
(Base_Type
(E
));
6225 -- Attribute belongs on the base type. If the view of the type is
6226 -- currently private, it also belongs on the underlying type.
6228 Set_Is_Volatile
(Base_Type
(E
));
6229 Set_Is_Volatile
(Underlying_Type
(E
));
6231 Set_Treat_As_Volatile
(E
);
6232 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6234 elsif K
= N_Object_Declaration
6235 or else (K
= N_Component_Declaration
6236 and then Original_Record_Component
(E
) = E
)
6238 if Rep_Item_Too_Late
(E
, N
) then
6242 if Prag_Id
/= Pragma_Volatile
then
6245 -- If the object declaration has an explicit initialization, a
6246 -- temporary may have to be created to hold the expression, to
6247 -- ensure that access to the object remain atomic.
6249 if Nkind
(Parent
(E
)) = N_Object_Declaration
6250 and then Present
(Expression
(Parent
(E
)))
6252 Set_Has_Delayed_Freeze
(E
);
6255 -- An interesting improvement here. If an object of composite
6256 -- type X is declared atomic, and the type X isn't, that's a
6257 -- pity, since it may not have appropriate alignment etc. We
6258 -- can rescue this in the special case where the object and
6259 -- type are in the same unit by just setting the type as
6260 -- atomic, so that the back end will process it as atomic.
6262 -- Note: we used to do this for elementary types as well,
6263 -- but that turns out to be a bad idea and can have unwanted
6264 -- effects, most notably if the type is elementary, the object
6265 -- a simple component within a record, and both are in a spec:
6266 -- every object of this type in the entire program will be
6267 -- treated as atomic, thus incurring a potentially costly
6268 -- synchronization operation for every access.
6270 -- Of course it would be best if the back end could just adjust
6271 -- the alignment etc for the specific object, but that's not
6272 -- something we are capable of doing at this point.
6274 Utyp
:= Underlying_Type
(Etype
(E
));
6277 and then Is_Composite_Type
(Utyp
)
6278 and then Sloc
(E
) > No_Location
6279 and then Sloc
(Utyp
) > No_Location
6281 Get_Source_File_Index
(Sloc
(E
)) =
6282 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6284 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6288 Set_Is_Volatile
(E
);
6289 Set_Treat_As_Volatile
(E
);
6292 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6295 -- The following check is only relevant when SPARK_Mode is on as
6296 -- this is not a standard Ada legality rule. Pragma Volatile can
6297 -- only apply to a full type declaration or an object declaration
6298 -- (SPARK RM C.6(1)).
6301 and then Prag_Id
= Pragma_Volatile
6302 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6303 N_Object_Declaration
)
6306 ("argument of pragma % must denote a full type or object "
6307 & "declaration", Arg1
);
6309 end Process_Atomic_Shared_Volatile
;
6311 -------------------------------------------
6312 -- Process_Compile_Time_Warning_Or_Error --
6313 -------------------------------------------
6315 procedure Process_Compile_Time_Warning_Or_Error
is
6316 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6319 Check_Arg_Count
(2);
6320 Check_No_Identifiers
;
6321 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6322 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6324 if Compile_Time_Known_Value
(Arg1x
) then
6325 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6327 Str
: constant String_Id
:=
6328 Strval
(Get_Pragma_Arg
(Arg2
));
6329 Len
: constant Int
:= String_Length
(Str
);
6334 Cent
: constant Entity_Id
:=
6335 Cunit_Entity
(Current_Sem_Unit
);
6337 Force
: constant Boolean :=
6338 Prag_Id
= Pragma_Compile_Time_Warning
6340 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6341 and then (Ekind
(Cent
) /= E_Package
6342 or else not In_Private_Part
(Cent
));
6343 -- Set True if this is the warning case, and we are in the
6344 -- visible part of a package spec, or in a subprogram spec,
6345 -- in which case we want to force the client to see the
6346 -- warning, even though it is not in the main unit.
6349 -- Loop through segments of message separated by line feeds.
6350 -- We output these segments as separate messages with
6351 -- continuation marks for all but the first.
6356 Error_Msg_Strlen
:= 0;
6358 -- Loop to copy characters from argument to error message
6362 exit when Ptr
> Len
;
6363 CC
:= Get_String_Char
(Str
, Ptr
);
6366 -- Ignore wide chars ??? else store character
6368 if In_Character_Range
(CC
) then
6369 C
:= Get_Character
(CC
);
6370 exit when C
= ASCII
.LF
;
6371 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6372 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6376 -- Here with one line ready to go
6378 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6380 -- If this is a warning in a spec, then we want clients
6381 -- to see the warning, so mark the message with the
6382 -- special sequence !! to force the warning. In the case
6383 -- of a package spec, we do not force this if we are in
6384 -- the private part of the spec.
6387 if Cont
= False then
6388 Error_Msg_N
("<<~!!", Arg1
);
6391 Error_Msg_N
("\<<~!!", Arg1
);
6394 -- Error, rather than warning, or in a body, so we do not
6395 -- need to force visibility for client (error will be
6396 -- output in any case, and this is the situation in which
6397 -- we do not want a client to get a warning, since the
6398 -- warning is in the body or the spec private part).
6401 if Cont
= False then
6402 Error_Msg_N
("<<~", Arg1
);
6405 Error_Msg_N
("\<<~", Arg1
);
6409 exit when Ptr
> Len
;
6414 end Process_Compile_Time_Warning_Or_Error
;
6416 ------------------------
6417 -- Process_Convention --
6418 ------------------------
6420 procedure Process_Convention
6421 (C
: out Convention_Id
;
6422 Ent
: out Entity_Id
)
6426 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6427 -- Called if we have more than one Export/Import/Convention pragma.
6428 -- This is generally illegal, but we have a special case of allowing
6429 -- Import and Interface to coexist if they specify the convention in
6430 -- a consistent manner. We are allowed to do this, since Interface is
6431 -- an implementation defined pragma, and we choose to do it since we
6432 -- know Rational allows this combination. S is the entity id of the
6433 -- subprogram in question. This procedure also sets the special flag
6434 -- Import_Interface_Present in both pragmas in the case where we do
6435 -- have matching Import and Interface pragmas.
6437 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6438 -- Set convention in entity E, and also flag that the entity has a
6439 -- convention pragma. If entity is for a private or incomplete type,
6440 -- also set convention and flag on underlying type. This procedure
6441 -- also deals with the special case of C_Pass_By_Copy convention,
6442 -- and error checks for inappropriate convention specification.
6444 -------------------------------
6445 -- Diagnose_Multiple_Pragmas --
6446 -------------------------------
6448 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6449 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6453 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6454 -- Decl is a pragma node. This function returns True if this
6455 -- pragma has a first argument that is an identifier with a
6456 -- Chars field corresponding to the Convention_Id C.
6458 function Same_Name
(Decl
: Node_Id
) return Boolean;
6459 -- Decl is a pragma node. This function returns True if this
6460 -- pragma has a second argument that is an identifier with a
6461 -- Chars field that matches the Chars of the current subprogram.
6463 ---------------------
6464 -- Same_Convention --
6465 ---------------------
6467 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6468 Arg1
: constant Node_Id
:=
6469 First
(Pragma_Argument_Associations
(Decl
));
6472 if Present
(Arg1
) then
6474 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6476 if Nkind
(Arg
) = N_Identifier
6477 and then Is_Convention_Name
(Chars
(Arg
))
6478 and then Get_Convention_Id
(Chars
(Arg
)) = C
6486 end Same_Convention
;
6492 function Same_Name
(Decl
: Node_Id
) return Boolean is
6493 Arg1
: constant Node_Id
:=
6494 First
(Pragma_Argument_Associations
(Decl
));
6502 Arg2
:= Next
(Arg1
);
6509 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6511 if Nkind
(Arg
) = N_Identifier
6512 and then Chars
(Arg
) = Chars
(S
)
6521 -- Start of processing for Diagnose_Multiple_Pragmas
6526 -- Definitely give message if we have Convention/Export here
6528 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6531 -- If we have an Import or Export, scan back from pragma to
6532 -- find any previous pragma applying to the same procedure.
6533 -- The scan will be terminated by the start of the list, or
6534 -- hitting the subprogram declaration. This won't allow one
6535 -- pragma to appear in the public part and one in the private
6536 -- part, but that seems very unlikely in practice.
6540 while Present
(Decl
) and then Decl
/= Pdec
loop
6542 -- Look for pragma with same name as us
6544 if Nkind
(Decl
) = N_Pragma
6545 and then Same_Name
(Decl
)
6547 -- Give error if same as our pragma or Export/Convention
6549 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6555 -- Case of Import/Interface or the other way round
6557 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6560 -- Here we know that we have Import and Interface. It
6561 -- doesn't matter which way round they are. See if
6562 -- they specify the same convention. If so, all OK,
6563 -- and set special flags to stop other messages
6565 if Same_Convention
(Decl
) then
6566 Set_Import_Interface_Present
(N
);
6567 Set_Import_Interface_Present
(Decl
);
6570 -- If different conventions, special message
6573 Error_Msg_Sloc
:= Sloc
(Decl
);
6575 ("convention differs from that given#", Arg1
);
6585 -- Give message if needed if we fall through those tests
6586 -- except on Relaxed_RM_Semantics where we let go: either this
6587 -- is a case accepted/ignored by other Ada compilers (e.g.
6588 -- a mix of Convention and Import), or another error will be
6589 -- generated later (e.g. using both Import and Export).
6591 if Err
and not Relaxed_RM_Semantics
then
6593 ("at most one Convention/Export/Import pragma is allowed",
6596 end Diagnose_Multiple_Pragmas
;
6598 --------------------------------
6599 -- Set_Convention_From_Pragma --
6600 --------------------------------
6602 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6604 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6605 -- for an overridden dispatching operation. Technically this is
6606 -- an amendment and should only be done in Ada 2005 mode. However,
6607 -- this is clearly a mistake, since the problem that is addressed
6608 -- by this AI is that there is a clear gap in the RM.
6610 if Is_Dispatching_Operation
(E
)
6611 and then Present
(Overridden_Operation
(E
))
6612 and then C
/= Convention
(Overridden_Operation
(E
))
6615 ("cannot change convention for overridden dispatching "
6616 & "operation", Arg1
);
6619 -- Special checks for Convention_Stdcall
6621 if C
= Convention_Stdcall
then
6623 -- A dispatching call is not allowed. A dispatching subprogram
6624 -- cannot be used to interface to the Win32 API, so in fact
6625 -- this check does not impose any effective restriction.
6627 if Is_Dispatching_Operation
(E
) then
6628 Error_Msg_Sloc
:= Sloc
(E
);
6630 -- Note: make this unconditional so that if there is more
6631 -- than one call to which the pragma applies, we get a
6632 -- message for each call. Also don't use Error_Pragma,
6633 -- so that we get multiple messages.
6636 ("dispatching subprogram# cannot use Stdcall convention!",
6639 -- Subprograms are not allowed
6641 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6645 and then Ekind
(E
) /= E_Variable
6647 -- An access to subprogram is also allowed
6651 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6653 -- Allow internal call to set convention of subprogram type
6655 and then not (Ekind
(E
) = E_Subprogram_Type
)
6658 ("second argument of pragma% must be subprogram (type)",
6663 -- Set the convention
6665 Set_Convention
(E
, C
);
6666 Set_Has_Convention_Pragma
(E
);
6668 -- For the case of a record base type, also set the convention of
6669 -- any anonymous access types declared in the record which do not
6670 -- currently have a specified convention.
6672 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6677 Comp
:= First_Component
(E
);
6678 while Present
(Comp
) loop
6679 if Present
(Etype
(Comp
))
6680 and then Ekind_In
(Etype
(Comp
),
6681 E_Anonymous_Access_Type
,
6682 E_Anonymous_Access_Subprogram_Type
)
6683 and then not Has_Convention_Pragma
(Comp
)
6685 Set_Convention
(Comp
, C
);
6688 Next_Component
(Comp
);
6693 -- Deal with incomplete/private type case, where underlying type
6694 -- is available, so set convention of that underlying type.
6696 if Is_Incomplete_Or_Private_Type
(E
)
6697 and then Present
(Underlying_Type
(E
))
6699 Set_Convention
(Underlying_Type
(E
), C
);
6700 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6703 -- A class-wide type should inherit the convention of the specific
6704 -- root type (although this isn't specified clearly by the RM).
6706 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6707 Set_Convention
(Class_Wide_Type
(E
), C
);
6710 -- If the entity is a record type, then check for special case of
6711 -- C_Pass_By_Copy, which is treated the same as C except that the
6712 -- special record flag is set. This convention is only permitted
6713 -- on record types (see AI95-00131).
6715 if Cname
= Name_C_Pass_By_Copy
then
6716 if Is_Record_Type
(E
) then
6717 Set_C_Pass_By_Copy
(Base_Type
(E
));
6718 elsif Is_Incomplete_Or_Private_Type
(E
)
6719 and then Is_Record_Type
(Underlying_Type
(E
))
6721 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6724 ("C_Pass_By_Copy convention allowed only for record type",
6729 -- If the entity is a derived boolean type, check for the special
6730 -- case of convention C, C++, or Fortran, where we consider any
6731 -- nonzero value to represent true.
6733 if Is_Discrete_Type
(E
)
6734 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6740 C
= Convention_Fortran
)
6742 Set_Nonzero_Is_True
(Base_Type
(E
));
6744 end Set_Convention_From_Pragma
;
6748 Comp_Unit
: Unit_Number_Type
;
6753 -- Start of processing for Process_Convention
6756 Check_At_Least_N_Arguments
(2);
6757 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6758 Check_Arg_Is_Identifier
(Arg1
);
6759 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6761 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6762 -- tested again below to set the critical flag).
6764 if Cname
= Name_C_Pass_By_Copy
then
6767 -- Otherwise we must have something in the standard convention list
6769 elsif Is_Convention_Name
(Cname
) then
6770 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6772 -- Otherwise warn on unrecognized convention
6775 if Warn_On_Export_Import
then
6777 ("??unrecognized convention name, C assumed",
6778 Get_Pragma_Arg
(Arg1
));
6784 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6785 Check_Arg_Is_Local_Name
(Arg2
);
6787 Id
:= Get_Pragma_Arg
(Arg2
);
6790 if not Is_Entity_Name
(Id
) then
6791 Error_Pragma_Arg
("entity name required", Arg2
);
6796 -- Set entity to return
6800 -- Ada_Pass_By_Copy special checking
6802 if C
= Convention_Ada_Pass_By_Copy
then
6803 if not Is_First_Subtype
(E
) then
6805 ("convention `Ada_Pass_By_Copy` only allowed for types",
6809 if Is_By_Reference_Type
(E
) then
6811 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6815 -- Ada_Pass_By_Reference special checking
6817 elsif C
= Convention_Ada_Pass_By_Reference
then
6818 if not Is_First_Subtype
(E
) then
6820 ("convention `Ada_Pass_By_Reference` only allowed for types",
6824 if Is_By_Copy_Type
(E
) then
6826 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6831 -- Go to renamed subprogram if present, since convention applies to
6832 -- the actual renamed entity, not to the renaming entity. If the
6833 -- subprogram is inherited, go to parent subprogram.
6835 if Is_Subprogram
(E
)
6836 and then Present
(Alias
(E
))
6838 if Nkind
(Parent
(Declaration_Node
(E
))) =
6839 N_Subprogram_Renaming_Declaration
6841 if Scope
(E
) /= Scope
(Alias
(E
)) then
6843 ("cannot apply pragma% to non-local entity&#", E
);
6848 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6849 N_Private_Extension_Declaration
)
6850 and then Scope
(E
) = Scope
(Alias
(E
))
6854 -- Return the parent subprogram the entity was inherited from
6860 -- Check that we are not applying this to a specless body. Relax this
6861 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6863 if Is_Subprogram
(E
)
6864 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6865 and then not Relaxed_RM_Semantics
6868 ("pragma% requires separate spec and must come before body");
6871 -- Check that we are not applying this to a named constant
6873 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6874 Error_Msg_Name_1
:= Pname
;
6876 ("cannot apply pragma% to named constant!",
6877 Get_Pragma_Arg
(Arg2
));
6879 ("\supply appropriate type for&!", Arg2
);
6882 if Ekind
(E
) = E_Enumeration_Literal
then
6883 Error_Pragma
("enumeration literal not allowed for pragma%");
6886 -- Check for rep item appearing too early or too late
6888 if Etype
(E
) = Any_Type
6889 or else Rep_Item_Too_Early
(E
, N
)
6893 elsif Present
(Underlying_Type
(E
)) then
6894 E
:= Underlying_Type
(E
);
6897 if Rep_Item_Too_Late
(E
, N
) then
6901 if Has_Convention_Pragma
(E
) then
6902 Diagnose_Multiple_Pragmas
(E
);
6904 elsif Convention
(E
) = Convention_Protected
6905 or else Ekind
(Scope
(E
)) = E_Protected_Type
6908 ("a protected operation cannot be given a different convention",
6912 -- For Intrinsic, a subprogram is required
6914 if C
= Convention_Intrinsic
6915 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
6918 ("second argument of pragma% must be a subprogram", Arg2
);
6921 -- Deal with non-subprogram cases
6923 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
6924 Set_Convention_From_Pragma
(E
);
6927 Check_First_Subtype
(Arg2
);
6928 Set_Convention_From_Pragma
(Base_Type
(E
));
6930 -- For access subprograms, we must set the convention on the
6931 -- internally generated directly designated type as well.
6933 if Ekind
(E
) = E_Access_Subprogram_Type
then
6934 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
6938 -- For the subprogram case, set proper convention for all homonyms
6939 -- in same scope and the same declarative part, i.e. the same
6940 -- compilation unit.
6943 Comp_Unit
:= Get_Source_Unit
(E
);
6944 Set_Convention_From_Pragma
(E
);
6946 -- Treat a pragma Import as an implicit body, and pragma import
6947 -- as implicit reference (for navigation in GPS).
6949 if Prag_Id
= Pragma_Import
then
6950 Generate_Reference
(E
, Id
, 'b');
6952 -- For exported entities we restrict the generation of references
6953 -- to entities exported to foreign languages since entities
6954 -- exported to Ada do not provide further information to GPS and
6955 -- add undesired references to the output of the gnatxref tool.
6957 elsif Prag_Id
= Pragma_Export
6958 and then Convention
(E
) /= Convention_Ada
6960 Generate_Reference
(E
, Id
, 'i');
6963 -- If the pragma comes from from an aspect, it only applies to the
6964 -- given entity, not its homonyms.
6966 if From_Aspect_Specification
(N
) then
6970 -- Otherwise Loop through the homonyms of the pragma argument's
6971 -- entity, an apply convention to those in the current scope.
6977 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
6979 -- Ignore entry for which convention is already set
6981 if Has_Convention_Pragma
(E1
) then
6985 -- Do not set the pragma on inherited operations or on formal
6988 if Comes_From_Source
(E1
)
6989 and then Comp_Unit
= Get_Source_Unit
(E1
)
6990 and then not Is_Formal_Subprogram
(E1
)
6991 and then Nkind
(Original_Node
(Parent
(E1
))) /=
6992 N_Full_Type_Declaration
6994 if Present
(Alias
(E1
))
6995 and then Scope
(E1
) /= Scope
(Alias
(E1
))
6998 ("cannot apply pragma% to non-local entity& declared#",
7002 Set_Convention_From_Pragma
(E1
);
7004 if Prag_Id
= Pragma_Import
then
7005 Generate_Reference
(E1
, Id
, 'b');
7013 end Process_Convention
;
7015 ----------------------------------------
7016 -- Process_Disable_Enable_Atomic_Sync --
7017 ----------------------------------------
7019 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7021 Check_No_Identifiers
;
7022 Check_At_Most_N_Arguments
(1);
7024 -- Modeled internally as
7025 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7029 Pragma_Identifier
=>
7030 Make_Identifier
(Loc
, Nam
),
7031 Pragma_Argument_Associations
=> New_List
(
7032 Make_Pragma_Argument_Association
(Loc
,
7034 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7036 if Present
(Arg1
) then
7037 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7041 end Process_Disable_Enable_Atomic_Sync
;
7043 -------------------------------------------------
7044 -- Process_Extended_Import_Export_Internal_Arg --
7045 -------------------------------------------------
7047 procedure Process_Extended_Import_Export_Internal_Arg
7048 (Arg_Internal
: Node_Id
:= Empty
)
7051 if No
(Arg_Internal
) then
7052 Error_Pragma
("Internal parameter required for pragma%");
7055 if Nkind
(Arg_Internal
) = N_Identifier
then
7058 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7059 and then (Prag_Id
= Pragma_Import_Function
7061 Prag_Id
= Pragma_Export_Function
)
7067 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7070 Check_Arg_Is_Local_Name
(Arg_Internal
);
7071 end Process_Extended_Import_Export_Internal_Arg
;
7073 --------------------------------------------------
7074 -- Process_Extended_Import_Export_Object_Pragma --
7075 --------------------------------------------------
7077 procedure Process_Extended_Import_Export_Object_Pragma
7078 (Arg_Internal
: Node_Id
;
7079 Arg_External
: Node_Id
;
7085 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7086 Def_Id
:= Entity
(Arg_Internal
);
7088 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7090 ("pragma% must designate an object", Arg_Internal
);
7093 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7095 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7098 ("previous Common/Psect_Object applies, pragma % not permitted",
7102 if Rep_Item_Too_Late
(Def_Id
, N
) then
7106 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7108 if Present
(Arg_Size
) then
7109 Check_Arg_Is_External_Name
(Arg_Size
);
7112 -- Export_Object case
7114 if Prag_Id
= Pragma_Export_Object
then
7115 if not Is_Library_Level_Entity
(Def_Id
) then
7117 ("argument for pragma% must be library level entity",
7121 if Ekind
(Current_Scope
) = E_Generic_Package
then
7122 Error_Pragma
("pragma& cannot appear in a generic unit");
7125 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7127 ("exported object must have compile time known size",
7131 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7132 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7134 Set_Exported
(Def_Id
, Arg_Internal
);
7137 -- Import_Object case
7140 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7142 ("cannot use pragma% for task/protected object",
7146 if Ekind
(Def_Id
) = E_Constant
then
7148 ("cannot import a constant", Arg_Internal
);
7151 if Warn_On_Export_Import
7152 and then Has_Discriminants
(Etype
(Def_Id
))
7155 ("imported value must be initialized??", Arg_Internal
);
7158 if Warn_On_Export_Import
7159 and then Is_Access_Type
(Etype
(Def_Id
))
7162 ("cannot import object of an access type??", Arg_Internal
);
7165 if Warn_On_Export_Import
7166 and then Is_Imported
(Def_Id
)
7168 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7170 -- Check for explicit initialization present. Note that an
7171 -- initialization generated by the code generator, e.g. for an
7172 -- access type, does not count here.
7174 elsif Present
(Expression
(Parent
(Def_Id
)))
7177 (Original_Node
(Expression
(Parent
(Def_Id
))))
7179 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7181 ("imported entities cannot be initialized (RM B.1(24))",
7182 "\no initialization allowed for & declared#", Arg1
);
7184 Set_Imported
(Def_Id
);
7185 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7188 end Process_Extended_Import_Export_Object_Pragma
;
7190 ------------------------------------------------------
7191 -- Process_Extended_Import_Export_Subprogram_Pragma --
7192 ------------------------------------------------------
7194 procedure Process_Extended_Import_Export_Subprogram_Pragma
7195 (Arg_Internal
: Node_Id
;
7196 Arg_External
: Node_Id
;
7197 Arg_Parameter_Types
: Node_Id
;
7198 Arg_Result_Type
: Node_Id
:= Empty
;
7199 Arg_Mechanism
: Node_Id
;
7200 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7206 Ambiguous
: Boolean;
7209 function Same_Base_Type
7211 Formal
: Entity_Id
) return Boolean;
7212 -- Determines if Ptype references the type of Formal. Note that only
7213 -- the base types need to match according to the spec. Ptype here is
7214 -- the argument from the pragma, which is either a type name, or an
7215 -- access attribute.
7217 --------------------
7218 -- Same_Base_Type --
7219 --------------------
7221 function Same_Base_Type
7223 Formal
: Entity_Id
) return Boolean
7225 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7229 -- Case where pragma argument is typ'Access
7231 if Nkind
(Ptype
) = N_Attribute_Reference
7232 and then Attribute_Name
(Ptype
) = Name_Access
7234 Pref
:= Prefix
(Ptype
);
7237 if not Is_Entity_Name
(Pref
)
7238 or else Entity
(Pref
) = Any_Type
7243 -- We have a match if the corresponding argument is of an
7244 -- anonymous access type, and its designated type matches the
7245 -- type of the prefix of the access attribute
7247 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7248 and then Base_Type
(Entity
(Pref
)) =
7249 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7251 -- Case where pragma argument is a type name
7256 if not Is_Entity_Name
(Ptype
)
7257 or else Entity
(Ptype
) = Any_Type
7262 -- We have a match if the corresponding argument is of the type
7263 -- given in the pragma (comparing base types)
7265 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7269 -- Start of processing for
7270 -- Process_Extended_Import_Export_Subprogram_Pragma
7273 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7277 -- Loop through homonyms (overloadings) of the entity
7279 Hom_Id
:= Entity
(Arg_Internal
);
7280 while Present
(Hom_Id
) loop
7281 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7283 -- We need a subprogram in the current scope
7285 if not Is_Subprogram
(Def_Id
)
7286 or else Scope
(Def_Id
) /= Current_Scope
7293 -- Pragma cannot apply to subprogram body
7295 if Is_Subprogram
(Def_Id
)
7296 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7300 ("pragma% requires separate spec"
7301 & " and must come before body");
7304 -- Test result type if given, note that the result type
7305 -- parameter can only be present for the function cases.
7307 if Present
(Arg_Result_Type
)
7308 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7312 elsif Etype
(Def_Id
) /= Standard_Void_Type
7314 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7318 -- Test parameter types if given. Note that this parameter
7319 -- has not been analyzed (and must not be, since it is
7320 -- semantic nonsense), so we get it as the parser left it.
7322 elsif Present
(Arg_Parameter_Types
) then
7323 Check_Matching_Types
: declare
7328 Formal
:= First_Formal
(Def_Id
);
7330 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7331 if Present
(Formal
) then
7335 -- A list of one type, e.g. (List) is parsed as
7336 -- a parenthesized expression.
7338 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7339 and then Paren_Count
(Arg_Parameter_Types
) = 1
7342 or else Present
(Next_Formal
(Formal
))
7347 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7350 -- A list of more than one type is parsed as a aggregate
7352 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7353 and then Paren_Count
(Arg_Parameter_Types
) = 0
7355 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7356 while Present
(Ptype
) or else Present
(Formal
) loop
7359 or else not Same_Base_Type
(Ptype
, Formal
)
7364 Next_Formal
(Formal
);
7369 -- Anything else is of the wrong form
7373 ("wrong form for Parameter_Types parameter",
7374 Arg_Parameter_Types
);
7376 end Check_Matching_Types
;
7379 -- Match is now False if the entry we found did not match
7380 -- either a supplied Parameter_Types or Result_Types argument
7386 -- Ambiguous case, the flag Ambiguous shows if we already
7387 -- detected this and output the initial messages.
7390 if not Ambiguous
then
7392 Error_Msg_Name_1
:= Pname
;
7394 ("pragma% does not uniquely identify subprogram!",
7396 Error_Msg_Sloc
:= Sloc
(Ent
);
7397 Error_Msg_N
("matching subprogram #!", N
);
7401 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7402 Error_Msg_N
("matching subprogram #!", N
);
7407 Hom_Id
:= Homonym
(Hom_Id
);
7410 -- See if we found an entry
7413 if not Ambiguous
then
7414 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7416 ("pragma% cannot be given for generic subprogram");
7419 ("pragma% does not identify local subprogram");
7426 -- Import pragmas must be for imported entities
7428 if Prag_Id
= Pragma_Import_Function
7430 Prag_Id
= Pragma_Import_Procedure
7432 Prag_Id
= Pragma_Import_Valued_Procedure
7434 if not Is_Imported
(Ent
) then
7436 ("pragma Import or Interface must precede pragma%");
7439 -- Here we have the Export case which can set the entity as exported
7441 -- But does not do so if the specified external name is null, since
7442 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7443 -- compatible) to request no external name.
7445 elsif Nkind
(Arg_External
) = N_String_Literal
7446 and then String_Length
(Strval
(Arg_External
)) = 0
7450 -- In all other cases, set entity as exported
7453 Set_Exported
(Ent
, Arg_Internal
);
7456 -- Special processing for Valued_Procedure cases
7458 if Prag_Id
= Pragma_Import_Valued_Procedure
7460 Prag_Id
= Pragma_Export_Valued_Procedure
7462 Formal
:= First_Formal
(Ent
);
7465 Error_Pragma
("at least one parameter required for pragma%");
7467 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7468 Error_Pragma
("first parameter must have mode out for pragma%");
7471 Set_Is_Valued_Procedure
(Ent
);
7475 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7477 -- Process Result_Mechanism argument if present. We have already
7478 -- checked that this is only allowed for the function case.
7480 if Present
(Arg_Result_Mechanism
) then
7481 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7484 -- Process Mechanism parameter if present. Note that this parameter
7485 -- is not analyzed, and must not be analyzed since it is semantic
7486 -- nonsense, so we get it in exactly as the parser left it.
7488 if Present
(Arg_Mechanism
) then
7496 -- A single mechanism association without a formal parameter
7497 -- name is parsed as a parenthesized expression. All other
7498 -- cases are parsed as aggregates, so we rewrite the single
7499 -- parameter case as an aggregate for consistency.
7501 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7502 and then Paren_Count
(Arg_Mechanism
) = 1
7504 Rewrite
(Arg_Mechanism
,
7505 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7506 Expressions
=> New_List
(
7507 Relocate_Node
(Arg_Mechanism
))));
7510 -- Case of only mechanism name given, applies to all formals
7512 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7513 Formal
:= First_Formal
(Ent
);
7514 while Present
(Formal
) loop
7515 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7516 Next_Formal
(Formal
);
7519 -- Case of list of mechanism associations given
7522 if Null_Record_Present
(Arg_Mechanism
) then
7524 ("inappropriate form for Mechanism parameter",
7528 -- Deal with positional ones first
7530 Formal
:= First_Formal
(Ent
);
7532 if Present
(Expressions
(Arg_Mechanism
)) then
7533 Mname
:= First
(Expressions
(Arg_Mechanism
));
7534 while Present
(Mname
) loop
7537 ("too many mechanism associations", Mname
);
7540 Set_Mechanism_Value
(Formal
, Mname
);
7541 Next_Formal
(Formal
);
7546 -- Deal with named entries
7548 if Present
(Component_Associations
(Arg_Mechanism
)) then
7549 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7550 while Present
(Massoc
) loop
7551 Choice
:= First
(Choices
(Massoc
));
7553 if Nkind
(Choice
) /= N_Identifier
7554 or else Present
(Next
(Choice
))
7557 ("incorrect form for mechanism association",
7561 Formal
:= First_Formal
(Ent
);
7565 ("parameter name & not present", Choice
);
7568 if Chars
(Choice
) = Chars
(Formal
) then
7570 (Formal
, Expression
(Massoc
));
7572 -- Set entity on identifier (needed by ASIS)
7574 Set_Entity
(Choice
, Formal
);
7579 Next_Formal
(Formal
);
7588 end Process_Extended_Import_Export_Subprogram_Pragma
;
7590 --------------------------
7591 -- Process_Generic_List --
7592 --------------------------
7594 procedure Process_Generic_List
is
7599 Check_No_Identifiers
;
7600 Check_At_Least_N_Arguments
(1);
7602 -- Check all arguments are names of generic units or instances
7605 while Present
(Arg
) loop
7606 Exp
:= Get_Pragma_Arg
(Arg
);
7609 if not Is_Entity_Name
(Exp
)
7611 (not Is_Generic_Instance
(Entity
(Exp
))
7613 not Is_Generic_Unit
(Entity
(Exp
)))
7616 ("pragma% argument must be name of generic unit/instance",
7622 end Process_Generic_List
;
7624 ------------------------------------
7625 -- Process_Import_Predefined_Type --
7626 ------------------------------------
7628 procedure Process_Import_Predefined_Type
is
7629 Loc
: constant Source_Ptr
:= Sloc
(N
);
7631 Ftyp
: Node_Id
:= Empty
;
7637 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7640 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7641 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7645 Ftyp
:= Node
(Elmt
);
7647 if Present
(Ftyp
) then
7649 -- Don't build a derived type declaration, because predefined C
7650 -- types have no declaration anywhere, so cannot really be named.
7651 -- Instead build a full type declaration, starting with an
7652 -- appropriate type definition is built
7654 if Is_Floating_Point_Type
(Ftyp
) then
7655 Def
:= Make_Floating_Point_Definition
(Loc
,
7656 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7657 Make_Real_Range_Specification
(Loc
,
7658 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7659 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7661 -- Should never have a predefined type we cannot handle
7664 raise Program_Error
;
7667 -- Build and insert a Full_Type_Declaration, which will be
7668 -- analyzed as soon as this list entry has been analyzed.
7670 Decl
:= Make_Full_Type_Declaration
(Loc
,
7671 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7672 Type_Definition
=> Def
);
7674 Insert_After
(N
, Decl
);
7675 Mark_Rewrite_Insertion
(Decl
);
7678 Error_Pragma_Arg
("no matching type found for pragma%",
7681 end Process_Import_Predefined_Type
;
7683 ---------------------------------
7684 -- Process_Import_Or_Interface --
7685 ---------------------------------
7687 procedure Process_Import_Or_Interface
is
7693 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7694 -- pragma Import (Entity, "external name");
7696 if Relaxed_RM_Semantics
7697 and then Arg_Count
= 2
7698 and then Prag_Id
= Pragma_Import
7699 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7702 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7705 if not Is_Entity_Name
(Def_Id
) then
7706 Error_Pragma_Arg
("entity name required", Arg1
);
7709 Def_Id
:= Entity
(Def_Id
);
7710 Kill_Size_Check_Code
(Def_Id
);
7711 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7714 Process_Convention
(C
, Def_Id
);
7715 Kill_Size_Check_Code
(Def_Id
);
7716 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7719 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7721 -- We do not permit Import to apply to a renaming declaration
7723 if Present
(Renamed_Object
(Def_Id
)) then
7725 ("pragma% not allowed for object renaming", Arg2
);
7727 -- User initialization is not allowed for imported object, but
7728 -- the object declaration may contain a default initialization,
7729 -- that will be discarded. Note that an explicit initialization
7730 -- only counts if it comes from source, otherwise it is simply
7731 -- the code generator making an implicit initialization explicit.
7733 elsif Present
(Expression
(Parent
(Def_Id
)))
7734 and then Comes_From_Source
7735 (Original_Node
(Expression
(Parent
(Def_Id
))))
7737 -- Set imported flag to prevent cascaded errors
7739 Set_Is_Imported
(Def_Id
);
7741 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7743 ("no initialization allowed for declaration of& #",
7744 "\imported entities cannot be initialized (RM B.1(24))",
7748 -- If the pragma comes from an aspect specification the
7749 -- Is_Imported flag has already been set.
7751 if not From_Aspect_Specification
(N
) then
7752 Set_Imported
(Def_Id
);
7755 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7757 -- Note that we do not set Is_Public here. That's because we
7758 -- only want to set it if there is no address clause, and we
7759 -- don't know that yet, so we delay that processing till
7762 -- pragma Import completes deferred constants
7764 if Ekind
(Def_Id
) = E_Constant
then
7765 Set_Has_Completion
(Def_Id
);
7768 -- It is not possible to import a constant of an unconstrained
7769 -- array type (e.g. string) because there is no simple way to
7770 -- write a meaningful subtype for it.
7772 if Is_Array_Type
(Etype
(Def_Id
))
7773 and then not Is_Constrained
(Etype
(Def_Id
))
7776 ("imported constant& must have a constrained subtype",
7781 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7783 -- If the name is overloaded, pragma applies to all of the denoted
7784 -- entities in the same declarative part, unless the pragma comes
7785 -- from an aspect specification or was generated by the compiler
7786 -- (such as for pragma Provide_Shift_Operators).
7789 while Present
(Hom_Id
) loop
7791 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7793 -- Ignore inherited subprograms because the pragma will apply
7794 -- to the parent operation, which is the one called.
7796 if Is_Overloadable
(Def_Id
)
7797 and then Present
(Alias
(Def_Id
))
7801 -- If it is not a subprogram, it must be in an outer scope and
7802 -- pragma does not apply.
7804 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7807 -- The pragma does not apply to primitives of interfaces
7809 elsif Is_Dispatching_Operation
(Def_Id
)
7810 and then Present
(Find_Dispatching_Type
(Def_Id
))
7811 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7815 -- Verify that the homonym is in the same declarative part (not
7816 -- just the same scope). If the pragma comes from an aspect
7817 -- specification we know that it is part of the declaration.
7819 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7820 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7821 and then not From_Aspect_Specification
(N
)
7826 -- If the pragma comes from an aspect specification the
7827 -- Is_Imported flag has already been set.
7829 if not From_Aspect_Specification
(N
) then
7830 Set_Imported
(Def_Id
);
7833 -- Reject an Import applied to an abstract subprogram
7835 if Is_Subprogram
(Def_Id
)
7836 and then Is_Abstract_Subprogram
(Def_Id
)
7838 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7840 ("cannot import abstract subprogram& declared#",
7844 -- Special processing for Convention_Intrinsic
7846 if C
= Convention_Intrinsic
then
7848 -- Link_Name argument not allowed for intrinsic
7852 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7854 -- If no external name is present, then check that this
7855 -- is a valid intrinsic subprogram. If an external name
7856 -- is present, then this is handled by the back end.
7859 Check_Intrinsic_Subprogram
7860 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7864 -- Verify that the subprogram does not have a completion
7865 -- through a renaming declaration. For other completions the
7866 -- pragma appears as a too late representation.
7869 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7873 and then Nkind
(Decl
) = N_Subprogram_Declaration
7874 and then Present
(Corresponding_Body
(Decl
))
7875 and then Nkind
(Unit_Declaration_Node
7876 (Corresponding_Body
(Decl
))) =
7877 N_Subprogram_Renaming_Declaration
7879 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7881 ("cannot import&, renaming already provided for "
7882 & "declaration #", N
, Def_Id
);
7886 -- If the pragma comes from an aspect specification, there
7887 -- must be an Import aspect specified as well. In the rare
7888 -- case where Import is set to False, the suprogram needs to
7889 -- have a local completion.
7892 Imp_Aspect
: constant Node_Id
:=
7893 Find_Aspect
(Def_Id
, Aspect_Import
);
7897 if Present
(Imp_Aspect
)
7898 and then Present
(Expression
(Imp_Aspect
))
7900 Expr
:= Expression
(Imp_Aspect
);
7901 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7903 if Is_Entity_Name
(Expr
)
7904 and then Entity
(Expr
) = Standard_True
7906 Set_Has_Completion
(Def_Id
);
7909 -- If there is no expression, the default is True, as for
7910 -- all boolean aspects. Same for the older pragma.
7913 Set_Has_Completion
(Def_Id
);
7917 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7920 if Is_Compilation_Unit
(Hom_Id
) then
7922 -- Its possible homonyms are not affected by the pragma.
7923 -- Such homonyms might be present in the context of other
7924 -- units being compiled.
7928 elsif From_Aspect_Specification
(N
) then
7931 -- If the pragma was created by the compiler, then we don't
7932 -- want it to apply to other homonyms. This kind of case can
7933 -- occur when using pragma Provide_Shift_Operators, which
7934 -- generates implicit shift and rotate operators with Import
7935 -- pragmas that might apply to earlier explicit or implicit
7936 -- declarations marked with Import (for example, coming from
7937 -- an earlier pragma Provide_Shift_Operators for another type),
7938 -- and we don't generally want other homonyms being treated
7939 -- as imported or the pragma flagged as an illegal duplicate.
7941 elsif not Comes_From_Source
(N
) then
7945 Hom_Id
:= Homonym
(Hom_Id
);
7949 -- When the convention is Java or CIL, we also allow Import to
7950 -- be given for packages, generic packages, exceptions, record
7951 -- components, and access to subprograms.
7953 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
7955 (Is_Package_Or_Generic_Package
(Def_Id
)
7956 or else Ekind
(Def_Id
) = E_Exception
7957 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
7958 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
7960 Set_Imported
(Def_Id
);
7961 Set_Is_Public
(Def_Id
);
7962 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7964 -- Import a CPP class
7966 elsif C
= Convention_CPP
7967 and then (Is_Record_Type
(Def_Id
)
7968 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
7970 if Ekind
(Def_Id
) = E_Incomplete_Type
then
7971 if Present
(Full_View
(Def_Id
)) then
7972 Def_Id
:= Full_View
(Def_Id
);
7976 ("cannot import 'C'P'P type before full declaration seen",
7977 Get_Pragma_Arg
(Arg2
));
7979 -- Although we have reported the error we decorate it as
7980 -- CPP_Class to avoid reporting spurious errors
7982 Set_Is_CPP_Class
(Def_Id
);
7987 -- Types treated as CPP classes must be declared limited (note:
7988 -- this used to be a warning but there is no real benefit to it
7989 -- since we did effectively intend to treat the type as limited
7992 if not Is_Limited_Type
(Def_Id
) then
7994 ("imported 'C'P'P type must be limited",
7995 Get_Pragma_Arg
(Arg2
));
7998 if Etype
(Def_Id
) /= Def_Id
7999 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8001 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8004 Set_Is_CPP_Class
(Def_Id
);
8006 -- Imported CPP types must not have discriminants (because C++
8007 -- classes do not have discriminants).
8009 if Has_Discriminants
(Def_Id
) then
8011 ("imported 'C'P'P type cannot have discriminants",
8012 First
(Discriminant_Specifications
8013 (Declaration_Node
(Def_Id
))));
8016 -- Check that components of imported CPP types do not have default
8017 -- expressions. For private types this check is performed when the
8018 -- full view is analyzed (see Process_Full_View).
8020 if not Is_Private_Type
(Def_Id
) then
8021 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8024 -- Import a CPP exception
8026 elsif C
= Convention_CPP
8027 and then Ekind
(Def_Id
) = E_Exception
8031 ("'External_'Name arguments is required for 'Cpp exception",
8034 -- As only a string is allowed, Check_Arg_Is_External_Name
8037 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8040 if Present
(Arg4
) then
8042 ("Link_Name argument not allowed for imported Cpp exception",
8046 -- Do not call Set_Interface_Name as the name of the exception
8047 -- shouldn't be modified (and in particular it shouldn't be
8048 -- the External_Name). For exceptions, the External_Name is the
8049 -- name of the RTTI structure.
8051 -- ??? Emit an error if pragma Import/Export_Exception is present
8053 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8055 Check_Arg_Count
(3);
8056 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8058 Process_Import_Predefined_Type
;
8062 ("second argument of pragma% must be object, subprogram "
8063 & "or incomplete type",
8067 -- If this pragma applies to a compilation unit, then the unit, which
8068 -- is a subprogram, does not require (or allow) a body. We also do
8069 -- not need to elaborate imported procedures.
8071 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8073 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8075 Set_Body_Required
(Cunit
, False);
8078 end Process_Import_Or_Interface
;
8080 --------------------
8081 -- Process_Inline --
8082 --------------------
8084 procedure Process_Inline
(Status
: Inline_Status
) is
8091 Effective
: Boolean := False;
8092 -- Set True if inline has some effect, i.e. if there is at least one
8093 -- subprogram set as inlined as a result of the use of the pragma.
8095 procedure Make_Inline
(Subp
: Entity_Id
);
8096 -- Subp is the defining unit name of the subprogram declaration. Set
8097 -- the flag, as well as the flag in the corresponding body, if there
8100 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8101 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8102 -- Has_Pragma_Inline_Always for the Inline_Always case.
8104 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8105 -- Returns True if it can be determined at this stage that inlining
8106 -- is not possible, for example if the body is available and contains
8107 -- exception handlers, we prevent inlining, since otherwise we can
8108 -- get undefined symbols at link time. This function also emits a
8109 -- warning if front-end inlining is enabled and the pragma appears
8112 -- ??? is business with link symbols still valid, or does it relate
8113 -- to front end ZCX which is being phased out ???
8115 ---------------------------
8116 -- Inlining_Not_Possible --
8117 ---------------------------
8119 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8120 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8124 if Nkind
(Decl
) = N_Subprogram_Body
then
8125 Stats
:= Handled_Statement_Sequence
(Decl
);
8126 return Present
(Exception_Handlers
(Stats
))
8127 or else Present
(At_End_Proc
(Stats
));
8129 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8130 and then Present
(Corresponding_Body
(Decl
))
8132 if Front_End_Inlining
8133 and then Analyzed
(Corresponding_Body
(Decl
))
8135 Error_Msg_N
("pragma appears too late, ignored??", N
);
8138 -- If the subprogram is a renaming as body, the body is just a
8139 -- call to the renamed subprogram, and inlining is trivially
8143 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8144 N_Subprogram_Renaming_Declaration
8150 Handled_Statement_Sequence
8151 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8154 Present
(Exception_Handlers
(Stats
))
8155 or else Present
(At_End_Proc
(Stats
));
8159 -- If body is not available, assume the best, the check is
8160 -- performed again when compiling enclosing package bodies.
8164 end Inlining_Not_Possible
;
8170 procedure Make_Inline
(Subp
: Entity_Id
) is
8171 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8172 Inner_Subp
: Entity_Id
:= Subp
;
8175 -- Ignore if bad type, avoid cascaded error
8177 if Etype
(Subp
) = Any_Type
then
8181 -- Ignore if all inlining is suppressed
8183 elsif Suppress_All_Inlining
then
8187 -- If inlining is not possible, for now do not treat as an error
8189 elsif Status
/= Suppressed
8190 and then Inlining_Not_Possible
(Subp
)
8195 -- Here we have a candidate for inlining, but we must exclude
8196 -- derived operations. Otherwise we would end up trying to inline
8197 -- a phantom declaration, and the result would be to drag in a
8198 -- body which has no direct inlining associated with it. That
8199 -- would not only be inefficient but would also result in the
8200 -- backend doing cross-unit inlining in cases where it was
8201 -- definitely inappropriate to do so.
8203 -- However, a simple Comes_From_Source test is insufficient, since
8204 -- we do want to allow inlining of generic instances which also do
8205 -- not come from source. We also need to recognize specs generated
8206 -- by the front-end for bodies that carry the pragma. Finally,
8207 -- predefined operators do not come from source but are not
8208 -- inlineable either.
8210 elsif Is_Generic_Instance
(Subp
)
8211 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8215 elsif not Comes_From_Source
(Subp
)
8216 and then Scope
(Subp
) /= Standard_Standard
8222 -- The referenced entity must either be the enclosing entity, or
8223 -- an entity declared within the current open scope.
8225 if Present
(Scope
(Subp
))
8226 and then Scope
(Subp
) /= Current_Scope
8227 and then Subp
/= Current_Scope
8230 ("argument of% must be entity in current scope", Assoc
);
8234 -- Processing for procedure, operator or function. If subprogram
8235 -- is aliased (as for an instance) indicate that the renamed
8236 -- entity (if declared in the same unit) is inlined.
8238 if Is_Subprogram
(Subp
) then
8239 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8241 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8242 Set_Inline_Flags
(Inner_Subp
);
8244 Decl
:= Parent
(Parent
(Inner_Subp
));
8246 if Nkind
(Decl
) = N_Subprogram_Declaration
8247 and then Present
(Corresponding_Body
(Decl
))
8249 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8251 elsif Is_Generic_Instance
(Subp
) then
8253 -- Indicate that the body needs to be created for
8254 -- inlining subsequent calls. The instantiation node
8255 -- follows the declaration of the wrapper package
8258 if Scope
(Subp
) /= Standard_Standard
8260 Need_Subprogram_Instance_Body
8261 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8267 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8268 -- appear in a formal part to apply to a formal subprogram.
8269 -- Do not apply check within an instance or a formal package
8270 -- the test will have been applied to the original generic.
8272 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8273 and then List_Containing
(Decl
) = List_Containing
(N
)
8274 and then not In_Instance
8277 ("Inline cannot apply to a formal subprogram", N
);
8279 -- If Subp is a renaming, it is the renamed entity that
8280 -- will appear in any call, and be inlined. However, for
8281 -- ASIS uses it is convenient to indicate that the renaming
8282 -- itself is an inlined subprogram, so that some gnatcheck
8283 -- rules can be applied in the absence of expansion.
8285 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8286 Set_Inline_Flags
(Subp
);
8292 -- For a generic subprogram set flag as well, for use at the point
8293 -- of instantiation, to determine whether the body should be
8296 elsif Is_Generic_Subprogram
(Subp
) then
8297 Set_Inline_Flags
(Subp
);
8300 -- Literals are by definition inlined
8302 elsif Kind
= E_Enumeration_Literal
then
8305 -- Anything else is an error
8309 ("expect subprogram name for pragma%", Assoc
);
8313 ----------------------
8314 -- Set_Inline_Flags --
8315 ----------------------
8317 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8319 -- First set the Has_Pragma_XXX flags and issue the appropriate
8320 -- errors and warnings for suspicious combinations.
8322 if Prag_Id
= Pragma_No_Inline
then
8323 if Has_Pragma_Inline_Always
(Subp
) then
8325 ("Inline_Always and No_Inline are mutually exclusive", N
);
8326 elsif Has_Pragma_Inline
(Subp
) then
8328 ("Inline and No_Inline both specified for& ??",
8329 N
, Entity
(Subp_Id
));
8332 Set_Has_Pragma_No_Inline
(Subp
);
8334 if Prag_Id
= Pragma_Inline_Always
then
8335 if Has_Pragma_No_Inline
(Subp
) then
8337 ("Inline_Always and No_Inline are mutually exclusive",
8341 Set_Has_Pragma_Inline_Always
(Subp
);
8343 if Has_Pragma_No_Inline
(Subp
) then
8345 ("Inline and No_Inline both specified for& ??",
8346 N
, Entity
(Subp_Id
));
8350 if not Has_Pragma_Inline
(Subp
) then
8351 Set_Has_Pragma_Inline
(Subp
);
8356 -- Then adjust the Is_Inlined flag. It can never be set if the
8357 -- subprogram is subject to pragma No_Inline.
8361 Set_Is_Inlined
(Subp
, False);
8365 if not Has_Pragma_No_Inline
(Subp
) then
8366 Set_Is_Inlined
(Subp
, True);
8369 end Set_Inline_Flags
;
8371 -- Start of processing for Process_Inline
8374 Check_No_Identifiers
;
8375 Check_At_Least_N_Arguments
(1);
8377 if Status
= Enabled
then
8378 Inline_Processing_Required
:= True;
8382 while Present
(Assoc
) loop
8383 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8387 if Is_Entity_Name
(Subp_Id
) then
8388 Subp
:= Entity
(Subp_Id
);
8390 if Subp
= Any_Id
then
8392 -- If previous error, avoid cascaded errors
8394 Check_Error_Detected
;
8401 -- For the pragma case, climb homonym chain. This is
8402 -- what implements allowing the pragma in the renaming
8403 -- case, with the result applying to the ancestors, and
8404 -- also allows Inline to apply to all previous homonyms.
8406 if not From_Aspect_Specification
(N
) then
8407 while Present
(Homonym
(Subp
))
8408 and then Scope
(Homonym
(Subp
)) = Current_Scope
8410 Make_Inline
(Homonym
(Subp
));
8411 Subp
:= Homonym
(Subp
);
8419 ("inappropriate argument for pragma%", Assoc
);
8422 and then Warn_On_Redundant_Constructs
8423 and then not (Status
= Suppressed
or else Suppress_All_Inlining
)
8425 if Inlining_Not_Possible
(Subp
) then
8427 ("pragma Inline for& is ignored?r?",
8428 N
, Entity
(Subp_Id
));
8431 ("pragma Inline for& is redundant?r?",
8432 N
, Entity
(Subp_Id
));
8440 ----------------------------
8441 -- Process_Interface_Name --
8442 ----------------------------
8444 procedure Process_Interface_Name
8445 (Subprogram_Def
: Entity_Id
;
8451 String_Val
: String_Id
;
8453 procedure Check_Form_Of_Interface_Name
8455 Ext_Name_Case
: Boolean);
8456 -- SN is a string literal node for an interface name. This routine
8457 -- performs some minimal checks that the name is reasonable. In
8458 -- particular that no spaces or other obviously incorrect characters
8459 -- appear. This is only a warning, since any characters are allowed.
8460 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8462 ----------------------------------
8463 -- Check_Form_Of_Interface_Name --
8464 ----------------------------------
8466 procedure Check_Form_Of_Interface_Name
8468 Ext_Name_Case
: Boolean)
8470 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8471 SL
: constant Nat
:= String_Length
(S
);
8476 Error_Msg_N
("interface name cannot be null string", SN
);
8479 for J
in 1 .. SL
loop
8480 C
:= Get_String_Char
(S
, J
);
8482 -- Look for dubious character and issue unconditional warning.
8483 -- Definitely dubious if not in character range.
8485 if not In_Character_Range
(C
)
8487 -- For all cases except CLI target,
8488 -- commas, spaces and slashes are dubious (in CLI, we use
8489 -- commas and backslashes in external names to specify
8490 -- assembly version and public key, while slashes and spaces
8491 -- can be used in names to mark nested classes and
8494 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8495 and then (Get_Character
(C
) = ','
8497 Get_Character
(C
) = '\'))
8498 or else (VM_Target
/= CLI_Target
8499 and then (Get_Character
(C
) = ' '
8501 Get_Character
(C
) = '/'))
8504 ("??interface name contains illegal character",
8505 Sloc
(SN
) + Source_Ptr
(J
));
8508 end Check_Form_Of_Interface_Name
;
8510 -- Start of processing for Process_Interface_Name
8513 if No
(Link_Arg
) then
8514 if No
(Ext_Arg
) then
8515 if VM_Target
= CLI_Target
8516 and then Ekind
(Subprogram_Def
) = E_Package
8517 and then Nkind
(Parent
(Subprogram_Def
)) =
8518 N_Package_Specification
8519 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8524 (Generic_Parent
(Parent
(Subprogram_Def
))));
8529 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8531 Link_Nam
:= Expression
(Ext_Arg
);
8534 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8535 Ext_Nam
:= Expression
(Ext_Arg
);
8540 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8541 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8542 Ext_Nam
:= Expression
(Ext_Arg
);
8543 Link_Nam
:= Expression
(Link_Arg
);
8546 -- Check expressions for external name and link name are static
8548 if Present
(Ext_Nam
) then
8549 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8550 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8552 -- Verify that external name is not the name of a local entity,
8553 -- which would hide the imported one and could lead to run-time
8554 -- surprises. The problem can only arise for entities declared in
8555 -- a package body (otherwise the external name is fully qualified
8556 -- and will not conflict).
8564 if Prag_Id
= Pragma_Import
then
8565 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8567 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
8569 if Nam
/= Chars
(Subprogram_Def
)
8570 and then Present
(E
)
8571 and then not Is_Overloadable
(E
)
8572 and then Is_Immediately_Visible
(E
)
8573 and then not Is_Imported
(E
)
8574 and then Ekind
(Scope
(E
)) = E_Package
8577 while Present
(Par
) loop
8578 if Nkind
(Par
) = N_Package_Body
then
8579 Error_Msg_Sloc
:= Sloc
(E
);
8581 ("imported entity is hidden by & declared#",
8586 Par
:= Parent
(Par
);
8593 if Present
(Link_Nam
) then
8594 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8595 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8598 -- If there is no link name, just set the external name
8600 if No
(Link_Nam
) then
8601 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8603 -- For the Link_Name case, the given literal is preceded by an
8604 -- asterisk, which indicates to GCC that the given name should be
8605 -- taken literally, and in particular that no prepending of
8606 -- underlines should occur, even in systems where this is the
8612 if VM_Target
= No_VM
then
8613 Store_String_Char
(Get_Char_Code
('*'));
8616 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8617 Store_String_Chars
(String_Val
);
8619 Make_String_Literal
(Sloc
(Link_Nam
),
8620 Strval
=> End_String
);
8623 -- Set the interface name. If the entity is a generic instance, use
8624 -- its alias, which is the callable entity.
8626 if Is_Generic_Instance
(Subprogram_Def
) then
8627 Set_Encoded_Interface_Name
8628 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8630 Set_Encoded_Interface_Name
8631 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8634 -- We allow duplicated export names in CIL/Java, as they are always
8635 -- enclosed in a namespace that differentiates them, and overloaded
8636 -- entities are supported by the VM.
8638 if Convention
(Subprogram_Def
) /= Convention_CIL
8640 Convention
(Subprogram_Def
) /= Convention_Java
8642 Check_Duplicated_Export_Name
(Link_Nam
);
8644 end Process_Interface_Name
;
8646 -----------------------------------------
8647 -- Process_Interrupt_Or_Attach_Handler --
8648 -----------------------------------------
8650 procedure Process_Interrupt_Or_Attach_Handler
is
8651 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8652 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8653 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8656 Set_Is_Interrupt_Handler
(Handler_Proc
);
8658 -- If the pragma is not associated with a handler procedure within a
8659 -- protected type, then it must be for a nonprotected procedure for
8660 -- the AAMP target, in which case we don't associate a representation
8661 -- item with the procedure's scope.
8663 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8664 if Prag_Id
= Pragma_Interrupt_Handler
8666 Prag_Id
= Pragma_Attach_Handler
8668 Record_Rep_Item
(Proc_Scope
, N
);
8671 end Process_Interrupt_Or_Attach_Handler
;
8673 --------------------------------------------------
8674 -- Process_Restrictions_Or_Restriction_Warnings --
8675 --------------------------------------------------
8677 -- Note: some of the simple identifier cases were handled in par-prag,
8678 -- but it is harmless (and more straightforward) to simply handle all
8679 -- cases here, even if it means we repeat a bit of work in some cases.
8681 procedure Process_Restrictions_Or_Restriction_Warnings
8685 R_Id
: Restriction_Id
;
8691 -- Ignore all Restrictions pragmas in CodePeer mode
8693 if CodePeer_Mode
then
8697 Check_Ada_83_Warning
;
8698 Check_At_Least_N_Arguments
(1);
8699 Check_Valid_Configuration_Pragma
;
8702 while Present
(Arg
) loop
8704 Expr
:= Get_Pragma_Arg
(Arg
);
8706 -- Case of no restriction identifier present
8708 if Id
= No_Name
then
8709 if Nkind
(Expr
) /= N_Identifier
then
8711 ("invalid form for restriction", Arg
);
8716 (Process_Restriction_Synonyms
(Expr
));
8718 if R_Id
not in All_Boolean_Restrictions
then
8719 Error_Msg_Name_1
:= Pname
;
8721 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8723 -- Check for possible misspelling
8725 for J
in Restriction_Id
loop
8727 Rnm
: constant String := Restriction_Id
'Image (J
);
8730 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8731 Name_Len
:= Rnm
'Length;
8732 Set_Casing
(All_Lower_Case
);
8734 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8736 (Identifier_Casing
(Current_Source_File
));
8737 Error_Msg_String
(1 .. Rnm
'Length) :=
8738 Name_Buffer
(1 .. Name_Len
);
8739 Error_Msg_Strlen
:= Rnm
'Length;
8740 Error_Msg_N
-- CODEFIX
8741 ("\possible misspelling of ""~""",
8742 Get_Pragma_Arg
(Arg
));
8751 if Implementation_Restriction
(R_Id
) then
8752 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8755 -- Special processing for No_Elaboration_Code restriction
8757 if R_Id
= No_Elaboration_Code
then
8759 -- Restriction is only recognized within a configuration
8760 -- pragma file, or within a unit of the main extended
8761 -- program. Note: the test for Main_Unit is needed to
8762 -- properly include the case of configuration pragma files.
8764 if not (Current_Sem_Unit
= Main_Unit
8765 or else In_Extended_Main_Source_Unit
(N
))
8769 -- Don't allow in a subunit unless already specified in
8772 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8773 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8774 and then not Restriction_Active
(No_Elaboration_Code
)
8777 ("invalid specification of ""No_Elaboration_Code""",
8780 ("\restriction cannot be specified in a subunit", N
);
8782 ("\unless also specified in body or spec", N
);
8785 -- If we accept a No_Elaboration_Code restriction, then it
8786 -- needs to be added to the configuration restriction set so
8787 -- that we get proper application to other units in the main
8788 -- extended source as required.
8791 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8795 -- If this is a warning, then set the warning unless we already
8796 -- have a real restriction active (we never want a warning to
8797 -- override a real restriction).
8800 if not Restriction_Active
(R_Id
) then
8801 Set_Restriction
(R_Id
, N
);
8802 Restriction_Warnings
(R_Id
) := True;
8805 -- If real restriction case, then set it and make sure that the
8806 -- restriction warning flag is off, since a real restriction
8807 -- always overrides a warning.
8810 Set_Restriction
(R_Id
, N
);
8811 Restriction_Warnings
(R_Id
) := False;
8814 -- Check for obsolescent restrictions in Ada 2005 mode
8817 and then Ada_Version
>= Ada_2005
8818 and then (R_Id
= No_Asynchronous_Control
8820 R_Id
= No_Unchecked_Deallocation
8822 R_Id
= No_Unchecked_Conversion
)
8824 Check_Restriction
(No_Obsolescent_Features
, N
);
8827 -- A very special case that must be processed here: pragma
8828 -- Restrictions (No_Exceptions) turns off all run-time
8829 -- checking. This is a bit dubious in terms of the formal
8830 -- language definition, but it is what is intended by RM
8831 -- H.4(12). Restriction_Warnings never affects generated code
8832 -- so this is done only in the real restriction case.
8834 -- Atomic_Synchronization is not a real check, so it is not
8835 -- affected by this processing).
8837 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8838 -- run-time checks in CodePeer and GNATprove modes: we want to
8839 -- generate checks for analysis purposes, as set respectively
8840 -- by -gnatC and -gnatd.F
8843 and then not (CodePeer_Mode
or GNATprove_Mode
)
8844 and then R_Id
= No_Exceptions
8846 for J
in Scope_Suppress
.Suppress
'Range loop
8847 if J
/= Atomic_Synchronization
then
8848 Scope_Suppress
.Suppress
(J
) := True;
8853 -- Case of No_Dependence => unit-name. Note that the parser
8854 -- already made the necessary entry in the No_Dependence table.
8856 elsif Id
= Name_No_Dependence
then
8857 if not OK_No_Dependence_Unit_Name
(Expr
) then
8861 -- Case of No_Specification_Of_Aspect => Identifier.
8863 elsif Id
= Name_No_Specification_Of_Aspect
then
8868 if Nkind
(Expr
) /= N_Identifier
then
8871 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8874 if A_Id
= No_Aspect
then
8875 Error_Pragma_Arg
("invalid restriction name", Arg
);
8877 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8881 elsif Id
= Name_No_Use_Of_Attribute
then
8882 if Nkind
(Expr
) /= N_Identifier
8883 or else not Is_Attribute_Name
(Chars
(Expr
))
8885 Error_Msg_N
("unknown attribute name??", Expr
);
8888 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8891 elsif Id
= Name_No_Use_Of_Pragma
then
8892 if Nkind
(Expr
) /= N_Identifier
8893 or else not Is_Pragma_Name
(Chars
(Expr
))
8895 Error_Msg_N
("unknown pragma name??", Expr
);
8898 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8901 -- All other cases of restriction identifier present
8904 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8905 Analyze_And_Resolve
(Expr
, Any_Integer
);
8907 if R_Id
not in All_Parameter_Restrictions
then
8909 ("invalid restriction parameter identifier", Arg
);
8911 elsif not Is_OK_Static_Expression
(Expr
) then
8912 Flag_Non_Static_Expr
8913 ("value must be static expression!", Expr
);
8916 elsif not Is_Integer_Type
(Etype
(Expr
))
8917 or else Expr_Value
(Expr
) < 0
8920 ("value must be non-negative integer", Arg
);
8923 -- Restriction pragma is active
8925 Val
:= Expr_Value
(Expr
);
8927 if not UI_Is_In_Int_Range
(Val
) then
8929 ("pragma ignored, value too large??", Arg
);
8932 -- Warning case. If the real restriction is active, then we
8933 -- ignore the request, since warning never overrides a real
8934 -- restriction. Otherwise we set the proper warning. Note that
8935 -- this circuit sets the warning again if it is already set,
8936 -- which is what we want, since the constant may have changed.
8939 if not Restriction_Active
(R_Id
) then
8941 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
8942 Restriction_Warnings
(R_Id
) := True;
8945 -- Real restriction case, set restriction and make sure warning
8946 -- flag is off since real restriction always overrides warning.
8949 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
8950 Restriction_Warnings
(R_Id
) := False;
8956 end Process_Restrictions_Or_Restriction_Warnings
;
8958 ---------------------------------
8959 -- Process_Suppress_Unsuppress --
8960 ---------------------------------
8962 -- Note: this procedure makes entries in the check suppress data
8963 -- structures managed by Sem. See spec of package Sem for full
8964 -- details on how we handle recording of check suppression.
8966 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
8971 In_Package_Spec
: constant Boolean :=
8972 Is_Package_Or_Generic_Package
(Current_Scope
)
8973 and then not In_Package_Body
(Current_Scope
);
8975 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
8976 -- Used to suppress a single check on the given entity
8978 --------------------------------
8979 -- Suppress_Unsuppress_Echeck --
8980 --------------------------------
8982 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
8984 -- Check for error of trying to set atomic synchronization for
8985 -- a non-atomic variable.
8987 if C
= Atomic_Synchronization
8988 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
8991 ("pragma & requires atomic type or variable",
8992 Pragma_Identifier
(Original_Node
(N
)));
8995 Set_Checks_May_Be_Suppressed
(E
);
8997 if In_Package_Spec
then
8998 Push_Global_Suppress_Stack_Entry
9001 Suppress
=> Suppress_Case
);
9003 Push_Local_Suppress_Stack_Entry
9006 Suppress
=> Suppress_Case
);
9009 -- If this is a first subtype, and the base type is distinct,
9010 -- then also set the suppress flags on the base type.
9012 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9013 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9015 end Suppress_Unsuppress_Echeck
;
9017 -- Start of processing for Process_Suppress_Unsuppress
9020 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9021 -- on user code: we want to generate checks for analysis purposes, as
9022 -- set respectively by -gnatC and -gnatd.F
9024 if (CodePeer_Mode
or GNATprove_Mode
)
9025 and then Comes_From_Source
(N
)
9030 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9031 -- declarative part or a package spec (RM 11.5(5)).
9033 if not Is_Configuration_Pragma
then
9034 Check_Is_In_Decl_Part_Or_Package_Spec
;
9037 Check_At_Least_N_Arguments
(1);
9038 Check_At_Most_N_Arguments
(2);
9039 Check_No_Identifier
(Arg1
);
9040 Check_Arg_Is_Identifier
(Arg1
);
9042 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9044 if C
= No_Check_Id
then
9046 ("argument of pragma% is not valid check name", Arg1
);
9049 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9051 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9053 ("Suppress of Elaboration_Check ignored in SPARK??", Arg1
);
9056 -- One-argument case
9058 if Arg_Count
= 1 then
9060 -- Make an entry in the local scope suppress table. This is the
9061 -- table that directly shows the current value of the scope
9062 -- suppress check for any check id value.
9064 if C
= All_Checks
then
9066 -- For All_Checks, we set all specific predefined checks with
9067 -- the exception of Elaboration_Check, which is handled
9068 -- specially because of not wanting All_Checks to have the
9069 -- effect of deactivating static elaboration order processing.
9070 -- Atomic_Synchronization is also not affected, since this is
9071 -- not a real check.
9073 for J
in Scope_Suppress
.Suppress
'Range loop
9074 if J
/= Elaboration_Check
9076 J
/= Atomic_Synchronization
9078 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9082 -- If not All_Checks, and predefined check, then set appropriate
9083 -- scope entry. Note that we will set Elaboration_Check if this
9084 -- is explicitly specified. Atomic_Synchronization is allowed
9085 -- only if internally generated and entity is atomic.
9087 elsif C
in Predefined_Check_Id
9088 and then (not Comes_From_Source
(N
)
9089 or else C
/= Atomic_Synchronization
)
9091 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9094 -- Also make an entry in the Local_Entity_Suppress table
9096 Push_Local_Suppress_Stack_Entry
9099 Suppress
=> Suppress_Case
);
9101 -- Case of two arguments present, where the check is suppressed for
9102 -- a specified entity (given as the second argument of the pragma)
9105 -- This is obsolescent in Ada 2005 mode
9107 if Ada_Version
>= Ada_2005
then
9108 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9111 Check_Optional_Identifier
(Arg2
, Name_On
);
9112 E_Id
:= Get_Pragma_Arg
(Arg2
);
9115 if not Is_Entity_Name
(E_Id
) then
9117 ("second argument of pragma% must be entity name", Arg2
);
9126 -- Enforce RM 11.5(7) which requires that for a pragma that
9127 -- appears within a package spec, the named entity must be
9128 -- within the package spec. We allow the package name itself
9129 -- to be mentioned since that makes sense, although it is not
9130 -- strictly allowed by 11.5(7).
9133 and then E
/= Current_Scope
9134 and then Scope
(E
) /= Current_Scope
9137 ("entity in pragma% is not in package spec (RM 11.5(7))",
9141 -- Loop through homonyms. As noted below, in the case of a package
9142 -- spec, only homonyms within the package spec are considered.
9145 Suppress_Unsuppress_Echeck
(E
, C
);
9147 if Is_Generic_Instance
(E
)
9148 and then Is_Subprogram
(E
)
9149 and then Present
(Alias
(E
))
9151 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9154 -- Move to next homonym if not aspect spec case
9156 exit when From_Aspect_Specification
(N
);
9160 -- If we are within a package specification, the pragma only
9161 -- applies to homonyms in the same scope.
9163 exit when In_Package_Spec
9164 and then Scope
(E
) /= Current_Scope
;
9167 end Process_Suppress_Unsuppress
;
9173 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9175 if Is_Imported
(E
) then
9177 ("cannot export entity& that was previously imported", Arg
);
9179 elsif Present
(Address_Clause
(E
))
9180 and then not Relaxed_RM_Semantics
9183 ("cannot export entity& that has an address clause", Arg
);
9186 Set_Is_Exported
(E
);
9188 -- Generate a reference for entity explicitly, because the
9189 -- identifier may be overloaded and name resolution will not
9192 Generate_Reference
(E
, Arg
);
9194 -- Deal with exporting non-library level entity
9196 if not Is_Library_Level_Entity
(E
) then
9198 -- Not allowed at all for subprograms
9200 if Is_Subprogram
(E
) then
9201 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9203 -- Otherwise set public and statically allocated
9207 Set_Is_Statically_Allocated
(E
);
9209 -- Warn if the corresponding W flag is set
9211 if Warn_On_Export_Import
9213 -- Only do this for something that was in the source. Not
9214 -- clear if this can be False now (there used for sure to be
9215 -- cases on some systems where it was False), but anyway the
9216 -- test is harmless if not needed, so it is retained.
9218 and then Comes_From_Source
(Arg
)
9221 ("?x?& has been made static as a result of Export",
9224 ("\?x?this usage is non-standard and non-portable",
9230 if Warn_On_Export_Import
and then Is_Type
(E
) then
9231 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9234 if Warn_On_Export_Import
and Inside_A_Generic
then
9236 ("all instances of& will have the same external name?x?",
9241 ----------------------------------------------
9242 -- Set_Extended_Import_Export_External_Name --
9243 ----------------------------------------------
9245 procedure Set_Extended_Import_Export_External_Name
9246 (Internal_Ent
: Entity_Id
;
9247 Arg_External
: Node_Id
)
9249 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9253 if No
(Arg_External
) then
9257 Check_Arg_Is_External_Name
(Arg_External
);
9259 if Nkind
(Arg_External
) = N_String_Literal
then
9260 if String_Length
(Strval
(Arg_External
)) = 0 then
9263 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9266 elsif Nkind
(Arg_External
) = N_Identifier
then
9267 New_Name
:= Get_Default_External_Name
(Arg_External
);
9269 -- Check_Arg_Is_External_Name should let through only identifiers and
9270 -- string literals or static string expressions (which are folded to
9271 -- string literals).
9274 raise Program_Error
;
9277 -- If we already have an external name set (by a prior normal Import
9278 -- or Export pragma), then the external names must match
9280 if Present
(Interface_Name
(Internal_Ent
)) then
9282 -- Ignore mismatching names in CodePeer mode, to support some
9283 -- old compilers which would export the same procedure under
9284 -- different names, e.g:
9286 -- pragma Export_Procedure (P, "a");
9287 -- pragma Export_Procedure (P, "b");
9289 if CodePeer_Mode
then
9293 Check_Matching_Internal_Names
: declare
9294 S1
: constant String_Id
:= Strval
(Old_Name
);
9295 S2
: constant String_Id
:= Strval
(New_Name
);
9298 pragma No_Return
(Mismatch
);
9299 -- Called if names do not match
9305 procedure Mismatch
is
9307 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9309 ("external name does not match that given #",
9313 -- Start of processing for Check_Matching_Internal_Names
9316 if String_Length
(S1
) /= String_Length
(S2
) then
9320 for J
in 1 .. String_Length
(S1
) loop
9321 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9326 end Check_Matching_Internal_Names
;
9328 -- Otherwise set the given name
9331 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9332 Check_Duplicated_Export_Name
(New_Name
);
9334 end Set_Extended_Import_Export_External_Name
;
9340 procedure Set_Imported
(E
: Entity_Id
) is
9342 -- Error message if already imported or exported
9344 if Is_Exported
(E
) or else Is_Imported
(E
) then
9346 -- Error if being set Exported twice
9348 if Is_Exported
(E
) then
9349 Error_Msg_NE
("entity& was previously exported", N
, E
);
9351 -- Ignore error in CodePeer mode where we treat all imported
9352 -- subprograms as unknown.
9354 elsif CodePeer_Mode
then
9357 -- OK if Import/Interface case
9359 elsif Import_Interface_Present
(N
) then
9362 -- Error if being set Imported twice
9365 Error_Msg_NE
("entity& was previously imported", N
, E
);
9368 Error_Msg_Name_1
:= Pname
;
9370 ("\(pragma% applies to all previous entities)", N
);
9372 Error_Msg_Sloc
:= Sloc
(E
);
9373 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9375 -- Here if not previously imported or exported, OK to import
9378 Set_Is_Imported
(E
);
9380 -- For subprogram, set Import_Pragma field
9382 if Is_Subprogram
(E
) then
9383 Set_Import_Pragma
(E
, N
);
9386 -- If the entity is an object that is not at the library level,
9387 -- then it is statically allocated. We do not worry about objects
9388 -- with address clauses in this context since they are not really
9389 -- imported in the linker sense.
9392 and then not Is_Library_Level_Entity
(E
)
9393 and then No
(Address_Clause
(E
))
9395 Set_Is_Statically_Allocated
(E
);
9402 -------------------------
9403 -- Set_Mechanism_Value --
9404 -------------------------
9406 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9407 -- analyzed, since it is semantic nonsense), so we get it in the exact
9408 -- form created by the parser.
9410 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9411 procedure Bad_Mechanism
;
9412 pragma No_Return
(Bad_Mechanism
);
9413 -- Signal bad mechanism name
9415 -------------------------
9416 -- Bad_Mechanism_Value --
9417 -------------------------
9419 procedure Bad_Mechanism
is
9421 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9424 -- Start of processing for Set_Mechanism_Value
9427 if Mechanism
(Ent
) /= Default_Mechanism
then
9429 ("mechanism for & has already been set", Mech_Name
, Ent
);
9432 -- MECHANISM_NAME ::= value | reference
9434 if Nkind
(Mech_Name
) = N_Identifier
then
9435 if Chars
(Mech_Name
) = Name_Value
then
9436 Set_Mechanism
(Ent
, By_Copy
);
9439 elsif Chars
(Mech_Name
) = Name_Reference
then
9440 Set_Mechanism
(Ent
, By_Reference
);
9443 elsif Chars
(Mech_Name
) = Name_Copy
then
9445 ("bad mechanism name, Value assumed", Mech_Name
);
9454 end Set_Mechanism_Value
;
9456 --------------------------
9457 -- Set_Rational_Profile --
9458 --------------------------
9460 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9461 -- and extension to the semantics of renaming declarations.
9463 procedure Set_Rational_Profile
is
9465 Implicit_Packing
:= True;
9466 Overriding_Renamings
:= True;
9467 Use_VADS_Size
:= True;
9468 end Set_Rational_Profile
;
9470 ---------------------------
9471 -- Set_Ravenscar_Profile --
9472 ---------------------------
9474 -- The tasks to be done here are
9476 -- Set required policies
9478 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9479 -- pragma Locking_Policy (Ceiling_Locking)
9481 -- Set Detect_Blocking mode
9483 -- Set required restrictions (see System.Rident for detailed list)
9485 -- Set the No_Dependence rules
9486 -- No_Dependence => Ada.Asynchronous_Task_Control
9487 -- No_Dependence => Ada.Calendar
9488 -- No_Dependence => Ada.Execution_Time.Group_Budget
9489 -- No_Dependence => Ada.Execution_Time.Timers
9490 -- No_Dependence => Ada.Task_Attributes
9491 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9493 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9494 Prefix_Entity
: Entity_Id
;
9495 Selector_Entity
: Entity_Id
;
9496 Prefix_Node
: Node_Id
;
9500 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9502 if Task_Dispatching_Policy
/= ' '
9503 and then Task_Dispatching_Policy
/= 'F'
9505 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9506 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9508 -- Set the FIFO_Within_Priorities policy, but always preserve
9509 -- System_Location since we like the error message with the run time
9513 Task_Dispatching_Policy
:= 'F';
9515 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9516 Task_Dispatching_Policy_Sloc
:= Loc
;
9520 -- pragma Locking_Policy (Ceiling_Locking)
9522 if Locking_Policy
/= ' '
9523 and then Locking_Policy
/= 'C'
9525 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9526 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9528 -- Set the Ceiling_Locking policy, but preserve System_Location since
9529 -- we like the error message with the run time name.
9532 Locking_Policy
:= 'C';
9534 if Locking_Policy_Sloc
/= System_Location
then
9535 Locking_Policy_Sloc
:= Loc
;
9539 -- pragma Detect_Blocking
9541 Detect_Blocking
:= True;
9543 -- Set the corresponding restrictions
9545 Set_Profile_Restrictions
9546 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9548 -- Set the No_Dependence restrictions
9550 -- The following No_Dependence restrictions:
9551 -- No_Dependence => Ada.Asynchronous_Task_Control
9552 -- No_Dependence => Ada.Calendar
9553 -- No_Dependence => Ada.Task_Attributes
9554 -- are already set by previous call to Set_Profile_Restrictions.
9556 -- Set the following restrictions which were added to Ada 2005:
9557 -- No_Dependence => Ada.Execution_Time.Group_Budget
9558 -- No_Dependence => Ada.Execution_Time.Timers
9560 if Ada_Version
>= Ada_2005
then
9561 Name_Buffer
(1 .. 3) := "ada";
9564 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9566 Name_Buffer
(1 .. 14) := "execution_time";
9569 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9572 Make_Selected_Component
9574 Prefix
=> Prefix_Entity
,
9575 Selector_Name
=> Selector_Entity
);
9577 Name_Buffer
(1 .. 13) := "group_budgets";
9580 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9583 Make_Selected_Component
9585 Prefix
=> Prefix_Node
,
9586 Selector_Name
=> Selector_Entity
);
9588 Set_Restriction_No_Dependence
9590 Warn
=> Treat_Restrictions_As_Warnings
,
9591 Profile
=> Ravenscar
);
9593 Name_Buffer
(1 .. 6) := "timers";
9596 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9599 Make_Selected_Component
9601 Prefix
=> Prefix_Node
,
9602 Selector_Name
=> Selector_Entity
);
9604 Set_Restriction_No_Dependence
9606 Warn
=> Treat_Restrictions_As_Warnings
,
9607 Profile
=> Ravenscar
);
9610 -- Set the following restrictions which was added to Ada 2012 (see
9612 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9614 if Ada_Version
>= Ada_2012
then
9615 Name_Buffer
(1 .. 6) := "system";
9618 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9620 Name_Buffer
(1 .. 15) := "multiprocessors";
9623 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9626 Make_Selected_Component
9628 Prefix
=> Prefix_Entity
,
9629 Selector_Name
=> Selector_Entity
);
9631 Name_Buffer
(1 .. 19) := "dispatching_domains";
9634 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9637 Make_Selected_Component
9639 Prefix
=> Prefix_Node
,
9640 Selector_Name
=> Selector_Entity
);
9642 Set_Restriction_No_Dependence
9644 Warn
=> Treat_Restrictions_As_Warnings
,
9645 Profile
=> Ravenscar
);
9647 end Set_Ravenscar_Profile
;
9649 -- Start of processing for Analyze_Pragma
9652 -- The following code is a defense against recursion. Not clear that
9653 -- this can happen legitimately, but perhaps some error situations
9654 -- can cause it, and we did see this recursion during testing.
9656 if Analyzed
(N
) then
9659 Set_Analyzed
(N
, True);
9662 -- Deal with unrecognized pragma
9664 Pname
:= Pragma_Name
(N
);
9666 if not Is_Pragma_Name
(Pname
) then
9667 if Warn_On_Unrecognized_Pragma
then
9668 Error_Msg_Name_1
:= Pname
;
9669 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9671 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9672 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9673 Error_Msg_Name_1
:= PN
;
9674 Error_Msg_N
-- CODEFIX
9675 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9684 -- Here to start processing for recognized pragma
9686 Prag_Id
:= Get_Pragma_Id
(Pname
);
9687 Pname
:= Original_Aspect_Name
(N
);
9689 -- Capture setting of Opt.Uneval_Old
9691 case Opt
.Uneval_Old
is
9693 Set_Uneval_Old_Accept
(N
);
9697 Set_Uneval_Old_Warn
(N
);
9699 raise Program_Error
;
9702 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9703 -- is already set, indicating that we have already checked the policy
9704 -- at the right point. This happens for example in the case of a pragma
9705 -- that is derived from an Aspect.
9707 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9710 -- For a pragma that is a rewriting of another pragma, copy the
9711 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9713 elsif Is_Rewrite_Substitution
(N
)
9714 and then Nkind
(Original_Node
(N
)) = N_Pragma
9715 and then Original_Node
(N
) /= N
9717 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9718 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9720 -- Otherwise query the applicable policy at this point
9723 Check_Applicable_Policy
(N
);
9725 -- If pragma is disabled, rewrite as NULL and skip analysis
9727 if Is_Disabled
(N
) then
9728 Rewrite
(N
, Make_Null_Statement
(Loc
));
9742 if Present
(Pragma_Argument_Associations
(N
)) then
9743 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9744 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9746 if Present
(Arg1
) then
9747 Arg2
:= Next
(Arg1
);
9749 if Present
(Arg2
) then
9750 Arg3
:= Next
(Arg2
);
9752 if Present
(Arg3
) then
9753 Arg4
:= Next
(Arg3
);
9759 Check_Restriction_No_Use_Of_Pragma
(N
);
9761 -- An enumeration type defines the pragmas that are supported by the
9762 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9763 -- into the corresponding enumeration value for the following case.
9771 -- pragma Abort_Defer;
9773 when Pragma_Abort_Defer
=>
9775 Check_Arg_Count
(0);
9777 -- The only required semantic processing is to check the
9778 -- placement. This pragma must appear at the start of the
9779 -- statement sequence of a handled sequence of statements.
9781 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9782 or else N
/= First
(Statements
(Parent
(N
)))
9787 --------------------
9788 -- Abstract_State --
9789 --------------------
9791 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9793 -- ABSTRACT_STATE_LIST ::=
9795 -- | STATE_NAME_WITH_OPTIONS
9796 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9798 -- STATE_NAME_WITH_OPTIONS ::=
9800 -- | (STATE_NAME with OPTION_LIST)
9802 -- OPTION_LIST ::= OPTION {, OPTION}
9806 -- | NAME_VALUE_OPTION
9808 -- SIMPLE_OPTION ::= Ghost
9810 -- NAME_VALUE_OPTION ::=
9811 -- Part_Of => ABSTRACT_STATE
9812 -- | External [=> EXTERNAL_PROPERTY_LIST]
9814 -- EXTERNAL_PROPERTY_LIST ::=
9815 -- EXTERNAL_PROPERTY
9816 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9818 -- EXTERNAL_PROPERTY ::=
9819 -- Async_Readers [=> boolean_EXPRESSION]
9820 -- | Async_Writers [=> boolean_EXPRESSION]
9821 -- | Effective_Reads [=> boolean_EXPRESSION]
9822 -- | Effective_Writes [=> boolean_EXPRESSION]
9823 -- others => boolean_EXPRESSION
9825 -- STATE_NAME ::= defining_identifier
9827 -- ABSTRACT_STATE ::= name
9829 when Pragma_Abstract_State
=> Abstract_State
: declare
9830 Missing_Parentheses
: Boolean := False;
9831 -- Flag set when a state declaration with options is not properly
9834 -- Flags used to verify the consistency of states
9836 Non_Null_Seen
: Boolean := False;
9837 Null_Seen
: Boolean := False;
9839 procedure Analyze_Abstract_State
9841 Pack_Id
: Entity_Id
);
9842 -- Verify the legality of a single state declaration. Create and
9843 -- decorate a state abstraction entity and introduce it into the
9844 -- visibility chain. Pack_Id denotes the entity or the related
9845 -- package where pragma Abstract_State appears.
9847 ----------------------------
9848 -- Analyze_Abstract_State --
9849 ----------------------------
9851 procedure Analyze_Abstract_State
9853 Pack_Id
: Entity_Id
)
9855 -- Flags used to verify the consistency of options
9857 AR_Seen
: Boolean := False;
9858 AW_Seen
: Boolean := False;
9859 ER_Seen
: Boolean := False;
9860 EW_Seen
: Boolean := False;
9861 External_Seen
: Boolean := False;
9862 Others_Seen
: Boolean := False;
9863 Part_Of_Seen
: Boolean := False;
9865 -- Flags used to store the static value of all external states'
9868 AR_Val
: Boolean := False;
9869 AW_Val
: Boolean := False;
9870 ER_Val
: Boolean := False;
9871 EW_Val
: Boolean := False;
9873 State_Id
: Entity_Id
:= Empty
;
9874 -- The entity to be generated for the current state declaration
9876 procedure Analyze_External_Option
(Opt
: Node_Id
);
9877 -- Verify the legality of option External
9879 procedure Analyze_External_Property
9881 Expr
: Node_Id
:= Empty
);
9882 -- Verify the legailty of a single external property. Prop
9883 -- denotes the external property. Expr is the expression used
9884 -- to set the property.
9886 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9887 -- Verify the legality of option Part_Of
9889 procedure Check_Duplicate_Option
9891 Status
: in out Boolean);
9892 -- Flag Status denotes whether a particular option has been
9893 -- seen while processing a state. This routine verifies that
9894 -- Opt is not a duplicate option and sets the flag Status
9895 -- (SPARK RM 7.1.4(1)).
9897 procedure Check_Duplicate_Property
9899 Status
: in out Boolean);
9900 -- Flag Status denotes whether a particular property has been
9901 -- seen while processing option External. This routine verifies
9902 -- that Prop is not a duplicate property and sets flag Status.
9903 -- Opt is not a duplicate property and sets the flag Status.
9904 -- (SPARK RM 7.1.4(2))
9906 procedure Create_Abstract_State
9911 -- Generate an abstract state entity with name Nam and enter it
9912 -- into visibility. Decl is the "declaration" of the state as
9913 -- it appears in pragma Abstract_State. Loc is the location of
9914 -- the related state "declaration". Flag Is_Null should be set
9915 -- when the associated Abstract_State pragma defines a null
9918 -----------------------------
9919 -- Analyze_External_Option --
9920 -----------------------------
9922 procedure Analyze_External_Option
(Opt
: Node_Id
) is
9923 Errors
: constant Nat
:= Serious_Errors_Detected
;
9925 Props
: Node_Id
:= Empty
;
9928 Check_Duplicate_Option
(Opt
, External_Seen
);
9930 if Nkind
(Opt
) = N_Component_Association
then
9931 Props
:= Expression
(Opt
);
9934 -- External state with properties
9936 if Present
(Props
) then
9938 -- Multiple properties appear as an aggregate
9940 if Nkind
(Props
) = N_Aggregate
then
9942 -- Simple property form
9944 Prop
:= First
(Expressions
(Props
));
9945 while Present
(Prop
) loop
9946 Analyze_External_Property
(Prop
);
9950 -- Property with expression form
9952 Prop
:= First
(Component_Associations
(Props
));
9953 while Present
(Prop
) loop
9954 Analyze_External_Property
9955 (Prop
=> First
(Choices
(Prop
)),
9956 Expr
=> Expression
(Prop
));
9964 Analyze_External_Property
(Props
);
9967 -- An external state defined without any properties defaults
9968 -- all properties to True.
9977 -- Once all external properties have been processed, verify
9978 -- their mutual interaction. Do not perform the check when
9979 -- at least one of the properties is illegal as this will
9980 -- produce a bogus error.
9982 if Errors
= Serious_Errors_Detected
then
9983 Check_External_Properties
9984 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
9986 end Analyze_External_Option
;
9988 -------------------------------
9989 -- Analyze_External_Property --
9990 -------------------------------
9992 procedure Analyze_External_Property
9994 Expr
: Node_Id
:= Empty
)
9999 -- Check the placement of "others" (if available)
10001 if Nkind
(Prop
) = N_Others_Choice
then
10002 if Others_Seen
then
10004 ("only one others choice allowed in option External",
10007 Others_Seen
:= True;
10010 elsif Others_Seen
then
10012 ("others must be the last property in option External",
10015 -- The only remaining legal options are the four predefined
10016 -- external properties.
10018 elsif Nkind
(Prop
) = N_Identifier
10019 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10020 Name_Async_Writers
,
10021 Name_Effective_Reads
,
10022 Name_Effective_Writes
)
10026 -- Otherwise the construct is not a valid property
10029 SPARK_Msg_N
("invalid external state property", Prop
);
10033 -- Ensure that the expression of the external state property
10034 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10036 if Present
(Expr
) then
10037 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10039 if Is_OK_Static_Expression
(Expr
) then
10040 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10043 ("expression of external state property must be "
10047 -- The lack of expression defaults the property to True
10053 -- Named properties
10055 if Nkind
(Prop
) = N_Identifier
then
10056 if Chars
(Prop
) = Name_Async_Readers
then
10057 Check_Duplicate_Property
(Prop
, AR_Seen
);
10058 AR_Val
:= Expr_Val
;
10060 elsif Chars
(Prop
) = Name_Async_Writers
then
10061 Check_Duplicate_Property
(Prop
, AW_Seen
);
10062 AW_Val
:= Expr_Val
;
10064 elsif Chars
(Prop
) = Name_Effective_Reads
then
10065 Check_Duplicate_Property
(Prop
, ER_Seen
);
10066 ER_Val
:= Expr_Val
;
10069 Check_Duplicate_Property
(Prop
, EW_Seen
);
10070 EW_Val
:= Expr_Val
;
10073 -- The handling of property "others" must take into account
10074 -- all other named properties that have been encountered so
10075 -- far. Only those that have not been seen are affected by
10079 if not AR_Seen
then
10080 AR_Val
:= Expr_Val
;
10083 if not AW_Seen
then
10084 AW_Val
:= Expr_Val
;
10087 if not ER_Seen
then
10088 ER_Val
:= Expr_Val
;
10091 if not EW_Seen
then
10092 EW_Val
:= Expr_Val
;
10095 end Analyze_External_Property
;
10097 ----------------------------
10098 -- Analyze_Part_Of_Option --
10099 ----------------------------
10101 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10102 Encaps
: constant Node_Id
:= Expression
(Opt
);
10103 Encaps_Id
: Entity_Id
;
10107 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10110 (Item_Id
=> State_Id
,
10112 Indic
=> First
(Choices
(Opt
)),
10115 -- The Part_Of indicator turns an abstract state into a
10116 -- constituent of the encapsulating state.
10119 Encaps_Id
:= Entity
(Encaps
);
10121 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10122 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10124 end Analyze_Part_Of_Option
;
10126 ----------------------------
10127 -- Check_Duplicate_Option --
10128 ----------------------------
10130 procedure Check_Duplicate_Option
10132 Status
: in out Boolean)
10136 SPARK_Msg_N
("duplicate state option", Opt
);
10140 end Check_Duplicate_Option
;
10142 ------------------------------
10143 -- Check_Duplicate_Property --
10144 ------------------------------
10146 procedure Check_Duplicate_Property
10148 Status
: in out Boolean)
10152 SPARK_Msg_N
("duplicate external property", Prop
);
10156 end Check_Duplicate_Property
;
10158 ---------------------------
10159 -- Create_Abstract_State --
10160 ---------------------------
10162 procedure Create_Abstract_State
10169 -- The abstract state may be semi-declared when the related
10170 -- package was withed through a limited with clause. In that
10171 -- case reuse the entity to fully declare the state.
10173 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10174 State_Id
:= Entity
(Decl
);
10176 -- Otherwise the elaboration of pragma Abstract_State
10177 -- declares the state.
10180 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10182 if Present
(Decl
) then
10183 Set_Entity
(Decl
, State_Id
);
10187 -- Null states never come from source
10189 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10190 Set_Parent
(State_Id
, State
);
10191 Set_Ekind
(State_Id
, E_Abstract_State
);
10192 Set_Etype
(State_Id
, Standard_Void_Type
);
10193 Set_Encapsulating_State
(State_Id
, Empty
);
10194 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10195 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10197 -- An abstract state declared within a Ghost scope becomes
10198 -- Ghost (SPARK RM 6.9(2)).
10200 if Within_Ghost_Scope
then
10201 Set_Is_Ghost_Entity
(State_Id
);
10204 -- Establish a link between the state declaration and the
10205 -- abstract state entity. Note that a null state remains as
10206 -- N_Null and does not carry any linkages.
10208 if not Is_Null
then
10209 if Present
(Decl
) then
10210 Set_Entity
(Decl
, State_Id
);
10211 Set_Etype
(Decl
, Standard_Void_Type
);
10214 -- Every non-null state must be defined, nameable and
10217 Push_Scope
(Pack_Id
);
10218 Generate_Definition
(State_Id
);
10219 Enter_Name
(State_Id
);
10222 end Create_Abstract_State
;
10229 -- Start of processing for Analyze_Abstract_State
10232 -- A package with a null abstract state is not allowed to
10233 -- declare additional states.
10237 ("package & has null abstract state", State
, Pack_Id
);
10239 -- Null states appear as internally generated entities
10241 elsif Nkind
(State
) = N_Null
then
10242 Create_Abstract_State
10243 (Nam
=> New_Internal_Name
('S'),
10245 Loc
=> Sloc
(State
),
10249 -- Catch a case where a null state appears in a list of
10250 -- non-null states.
10252 if Non_Null_Seen
then
10254 ("package & has non-null abstract state",
10258 -- Simple state declaration
10260 elsif Nkind
(State
) = N_Identifier
then
10261 Create_Abstract_State
10262 (Nam
=> Chars
(State
),
10264 Loc
=> Sloc
(State
),
10266 Non_Null_Seen
:= True;
10268 -- State declaration with various options. This construct
10269 -- appears as an extension aggregate in the tree.
10271 elsif Nkind
(State
) = N_Extension_Aggregate
then
10272 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10273 Create_Abstract_State
10274 (Nam
=> Chars
(Ancestor_Part
(State
)),
10275 Decl
=> Ancestor_Part
(State
),
10276 Loc
=> Sloc
(Ancestor_Part
(State
)),
10278 Non_Null_Seen
:= True;
10281 ("state name must be an identifier",
10282 Ancestor_Part
(State
));
10285 -- Options External and Ghost appear as expressions
10287 Opt
:= First
(Expressions
(State
));
10288 while Present
(Opt
) loop
10289 if Nkind
(Opt
) = N_Identifier
then
10290 if Chars
(Opt
) = Name_External
then
10291 Analyze_External_Option
(Opt
);
10293 elsif Chars
(Opt
) = Name_Ghost
then
10294 if Present
(State_Id
) then
10295 Set_Is_Ghost_Entity
(State_Id
);
10298 -- Option Part_Of without an encapsulating state is
10299 -- illegal. (SPARK RM 7.1.4(9)).
10301 elsif Chars
(Opt
) = Name_Part_Of
then
10303 ("indicator Part_Of must denote an abstract "
10306 -- Do not emit an error message when a previous state
10307 -- declaration with options was not parenthesized as
10308 -- the option is actually another state declaration.
10310 -- with Abstract_State
10311 -- (State_1 with ..., -- missing parentheses
10312 -- (State_2 with ...),
10313 -- State_3) -- ok state declaration
10315 elsif Missing_Parentheses
then
10318 -- Otherwise the option is not allowed. Note that it
10319 -- is not possible to distinguish between an option
10320 -- and a state declaration when a previous state with
10321 -- options not properly parentheses.
10323 -- with Abstract_State
10324 -- (State_1 with ..., -- missing parentheses
10325 -- State_2); -- could be an option
10329 ("simple option not allowed in state declaration",
10333 -- Catch a case where missing parentheses around a state
10334 -- declaration with options cause a subsequent state
10335 -- declaration with options to be treated as an option.
10337 -- with Abstract_State
10338 -- (State_1 with ..., -- missing parentheses
10339 -- (State_2 with ...))
10341 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10342 Missing_Parentheses
:= True;
10344 ("state declaration must be parenthesized",
10345 Ancestor_Part
(State
));
10347 -- Otherwise the option is malformed
10350 SPARK_Msg_N
("malformed option", Opt
);
10356 -- Options External and Part_Of appear as component
10359 Opt
:= First
(Component_Associations
(State
));
10360 while Present
(Opt
) loop
10361 Opt_Nam
:= First
(Choices
(Opt
));
10363 if Nkind
(Opt_Nam
) = N_Identifier
then
10364 if Chars
(Opt_Nam
) = Name_External
then
10365 Analyze_External_Option
(Opt
);
10367 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10368 Analyze_Part_Of_Option
(Opt
);
10371 SPARK_Msg_N
("invalid state option", Opt
);
10374 SPARK_Msg_N
("invalid state option", Opt
);
10380 -- Any other attempt to declare a state is illegal. This is a
10381 -- syntax error, always report.
10384 Error_Msg_N
("malformed abstract state declaration", State
);
10388 -- Guard against a junk state. In such cases no entity is
10389 -- generated and the subsequent checks cannot be applied.
10391 if Present
(State_Id
) then
10393 -- Verify whether the state does not introduce an illegal
10394 -- hidden state within a package subject to a null abstract
10397 Check_No_Hidden_State
(State_Id
);
10399 -- Check whether the lack of option Part_Of agrees with the
10400 -- placement of the abstract state with respect to the state
10403 if not Part_Of_Seen
then
10404 Check_Missing_Part_Of
(State_Id
);
10407 -- Associate the state with its related package
10409 if No
(Abstract_States
(Pack_Id
)) then
10410 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10413 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10415 end Analyze_Abstract_State
;
10419 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10420 Pack_Id
: Entity_Id
;
10423 -- Start of processing for Abstract_State
10427 Check_No_Identifiers
;
10428 Check_Arg_Count
(1);
10429 Ensure_Aggregate_Form
(Arg1
);
10431 -- Ensure the proper placement of the pragma. Abstract states must
10432 -- be associated with a package declaration.
10434 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10435 N_Package_Declaration
)
10441 State
:= Expression
(Arg1
);
10442 Pack_Id
:= Defining_Entity
(Context
);
10444 -- Mark the associated package as Ghost if it is subject to aspect
10445 -- or pragma Ghost as this affects the declaration of an abstract
10448 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10449 Set_Is_Ghost_Entity
(Pack_Id
);
10452 -- Multiple non-null abstract states appear as an aggregate
10454 if Nkind
(State
) = N_Aggregate
then
10455 State
:= First
(Expressions
(State
));
10456 while Present
(State
) loop
10457 Analyze_Abstract_State
(State
, Pack_Id
);
10461 -- Various forms of a single abstract state. Note that these may
10462 -- include malformed state declarations.
10465 Analyze_Abstract_State
(State
, Pack_Id
);
10468 -- Save the pragma for retrieval by other tools
10470 Add_Contract_Item
(N
, Pack_Id
);
10472 -- Verify the declaration order of pragmas Abstract_State and
10475 Check_Declaration_Order
10477 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10478 end Abstract_State
;
10486 -- Note: this pragma also has some specific processing in Par.Prag
10487 -- because we want to set the Ada version mode during parsing.
10489 when Pragma_Ada_83
=>
10491 Check_Arg_Count
(0);
10493 -- We really should check unconditionally for proper configuration
10494 -- pragma placement, since we really don't want mixed Ada modes
10495 -- within a single unit, and the GNAT reference manual has always
10496 -- said this was a configuration pragma, but we did not check and
10497 -- are hesitant to add the check now.
10499 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10500 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10501 -- or Ada 2012 mode.
10503 if Ada_Version
>= Ada_2005
then
10504 Check_Valid_Configuration_Pragma
;
10507 -- Now set Ada 83 mode
10509 Ada_Version
:= Ada_83
;
10510 Ada_Version_Explicit
:= Ada_83
;
10511 Ada_Version_Pragma
:= N
;
10519 -- Note: this pragma also has some specific processing in Par.Prag
10520 -- because we want to set the Ada 83 version mode during parsing.
10522 when Pragma_Ada_95
=>
10524 Check_Arg_Count
(0);
10526 -- We really should check unconditionally for proper configuration
10527 -- pragma placement, since we really don't want mixed Ada modes
10528 -- within a single unit, and the GNAT reference manual has always
10529 -- said this was a configuration pragma, but we did not check and
10530 -- are hesitant to add the check now.
10532 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10533 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10535 if Ada_Version
>= Ada_2005
then
10536 Check_Valid_Configuration_Pragma
;
10539 -- Now set Ada 95 mode
10541 Ada_Version
:= Ada_95
;
10542 Ada_Version_Explicit
:= Ada_95
;
10543 Ada_Version_Pragma
:= N
;
10545 ---------------------
10546 -- Ada_05/Ada_2005 --
10547 ---------------------
10550 -- pragma Ada_05 (LOCAL_NAME);
10552 -- pragma Ada_2005;
10553 -- pragma Ada_2005 (LOCAL_NAME):
10555 -- Note: these pragmas also have some specific processing in Par.Prag
10556 -- because we want to set the Ada 2005 version mode during parsing.
10558 -- The one argument form is used for managing the transition from
10559 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10560 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10561 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10562 -- mode, a preference rule is established which does not choose
10563 -- such an entity unless it is unambiguously specified. This avoids
10564 -- extra subprograms marked this way from generating ambiguities in
10565 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10566 -- intended for exclusive use in the GNAT run-time library.
10568 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10574 if Arg_Count
= 1 then
10575 Check_Arg_Is_Local_Name
(Arg1
);
10576 E_Id
:= Get_Pragma_Arg
(Arg1
);
10578 if Etype
(E_Id
) = Any_Type
then
10582 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10583 Record_Rep_Item
(Entity
(E_Id
), N
);
10586 Check_Arg_Count
(0);
10588 -- For Ada_2005 we unconditionally enforce the documented
10589 -- configuration pragma placement, since we do not want to
10590 -- tolerate mixed modes in a unit involving Ada 2005. That
10591 -- would cause real difficulties for those cases where there
10592 -- are incompatibilities between Ada 95 and Ada 2005.
10594 Check_Valid_Configuration_Pragma
;
10596 -- Now set appropriate Ada mode
10598 Ada_Version
:= Ada_2005
;
10599 Ada_Version_Explicit
:= Ada_2005
;
10600 Ada_Version_Pragma
:= N
;
10604 ---------------------
10605 -- Ada_12/Ada_2012 --
10606 ---------------------
10609 -- pragma Ada_12 (LOCAL_NAME);
10611 -- pragma Ada_2012;
10612 -- pragma Ada_2012 (LOCAL_NAME):
10614 -- Note: these pragmas also have some specific processing in Par.Prag
10615 -- because we want to set the Ada 2012 version mode during parsing.
10617 -- The one argument form is used for managing the transition from Ada
10618 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10619 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10620 -- mode will generate a warning. In addition, in any pre-Ada_2012
10621 -- mode, a preference rule is established which does not choose
10622 -- such an entity unless it is unambiguously specified. This avoids
10623 -- extra subprograms marked this way from generating ambiguities in
10624 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10625 -- intended for exclusive use in the GNAT run-time library.
10627 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10633 if Arg_Count
= 1 then
10634 Check_Arg_Is_Local_Name
(Arg1
);
10635 E_Id
:= Get_Pragma_Arg
(Arg1
);
10637 if Etype
(E_Id
) = Any_Type
then
10641 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10642 Record_Rep_Item
(Entity
(E_Id
), N
);
10645 Check_Arg_Count
(0);
10647 -- For Ada_2012 we unconditionally enforce the documented
10648 -- configuration pragma placement, since we do not want to
10649 -- tolerate mixed modes in a unit involving Ada 2012. That
10650 -- would cause real difficulties for those cases where there
10651 -- are incompatibilities between Ada 95 and Ada 2012. We could
10652 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10654 Check_Valid_Configuration_Pragma
;
10656 -- Now set appropriate Ada mode
10658 Ada_Version
:= Ada_2012
;
10659 Ada_Version_Explicit
:= Ada_2012
;
10660 Ada_Version_Pragma
:= N
;
10664 ----------------------
10665 -- All_Calls_Remote --
10666 ----------------------
10668 -- pragma All_Calls_Remote [(library_package_NAME)];
10670 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10671 Lib_Entity
: Entity_Id
;
10674 Check_Ada_83_Warning
;
10675 Check_Valid_Library_Unit_Pragma
;
10677 if Nkind
(N
) = N_Null_Statement
then
10681 Lib_Entity
:= Find_Lib_Unit_Name
;
10683 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10685 if Present
(Lib_Entity
)
10686 and then not Debug_Flag_U
10688 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10689 Error_Pragma
("pragma% only apply to rci unit");
10691 -- Set flag for entity of the library unit
10694 Set_Has_All_Calls_Remote
(Lib_Entity
);
10698 end All_Calls_Remote
;
10700 ---------------------------
10701 -- Allow_Integer_Address --
10702 ---------------------------
10704 -- pragma Allow_Integer_Address;
10706 when Pragma_Allow_Integer_Address
=>
10708 Check_Valid_Configuration_Pragma
;
10709 Check_Arg_Count
(0);
10711 -- If Address is a private type, then set the flag to allow
10712 -- integer address values. If Address is not private, then this
10713 -- pragma has no purpose, so it is simply ignored. Not clear if
10714 -- there are any such targets now.
10716 if Opt
.Address_Is_Private
then
10717 Opt
.Allow_Integer_Address
:= True;
10725 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10726 -- ARG ::= NAME | EXPRESSION
10728 -- The first two arguments are by convention intended to refer to an
10729 -- external tool and a tool-specific function. These arguments are
10732 when Pragma_Annotate
=> Annotate
: declare
10738 Check_At_Least_N_Arguments
(1);
10740 -- See if last argument is Entity => local_Name, and if so process
10741 -- and then remove it for remaining processing.
10744 Last_Arg
: constant Node_Id
:=
10745 Last
(Pragma_Argument_Associations
(N
));
10748 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10749 and then Chars
(Last_Arg
) = Name_Entity
10751 Check_Arg_Is_Local_Name
(Last_Arg
);
10752 Arg_Count
:= Arg_Count
- 1;
10754 -- Not allowed in compiler units (bootstrap issues)
10756 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10760 -- Continue processing with last argument removed for now
10762 Check_Arg_Is_Identifier
(Arg1
);
10763 Check_No_Identifiers
;
10766 -- Second parameter is optional, it is never analyzed
10771 -- Here if we have a second parameter
10774 -- Second parameter must be identifier
10776 Check_Arg_Is_Identifier
(Arg2
);
10778 -- Process remaining parameters if any
10780 Arg
:= Next
(Arg2
);
10781 while Present
(Arg
) loop
10782 Exp
:= Get_Pragma_Arg
(Arg
);
10785 if Is_Entity_Name
(Exp
) then
10788 -- For string literals, we assume Standard_String as the
10789 -- type, unless the string contains wide or wide_wide
10792 elsif Nkind
(Exp
) = N_String_Literal
then
10793 if Has_Wide_Wide_Character
(Exp
) then
10794 Resolve
(Exp
, Standard_Wide_Wide_String
);
10795 elsif Has_Wide_Character
(Exp
) then
10796 Resolve
(Exp
, Standard_Wide_String
);
10798 Resolve
(Exp
, Standard_String
);
10801 elsif Is_Overloaded
(Exp
) then
10803 ("ambiguous argument for pragma%", Exp
);
10814 -------------------------------------------------
10815 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10816 -------------------------------------------------
10819 -- ( [Check => ] Boolean_EXPRESSION
10820 -- [, [Message =>] Static_String_EXPRESSION]);
10822 -- pragma Assert_And_Cut
10823 -- ( [Check => ] Boolean_EXPRESSION
10824 -- [, [Message =>] Static_String_EXPRESSION]);
10827 -- ( [Check => ] Boolean_EXPRESSION
10828 -- [, [Message =>] Static_String_EXPRESSION]);
10830 -- pragma Loop_Invariant
10831 -- ( [Check => ] Boolean_EXPRESSION
10832 -- [, [Message =>] Static_String_EXPRESSION]);
10834 when Pragma_Assert |
10835 Pragma_Assert_And_Cut |
10837 Pragma_Loop_Invariant
=>
10839 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10840 -- Determine whether expression Expr contains a Loop_Entry
10841 -- attribute reference.
10843 -------------------------
10844 -- Contains_Loop_Entry --
10845 -------------------------
10847 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10848 Has_Loop_Entry
: Boolean := False;
10850 function Process
(N
: Node_Id
) return Traverse_Result
;
10851 -- Process function for traversal to look for Loop_Entry
10857 function Process
(N
: Node_Id
) return Traverse_Result
is
10859 if Nkind
(N
) = N_Attribute_Reference
10860 and then Attribute_Name
(N
) = Name_Loop_Entry
10862 Has_Loop_Entry
:= True;
10869 procedure Traverse
is new Traverse_Proc
(Process
);
10871 -- Start of processing for Contains_Loop_Entry
10875 return Has_Loop_Entry
;
10876 end Contains_Loop_Entry
;
10883 -- Start of processing for Assert
10886 -- Assert is an Ada 2005 RM-defined pragma
10888 if Prag_Id
= Pragma_Assert
then
10891 -- The remaining ones are GNAT pragmas
10897 Check_At_Least_N_Arguments
(1);
10898 Check_At_Most_N_Arguments
(2);
10899 Check_Arg_Order
((Name_Check
, Name_Message
));
10900 Check_Optional_Identifier
(Arg1
, Name_Check
);
10901 Expr
:= Get_Pragma_Arg
(Arg1
);
10903 -- Special processing for Loop_Invariant, Loop_Variant or for
10904 -- other cases where a Loop_Entry attribute is present. If the
10905 -- assertion pragma contains attribute Loop_Entry, ensure that
10906 -- the related pragma is within a loop.
10908 if Prag_Id
= Pragma_Loop_Invariant
10909 or else Prag_Id
= Pragma_Loop_Variant
10910 or else Contains_Loop_Entry
(Expr
)
10912 Check_Loop_Pragma_Placement
;
10914 -- Perform preanalysis to deal with embedded Loop_Entry
10917 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10920 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10921 -- a corresponding Check pragma:
10923 -- pragma Check (name, condition [, msg]);
10925 -- Where name is the identifier matching the pragma name. So
10926 -- rewrite pragma in this manner, transfer the message argument
10927 -- if present, and analyze the result
10929 -- Note: When dealing with a semantically analyzed tree, the
10930 -- information that a Check node N corresponds to a source Assert,
10931 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10932 -- pragma kind of Original_Node(N).
10935 Make_Pragma_Argument_Association
(Loc
,
10936 Expression
=> Make_Identifier
(Loc
, Pname
)),
10937 Make_Pragma_Argument_Association
(Sloc
(Expr
),
10938 Expression
=> Expr
));
10940 if Arg_Count
> 1 then
10941 Check_Optional_Identifier
(Arg2
, Name_Message
);
10943 -- Provide semantic annnotations for optional argument, for
10944 -- ASIS use, before rewriting.
10946 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
10947 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
10950 -- Rewrite as Check pragma
10954 Chars
=> Name_Check
,
10955 Pragma_Argument_Associations
=> Newa
));
10959 ----------------------
10960 -- Assertion_Policy --
10961 ----------------------
10963 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10965 -- The following form is Ada 2012 only, but we allow it in all modes
10967 -- Pragma Assertion_Policy (
10968 -- ASSERTION_KIND => POLICY_IDENTIFIER
10969 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
10971 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
10973 -- RM_ASSERTION_KIND ::= Assert |
10974 -- Static_Predicate |
10975 -- Dynamic_Predicate |
10980 -- Type_Invariant |
10981 -- Type_Invariant'Class
10983 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
10985 -- Contract_Cases |
10987 -- Default_Initial_Condition |
10989 -- Initial_Condition |
10990 -- Loop_Invariant |
10996 -- Statement_Assertions
10998 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
10999 -- ID_ASSERTION_KIND list contains implementation-defined additions
11000 -- recognized by GNAT. The effect is to control the behavior of
11001 -- identically named aspects and pragmas, depending on the specified
11002 -- policy identifier:
11004 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11006 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11007 -- implementation defined addition that results in totally ignoring
11008 -- the corresponding assertion. If Disable is specified, then the
11009 -- argument of the assertion is not even analyzed. This is useful
11010 -- when the aspect/pragma argument references entities in a with'ed
11011 -- package that is replaced by a dummy package in the final build.
11013 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11014 -- and Type_Invariant'Class were recognized by the parser and
11015 -- transformed into references to the special internal identifiers
11016 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11017 -- processing is required here.
11019 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11028 -- This can always appear as a configuration pragma
11030 if Is_Configuration_Pragma
then
11033 -- It can also appear in a declarative part or package spec in Ada
11034 -- 2012 mode. We allow this in other modes, but in that case we
11035 -- consider that we have an Ada 2012 pragma on our hands.
11038 Check_Is_In_Decl_Part_Or_Package_Spec
;
11042 -- One argument case with no identifier (first form above)
11045 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11046 or else Chars
(Arg1
) = No_Name
)
11048 Check_Arg_Is_One_Of
11049 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11051 -- Treat one argument Assertion_Policy as equivalent to:
11053 -- pragma Check_Policy (Assertion, policy)
11055 -- So rewrite pragma in that manner and link on to the chain
11056 -- of Check_Policy pragmas, marking the pragma as analyzed.
11058 Policy
:= Get_Pragma_Arg
(Arg1
);
11062 Chars
=> Name_Check_Policy
,
11063 Pragma_Argument_Associations
=> New_List
(
11064 Make_Pragma_Argument_Association
(Loc
,
11065 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11067 Make_Pragma_Argument_Association
(Loc
,
11069 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11072 -- Here if we have two or more arguments
11075 Check_At_Least_N_Arguments
(1);
11078 -- Loop through arguments
11081 while Present
(Arg
) loop
11082 LocP
:= Sloc
(Arg
);
11084 -- Kind must be specified
11086 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11087 or else Chars
(Arg
) = No_Name
11090 ("missing assertion kind for pragma%", Arg
);
11093 -- Check Kind and Policy have allowed forms
11095 Kind
:= Chars
(Arg
);
11097 if not Is_Valid_Assertion_Kind
(Kind
) then
11099 ("invalid assertion kind for pragma%", Arg
);
11102 Check_Arg_Is_One_Of
11103 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11105 -- We rewrite the Assertion_Policy pragma as a series of
11106 -- Check_Policy pragmas:
11108 -- Check_Policy (Kind, Policy);
11112 Chars
=> Name_Check_Policy
,
11113 Pragma_Argument_Associations
=> New_List
(
11114 Make_Pragma_Argument_Association
(LocP
,
11115 Expression
=> Make_Identifier
(LocP
, Kind
)),
11116 Make_Pragma_Argument_Association
(LocP
,
11117 Expression
=> Get_Pragma_Arg
(Arg
)))));
11122 -- Rewrite the Assertion_Policy pragma as null since we have
11123 -- now inserted all the equivalent Check pragmas.
11125 Rewrite
(N
, Make_Null_Statement
(Loc
));
11128 end Assertion_Policy
;
11130 ------------------------------
11131 -- Assume_No_Invalid_Values --
11132 ------------------------------
11134 -- pragma Assume_No_Invalid_Values (On | Off);
11136 when Pragma_Assume_No_Invalid_Values
=>
11138 Check_Valid_Configuration_Pragma
;
11139 Check_Arg_Count
(1);
11140 Check_No_Identifiers
;
11141 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11143 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11144 Assume_No_Invalid_Values
:= True;
11146 Assume_No_Invalid_Values
:= False;
11149 --------------------------
11150 -- Attribute_Definition --
11151 --------------------------
11153 -- pragma Attribute_Definition
11154 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11155 -- [Entity =>] LOCAL_NAME,
11156 -- [Expression =>] EXPRESSION | NAME);
11158 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11159 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11164 Check_Arg_Count
(3);
11165 Check_Optional_Identifier
(Arg1
, "attribute");
11166 Check_Optional_Identifier
(Arg2
, "entity");
11167 Check_Optional_Identifier
(Arg3
, "expression");
11169 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11170 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11174 Check_Arg_Is_Local_Name
(Arg2
);
11176 -- If the attribute is not recognized, then issue a warning (not
11177 -- an error), and ignore the pragma.
11179 Aname
:= Chars
(Attribute_Designator
);
11181 if not Is_Attribute_Name
(Aname
) then
11182 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11186 -- Otherwise, rewrite the pragma as an attribute definition clause
11189 Make_Attribute_Definition_Clause
(Loc
,
11190 Name
=> Get_Pragma_Arg
(Arg2
),
11192 Expression
=> Get_Pragma_Arg
(Arg3
)));
11194 end Attribute_Definition
;
11196 ------------------------------------------------------------------
11197 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11198 ------------------------------------------------------------------
11200 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11201 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11202 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11203 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11205 -- FLAG ::= boolean_EXPRESSION
11207 when Pragma_Async_Readers |
11208 Pragma_Async_Writers |
11209 Pragma_Effective_Reads |
11210 Pragma_Effective_Writes
=>
11211 Async_Effective
: declare
11215 Obj_Id
: Entity_Id
;
11219 Check_No_Identifiers
;
11220 Check_At_Least_N_Arguments
(1);
11221 Check_At_Most_N_Arguments
(2);
11222 Check_Arg_Is_Local_Name
(Arg1
);
11223 Error_Msg_Name_1
:= Pname
;
11225 Obj
:= Get_Pragma_Arg
(Arg1
);
11226 Expr
:= Get_Pragma_Arg
(Arg2
);
11228 -- Perform minimal verification to ensure that the argument is at
11229 -- least a variable. Subsequent finer grained checks will be done
11230 -- at the end of the declarative region the contains the pragma.
11232 if Is_Entity_Name
(Obj
)
11233 and then Present
(Entity
(Obj
))
11234 and then Ekind
(Entity
(Obj
)) = E_Variable
11236 Obj_Id
:= Entity
(Obj
);
11238 -- Detect a duplicate pragma. Note that it is not efficient to
11239 -- examine preceding statements as Boolean aspects may appear
11240 -- anywhere between the related object declaration and its
11241 -- freeze point. As an alternative, inspect the contents of the
11242 -- variable contract.
11244 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11246 if Present
(Duplic
) then
11247 Error_Msg_Sloc
:= Sloc
(Duplic
);
11248 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11250 -- No duplicate detected
11253 if Present
(Expr
) then
11254 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11257 -- Chain the pragma on the contract for further processing
11259 Add_Contract_Item
(N
, Obj_Id
);
11262 Error_Pragma
("pragma % must apply to a volatile object");
11264 end Async_Effective
;
11270 -- pragma Asynchronous (LOCAL_NAME);
11272 when Pragma_Asynchronous
=> Asynchronous
: declare
11278 Formal
: Entity_Id
;
11280 procedure Process_Async_Pragma
;
11281 -- Common processing for procedure and access-to-procedure case
11283 --------------------------
11284 -- Process_Async_Pragma --
11285 --------------------------
11287 procedure Process_Async_Pragma
is
11290 Set_Is_Asynchronous
(Nm
);
11294 -- The formals should be of mode IN (RM E.4.1(6))
11297 while Present
(S
) loop
11298 Formal
:= Defining_Identifier
(S
);
11300 if Nkind
(Formal
) = N_Defining_Identifier
11301 and then Ekind
(Formal
) /= E_In_Parameter
11304 ("pragma% procedure can only have IN parameter",
11311 Set_Is_Asynchronous
(Nm
);
11312 end Process_Async_Pragma
;
11314 -- Start of processing for pragma Asynchronous
11317 Check_Ada_83_Warning
;
11318 Check_No_Identifiers
;
11319 Check_Arg_Count
(1);
11320 Check_Arg_Is_Local_Name
(Arg1
);
11322 if Debug_Flag_U
then
11326 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11327 Analyze
(Get_Pragma_Arg
(Arg1
));
11328 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11330 if not Is_Remote_Call_Interface
(C_Ent
)
11331 and then not Is_Remote_Types
(C_Ent
)
11333 -- This pragma should only appear in an RCI or Remote Types
11334 -- unit (RM E.4.1(4)).
11337 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11340 if Ekind
(Nm
) = E_Procedure
11341 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11343 if not Is_Remote_Call_Interface
(Nm
) then
11345 ("pragma% cannot be applied on non-remote procedure",
11349 L
:= Parameter_Specifications
(Parent
(Nm
));
11350 Process_Async_Pragma
;
11353 elsif Ekind
(Nm
) = E_Function
then
11355 ("pragma% cannot be applied to function", Arg1
);
11357 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11358 if Is_Record_Type
(Nm
) then
11360 -- A record type that is the Equivalent_Type for a remote
11361 -- access-to-subprogram type.
11363 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11366 -- A non-expanded RAS type (distribution is not enabled)
11368 N
:= Declaration_Node
(Nm
);
11371 if Nkind
(N
) = N_Full_Type_Declaration
11372 and then Nkind
(Type_Definition
(N
)) =
11373 N_Access_Procedure_Definition
11375 L
:= Parameter_Specifications
(Type_Definition
(N
));
11376 Process_Async_Pragma
;
11378 if Is_Asynchronous
(Nm
)
11379 and then Expander_Active
11380 and then Get_PCS_Name
/= Name_No_DSA
11382 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11387 ("pragma% cannot reference access-to-function type",
11391 -- Only other possibility is Access-to-class-wide type
11393 elsif Is_Access_Type
(Nm
)
11394 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11396 Check_First_Subtype
(Arg1
);
11397 Set_Is_Asynchronous
(Nm
);
11398 if Expander_Active
then
11399 RACW_Type_Is_Asynchronous
(Nm
);
11403 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11411 -- pragma Atomic (LOCAL_NAME);
11413 when Pragma_Atomic
=>
11414 Process_Atomic_Shared_Volatile
;
11416 -----------------------
11417 -- Atomic_Components --
11418 -----------------------
11420 -- pragma Atomic_Components (array_LOCAL_NAME);
11422 -- This processing is shared by Volatile_Components
11424 when Pragma_Atomic_Components |
11425 Pragma_Volatile_Components
=>
11427 Atomic_Components
: declare
11434 Check_Ada_83_Warning
;
11435 Check_No_Identifiers
;
11436 Check_Arg_Count
(1);
11437 Check_Arg_Is_Local_Name
(Arg1
);
11438 E_Id
:= Get_Pragma_Arg
(Arg1
);
11440 if Etype
(E_Id
) = Any_Type
then
11444 E
:= Entity
(E_Id
);
11446 Check_Duplicate_Pragma
(E
);
11448 if Rep_Item_Too_Early
(E
, N
)
11450 Rep_Item_Too_Late
(E
, N
)
11455 D
:= Declaration_Node
(E
);
11458 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11460 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11461 and then Nkind
(D
) = N_Object_Declaration
11462 and then Nkind
(Object_Definition
(D
)) =
11463 N_Constrained_Array_Definition
)
11465 -- The flag is set on the object, or on the base type
11467 if Nkind
(D
) /= N_Object_Declaration
then
11468 E
:= Base_Type
(E
);
11471 Set_Has_Volatile_Components
(E
);
11473 if Prag_Id
= Pragma_Atomic_Components
then
11474 Set_Has_Atomic_Components
(E
);
11478 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11480 end Atomic_Components
;
11482 --------------------
11483 -- Attach_Handler --
11484 --------------------
11486 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11488 when Pragma_Attach_Handler
=>
11489 Check_Ada_83_Warning
;
11490 Check_No_Identifiers
;
11491 Check_Arg_Count
(2);
11493 if No_Run_Time_Mode
then
11494 Error_Msg_CRT
("Attach_Handler pragma", N
);
11496 Check_Interrupt_Or_Attach_Handler
;
11498 -- The expression that designates the attribute may depend on a
11499 -- discriminant, and is therefore a per-object expression, to
11500 -- be expanded in the init proc. If expansion is enabled, then
11501 -- perform semantic checks on a copy only.
11506 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11509 -- In Relaxed_RM_Semantics mode, we allow any static
11510 -- integer value, for compatibility with other compilers.
11512 if Relaxed_RM_Semantics
11513 and then Nkind
(Parg2
) = N_Integer_Literal
11515 Typ
:= Standard_Integer
;
11517 Typ
:= RTE
(RE_Interrupt_ID
);
11520 if Expander_Active
then
11521 Temp
:= New_Copy_Tree
(Parg2
);
11522 Set_Parent
(Temp
, N
);
11523 Preanalyze_And_Resolve
(Temp
, Typ
);
11526 Resolve
(Parg2
, Typ
);
11530 Process_Interrupt_Or_Attach_Handler
;
11533 --------------------
11534 -- C_Pass_By_Copy --
11535 --------------------
11537 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11539 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11545 Check_Valid_Configuration_Pragma
;
11546 Check_Arg_Count
(1);
11547 Check_Optional_Identifier
(Arg1
, "max_size");
11549 Arg
:= Get_Pragma_Arg
(Arg1
);
11550 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11552 Val
:= Expr_Value
(Arg
);
11556 ("maximum size for pragma% must be positive", Arg1
);
11558 elsif UI_Is_In_Int_Range
(Val
) then
11559 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11561 -- If a giant value is given, Int'Last will do well enough.
11562 -- If sometime someone complains that a record larger than
11563 -- two gigabytes is not copied, we will worry about it then.
11566 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11568 end C_Pass_By_Copy
;
11574 -- pragma Check ([Name =>] CHECK_KIND,
11575 -- [Check =>] Boolean_EXPRESSION
11576 -- [,[Message =>] String_EXPRESSION]);
11578 -- CHECK_KIND ::= IDENTIFIER |
11581 -- Invariant'Class |
11582 -- Type_Invariant'Class
11584 -- The identifiers Assertions and Statement_Assertions are not
11585 -- allowed, since they have special meaning for Check_Policy.
11587 when Pragma_Check
=> Check
: declare
11595 Check_At_Least_N_Arguments
(2);
11596 Check_At_Most_N_Arguments
(3);
11597 Check_Optional_Identifier
(Arg1
, Name_Name
);
11598 Check_Optional_Identifier
(Arg2
, Name_Check
);
11600 if Arg_Count
= 3 then
11601 Check_Optional_Identifier
(Arg3
, Name_Message
);
11602 Str
:= Get_Pragma_Arg
(Arg3
);
11605 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11606 Check_Arg_Is_Identifier
(Arg1
);
11607 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11609 -- Check forbidden name Assertions or Statement_Assertions
11612 when Name_Assertions
=>
11614 ("""Assertions"" is not allowed as a check kind "
11615 & "for pragma%", Arg1
);
11617 when Name_Statement_Assertions
=>
11619 ("""Statement_Assertions"" is not allowed as a check kind "
11620 & "for pragma%", Arg1
);
11626 -- Check applicable policy. We skip this if Checked/Ignored status
11627 -- is already set (e.g. in the casse of a pragma from an aspect).
11629 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11632 -- For a non-source pragma that is a rewriting of another pragma,
11633 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11635 elsif Is_Rewrite_Substitution
(N
)
11636 and then Nkind
(Original_Node
(N
)) = N_Pragma
11637 and then Original_Node
(N
) /= N
11639 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11640 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11642 -- Otherwise query the applicable policy at this point
11645 case Check_Kind
(Cname
) is
11646 when Name_Ignore
=>
11647 Set_Is_Ignored
(N
, True);
11648 Set_Is_Checked
(N
, False);
11651 Set_Is_Ignored
(N
, False);
11652 Set_Is_Checked
(N
, True);
11654 -- For disable, rewrite pragma as null statement and skip
11655 -- rest of the analysis of the pragma.
11657 when Name_Disable
=>
11658 Rewrite
(N
, Make_Null_Statement
(Loc
));
11662 -- No other possibilities
11665 raise Program_Error
;
11669 -- If check kind was not Disable, then continue pragma analysis
11671 Expr
:= Get_Pragma_Arg
(Arg2
);
11673 -- Deal with SCO generation
11676 when Name_Predicate |
11679 -- Nothing to do: since checks occur in client units,
11680 -- the SCO for the aspect in the declaration unit is
11681 -- conservatively always enabled.
11687 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11689 -- Mark aspect/pragma SCO as enabled
11691 Set_SCO_Pragma_Enabled
(Loc
);
11695 -- Deal with analyzing the string argument.
11697 if Arg_Count
= 3 then
11699 -- If checks are not on we don't want any expansion (since
11700 -- such expansion would not get properly deleted) but
11701 -- we do want to analyze (to get proper references).
11702 -- The Preanalyze_And_Resolve routine does just what we want
11704 if Is_Ignored
(N
) then
11705 Preanalyze_And_Resolve
(Str
, Standard_String
);
11707 -- Otherwise we need a proper analysis and expansion
11710 Analyze_And_Resolve
(Str
, Standard_String
);
11714 -- Now you might think we could just do the same with the Boolean
11715 -- expression if checks are off (and expansion is on) and then
11716 -- rewrite the check as a null statement. This would work but we
11717 -- would lose the useful warnings about an assertion being bound
11718 -- to fail even if assertions are turned off.
11720 -- So instead we wrap the boolean expression in an if statement
11721 -- that looks like:
11723 -- if False and then condition then
11727 -- The reason we do this rewriting during semantic analysis rather
11728 -- than as part of normal expansion is that we cannot analyze and
11729 -- expand the code for the boolean expression directly, or it may
11730 -- cause insertion of actions that would escape the attempt to
11731 -- suppress the check code.
11733 -- Note that the Sloc for the if statement corresponds to the
11734 -- argument condition, not the pragma itself. The reason for
11735 -- this is that we may generate a warning if the condition is
11736 -- False at compile time, and we do not want to delete this
11737 -- warning when we delete the if statement.
11739 if Expander_Active
and Is_Ignored
(N
) then
11740 Eloc
:= Sloc
(Expr
);
11743 Make_If_Statement
(Eloc
,
11745 Make_And_Then
(Eloc
,
11746 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
11747 Right_Opnd
=> Expr
),
11748 Then_Statements
=> New_List
(
11749 Make_Null_Statement
(Eloc
))));
11751 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11753 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11755 -- Check is active or expansion not active. In these cases we can
11756 -- just go ahead and analyze the boolean with no worries.
11759 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11760 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11761 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11765 --------------------------
11766 -- Check_Float_Overflow --
11767 --------------------------
11769 -- pragma Check_Float_Overflow;
11771 when Pragma_Check_Float_Overflow
=>
11773 Check_Valid_Configuration_Pragma
;
11774 Check_Arg_Count
(0);
11775 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11781 -- pragma Check_Name (check_IDENTIFIER);
11783 when Pragma_Check_Name
=>
11785 Check_No_Identifiers
;
11786 Check_Valid_Configuration_Pragma
;
11787 Check_Arg_Count
(1);
11788 Check_Arg_Is_Identifier
(Arg1
);
11791 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11794 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11795 if Check_Names
.Table
(J
) = Nam
then
11800 Check_Names
.Append
(Nam
);
11807 -- This is the old style syntax, which is still allowed in all modes:
11809 -- pragma Check_Policy ([Name =>] CHECK_KIND
11810 -- [Policy =>] POLICY_IDENTIFIER);
11812 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11814 -- CHECK_KIND ::= IDENTIFIER |
11817 -- Type_Invariant'Class |
11820 -- This is the new style syntax, compatible with Assertion_Policy
11821 -- and also allowed in all modes.
11823 -- Pragma Check_Policy (
11824 -- CHECK_KIND => POLICY_IDENTIFIER
11825 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11827 -- Note: the identifiers Name and Policy are not allowed as
11828 -- Check_Kind values. This avoids ambiguities between the old and
11829 -- new form syntax.
11831 when Pragma_Check_Policy
=> Check_Policy
: declare
11837 Check_At_Least_N_Arguments
(1);
11839 -- A Check_Policy pragma can appear either as a configuration
11840 -- pragma, or in a declarative part or a package spec (see RM
11841 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11842 -- followed for Check_Policy).
11844 if not Is_Configuration_Pragma
then
11845 Check_Is_In_Decl_Part_Or_Package_Spec
;
11848 -- Figure out if we have the old or new syntax. We have the
11849 -- old syntax if the first argument has no identifier, or the
11850 -- identifier is Name.
11852 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11853 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11857 Check_Arg_Count
(2);
11858 Check_Optional_Identifier
(Arg1
, Name_Name
);
11859 Kind
:= Get_Pragma_Arg
(Arg1
);
11860 Rewrite_Assertion_Kind
(Kind
);
11861 Check_Arg_Is_Identifier
(Arg1
);
11863 -- Check forbidden check kind
11865 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11866 Error_Msg_Name_2
:= Chars
(Kind
);
11868 ("pragma% does not allow% as check name", Arg1
);
11873 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11874 Check_Arg_Is_One_Of
11876 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11877 Ident
:= Get_Pragma_Arg
(Arg2
);
11879 if Chars
(Kind
) = Name_Ghost
then
11881 -- Pragma Check_Policy specifying a Ghost policy cannot
11882 -- occur within a ghost subprogram or package.
11884 if Within_Ghost_Scope
then
11886 ("pragma % cannot appear within ghost subprogram or "
11889 -- The policy identifier of pragma Ghost must be either
11890 -- Check or Ignore (SPARK RM 6.9(7)).
11892 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11896 ("argument of pragma % Ghost must be Check or Ignore",
11901 -- And chain pragma on the Check_Policy_List for search
11903 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11904 Opt
.Check_Policy_List
:= N
;
11906 -- For the new syntax, what we do is to convert each argument to
11907 -- an old syntax equivalent. We do that because we want to chain
11908 -- old style Check_Policy pragmas for the search (we don't want
11909 -- to have to deal with multiple arguments in the search).
11919 while Present
(Arg
) loop
11920 LocP
:= Sloc
(Arg
);
11921 Argx
:= Get_Pragma_Arg
(Arg
);
11923 -- Kind must be specified
11925 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11926 or else Chars
(Arg
) = No_Name
11929 ("missing assertion kind for pragma%", Arg
);
11932 -- Construct equivalent old form syntax Check_Policy
11933 -- pragma and insert it to get remaining checks.
11937 Chars
=> Name_Check_Policy
,
11938 Pragma_Argument_Associations
=> New_List
(
11939 Make_Pragma_Argument_Association
(LocP
,
11941 Make_Identifier
(LocP
, Chars
(Arg
))),
11942 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11943 Expression
=> Argx
))));
11948 -- Rewrite original Check_Policy pragma to null, since we
11949 -- have converted it into a series of old syntax pragmas.
11951 Rewrite
(N
, Make_Null_Statement
(Loc
));
11957 ---------------------
11958 -- CIL_Constructor --
11959 ---------------------
11961 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
11963 -- Processing for this pragma is shared with Java_Constructor
11969 -- pragma Comment (static_string_EXPRESSION)
11971 -- Processing for pragma Comment shares the circuitry for pragma
11972 -- Ident. The only differences are that Ident enforces a limit of 31
11973 -- characters on its argument, and also enforces limitations on
11974 -- placement for DEC compatibility. Pragma Comment shares neither of
11975 -- these restrictions.
11977 -------------------
11978 -- Common_Object --
11979 -------------------
11981 -- pragma Common_Object (
11982 -- [Internal =>] LOCAL_NAME
11983 -- [, [External =>] EXTERNAL_SYMBOL]
11984 -- [, [Size =>] EXTERNAL_SYMBOL]);
11986 -- Processing for this pragma is shared with Psect_Object
11988 ------------------------
11989 -- Compile_Time_Error --
11990 ------------------------
11992 -- pragma Compile_Time_Error
11993 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11995 when Pragma_Compile_Time_Error
=>
11997 Process_Compile_Time_Warning_Or_Error
;
11999 --------------------------
12000 -- Compile_Time_Warning --
12001 --------------------------
12003 -- pragma Compile_Time_Warning
12004 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12006 when Pragma_Compile_Time_Warning
=>
12008 Process_Compile_Time_Warning_Or_Error
;
12010 ---------------------------
12011 -- Compiler_Unit_Warning --
12012 ---------------------------
12014 -- pragma Compiler_Unit_Warning;
12018 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12019 -- errors not warnings. This means that we had introduced a big extra
12020 -- inertia to compiler changes, since even if we implemented a new
12021 -- feature, and even if all versions to be used for bootstrapping
12022 -- implemented this new feature, we could not use it, since old
12023 -- compilers would give errors for using this feature in units
12024 -- having Compiler_Unit pragmas.
12026 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12027 -- problem. We no longer have any units mentioning Compiler_Unit,
12028 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12029 -- and thus generates a warning which can be ignored. So that deals
12030 -- with the problem of old compilers not implementing the newer form
12033 -- Newer compilers recognize the new pragma, but generate warning
12034 -- messages instead of errors, which again can be ignored in the
12035 -- case of an old compiler which implements a wanted new feature
12036 -- but at the time felt like warning about it for older compilers.
12038 -- We retain Compiler_Unit so that new compilers can be used to build
12039 -- older run-times that use this pragma. That's an unusual case, but
12040 -- it's easy enough to handle, so why not?
12042 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12044 Check_Arg_Count
(0);
12046 -- Only recognized in main unit
12048 if Current_Sem_Unit
= Main_Unit
then
12049 Compiler_Unit
:= True;
12052 -----------------------------
12053 -- Complete_Representation --
12054 -----------------------------
12056 -- pragma Complete_Representation;
12058 when Pragma_Complete_Representation
=>
12060 Check_Arg_Count
(0);
12062 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12064 ("pragma & must appear within record representation clause");
12067 ----------------------------
12068 -- Complex_Representation --
12069 ----------------------------
12071 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12073 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12080 Check_Arg_Count
(1);
12081 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12082 Check_Arg_Is_Local_Name
(Arg1
);
12083 E_Id
:= Get_Pragma_Arg
(Arg1
);
12085 if Etype
(E_Id
) = Any_Type
then
12089 E
:= Entity
(E_Id
);
12091 if not Is_Record_Type
(E
) then
12093 ("argument for pragma% must be record type", Arg1
);
12096 Ent
:= First_Entity
(E
);
12099 or else No
(Next_Entity
(Ent
))
12100 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12101 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12102 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12105 ("record for pragma% must have two fields of the same "
12106 & "floating-point type", Arg1
);
12109 Set_Has_Complex_Representation
(Base_Type
(E
));
12111 -- We need to treat the type has having a non-standard
12112 -- representation, for back-end purposes, even though in
12113 -- general a complex will have the default representation
12114 -- of a record with two real components.
12116 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12118 end Complex_Representation
;
12120 -------------------------
12121 -- Component_Alignment --
12122 -------------------------
12124 -- pragma Component_Alignment (
12125 -- [Form =>] ALIGNMENT_CHOICE
12126 -- [, [Name =>] type_LOCAL_NAME]);
12128 -- ALIGNMENT_CHOICE ::=
12130 -- | Component_Size_4
12134 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12135 Args
: Args_List
(1 .. 2);
12136 Names
: constant Name_List
(1 .. 2) := (
12140 Form
: Node_Id
renames Args
(1);
12141 Name
: Node_Id
renames Args
(2);
12143 Atype
: Component_Alignment_Kind
;
12148 Gather_Associations
(Names
, Args
);
12151 Error_Pragma
("missing Form argument for pragma%");
12154 Check_Arg_Is_Identifier
(Form
);
12156 -- Get proper alignment, note that Default = Component_Size on all
12157 -- machines we have so far, and we want to set this value rather
12158 -- than the default value to indicate that it has been explicitly
12159 -- set (and thus will not get overridden by the default component
12160 -- alignment for the current scope)
12162 if Chars
(Form
) = Name_Component_Size
then
12163 Atype
:= Calign_Component_Size
;
12165 elsif Chars
(Form
) = Name_Component_Size_4
then
12166 Atype
:= Calign_Component_Size_4
;
12168 elsif Chars
(Form
) = Name_Default
then
12169 Atype
:= Calign_Component_Size
;
12171 elsif Chars
(Form
) = Name_Storage_Unit
then
12172 Atype
:= Calign_Storage_Unit
;
12176 ("invalid Form parameter for pragma%", Form
);
12179 -- Case with no name, supplied, affects scope table entry
12183 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12185 -- Case of name supplied
12188 Check_Arg_Is_Local_Name
(Name
);
12190 Typ
:= Entity
(Name
);
12193 or else Rep_Item_Too_Early
(Typ
, N
)
12197 Typ
:= Underlying_Type
(Typ
);
12200 if not Is_Record_Type
(Typ
)
12201 and then not Is_Array_Type
(Typ
)
12204 ("Name parameter of pragma% must identify record or "
12205 & "array type", Name
);
12208 -- An explicit Component_Alignment pragma overrides an
12209 -- implicit pragma Pack, but not an explicit one.
12211 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12212 Set_Is_Packed
(Base_Type
(Typ
), False);
12213 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12216 end Component_AlignmentP
;
12218 --------------------
12219 -- Contract_Cases --
12220 --------------------
12222 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12224 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12226 -- CASE_GUARD ::= boolean_EXPRESSION | others
12228 -- CONSEQUENCE ::= boolean_EXPRESSION
12230 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12231 Subp_Decl
: Node_Id
;
12235 Check_No_Identifiers
;
12236 Check_Arg_Count
(1);
12237 Ensure_Aggregate_Form
(Arg1
);
12239 -- The pragma is analyzed at the end of the declarative part which
12240 -- contains the related subprogram. Reset the analyzed flag.
12242 Set_Analyzed
(N
, False);
12244 -- Ensure the proper placement of the pragma. Contract_Cases must
12245 -- be associated with a subprogram declaration or a body that acts
12249 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12251 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12254 -- Body acts as spec
12256 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12257 and then No
(Corresponding_Spec
(Subp_Decl
))
12261 -- Body stub acts as spec
12263 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12264 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12273 -- When the pragma appears on a subprogram body, perform the full
12276 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12277 Analyze_Contract_Cases_In_Decl_Part
(N
);
12279 -- When Contract_Cases applies to a subprogram compilation unit,
12280 -- the corresponding pragma is placed after the unit's declaration
12281 -- node and needs to be analyzed immediately.
12283 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12284 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12286 Analyze_Contract_Cases_In_Decl_Part
(N
);
12289 -- Chain the pragma on the contract for further processing
12291 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12292 end Contract_Cases
;
12298 -- pragma Controlled (first_subtype_LOCAL_NAME);
12300 when Pragma_Controlled
=> Controlled
: declare
12304 Check_No_Identifiers
;
12305 Check_Arg_Count
(1);
12306 Check_Arg_Is_Local_Name
(Arg1
);
12307 Arg
:= Get_Pragma_Arg
(Arg1
);
12309 if not Is_Entity_Name
(Arg
)
12310 or else not Is_Access_Type
(Entity
(Arg
))
12312 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12314 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12322 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12323 -- [Entity =>] LOCAL_NAME);
12325 when Pragma_Convention
=> Convention
: declare
12328 pragma Warnings
(Off
, C
);
12329 pragma Warnings
(Off
, E
);
12331 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12332 Check_Ada_83_Warning
;
12333 Check_Arg_Count
(2);
12334 Process_Convention
(C
, E
);
12337 ---------------------------
12338 -- Convention_Identifier --
12339 ---------------------------
12341 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12342 -- [Convention =>] convention_IDENTIFIER);
12344 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12350 Check_Arg_Order
((Name_Name
, Name_Convention
));
12351 Check_Arg_Count
(2);
12352 Check_Optional_Identifier
(Arg1
, Name_Name
);
12353 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12354 Check_Arg_Is_Identifier
(Arg1
);
12355 Check_Arg_Is_Identifier
(Arg2
);
12356 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12357 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12359 if Is_Convention_Name
(Cname
) then
12360 Record_Convention_Identifier
12361 (Idnam
, Get_Convention_Id
(Cname
));
12364 ("second arg for % pragma must be convention", Arg2
);
12366 end Convention_Identifier
;
12372 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12374 when Pragma_CPP_Class
=> CPP_Class
: declare
12378 if Warn_On_Obsolescent_Feature
then
12380 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12381 & "effect; replace it by pragma import?j?", N
);
12384 Check_Arg_Count
(1);
12388 Chars
=> Name_Import
,
12389 Pragma_Argument_Associations
=> New_List
(
12390 Make_Pragma_Argument_Association
(Loc
,
12391 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12392 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12396 ---------------------
12397 -- CPP_Constructor --
12398 ---------------------
12400 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12401 -- [, [External_Name =>] static_string_EXPRESSION ]
12402 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12404 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12407 Def_Id
: Entity_Id
;
12408 Tag_Typ
: Entity_Id
;
12412 Check_At_Least_N_Arguments
(1);
12413 Check_At_Most_N_Arguments
(3);
12414 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12415 Check_Arg_Is_Local_Name
(Arg1
);
12417 Id
:= Get_Pragma_Arg
(Arg1
);
12418 Find_Program_Unit_Name
(Id
);
12420 -- If we did not find the name, we are done
12422 if Etype
(Id
) = Any_Type
then
12426 Def_Id
:= Entity
(Id
);
12428 -- Check if already defined as constructor
12430 if Is_Constructor
(Def_Id
) then
12432 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12436 if Ekind
(Def_Id
) = E_Function
12437 and then (Is_CPP_Class
(Etype
(Def_Id
))
12438 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12440 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12442 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12444 ("'C'P'P constructor must be defined in the scope of "
12445 & "its returned type", Arg1
);
12448 if Arg_Count
>= 2 then
12449 Set_Imported
(Def_Id
);
12450 Set_Is_Public
(Def_Id
);
12451 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12454 Set_Has_Completion
(Def_Id
);
12455 Set_Is_Constructor
(Def_Id
);
12456 Set_Convention
(Def_Id
, Convention_CPP
);
12458 -- Imported C++ constructors are not dispatching primitives
12459 -- because in C++ they don't have a dispatch table slot.
12460 -- However, in Ada the constructor has the profile of a
12461 -- function that returns a tagged type and therefore it has
12462 -- been treated as a primitive operation during semantic
12463 -- analysis. We now remove it from the list of primitive
12464 -- operations of the type.
12466 if Is_Tagged_Type
(Etype
(Def_Id
))
12467 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12468 and then Is_Dispatching_Operation
(Def_Id
)
12470 Tag_Typ
:= Etype
(Def_Id
);
12472 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12473 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12477 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12478 Set_Is_Dispatching_Operation
(Def_Id
, False);
12481 -- For backward compatibility, if the constructor returns a
12482 -- class wide type, and we internally change the return type to
12483 -- the corresponding root type.
12485 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12486 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12490 ("pragma% requires function returning a 'C'P'P_Class type",
12493 end CPP_Constructor
;
12499 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12503 if Warn_On_Obsolescent_Feature
then
12505 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12514 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12518 if Warn_On_Obsolescent_Feature
then
12520 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12529 -- pragma CPU (EXPRESSION);
12531 when Pragma_CPU
=> CPU
: declare
12532 P
: constant Node_Id
:= Parent
(N
);
12538 Check_No_Identifiers
;
12539 Check_Arg_Count
(1);
12543 if Nkind
(P
) = N_Subprogram_Body
then
12544 Check_In_Main_Program
;
12546 Arg
:= Get_Pragma_Arg
(Arg1
);
12547 Analyze_And_Resolve
(Arg
, Any_Integer
);
12549 Ent
:= Defining_Unit_Name
(Specification
(P
));
12551 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12552 Ent
:= Defining_Identifier
(Ent
);
12557 if not Is_OK_Static_Expression
(Arg
) then
12558 Flag_Non_Static_Expr
12559 ("main subprogram affinity is not static!", Arg
);
12562 -- If constraint error, then we already signalled an error
12564 elsif Raises_Constraint_Error
(Arg
) then
12567 -- Otherwise check in range
12571 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12572 -- This is the entity System.Multiprocessors.CPU_Range;
12574 Val
: constant Uint
:= Expr_Value
(Arg
);
12577 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12579 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12582 ("main subprogram CPU is out of range", Arg1
);
12588 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12592 elsif Nkind
(P
) = N_Task_Definition
then
12593 Arg
:= Get_Pragma_Arg
(Arg1
);
12594 Ent
:= Defining_Identifier
(Parent
(P
));
12596 -- The expression must be analyzed in the special manner
12597 -- described in "Handling of Default and Per-Object
12598 -- Expressions" in sem.ads.
12600 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12602 -- Anything else is incorrect
12608 -- Check duplicate pragma before we chain the pragma in the Rep
12609 -- Item chain of Ent.
12611 Check_Duplicate_Pragma
(Ent
);
12612 Record_Rep_Item
(Ent
, N
);
12619 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12621 when Pragma_Debug
=> Debug
: declare
12628 -- The condition for executing the call is that the expander
12629 -- is active and that we are not ignoring this debug pragma.
12634 (Expander_Active
and then not Is_Ignored
(N
)),
12637 if not Is_Ignored
(N
) then
12638 Set_SCO_Pragma_Enabled
(Loc
);
12641 if Arg_Count
= 2 then
12643 Make_And_Then
(Loc
,
12644 Left_Opnd
=> Relocate_Node
(Cond
),
12645 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12646 Call
:= Get_Pragma_Arg
(Arg2
);
12648 Call
:= Get_Pragma_Arg
(Arg1
);
12652 N_Indexed_Component
,
12656 N_Selected_Component
)
12658 -- If this pragma Debug comes from source, its argument was
12659 -- parsed as a name form (which is syntactically identical).
12660 -- In a generic context a parameterless call will be left as
12661 -- an expanded name (if global) or selected_component if local.
12662 -- Change it to a procedure call statement now.
12664 Change_Name_To_Procedure_Call_Statement
(Call
);
12666 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12668 -- Already in the form of a procedure call statement: nothing
12669 -- to do (could happen in case of an internally generated
12675 -- All other cases: diagnose error
12678 ("argument of pragma ""Debug"" is not procedure call",
12683 -- Rewrite into a conditional with an appropriate condition. We
12684 -- wrap the procedure call in a block so that overhead from e.g.
12685 -- use of the secondary stack does not generate execution overhead
12686 -- for suppressed conditions.
12688 -- Normally the analysis that follows will freeze the subprogram
12689 -- being called. However, if the call is to a null procedure,
12690 -- we want to freeze it before creating the block, because the
12691 -- analysis that follows may be done with expansion disabled, in
12692 -- which case the body will not be generated, leading to spurious
12695 if Nkind
(Call
) = N_Procedure_Call_Statement
12696 and then Is_Entity_Name
(Name
(Call
))
12698 Analyze
(Name
(Call
));
12699 Freeze_Before
(N
, Entity
(Name
(Call
)));
12703 Make_Implicit_If_Statement
(N
,
12705 Then_Statements
=> New_List
(
12706 Make_Block_Statement
(Loc
,
12707 Handled_Statement_Sequence
=>
12708 Make_Handled_Sequence_Of_Statements
(Loc
,
12709 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12712 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12713 -- after analysis of the normally rewritten node, to capture all
12714 -- references to entities, which avoids issuing wrong warnings
12715 -- about unused entities.
12717 if GNATprove_Mode
then
12718 Rewrite
(N
, Make_Null_Statement
(Loc
));
12726 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12728 when Pragma_Debug_Policy
=>
12730 Check_Arg_Count
(1);
12731 Check_No_Identifiers
;
12732 Check_Arg_Is_Identifier
(Arg1
);
12734 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12735 -- rewrite it that way, and let the rest of the checking come
12736 -- from analyzing the rewritten pragma.
12740 Chars
=> Name_Check_Policy
,
12741 Pragma_Argument_Associations
=> New_List
(
12742 Make_Pragma_Argument_Association
(Loc
,
12743 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12745 Make_Pragma_Argument_Association
(Loc
,
12746 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12749 -------------------------------
12750 -- Default_Initial_Condition --
12751 -------------------------------
12753 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12755 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12762 Check_No_Identifiers
;
12763 Check_At_Most_N_Arguments
(1);
12766 while Present
(Stmt
) loop
12768 -- Skip prior pragmas, but check for duplicates
12770 if Nkind
(Stmt
) = N_Pragma
then
12771 if Pragma_Name
(Stmt
) = Pname
then
12772 Error_Msg_Name_1
:= Pname
;
12773 Error_Msg_Sloc
:= Sloc
(Stmt
);
12774 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12777 -- Skip internally generated code
12779 elsif not Comes_From_Source
(Stmt
) then
12782 -- The associated private type [extension] has been found, stop
12785 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12786 N_Private_Type_Declaration
)
12788 Typ
:= Defining_Entity
(Stmt
);
12791 -- The pragma does not apply to a legal construct, issue an
12792 -- error and stop the analysis.
12799 Stmt
:= Prev
(Stmt
);
12802 Set_Has_Default_Init_Cond
(Typ
);
12803 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12805 -- Chain the pragma on the rep item chain for further processing
12807 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12808 end Default_Init_Cond
;
12810 ----------------------------------
12811 -- Default_Scalar_Storage_Order --
12812 ----------------------------------
12814 -- pragma Default_Scalar_Storage_Order
12815 -- (High_Order_First | Low_Order_First);
12817 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12818 Default
: Character;
12822 Check_Arg_Count
(1);
12824 -- Default_Scalar_Storage_Order can appear as a configuration
12825 -- pragma, or in a declarative part of a package spec.
12827 if not Is_Configuration_Pragma
then
12828 Check_Is_In_Decl_Part_Or_Package_Spec
;
12831 Check_No_Identifiers
;
12832 Check_Arg_Is_One_Of
12833 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12834 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12835 Default
:= Fold_Upper
(Name_Buffer
(1));
12837 if not Support_Nondefault_SSO_On_Target
12838 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12840 if Warn_On_Unrecognized_Pragma
then
12842 ("non-default Scalar_Storage_Order not supported "
12843 & "on target?g?", N
);
12845 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12848 -- Here set the specified default
12851 Opt
.Default_SSO
:= Default
;
12855 --------------------------
12856 -- Default_Storage_Pool --
12857 --------------------------
12859 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12861 when Pragma_Default_Storage_Pool
=>
12863 Check_Arg_Count
(1);
12865 -- Default_Storage_Pool can appear as a configuration pragma, or
12866 -- in a declarative part of a package spec.
12868 if not Is_Configuration_Pragma
then
12869 Check_Is_In_Decl_Part_Or_Package_Spec
;
12872 -- Case of Default_Storage_Pool (null);
12874 if Nkind
(Expression
(Arg1
)) = N_Null
then
12875 Analyze
(Expression
(Arg1
));
12877 -- This is an odd case, this is not really an expression, so
12878 -- we don't have a type for it. So just set the type to Empty.
12880 Set_Etype
(Expression
(Arg1
), Empty
);
12882 -- Case of Default_Storage_Pool (storage_pool_NAME);
12885 -- If it's a configuration pragma, then the only allowed
12886 -- argument is "null".
12888 if Is_Configuration_Pragma
then
12889 Error_Pragma_Arg
("NULL expected", Arg1
);
12892 -- The expected type for a non-"null" argument is
12893 -- Root_Storage_Pool'Class, and the pool must be a variable.
12895 Analyze_And_Resolve
12896 (Get_Pragma_Arg
(Arg1
),
12897 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12899 if not Is_Variable
(Expression
(Arg1
)) then
12901 ("default storage pool must be a variable", Arg1
);
12905 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12906 -- for an access type will use this information to set the
12907 -- appropriate attributes of the access type.
12909 Default_Pool
:= Expression
(Arg1
);
12915 -- pragma Depends (DEPENDENCY_RELATION);
12917 -- DEPENDENCY_RELATION ::=
12919 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12921 -- DEPENDENCY_CLAUSE ::=
12922 -- OUTPUT_LIST =>[+] INPUT_LIST
12923 -- | NULL_DEPENDENCY_CLAUSE
12925 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12927 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12929 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12931 -- OUTPUT ::= NAME | FUNCTION_RESULT
12934 -- where FUNCTION_RESULT is a function Result attribute_reference
12936 when Pragma_Depends
=> Depends
: declare
12937 Subp_Decl
: Node_Id
;
12941 Check_Arg_Count
(1);
12942 Ensure_Aggregate_Form
(Arg1
);
12944 -- Ensure the proper placement of the pragma. Depends must be
12945 -- associated with a subprogram declaration or a body that acts
12949 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12951 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12954 -- Body acts as spec
12956 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12957 and then No
(Corresponding_Spec
(Subp_Decl
))
12961 -- Body stub acts as spec
12963 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12964 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12973 -- When the pragma appears on a subprogram body, perform the full
12976 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12977 Analyze_Depends_In_Decl_Part
(N
);
12979 -- When Depends applies to a subprogram compilation unit, the
12980 -- corresponding pragma is placed after the unit's declaration
12981 -- node and needs to be analyzed immediately.
12983 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12984 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12986 Analyze_Depends_In_Decl_Part
(N
);
12989 -- Chain the pragma on the contract for further processing
12991 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12994 ---------------------
12995 -- Detect_Blocking --
12996 ---------------------
12998 -- pragma Detect_Blocking;
13000 when Pragma_Detect_Blocking
=>
13002 Check_Arg_Count
(0);
13003 Check_Valid_Configuration_Pragma
;
13004 Detect_Blocking
:= True;
13006 ------------------------------------
13007 -- Disable_Atomic_Synchronization --
13008 ------------------------------------
13010 -- pragma Disable_Atomic_Synchronization [(Entity)];
13012 when Pragma_Disable_Atomic_Synchronization
=>
13014 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13016 -------------------
13017 -- Discard_Names --
13018 -------------------
13020 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13022 when Pragma_Discard_Names
=> Discard_Names
: declare
13027 Check_Ada_83_Warning
;
13029 -- Deal with configuration pragma case
13031 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13032 Global_Discard_Names
:= True;
13035 -- Otherwise, check correct appropriate context
13038 Check_Is_In_Decl_Part_Or_Package_Spec
;
13040 if Arg_Count
= 0 then
13042 -- If there is no parameter, then from now on this pragma
13043 -- applies to any enumeration, exception or tagged type
13044 -- defined in the current declarative part, and recursively
13045 -- to any nested scope.
13047 Set_Discard_Names
(Current_Scope
);
13051 Check_Arg_Count
(1);
13052 Check_Optional_Identifier
(Arg1
, Name_On
);
13053 Check_Arg_Is_Local_Name
(Arg1
);
13055 E_Id
:= Get_Pragma_Arg
(Arg1
);
13057 if Etype
(E_Id
) = Any_Type
then
13060 E
:= Entity
(E_Id
);
13063 if (Is_First_Subtype
(E
)
13065 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13066 or else Ekind
(E
) = E_Exception
13068 Set_Discard_Names
(E
);
13069 Record_Rep_Item
(E
, N
);
13073 ("inappropriate entity for pragma%", Arg1
);
13080 ------------------------
13081 -- Dispatching_Domain --
13082 ------------------------
13084 -- pragma Dispatching_Domain (EXPRESSION);
13086 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13087 P
: constant Node_Id
:= Parent
(N
);
13093 Check_No_Identifiers
;
13094 Check_Arg_Count
(1);
13096 -- This pragma is born obsolete, but not the aspect
13098 if not From_Aspect_Specification
(N
) then
13100 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13103 if Nkind
(P
) = N_Task_Definition
then
13104 Arg
:= Get_Pragma_Arg
(Arg1
);
13105 Ent
:= Defining_Identifier
(Parent
(P
));
13107 -- The expression must be analyzed in the special manner
13108 -- described in "Handling of Default and Per-Object
13109 -- Expressions" in sem.ads.
13111 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13113 -- Check duplicate pragma before we chain the pragma in the Rep
13114 -- Item chain of Ent.
13116 Check_Duplicate_Pragma
(Ent
);
13117 Record_Rep_Item
(Ent
, N
);
13119 -- Anything else is incorrect
13124 end Dispatching_Domain
;
13130 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13132 when Pragma_Elaborate
=> Elaborate
: declare
13137 -- Pragma must be in context items list of a compilation unit
13139 if not Is_In_Context_Clause
then
13143 -- Must be at least one argument
13145 if Arg_Count
= 0 then
13146 Error_Pragma
("pragma% requires at least one argument");
13149 -- In Ada 83 mode, there can be no items following it in the
13150 -- context list except other pragmas and implicit with clauses
13151 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13152 -- placement rule does not apply.
13154 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13156 while Present
(Citem
) loop
13157 if Nkind
(Citem
) = N_Pragma
13158 or else (Nkind
(Citem
) = N_With_Clause
13159 and then Implicit_With
(Citem
))
13164 ("(Ada 83) pragma% must be at end of context clause");
13171 -- Finally, the arguments must all be units mentioned in a with
13172 -- clause in the same context clause. Note we already checked (in
13173 -- Par.Prag) that the arguments are all identifiers or selected
13177 Outer
: while Present
(Arg
) loop
13178 Citem
:= First
(List_Containing
(N
));
13179 Inner
: while Citem
/= N
loop
13180 if Nkind
(Citem
) = N_With_Clause
13181 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13183 Set_Elaborate_Present
(Citem
, True);
13184 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13185 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
13187 -- With the pragma present, elaboration calls on
13188 -- subprograms from the named unit need no further
13189 -- checks, as long as the pragma appears in the current
13190 -- compilation unit. If the pragma appears in some unit
13191 -- in the context, there might still be a need for an
13192 -- Elaborate_All_Desirable from the current compilation
13193 -- to the named unit, so we keep the check enabled.
13195 if In_Extended_Main_Source_Unit
(N
) then
13197 -- This does not apply in SPARK mode, where we allow
13198 -- pragma Elaborate, but we don't trust it to be right
13199 -- so we will still insist on the Elaborate_All.
13201 if SPARK_Mode
/= On
then
13202 Set_Suppress_Elaboration_Warnings
13203 (Entity
(Name
(Citem
)));
13215 ("argument of pragma% is not withed unit", Arg
);
13221 -- Give a warning if operating in static mode with one of the
13222 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13225 and not Dynamic_Elaboration_Checks
13227 -- pragma Elaborate not allowed in SPARK mode anyway. We
13228 -- already complained about it, no point in generating any
13229 -- further complaint.
13231 and SPARK_Mode
/= On
13234 ("?l?use of pragma Elaborate may not be safe", N
);
13236 ("?l?use pragma Elaborate_All instead if possible", N
);
13240 -------------------
13241 -- Elaborate_All --
13242 -------------------
13244 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13246 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13251 Check_Ada_83_Warning
;
13253 -- Pragma must be in context items list of a compilation unit
13255 if not Is_In_Context_Clause
then
13259 -- Must be at least one argument
13261 if Arg_Count
= 0 then
13262 Error_Pragma
("pragma% requires at least one argument");
13265 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13266 -- have to appear at the end of the context clause, but may
13267 -- appear mixed in with other items, even in Ada 83 mode.
13269 -- Final check: the arguments must all be units mentioned in
13270 -- a with clause in the same context clause. Note that we
13271 -- already checked (in Par.Prag) that all the arguments are
13272 -- either identifiers or selected components.
13275 Outr
: while Present
(Arg
) loop
13276 Citem
:= First
(List_Containing
(N
));
13277 Innr
: while Citem
/= N
loop
13278 if Nkind
(Citem
) = N_With_Clause
13279 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13281 Set_Elaborate_All_Present
(Citem
, True);
13282 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13284 -- Suppress warnings and elaboration checks on the named
13285 -- unit if the pragma is in the current compilation, as
13286 -- for pragma Elaborate.
13288 if In_Extended_Main_Source_Unit
(N
) then
13289 Set_Suppress_Elaboration_Warnings
13290 (Entity
(Name
(Citem
)));
13299 Set_Error_Posted
(N
);
13301 ("argument of pragma% is not withed unit", Arg
);
13308 --------------------
13309 -- Elaborate_Body --
13310 --------------------
13312 -- pragma Elaborate_Body [( library_unit_NAME )];
13314 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13315 Cunit_Node
: Node_Id
;
13316 Cunit_Ent
: Entity_Id
;
13319 Check_Ada_83_Warning
;
13320 Check_Valid_Library_Unit_Pragma
;
13322 if Nkind
(N
) = N_Null_Statement
then
13326 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13327 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13329 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13332 Error_Pragma
("pragma% must refer to a spec, not a body");
13334 Set_Body_Required
(Cunit_Node
, True);
13335 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13337 -- If we are in dynamic elaboration mode, then we suppress
13338 -- elaboration warnings for the unit, since it is definitely
13339 -- fine NOT to do dynamic checks at the first level (and such
13340 -- checks will be suppressed because no elaboration boolean
13341 -- is created for Elaborate_Body packages).
13343 -- But in the static model of elaboration, Elaborate_Body is
13344 -- definitely NOT good enough to ensure elaboration safety on
13345 -- its own, since the body may WITH other units that are not
13346 -- safe from an elaboration point of view, so a client must
13347 -- still do an Elaborate_All on such units.
13349 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13350 -- Elaborate_Body always suppressed elab warnings.
13352 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13353 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13356 end Elaborate_Body
;
13358 ------------------------
13359 -- Elaboration_Checks --
13360 ------------------------
13362 -- pragma Elaboration_Checks (Static | Dynamic);
13364 when Pragma_Elaboration_Checks
=>
13366 Check_Arg_Count
(1);
13367 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13369 -- Set flag accordingly (ignore attempt at dynamic elaboration
13370 -- checks in SPARK mode).
13372 Dynamic_Elaboration_Checks
:=
13373 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13374 and then SPARK_Mode
/= On
;
13380 -- pragma Eliminate (
13381 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13382 -- [,[Entity =>] IDENTIFIER |
13383 -- SELECTED_COMPONENT |
13385 -- [, OVERLOADING_RESOLUTION]);
13387 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13390 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13391 -- FUNCTION_PROFILE
13393 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13395 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13396 -- Result_Type => result_SUBTYPE_NAME]
13398 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13399 -- SUBTYPE_NAME ::= STRING_LITERAL
13401 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13402 -- SOURCE_TRACE ::= STRING_LITERAL
13404 when Pragma_Eliminate
=> Eliminate
: declare
13405 Args
: Args_List
(1 .. 5);
13406 Names
: constant Name_List
(1 .. 5) := (
13409 Name_Parameter_Types
,
13411 Name_Source_Location
);
13413 Unit_Name
: Node_Id
renames Args
(1);
13414 Entity
: Node_Id
renames Args
(2);
13415 Parameter_Types
: Node_Id
renames Args
(3);
13416 Result_Type
: Node_Id
renames Args
(4);
13417 Source_Location
: Node_Id
renames Args
(5);
13421 Check_Valid_Configuration_Pragma
;
13422 Gather_Associations
(Names
, Args
);
13424 if No
(Unit_Name
) then
13425 Error_Pragma
("missing Unit_Name argument for pragma%");
13429 and then (Present
(Parameter_Types
)
13431 Present
(Result_Type
)
13433 Present
(Source_Location
))
13435 Error_Pragma
("missing Entity argument for pragma%");
13438 if (Present
(Parameter_Types
)
13440 Present
(Result_Type
))
13442 Present
(Source_Location
)
13445 ("parameter profile and source location cannot be used "
13446 & "together in pragma%");
13449 Process_Eliminate_Pragma
13458 -----------------------------------
13459 -- Enable_Atomic_Synchronization --
13460 -----------------------------------
13462 -- pragma Enable_Atomic_Synchronization [(Entity)];
13464 when Pragma_Enable_Atomic_Synchronization
=>
13466 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13473 -- [ Convention =>] convention_IDENTIFIER,
13474 -- [ Entity =>] LOCAL_NAME
13475 -- [, [External_Name =>] static_string_EXPRESSION ]
13476 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13478 when Pragma_Export
=> Export
: declare
13480 Def_Id
: Entity_Id
;
13482 pragma Warnings
(Off
, C
);
13485 Check_Ada_83_Warning
;
13489 Name_External_Name
,
13492 Check_At_Least_N_Arguments
(2);
13493 Check_At_Most_N_Arguments
(4);
13495 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13496 -- pragma Export (Entity, "external name");
13498 if Relaxed_RM_Semantics
13499 and then Arg_Count
= 2
13500 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13503 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13506 if not Is_Entity_Name
(Def_Id
) then
13507 Error_Pragma_Arg
("entity name required", Arg1
);
13510 Def_Id
:= Entity
(Def_Id
);
13511 Set_Exported
(Def_Id
, Arg1
);
13514 Process_Convention
(C
, Def_Id
);
13516 if Ekind
(Def_Id
) /= E_Constant
then
13517 Note_Possible_Modification
13518 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13521 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13522 Set_Exported
(Def_Id
, Arg2
);
13525 -- If the entity is a deferred constant, propagate the information
13526 -- to the full view, because gigi elaborates the full view only.
13528 if Ekind
(Def_Id
) = E_Constant
13529 and then Present
(Full_View
(Def_Id
))
13532 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13534 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13535 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13536 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13541 ---------------------
13542 -- Export_Function --
13543 ---------------------
13545 -- pragma Export_Function (
13546 -- [Internal =>] LOCAL_NAME
13547 -- [, [External =>] EXTERNAL_SYMBOL]
13548 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13549 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13550 -- [, [Mechanism =>] MECHANISM]
13551 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13553 -- EXTERNAL_SYMBOL ::=
13555 -- | static_string_EXPRESSION
13557 -- PARAMETER_TYPES ::=
13559 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13561 -- TYPE_DESIGNATOR ::=
13563 -- | subtype_Name ' Access
13567 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13569 -- MECHANISM_ASSOCIATION ::=
13570 -- [formal_parameter_NAME =>] MECHANISM_NAME
13572 -- MECHANISM_NAME ::=
13576 when Pragma_Export_Function
=> Export_Function
: declare
13577 Args
: Args_List
(1 .. 6);
13578 Names
: constant Name_List
(1 .. 6) := (
13581 Name_Parameter_Types
,
13584 Name_Result_Mechanism
);
13586 Internal
: Node_Id
renames Args
(1);
13587 External
: Node_Id
renames Args
(2);
13588 Parameter_Types
: Node_Id
renames Args
(3);
13589 Result_Type
: Node_Id
renames Args
(4);
13590 Mechanism
: Node_Id
renames Args
(5);
13591 Result_Mechanism
: Node_Id
renames Args
(6);
13595 Gather_Associations
(Names
, Args
);
13596 Process_Extended_Import_Export_Subprogram_Pragma
(
13597 Arg_Internal
=> Internal
,
13598 Arg_External
=> External
,
13599 Arg_Parameter_Types
=> Parameter_Types
,
13600 Arg_Result_Type
=> Result_Type
,
13601 Arg_Mechanism
=> Mechanism
,
13602 Arg_Result_Mechanism
=> Result_Mechanism
);
13603 end Export_Function
;
13605 -------------------
13606 -- Export_Object --
13607 -------------------
13609 -- pragma Export_Object (
13610 -- [Internal =>] LOCAL_NAME
13611 -- [, [External =>] EXTERNAL_SYMBOL]
13612 -- [, [Size =>] EXTERNAL_SYMBOL]);
13614 -- EXTERNAL_SYMBOL ::=
13616 -- | static_string_EXPRESSION
13618 -- PARAMETER_TYPES ::=
13620 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13622 -- TYPE_DESIGNATOR ::=
13624 -- | subtype_Name ' Access
13628 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13630 -- MECHANISM_ASSOCIATION ::=
13631 -- [formal_parameter_NAME =>] MECHANISM_NAME
13633 -- MECHANISM_NAME ::=
13637 when Pragma_Export_Object
=> Export_Object
: declare
13638 Args
: Args_List
(1 .. 3);
13639 Names
: constant Name_List
(1 .. 3) := (
13644 Internal
: Node_Id
renames Args
(1);
13645 External
: Node_Id
renames Args
(2);
13646 Size
: Node_Id
renames Args
(3);
13650 Gather_Associations
(Names
, Args
);
13651 Process_Extended_Import_Export_Object_Pragma
(
13652 Arg_Internal
=> Internal
,
13653 Arg_External
=> External
,
13657 ----------------------
13658 -- Export_Procedure --
13659 ----------------------
13661 -- pragma Export_Procedure (
13662 -- [Internal =>] LOCAL_NAME
13663 -- [, [External =>] EXTERNAL_SYMBOL]
13664 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13665 -- [, [Mechanism =>] MECHANISM]);
13667 -- EXTERNAL_SYMBOL ::=
13669 -- | static_string_EXPRESSION
13671 -- PARAMETER_TYPES ::=
13673 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13675 -- TYPE_DESIGNATOR ::=
13677 -- | subtype_Name ' Access
13681 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13683 -- MECHANISM_ASSOCIATION ::=
13684 -- [formal_parameter_NAME =>] MECHANISM_NAME
13686 -- MECHANISM_NAME ::=
13690 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13691 Args
: Args_List
(1 .. 4);
13692 Names
: constant Name_List
(1 .. 4) := (
13695 Name_Parameter_Types
,
13698 Internal
: Node_Id
renames Args
(1);
13699 External
: Node_Id
renames Args
(2);
13700 Parameter_Types
: Node_Id
renames Args
(3);
13701 Mechanism
: Node_Id
renames Args
(4);
13705 Gather_Associations
(Names
, Args
);
13706 Process_Extended_Import_Export_Subprogram_Pragma
(
13707 Arg_Internal
=> Internal
,
13708 Arg_External
=> External
,
13709 Arg_Parameter_Types
=> Parameter_Types
,
13710 Arg_Mechanism
=> Mechanism
);
13711 end Export_Procedure
;
13717 -- pragma Export_Value (
13718 -- [Value =>] static_integer_EXPRESSION,
13719 -- [Link_Name =>] static_string_EXPRESSION);
13721 when Pragma_Export_Value
=>
13723 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13724 Check_Arg_Count
(2);
13726 Check_Optional_Identifier
(Arg1
, Name_Value
);
13727 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13729 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13730 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13732 -----------------------------
13733 -- Export_Valued_Procedure --
13734 -----------------------------
13736 -- pragma Export_Valued_Procedure (
13737 -- [Internal =>] LOCAL_NAME
13738 -- [, [External =>] EXTERNAL_SYMBOL,]
13739 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13740 -- [, [Mechanism =>] MECHANISM]);
13742 -- EXTERNAL_SYMBOL ::=
13744 -- | static_string_EXPRESSION
13746 -- PARAMETER_TYPES ::=
13748 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13750 -- TYPE_DESIGNATOR ::=
13752 -- | subtype_Name ' Access
13756 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13758 -- MECHANISM_ASSOCIATION ::=
13759 -- [formal_parameter_NAME =>] MECHANISM_NAME
13761 -- MECHANISM_NAME ::=
13765 when Pragma_Export_Valued_Procedure
=>
13766 Export_Valued_Procedure
: declare
13767 Args
: Args_List
(1 .. 4);
13768 Names
: constant Name_List
(1 .. 4) := (
13771 Name_Parameter_Types
,
13774 Internal
: Node_Id
renames Args
(1);
13775 External
: Node_Id
renames Args
(2);
13776 Parameter_Types
: Node_Id
renames Args
(3);
13777 Mechanism
: Node_Id
renames Args
(4);
13781 Gather_Associations
(Names
, Args
);
13782 Process_Extended_Import_Export_Subprogram_Pragma
(
13783 Arg_Internal
=> Internal
,
13784 Arg_External
=> External
,
13785 Arg_Parameter_Types
=> Parameter_Types
,
13786 Arg_Mechanism
=> Mechanism
);
13787 end Export_Valued_Procedure
;
13789 -------------------
13790 -- Extend_System --
13791 -------------------
13793 -- pragma Extend_System ([Name =>] Identifier);
13795 when Pragma_Extend_System
=> Extend_System
: declare
13798 Check_Valid_Configuration_Pragma
;
13799 Check_Arg_Count
(1);
13800 Check_Optional_Identifier
(Arg1
, Name_Name
);
13801 Check_Arg_Is_Identifier
(Arg1
);
13803 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13806 and then Name_Buffer
(1 .. 4) = "aux_"
13808 if Present
(System_Extend_Pragma_Arg
) then
13809 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13810 Chars
(Expression
(System_Extend_Pragma_Arg
))
13814 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13815 Error_Pragma
("pragma% conflicts with that #");
13819 System_Extend_Pragma_Arg
:= Arg1
;
13821 if not GNAT_Mode
then
13822 System_Extend_Unit
:= Arg1
;
13826 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13830 ------------------------
13831 -- Extensions_Allowed --
13832 ------------------------
13834 -- pragma Extensions_Allowed (ON | OFF);
13836 when Pragma_Extensions_Allowed
=>
13838 Check_Arg_Count
(1);
13839 Check_No_Identifiers
;
13840 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13842 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13843 Extensions_Allowed
:= True;
13844 Ada_Version
:= Ada_Version_Type
'Last;
13847 Extensions_Allowed
:= False;
13848 Ada_Version
:= Ada_Version_Explicit
;
13849 Ada_Version_Pragma
:= Empty
;
13852 ------------------------
13853 -- Extensions_Visible --
13854 ------------------------
13856 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13858 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13859 Context
: constant Node_Id
:= Parent
(N
);
13861 Formal
: Entity_Id
;
13862 Orig_Stmt
: Node_Id
;
13866 Has_OK_Formal
: Boolean := False;
13870 Check_No_Identifiers
;
13871 Check_At_Most_N_Arguments
(1);
13875 while Present
(Stmt
) loop
13877 -- Skip prior pragmas, but check for duplicates
13879 if Nkind
(Stmt
) = N_Pragma
then
13880 if Pragma_Name
(Stmt
) = Pname
then
13881 Error_Msg_Name_1
:= Pname
;
13882 Error_Msg_Sloc
:= Sloc
(Stmt
);
13883 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13886 -- Skip internally generated code
13888 elsif not Comes_From_Source
(Stmt
) then
13889 Orig_Stmt
:= Original_Node
(Stmt
);
13891 -- When pragma Ghost applies to an expression function, the
13892 -- expression function is transformed into a subprogram.
13894 if Nkind
(Stmt
) = N_Subprogram_Declaration
13895 and then Comes_From_Source
(Orig_Stmt
)
13896 and then Nkind
(Orig_Stmt
) = N_Expression_Function
13898 Subp
:= Defining_Entity
(Stmt
);
13902 -- The associated [generic] subprogram declaration has been
13903 -- found, stop the search.
13905 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
13906 N_Subprogram_Declaration
)
13908 Subp
:= Defining_Entity
(Stmt
);
13911 -- The pragma does not apply to a legal construct, issue an
13912 -- error and stop the analysis.
13915 Error_Pragma
("pragma % must apply to a subprogram");
13919 Stmt
:= Prev
(Stmt
);
13922 -- When the pragma applies to a stand alone subprogram body, it
13923 -- appears within the declarations of the body. In that case the
13924 -- enclosing construct is the proper context. This check is done
13925 -- after the traversal above to allow for duplicate detection.
13928 and then Nkind
(Context
) = N_Subprogram_Body
13929 and then No
(Corresponding_Spec
(Context
))
13931 Subp
:= Defining_Entity
(Context
);
13935 Error_Pragma
("pragma % must apply to a subprogram");
13939 -- Examine the formals of the related subprogram
13941 Formal
:= First_Formal
(Subp
);
13942 while Present
(Formal
) loop
13944 -- At least one of the formals is of a specific tagged type,
13945 -- the pragma is legal.
13947 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13948 Has_OK_Formal
:= True;
13951 -- A generic subprogram with at least one formal of a private
13952 -- type ensures the legality of the pragma because the actual
13953 -- may be specifically tagged. Note that this is verified by
13954 -- the check above at instantiation time.
13956 elsif Is_Private_Type
(Etype
(Formal
))
13957 and then Is_Generic_Type
(Etype
(Formal
))
13959 Has_OK_Formal
:= True;
13963 Next_Formal
(Formal
);
13966 if not Has_OK_Formal
then
13967 Error_Msg_Name_1
:= Pname
;
13968 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
13970 ("\subprogram & lacks parameter of specific tagged or "
13971 & "generic private type", N
, Subp
);
13975 -- Analyze the Boolean expression (if any)
13977 if Present
(Arg1
) then
13978 Expr
:= Get_Pragma_Arg
(Arg1
);
13980 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
13982 if not Is_OK_Static_Expression
(Expr
) then
13984 ("expression of pragma % must be static", Expr
);
13989 -- Chain the pragma on the contract for further processing
13991 Add_Contract_Item
(N
, Subp
);
13992 end Extensions_Visible
;
13998 -- pragma External (
13999 -- [ Convention =>] convention_IDENTIFIER,
14000 -- [ Entity =>] LOCAL_NAME
14001 -- [, [External_Name =>] static_string_EXPRESSION ]
14002 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14004 when Pragma_External
=> External
: declare
14005 Def_Id
: Entity_Id
;
14008 pragma Warnings
(Off
, C
);
14015 Name_External_Name
,
14017 Check_At_Least_N_Arguments
(2);
14018 Check_At_Most_N_Arguments
(4);
14019 Process_Convention
(C
, Def_Id
);
14020 Note_Possible_Modification
14021 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14022 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14023 Set_Exported
(Def_Id
, Arg2
);
14026 --------------------------
14027 -- External_Name_Casing --
14028 --------------------------
14030 -- pragma External_Name_Casing (
14031 -- UPPERCASE | LOWERCASE
14032 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14034 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14037 Check_No_Identifiers
;
14039 if Arg_Count
= 2 then
14040 Check_Arg_Is_One_Of
14041 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14043 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14045 Opt
.External_Name_Exp_Casing
:= As_Is
;
14047 when Name_Uppercase
=>
14048 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14050 when Name_Lowercase
=>
14051 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14058 Check_Arg_Count
(1);
14061 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14063 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14064 when Name_Uppercase
=>
14065 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14067 when Name_Lowercase
=>
14068 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14073 end External_Name_Casing
;
14079 -- pragma Fast_Math;
14081 when Pragma_Fast_Math
=>
14083 Check_No_Identifiers
;
14084 Check_Valid_Configuration_Pragma
;
14087 --------------------------
14088 -- Favor_Top_Level --
14089 --------------------------
14091 -- pragma Favor_Top_Level (type_NAME);
14093 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14094 Named_Entity
: Entity_Id
;
14098 Check_No_Identifiers
;
14099 Check_Arg_Count
(1);
14100 Check_Arg_Is_Local_Name
(Arg1
);
14101 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14103 -- If it's an access-to-subprogram type (in particular, not a
14104 -- subtype), set the flag on that type.
14106 if Is_Access_Subprogram_Type
(Named_Entity
) then
14107 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14109 -- Otherwise it's an error (name denotes the wrong sort of entity)
14113 ("access-to-subprogram type expected",
14114 Get_Pragma_Arg
(Arg1
));
14116 end Favor_Top_Level
;
14118 ---------------------------
14119 -- Finalize_Storage_Only --
14120 ---------------------------
14122 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14124 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14125 Assoc
: constant Node_Id
:= Arg1
;
14126 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14131 Check_No_Identifiers
;
14132 Check_Arg_Count
(1);
14133 Check_Arg_Is_Local_Name
(Arg1
);
14135 Find_Type
(Type_Id
);
14136 Typ
:= Entity
(Type_Id
);
14139 or else Rep_Item_Too_Early
(Typ
, N
)
14143 Typ
:= Underlying_Type
(Typ
);
14146 if not Is_Controlled
(Typ
) then
14147 Error_Pragma
("pragma% must specify controlled type");
14150 Check_First_Subtype
(Arg1
);
14152 if Finalize_Storage_Only
(Typ
) then
14153 Error_Pragma
("duplicate pragma%, only one allowed");
14155 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14156 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14158 end Finalize_Storage
;
14164 -- pragma Ghost [ (boolean_EXPRESSION) ];
14166 when Pragma_Ghost
=> Ghost
: declare
14170 Orig_Stmt
: Node_Id
;
14171 Prev_Id
: Entity_Id
;
14176 Check_No_Identifiers
;
14177 Check_At_Most_N_Arguments
(1);
14179 Context
:= Parent
(N
);
14181 -- Handle compilation units
14183 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14184 Context
:= Unit
(Parent
(Context
));
14189 while Present
(Stmt
) loop
14191 -- Skip prior pragmas, but check for duplicates
14193 if Nkind
(Stmt
) = N_Pragma
then
14194 if Pragma_Name
(Stmt
) = Pname
then
14195 Error_Msg_Name_1
:= Pname
;
14196 Error_Msg_Sloc
:= Sloc
(Stmt
);
14197 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14200 -- Protected and task types cannot be subject to pragma Ghost
14202 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
14203 Error_Pragma
("pragma % cannot apply to a protected type");
14206 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
14207 Error_Pragma
("pragma % cannot apply to a task type");
14210 -- Skip internally generated code
14212 elsif not Comes_From_Source
(Stmt
) then
14213 Orig_Stmt
:= Original_Node
(Stmt
);
14215 -- When pragma Ghost applies to an untagged derivation, the
14216 -- derivation is transformed into a [sub]type declaration.
14218 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14219 N_Subtype_Declaration
)
14220 and then Comes_From_Source
(Orig_Stmt
)
14221 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14222 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14223 N_Derived_Type_Definition
14225 Id
:= Defining_Entity
(Stmt
);
14228 -- When pragma Ghost applies to an expression function, the
14229 -- expression function is transformed into a subprogram.
14231 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14232 and then Comes_From_Source
(Orig_Stmt
)
14233 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14235 Id
:= Defining_Entity
(Stmt
);
14239 -- The pragma applies to a legal construct, stop the traversal
14241 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14242 N_Full_Type_Declaration
,
14243 N_Generic_Subprogram_Declaration
,
14244 N_Object_Declaration
,
14245 N_Private_Extension_Declaration
,
14246 N_Private_Type_Declaration
,
14247 N_Subprogram_Declaration
,
14248 N_Subtype_Declaration
)
14250 Id
:= Defining_Entity
(Stmt
);
14253 -- The pragma does not apply to a legal construct, issue an
14254 -- error and stop the analysis.
14258 ("pragma % must apply to an object, package, subprogram "
14263 Stmt
:= Prev
(Stmt
);
14268 -- When pragma Ghost is associated with a [generic] package, it
14269 -- appears in the visible declarations.
14271 if Nkind
(Context
) = N_Package_Specification
14272 and then Present
(Visible_Declarations
(Context
))
14273 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14275 Id
:= Defining_Entity
(Context
);
14277 -- Pragma Ghost applies to a stand alone subprogram body
14279 elsif Nkind
(Context
) = N_Subprogram_Body
14280 and then No
(Corresponding_Spec
(Context
))
14282 Id
:= Defining_Entity
(Context
);
14288 ("pragma % must apply to an object, package, subprogram or "
14293 -- A derived type or type extension cannot be subject to pragma
14294 -- Ghost if either the parent type or one of the progenitor types
14295 -- is not Ghost (SPARK RM 6.9(9)).
14297 if Is_Derived_Type
(Id
) then
14298 Check_Ghost_Derivation
(Id
);
14301 -- Handle completions of types and constants that are subject to
14304 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14305 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14307 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14308 Error_Msg_Name_1
:= Pname
;
14310 -- The full declaration of a deferred constant cannot be
14311 -- subject to pragma Ghost unless the deferred declaration
14312 -- is also Ghost (SPARK RM 6.9(10)).
14314 if Ekind
(Prev_Id
) = E_Constant
then
14315 Error_Msg_Name_1
:= Pname
;
14316 Error_Msg_NE
(Fix_Error
14317 ("pragma % must apply to declaration of deferred "
14318 & "constant &"), N
, Id
);
14321 -- Pragma Ghost may appear on the full view of an incomplete
14322 -- type because the incomplete declaration lacks aspects and
14323 -- cannot be subject to pragma Ghost.
14325 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14328 -- The full declaration of a type cannot be subject to
14329 -- pragma Ghost unless the partial view is also Ghost
14330 -- (SPARK RM 6.9(10)).
14333 Error_Msg_NE
(Fix_Error
14334 ("pragma % must apply to partial view of type &"),
14341 -- Analyze the Boolean expression (if any)
14343 if Present
(Arg1
) then
14344 Expr
:= Get_Pragma_Arg
(Arg1
);
14346 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14348 if Is_OK_Static_Expression
(Expr
) then
14350 -- "Ghostness" cannot be turned off once enabled within a
14351 -- region (SPARK RM 6.9(7)).
14353 if Is_False
(Expr_Value
(Expr
))
14354 and then Within_Ghost_Scope
14357 ("pragma % with value False cannot appear in enabled "
14362 -- Otherwie the expression is not static
14366 ("expression of pragma % must be static", Expr
);
14371 Set_Is_Ghost_Entity
(Id
);
14378 -- pragma Global (GLOBAL_SPECIFICATION);
14380 -- GLOBAL_SPECIFICATION ::=
14383 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14385 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14387 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14388 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14389 -- GLOBAL_ITEM ::= NAME
14391 when Pragma_Global
=> Global
: declare
14392 Subp_Decl
: Node_Id
;
14396 Check_Arg_Count
(1);
14397 Ensure_Aggregate_Form
(Arg1
);
14399 -- Ensure the proper placement of the pragma. Global must be
14400 -- associated with a subprogram declaration or a body that acts
14404 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14406 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14409 -- Body acts as spec
14411 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14412 and then No
(Corresponding_Spec
(Subp_Decl
))
14416 -- Body stub acts as spec
14418 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14419 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14428 -- When the pragma appears on a subprogram body, perform the full
14431 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14432 Analyze_Global_In_Decl_Part
(N
);
14434 -- When Global applies to a subprogram compilation unit, the
14435 -- corresponding pragma is placed after the unit's declaration
14436 -- node and needs to be analyzed immediately.
14438 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14439 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14441 Analyze_Global_In_Decl_Part
(N
);
14444 -- Chain the pragma on the contract for further processing
14446 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14453 -- pragma Ident (static_string_EXPRESSION)
14455 -- Note: pragma Comment shares this processing. Pragma Ident is
14456 -- identical in effect to pragma Commment.
14458 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14463 Check_Arg_Count
(1);
14464 Check_No_Identifiers
;
14465 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14468 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14475 GP
:= Parent
(Parent
(N
));
14477 if Nkind_In
(GP
, N_Package_Declaration
,
14478 N_Generic_Package_Declaration
)
14483 -- If we have a compilation unit, then record the ident value,
14484 -- checking for improper duplication.
14486 if Nkind
(GP
) = N_Compilation_Unit
then
14487 CS
:= Ident_String
(Current_Sem_Unit
);
14489 if Present
(CS
) then
14491 -- If we have multiple instances, concatenate them, but
14492 -- not in ASIS, where we want the original tree.
14494 if not ASIS_Mode
then
14495 Start_String
(Strval
(CS
));
14496 Store_String_Char
(' ');
14497 Store_String_Chars
(Strval
(Str
));
14498 Set_Strval
(CS
, End_String
);
14502 Set_Ident_String
(Current_Sem_Unit
, Str
);
14505 -- For subunits, we just ignore the Ident, since in GNAT these
14506 -- are not separate object files, and hence not separate units
14507 -- in the unit table.
14509 elsif Nkind
(GP
) = N_Subunit
then
14515 ----------------------------
14516 -- Implementation_Defined --
14517 ----------------------------
14519 -- pragma Implementation_Defined (LOCAL_NAME);
14521 -- Marks previously declared entity as implementation defined. For
14522 -- an overloaded entity, applies to the most recent homonym.
14524 -- pragma Implementation_Defined;
14526 -- The form with no arguments appears anywhere within a scope, most
14527 -- typically a package spec, and indicates that all entities that are
14528 -- defined within the package spec are Implementation_Defined.
14530 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14535 Check_No_Identifiers
;
14537 -- Form with no arguments
14539 if Arg_Count
= 0 then
14540 Set_Is_Implementation_Defined
(Current_Scope
);
14542 -- Form with one argument
14545 Check_Arg_Count
(1);
14546 Check_Arg_Is_Local_Name
(Arg1
);
14547 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14548 Set_Is_Implementation_Defined
(Ent
);
14550 end Implementation_Defined
;
14556 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14558 -- IMPLEMENTATION_KIND ::=
14559 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14561 -- "By_Any" and "Optional" are treated as synonyms in order to
14562 -- support Ada 2012 aspect Synchronization.
14564 when Pragma_Implemented
=> Implemented
: declare
14565 Proc_Id
: Entity_Id
;
14570 Check_Arg_Count
(2);
14571 Check_No_Identifiers
;
14572 Check_Arg_Is_Identifier
(Arg1
);
14573 Check_Arg_Is_Local_Name
(Arg1
);
14574 Check_Arg_Is_One_Of
(Arg2
,
14577 Name_By_Protected_Procedure
,
14580 -- Extract the name of the local procedure
14582 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14584 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14585 -- primitive procedure of a synchronized tagged type.
14587 if Ekind
(Proc_Id
) = E_Procedure
14588 and then Is_Primitive
(Proc_Id
)
14589 and then Present
(First_Formal
(Proc_Id
))
14591 Typ
:= Etype
(First_Formal
(Proc_Id
));
14593 if Is_Tagged_Type
(Typ
)
14596 -- Check for a protected, a synchronized or a task interface
14598 ((Is_Interface
(Typ
)
14599 and then Is_Synchronized_Interface
(Typ
))
14601 -- Check for a protected type or a task type that implements
14605 (Is_Concurrent_Record_Type
(Typ
)
14606 and then Present
(Interfaces
(Typ
)))
14608 -- In analysis-only mode, examine original protected type
14611 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
14612 and then Present
(Interface_List
(Parent
(Typ
))))
14614 -- Check for a private record extension with keyword
14618 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14619 E_Record_Subtype_With_Private
)
14620 and then Synchronized_Present
(Parent
(Typ
))))
14625 ("controlling formal must be of synchronized tagged type",
14630 -- Procedures declared inside a protected type must be accepted
14632 elsif Ekind
(Proc_Id
) = E_Procedure
14633 and then Is_Protected_Type
(Scope
(Proc_Id
))
14637 -- The first argument is not a primitive procedure
14641 ("pragma % must be applied to a primitive procedure", Arg1
);
14645 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14646 -- By_Protected_Procedure to the primitive procedure of a task
14649 if Chars
(Arg2
) = Name_By_Protected_Procedure
14650 and then Is_Interface
(Typ
)
14651 and then Is_Task_Interface
(Typ
)
14654 ("implementation kind By_Protected_Procedure cannot be "
14655 & "applied to a task interface primitive", Arg2
);
14659 Record_Rep_Item
(Proc_Id
, N
);
14662 ----------------------
14663 -- Implicit_Packing --
14664 ----------------------
14666 -- pragma Implicit_Packing;
14668 when Pragma_Implicit_Packing
=>
14670 Check_Arg_Count
(0);
14671 Implicit_Packing
:= True;
14678 -- [Convention =>] convention_IDENTIFIER,
14679 -- [Entity =>] LOCAL_NAME
14680 -- [, [External_Name =>] static_string_EXPRESSION ]
14681 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14683 when Pragma_Import
=>
14684 Check_Ada_83_Warning
;
14688 Name_External_Name
,
14691 Check_At_Least_N_Arguments
(2);
14692 Check_At_Most_N_Arguments
(4);
14693 Process_Import_Or_Interface
;
14695 ---------------------
14696 -- Import_Function --
14697 ---------------------
14699 -- pragma Import_Function (
14700 -- [Internal =>] LOCAL_NAME,
14701 -- [, [External =>] EXTERNAL_SYMBOL]
14702 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14703 -- [, [Result_Type =>] SUBTYPE_MARK]
14704 -- [, [Mechanism =>] MECHANISM]
14705 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14707 -- EXTERNAL_SYMBOL ::=
14709 -- | static_string_EXPRESSION
14711 -- PARAMETER_TYPES ::=
14713 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14715 -- TYPE_DESIGNATOR ::=
14717 -- | subtype_Name ' Access
14721 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14723 -- MECHANISM_ASSOCIATION ::=
14724 -- [formal_parameter_NAME =>] MECHANISM_NAME
14726 -- MECHANISM_NAME ::=
14730 when Pragma_Import_Function
=> Import_Function
: declare
14731 Args
: Args_List
(1 .. 6);
14732 Names
: constant Name_List
(1 .. 6) := (
14735 Name_Parameter_Types
,
14738 Name_Result_Mechanism
);
14740 Internal
: Node_Id
renames Args
(1);
14741 External
: Node_Id
renames Args
(2);
14742 Parameter_Types
: Node_Id
renames Args
(3);
14743 Result_Type
: Node_Id
renames Args
(4);
14744 Mechanism
: Node_Id
renames Args
(5);
14745 Result_Mechanism
: Node_Id
renames Args
(6);
14749 Gather_Associations
(Names
, Args
);
14750 Process_Extended_Import_Export_Subprogram_Pragma
(
14751 Arg_Internal
=> Internal
,
14752 Arg_External
=> External
,
14753 Arg_Parameter_Types
=> Parameter_Types
,
14754 Arg_Result_Type
=> Result_Type
,
14755 Arg_Mechanism
=> Mechanism
,
14756 Arg_Result_Mechanism
=> Result_Mechanism
);
14757 end Import_Function
;
14759 -------------------
14760 -- Import_Object --
14761 -------------------
14763 -- pragma Import_Object (
14764 -- [Internal =>] LOCAL_NAME
14765 -- [, [External =>] EXTERNAL_SYMBOL]
14766 -- [, [Size =>] EXTERNAL_SYMBOL]);
14768 -- EXTERNAL_SYMBOL ::=
14770 -- | static_string_EXPRESSION
14772 when Pragma_Import_Object
=> Import_Object
: declare
14773 Args
: Args_List
(1 .. 3);
14774 Names
: constant Name_List
(1 .. 3) := (
14779 Internal
: Node_Id
renames Args
(1);
14780 External
: Node_Id
renames Args
(2);
14781 Size
: Node_Id
renames Args
(3);
14785 Gather_Associations
(Names
, Args
);
14786 Process_Extended_Import_Export_Object_Pragma
(
14787 Arg_Internal
=> Internal
,
14788 Arg_External
=> External
,
14792 ----------------------
14793 -- Import_Procedure --
14794 ----------------------
14796 -- pragma Import_Procedure (
14797 -- [Internal =>] LOCAL_NAME
14798 -- [, [External =>] EXTERNAL_SYMBOL]
14799 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14800 -- [, [Mechanism =>] MECHANISM]);
14802 -- EXTERNAL_SYMBOL ::=
14804 -- | static_string_EXPRESSION
14806 -- PARAMETER_TYPES ::=
14808 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14810 -- TYPE_DESIGNATOR ::=
14812 -- | subtype_Name ' Access
14816 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14818 -- MECHANISM_ASSOCIATION ::=
14819 -- [formal_parameter_NAME =>] MECHANISM_NAME
14821 -- MECHANISM_NAME ::=
14825 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14826 Args
: Args_List
(1 .. 4);
14827 Names
: constant Name_List
(1 .. 4) := (
14830 Name_Parameter_Types
,
14833 Internal
: Node_Id
renames Args
(1);
14834 External
: Node_Id
renames Args
(2);
14835 Parameter_Types
: Node_Id
renames Args
(3);
14836 Mechanism
: Node_Id
renames Args
(4);
14840 Gather_Associations
(Names
, Args
);
14841 Process_Extended_Import_Export_Subprogram_Pragma
(
14842 Arg_Internal
=> Internal
,
14843 Arg_External
=> External
,
14844 Arg_Parameter_Types
=> Parameter_Types
,
14845 Arg_Mechanism
=> Mechanism
);
14846 end Import_Procedure
;
14848 -----------------------------
14849 -- Import_Valued_Procedure --
14850 -----------------------------
14852 -- pragma Import_Valued_Procedure (
14853 -- [Internal =>] LOCAL_NAME
14854 -- [, [External =>] EXTERNAL_SYMBOL]
14855 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14856 -- [, [Mechanism =>] MECHANISM]);
14858 -- EXTERNAL_SYMBOL ::=
14860 -- | static_string_EXPRESSION
14862 -- PARAMETER_TYPES ::=
14864 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14866 -- TYPE_DESIGNATOR ::=
14868 -- | subtype_Name ' Access
14872 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14874 -- MECHANISM_ASSOCIATION ::=
14875 -- [formal_parameter_NAME =>] MECHANISM_NAME
14877 -- MECHANISM_NAME ::=
14881 when Pragma_Import_Valued_Procedure
=>
14882 Import_Valued_Procedure
: declare
14883 Args
: Args_List
(1 .. 4);
14884 Names
: constant Name_List
(1 .. 4) := (
14887 Name_Parameter_Types
,
14890 Internal
: Node_Id
renames Args
(1);
14891 External
: Node_Id
renames Args
(2);
14892 Parameter_Types
: Node_Id
renames Args
(3);
14893 Mechanism
: Node_Id
renames Args
(4);
14897 Gather_Associations
(Names
, Args
);
14898 Process_Extended_Import_Export_Subprogram_Pragma
(
14899 Arg_Internal
=> Internal
,
14900 Arg_External
=> External
,
14901 Arg_Parameter_Types
=> Parameter_Types
,
14902 Arg_Mechanism
=> Mechanism
);
14903 end Import_Valued_Procedure
;
14909 -- pragma Independent (record_component_LOCAL_NAME);
14911 when Pragma_Independent
=> Independent
: declare
14916 Check_Ada_83_Warning
;
14918 Check_No_Identifiers
;
14919 Check_Arg_Count
(1);
14920 Check_Arg_Is_Local_Name
(Arg1
);
14921 E_Id
:= Get_Pragma_Arg
(Arg1
);
14923 if Etype
(E_Id
) = Any_Type
then
14927 E
:= Entity
(E_Id
);
14929 -- Check we have a record component. We have not yet setup
14930 -- components fully, so identify by syntactic structure.
14932 if Nkind
(Declaration_Node
(E
)) /= N_Component_Declaration
then
14934 ("argument for pragma% must be record component", Arg1
);
14937 -- Check duplicate before we chain ourselves
14939 Check_Duplicate_Pragma
(E
);
14943 if Rep_Item_Too_Early
(E
, N
)
14945 Rep_Item_Too_Late
(E
, N
)
14950 -- Set flag in component
14952 Set_Is_Independent
(E
);
14954 Independence_Checks
.Append
((N
, E
));
14957 ----------------------------
14958 -- Independent_Components --
14959 ----------------------------
14961 -- pragma Atomic_Components (array_LOCAL_NAME);
14963 -- This processing is shared by Volatile_Components
14965 when Pragma_Independent_Components
=> Independent_Components
: declare
14973 Check_Ada_83_Warning
;
14975 Check_No_Identifiers
;
14976 Check_Arg_Count
(1);
14977 Check_Arg_Is_Local_Name
(Arg1
);
14978 E_Id
:= Get_Pragma_Arg
(Arg1
);
14980 if Etype
(E_Id
) = Any_Type
then
14984 E
:= Entity
(E_Id
);
14986 -- Check duplicate before we chain ourselves
14988 Check_Duplicate_Pragma
(E
);
14990 -- Check appropriate entity
14992 if Rep_Item_Too_Early
(E
, N
)
14994 Rep_Item_Too_Late
(E
, N
)
14999 D
:= Declaration_Node
(E
);
15002 if K
= N_Full_Type_Declaration
15003 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15005 Independence_Checks
.Append
((N
, Base_Type
(E
)));
15006 Set_Has_Independent_Components
(Base_Type
(E
));
15008 -- For record type, set all components independent
15010 if Is_Record_Type
(E
) then
15011 C
:= First_Component
(E
);
15012 while Present
(C
) loop
15013 Set_Is_Independent
(C
);
15014 Next_Component
(C
);
15018 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15019 and then Nkind
(D
) = N_Object_Declaration
15020 and then Nkind
(Object_Definition
(D
)) =
15021 N_Constrained_Array_Definition
15023 Independence_Checks
.Append
((N
, Base_Type
(Etype
(E
))));
15024 Set_Has_Independent_Components
(Base_Type
(Etype
(E
)));
15027 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15029 end Independent_Components
;
15031 -----------------------
15032 -- Initial_Condition --
15033 -----------------------
15035 -- pragma Initial_Condition (boolean_EXPRESSION);
15037 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15038 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15039 Pack_Id
: Entity_Id
;
15044 Check_No_Identifiers
;
15045 Check_Arg_Count
(1);
15047 -- Ensure the proper placement of the pragma. Initial_Condition
15048 -- must be associated with a package declaration.
15050 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15051 N_Package_Declaration
)
15058 while Present
(Stmt
) loop
15060 -- Skip prior pragmas, but check for duplicates
15062 if Nkind
(Stmt
) = N_Pragma
then
15063 if Pragma_Name
(Stmt
) = Pname
then
15064 Error_Msg_Name_1
:= Pname
;
15065 Error_Msg_Sloc
:= Sloc
(Stmt
);
15066 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15069 -- Skip internally generated code
15071 elsif not Comes_From_Source
(Stmt
) then
15074 -- The pragma does not apply to a legal construct, issue an
15075 -- error and stop the analysis.
15082 Stmt
:= Prev
(Stmt
);
15085 -- The pragma must be analyzed at the end of the visible
15086 -- declarations of the related package. Save the pragma for later
15087 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15088 -- the contract of the package.
15090 Pack_Id
:= Defining_Entity
(Context
);
15091 Add_Contract_Item
(N
, Pack_Id
);
15093 -- Verify the declaration order of pragma Initial_Condition with
15094 -- respect to pragmas Abstract_State and Initializes when SPARK
15095 -- checks are enabled.
15097 if SPARK_Mode
/= Off
then
15098 Check_Declaration_Order
15099 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15102 Check_Declaration_Order
15103 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
15106 end Initial_Condition
;
15108 ------------------------
15109 -- Initialize_Scalars --
15110 ------------------------
15112 -- pragma Initialize_Scalars;
15114 when Pragma_Initialize_Scalars
=>
15116 Check_Arg_Count
(0);
15117 Check_Valid_Configuration_Pragma
;
15118 Check_Restriction
(No_Initialize_Scalars
, N
);
15120 -- Initialize_Scalars creates false positives in CodePeer, and
15121 -- incorrect negative results in GNATprove mode, so ignore this
15122 -- pragma in these modes.
15124 if not Restriction_Active
(No_Initialize_Scalars
)
15125 and then not (CodePeer_Mode
or GNATprove_Mode
)
15127 Init_Or_Norm_Scalars
:= True;
15128 Initialize_Scalars
:= True;
15135 -- pragma Initializes (INITIALIZATION_SPEC);
15137 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15139 -- INITIALIZATION_LIST ::=
15140 -- INITIALIZATION_ITEM
15141 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15143 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15148 -- | (INPUT {, INPUT})
15152 when Pragma_Initializes
=> Initializes
: declare
15153 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15154 Pack_Id
: Entity_Id
;
15159 Check_No_Identifiers
;
15160 Check_Arg_Count
(1);
15161 Ensure_Aggregate_Form
(Arg1
);
15163 -- Ensure the proper placement of the pragma. Initializes must be
15164 -- associated with a package declaration.
15166 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15167 N_Package_Declaration
)
15174 while Present
(Stmt
) loop
15176 -- Skip prior pragmas, but check for duplicates
15178 if Nkind
(Stmt
) = N_Pragma
then
15179 if Pragma_Name
(Stmt
) = Pname
then
15180 Error_Msg_Name_1
:= Pname
;
15181 Error_Msg_Sloc
:= Sloc
(Stmt
);
15182 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15185 -- Skip internally generated code
15187 elsif not Comes_From_Source
(Stmt
) then
15190 -- The pragma does not apply to a legal construct, issue an
15191 -- error and stop the analysis.
15198 Stmt
:= Prev
(Stmt
);
15201 -- The pragma must be analyzed at the end of the visible
15202 -- declarations of the related package. Save the pragma for later
15203 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15204 -- contract of the package.
15206 Pack_Id
:= Defining_Entity
(Context
);
15207 Add_Contract_Item
(N
, Pack_Id
);
15209 -- Verify the declaration order of pragmas Abstract_State and
15210 -- Initializes when SPARK checks are enabled.
15212 if SPARK_Mode
/= Off
then
15213 Check_Declaration_Order
15214 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15223 -- pragma Inline ( NAME {, NAME} );
15225 when Pragma_Inline
=>
15227 -- Pragma always active unless in GNATprove mode. It is disabled
15228 -- in GNATprove mode because frontend inlining is applied
15229 -- independently of pragmas Inline and Inline_Always for
15230 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15233 if not GNATprove_Mode
then
15235 -- Inline status is Enabled if inlining option is active
15237 if Inline_Active
then
15238 Process_Inline
(Enabled
);
15240 Process_Inline
(Disabled
);
15244 -------------------
15245 -- Inline_Always --
15246 -------------------
15248 -- pragma Inline_Always ( NAME {, NAME} );
15250 when Pragma_Inline_Always
=>
15253 -- Pragma always active unless in CodePeer mode or GNATprove
15254 -- mode. It is disabled in CodePeer mode because inlining is
15255 -- not helpful, and enabling it caused walk order issues. It
15256 -- is disabled in GNATprove mode because frontend inlining is
15257 -- applied independently of pragmas Inline and Inline_Always for
15258 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15261 if not CodePeer_Mode
and not GNATprove_Mode
then
15262 Process_Inline
(Enabled
);
15265 --------------------
15266 -- Inline_Generic --
15267 --------------------
15269 -- pragma Inline_Generic (NAME {, NAME});
15271 when Pragma_Inline_Generic
=>
15273 Process_Generic_List
;
15275 ----------------------
15276 -- Inspection_Point --
15277 ----------------------
15279 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15281 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15288 if Arg_Count
> 0 then
15291 Exp
:= Get_Pragma_Arg
(Arg
);
15294 if not Is_Entity_Name
(Exp
)
15295 or else not Is_Object
(Entity
(Exp
))
15297 Error_Pragma_Arg
("object name required", Arg
);
15301 exit when No
(Arg
);
15304 end Inspection_Point
;
15310 -- pragma Interface (
15311 -- [ Convention =>] convention_IDENTIFIER,
15312 -- [ Entity =>] LOCAL_NAME
15313 -- [, [External_Name =>] static_string_EXPRESSION ]
15314 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15316 when Pragma_Interface
=>
15321 Name_External_Name
,
15323 Check_At_Least_N_Arguments
(2);
15324 Check_At_Most_N_Arguments
(4);
15325 Process_Import_Or_Interface
;
15327 -- In Ada 2005, the permission to use Interface (a reserved word)
15328 -- as a pragma name is considered an obsolescent feature, and this
15329 -- pragma was already obsolescent in Ada 95.
15331 if Ada_Version
>= Ada_95
then
15333 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15335 if Warn_On_Obsolescent_Feature
then
15337 ("pragma Interface is an obsolescent feature?j?", N
);
15339 ("|use pragma Import instead?j?", N
);
15343 --------------------
15344 -- Interface_Name --
15345 --------------------
15347 -- pragma Interface_Name (
15348 -- [ Entity =>] LOCAL_NAME
15349 -- [,[External_Name =>] static_string_EXPRESSION ]
15350 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15352 when Pragma_Interface_Name
=> Interface_Name
: declare
15354 Def_Id
: Entity_Id
;
15355 Hom_Id
: Entity_Id
;
15361 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15362 Check_At_Least_N_Arguments
(2);
15363 Check_At_Most_N_Arguments
(3);
15364 Id
:= Get_Pragma_Arg
(Arg1
);
15367 -- This is obsolete from Ada 95 on, but it is an implementation
15368 -- defined pragma, so we do not consider that it violates the
15369 -- restriction (No_Obsolescent_Features).
15371 if Ada_Version
>= Ada_95
then
15372 if Warn_On_Obsolescent_Feature
then
15374 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15376 ("|use pragma Import instead?j?", N
);
15380 if not Is_Entity_Name
(Id
) then
15382 ("first argument for pragma% must be entity name", Arg1
);
15383 elsif Etype
(Id
) = Any_Type
then
15386 Def_Id
:= Entity
(Id
);
15389 -- Special DEC-compatible processing for the object case, forces
15390 -- object to be imported.
15392 if Ekind
(Def_Id
) = E_Variable
then
15393 Kill_Size_Check_Code
(Def_Id
);
15394 Note_Possible_Modification
(Id
, Sure
=> False);
15396 -- Initialization is not allowed for imported variable
15398 if Present
(Expression
(Parent
(Def_Id
)))
15399 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15401 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15403 ("no initialization allowed for declaration of& #",
15407 -- For compatibility, support VADS usage of providing both
15408 -- pragmas Interface and Interface_Name to obtain the effect
15409 -- of a single Import pragma.
15411 if Is_Imported
(Def_Id
)
15412 and then Present
(First_Rep_Item
(Def_Id
))
15413 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15415 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15419 Set_Imported
(Def_Id
);
15422 Set_Is_Public
(Def_Id
);
15423 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15426 -- Otherwise must be subprogram
15428 elsif not Is_Subprogram
(Def_Id
) then
15430 ("argument of pragma% is not subprogram", Arg1
);
15433 Check_At_Most_N_Arguments
(3);
15437 -- Loop through homonyms
15440 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15442 if Is_Imported
(Def_Id
) then
15443 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15447 exit when From_Aspect_Specification
(N
);
15448 Hom_Id
:= Homonym
(Hom_Id
);
15450 exit when No
(Hom_Id
)
15451 or else Scope
(Hom_Id
) /= Current_Scope
;
15456 ("argument of pragma% is not imported subprogram",
15460 end Interface_Name
;
15462 -----------------------
15463 -- Interrupt_Handler --
15464 -----------------------
15466 -- pragma Interrupt_Handler (handler_NAME);
15468 when Pragma_Interrupt_Handler
=>
15469 Check_Ada_83_Warning
;
15470 Check_Arg_Count
(1);
15471 Check_No_Identifiers
;
15473 if No_Run_Time_Mode
then
15474 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15476 Check_Interrupt_Or_Attach_Handler
;
15477 Process_Interrupt_Or_Attach_Handler
;
15480 ------------------------
15481 -- Interrupt_Priority --
15482 ------------------------
15484 -- pragma Interrupt_Priority [(EXPRESSION)];
15486 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15487 P
: constant Node_Id
:= Parent
(N
);
15492 Check_Ada_83_Warning
;
15494 if Arg_Count
/= 0 then
15495 Arg
:= Get_Pragma_Arg
(Arg1
);
15496 Check_Arg_Count
(1);
15497 Check_No_Identifiers
;
15499 -- The expression must be analyzed in the special manner
15500 -- described in "Handling of Default and Per-Object
15501 -- Expressions" in sem.ads.
15503 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15506 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15511 Ent
:= Defining_Identifier
(Parent
(P
));
15513 -- Check duplicate pragma before we chain the pragma in the Rep
15514 -- Item chain of Ent.
15516 Check_Duplicate_Pragma
(Ent
);
15517 Record_Rep_Item
(Ent
, N
);
15519 end Interrupt_Priority
;
15521 ---------------------
15522 -- Interrupt_State --
15523 ---------------------
15525 -- pragma Interrupt_State (
15526 -- [Name =>] INTERRUPT_ID,
15527 -- [State =>] INTERRUPT_STATE);
15529 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15530 -- INTERRUPT_STATE => System | Runtime | User
15532 -- Note: if the interrupt id is given as an identifier, then it must
15533 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15534 -- given as a static integer expression which must be in the range of
15535 -- Ada.Interrupts.Interrupt_ID.
15537 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15538 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15539 -- This is the entity Ada.Interrupts.Interrupt_ID;
15541 State_Type
: Character;
15542 -- Set to 's'/'r'/'u' for System/Runtime/User
15545 -- Index to entry in Interrupt_States table
15548 -- Value of interrupt
15550 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15551 -- The first argument to the pragma
15553 Int_Ent
: Entity_Id
;
15554 -- Interrupt entity in Ada.Interrupts.Names
15558 Check_Arg_Order
((Name_Name
, Name_State
));
15559 Check_Arg_Count
(2);
15561 Check_Optional_Identifier
(Arg1
, Name_Name
);
15562 Check_Optional_Identifier
(Arg2
, Name_State
);
15563 Check_Arg_Is_Identifier
(Arg2
);
15565 -- First argument is identifier
15567 if Nkind
(Arg1X
) = N_Identifier
then
15569 -- Search list of names in Ada.Interrupts.Names
15571 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15573 if No
(Int_Ent
) then
15574 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15576 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15577 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15581 Next_Entity
(Int_Ent
);
15584 -- First argument is not an identifier, so it must be a static
15585 -- expression of type Ada.Interrupts.Interrupt_ID.
15588 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15589 Int_Val
:= Expr_Value
(Arg1X
);
15591 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15593 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15596 ("value not in range of type "
15597 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15603 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15604 when Name_Runtime
=> State_Type
:= 'r';
15605 when Name_System
=> State_Type
:= 's';
15606 when Name_User
=> State_Type
:= 'u';
15609 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15612 -- Check if entry is already stored
15614 IST_Num
:= Interrupt_States
.First
;
15616 -- If entry not found, add it
15618 if IST_Num
> Interrupt_States
.Last
then
15619 Interrupt_States
.Append
15620 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15621 Interrupt_State
=> State_Type
,
15622 Pragma_Loc
=> Loc
));
15625 -- Case of entry for the same entry
15627 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15630 -- If state matches, done, no need to make redundant entry
15633 State_Type
= Interrupt_States
.Table
(IST_Num
).
15636 -- Otherwise if state does not match, error
15639 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15641 ("state conflicts with that given #", Arg2
);
15645 IST_Num
:= IST_Num
+ 1;
15647 end Interrupt_State
;
15653 -- pragma Invariant
15654 -- ([Entity =>] type_LOCAL_NAME,
15655 -- [Check =>] EXPRESSION
15656 -- [,[Message =>] String_Expression]);
15658 when Pragma_Invariant
=> Invariant
: declare
15665 Check_At_Least_N_Arguments
(2);
15666 Check_At_Most_N_Arguments
(3);
15667 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15668 Check_Optional_Identifier
(Arg2
, Name_Check
);
15670 if Arg_Count
= 3 then
15671 Check_Optional_Identifier
(Arg3
, Name_Message
);
15672 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15675 Check_Arg_Is_Local_Name
(Arg1
);
15677 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15678 Find_Type
(Type_Id
);
15679 Typ
:= Entity
(Type_Id
);
15681 if Typ
= Any_Type
then
15684 -- An invariant must apply to a private type, or appear in the
15685 -- private part of a package spec and apply to a completion.
15686 -- a class-wide invariant can only appear on a private declaration
15687 -- or private extension, not a completion.
15689 elsif Ekind_In
(Typ
, E_Private_Type
,
15690 E_Record_Type_With_Private
,
15691 E_Limited_Private_Type
)
15695 elsif In_Private_Part
(Current_Scope
)
15696 and then Has_Private_Declaration
(Typ
)
15697 and then not Class_Present
(N
)
15701 elsif In_Private_Part
(Current_Scope
) then
15703 ("pragma% only allowed for private type declared in "
15704 & "visible part", Arg1
);
15708 ("pragma% only allowed for private type", Arg1
);
15711 -- Note that the type has at least one invariant, and also that
15712 -- it has inheritable invariants if we have Invariant'Class
15713 -- or Type_Invariant'Class. Build the corresponding invariant
15714 -- procedure declaration, so that calls to it can be generated
15715 -- before the body is built (e.g. within an expression function).
15717 Insert_After_And_Analyze
15718 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15720 if Class_Present
(N
) then
15721 Set_Has_Inheritable_Invariants
(Typ
);
15724 -- The remaining processing is simply to link the pragma on to
15725 -- the rep item chain, for processing when the type is frozen.
15726 -- This is accomplished by a call to Rep_Item_Too_Late.
15728 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15731 ----------------------
15732 -- Java_Constructor --
15733 ----------------------
15735 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15737 -- Also handles pragma CIL_Constructor
15739 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15740 Java_Constructor
: declare
15741 Convention
: Convention_Id
;
15742 Def_Id
: Entity_Id
;
15743 Hom_Id
: Entity_Id
;
15745 This_Formal
: Entity_Id
;
15749 Check_Arg_Count
(1);
15750 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15751 Check_Arg_Is_Local_Name
(Arg1
);
15753 Id
:= Get_Pragma_Arg
(Arg1
);
15754 Find_Program_Unit_Name
(Id
);
15756 -- If we did not find the name, we are done
15758 if Etype
(Id
) = Any_Type
then
15762 -- Check wrong use of pragma in wrong VM target
15764 if VM_Target
= No_VM
then
15767 elsif VM_Target
= CLI_Target
15768 and then Prag_Id
= Pragma_Java_Constructor
15770 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15772 elsif VM_Target
= JVM_Target
15773 and then Prag_Id
= Pragma_CIL_Constructor
15775 Error_Pragma
("must use pragma 'Java_'Constructor");
15779 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15780 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15781 when others => null;
15784 Hom_Id
:= Entity
(Id
);
15786 -- Loop through homonyms
15789 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15791 -- The constructor is required to be a function
15793 if Ekind
(Def_Id
) /= E_Function
then
15794 if VM_Target
= JVM_Target
then
15796 ("pragma% requires function returning a 'Java access "
15800 ("pragma% requires function returning a 'C'I'L access "
15805 -- Check arguments: For tagged type the first formal must be
15806 -- named "this" and its type must be a named access type
15807 -- designating a class-wide tagged type that has convention
15808 -- CIL/Java. The first formal must also have a null default
15809 -- value. For example:
15811 -- type Typ is tagged ...
15812 -- type Ref is access all Typ;
15813 -- pragma Convention (CIL, Typ);
15815 -- function New_Typ (This : Ref) return Ref;
15816 -- function New_Typ (This : Ref; I : Integer) return Ref;
15817 -- pragma Cil_Constructor (New_Typ);
15819 -- Reason: The first formal must NOT be a primitive of the
15822 -- This rule also applies to constructors of delegates used
15823 -- to interface with standard target libraries. For example:
15825 -- type Delegate is access procedure ...
15826 -- pragma Import (CIL, Delegate, ...);
15828 -- function new_Delegate
15829 -- (This : Delegate := null; ... ) return Delegate;
15831 -- For value-types this rule does not apply.
15833 if not Is_Value_Type
(Etype
(Def_Id
)) then
15834 if No
(First_Formal
(Def_Id
)) then
15835 Error_Msg_Name_1
:= Pname
;
15836 Error_Msg_N
("% function must have parameters", Def_Id
);
15840 -- In the JRE library we have several occurrences in which
15841 -- the "this" parameter is not the first formal.
15843 This_Formal
:= First_Formal
(Def_Id
);
15845 -- In the JRE library we have several occurrences in which
15846 -- the "this" parameter is not the first formal. Search for
15849 if VM_Target
= JVM_Target
then
15850 while Present
(This_Formal
)
15851 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15853 Next_Formal
(This_Formal
);
15856 if No
(This_Formal
) then
15857 This_Formal
:= First_Formal
(Def_Id
);
15861 -- Warning: The first parameter should be named "this".
15862 -- We temporarily allow it because we have the following
15863 -- case in the Java runtime (file s-osinte.ads) ???
15865 -- function new_Thread
15866 -- (Self_Id : System.Address) return Thread_Id;
15867 -- pragma Java_Constructor (new_Thread);
15869 if VM_Target
= JVM_Target
15870 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15872 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15876 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15877 Error_Msg_Name_1
:= Pname
;
15879 ("first formal of % function must be named `this`",
15880 Parent
(This_Formal
));
15882 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15883 Error_Msg_Name_1
:= Pname
;
15885 ("first formal of % function must be an access type",
15886 Parameter_Type
(Parent
(This_Formal
)));
15888 -- For delegates the type of the first formal must be a
15889 -- named access-to-subprogram type (see previous example)
15891 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15892 and then Ekind
(Etype
(This_Formal
))
15893 /= E_Access_Subprogram_Type
15895 Error_Msg_Name_1
:= Pname
;
15897 ("first formal of % function must be a named access "
15898 & "to subprogram type",
15899 Parameter_Type
(Parent
(This_Formal
)));
15901 -- Warning: We should reject anonymous access types because
15902 -- the constructor must not be handled as a primitive of the
15903 -- tagged type. We temporarily allow it because this profile
15904 -- is currently generated by cil2ada???
15906 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15907 and then not Ekind_In
(Etype
(This_Formal
),
15909 E_General_Access_Type
,
15910 E_Anonymous_Access_Type
)
15912 Error_Msg_Name_1
:= Pname
;
15914 ("first formal of % function must be a named access "
15915 & "type", Parameter_Type
(Parent
(This_Formal
)));
15917 elsif Atree
.Convention
15918 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15920 Error_Msg_Name_1
:= Pname
;
15922 if Convention
= Convention_Java
then
15924 ("pragma% requires convention 'Cil in designated "
15925 & "type", Parameter_Type
(Parent
(This_Formal
)));
15928 ("pragma% requires convention 'Java in designated "
15929 & "type", Parameter_Type
(Parent
(This_Formal
)));
15932 elsif No
(Expression
(Parent
(This_Formal
)))
15933 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15935 Error_Msg_Name_1
:= Pname
;
15937 ("pragma% requires first formal with default `null`",
15938 Parameter_Type
(Parent
(This_Formal
)));
15942 -- Check result type: the constructor must be a function
15944 -- * a value type (only allowed in the CIL compiler)
15945 -- * an access-to-subprogram type with convention Java/CIL
15946 -- * an access-type designating a type that has convention
15949 if Is_Value_Type
(Etype
(Def_Id
)) then
15952 -- Access-to-subprogram type with convention Java/CIL
15954 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15955 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15956 if Convention
= Convention_Java
then
15958 ("pragma% requires function returning a 'Java "
15959 & "access type", Arg1
);
15961 pragma Assert
(Convention
= Convention_CIL
);
15963 ("pragma% requires function returning a 'C'I'L "
15964 & "access type", Arg1
);
15968 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15969 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15970 E_General_Access_Type
)
15973 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15975 Error_Msg_Name_1
:= Pname
;
15977 if Convention
= Convention_Java
then
15979 ("pragma% requires function returning a named "
15980 & "'Java access type", Arg1
);
15983 ("pragma% requires function returning a named "
15984 & "'C'I'L access type", Arg1
);
15989 Set_Is_Constructor
(Def_Id
);
15990 Set_Convention
(Def_Id
, Convention
);
15991 Set_Is_Imported
(Def_Id
);
15993 exit when From_Aspect_Specification
(N
);
15994 Hom_Id
:= Homonym
(Hom_Id
);
15996 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
15998 end Java_Constructor
;
16000 ----------------------
16001 -- Java_Interface --
16002 ----------------------
16004 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16006 when Pragma_Java_Interface
=> Java_Interface
: declare
16012 Check_Arg_Count
(1);
16013 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16014 Check_Arg_Is_Local_Name
(Arg1
);
16016 Arg
:= Get_Pragma_Arg
(Arg1
);
16019 if Etype
(Arg
) = Any_Type
then
16023 if not Is_Entity_Name
(Arg
)
16024 or else not Is_Type
(Entity
(Arg
))
16026 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
16029 Typ
:= Underlying_Type
(Entity
(Arg
));
16031 -- For now simply check some of the semantic constraints on the
16032 -- type. This currently leaves out some restrictions on interface
16033 -- types, namely that the parent type must be java.lang.Object.Typ
16034 -- and that all primitives of the type should be declared
16037 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
16039 ("pragma% requires an abstract tagged type", Arg1
);
16041 elsif not Has_Discriminants
(Typ
)
16042 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
16043 /= E_Anonymous_Access_Type
16045 not Is_Class_Wide_Type
16046 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
16049 ("type must have a class-wide access discriminant", Arg1
);
16051 end Java_Interface
;
16057 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16059 when Pragma_Keep_Names
=> Keep_Names
: declare
16064 Check_Arg_Count
(1);
16065 Check_Optional_Identifier
(Arg1
, Name_On
);
16066 Check_Arg_Is_Local_Name
(Arg1
);
16068 Arg
:= Get_Pragma_Arg
(Arg1
);
16071 if Etype
(Arg
) = Any_Type
then
16075 if not Is_Entity_Name
(Arg
)
16076 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16079 ("pragma% requires a local enumeration type", Arg1
);
16082 Set_Discard_Names
(Entity
(Arg
), False);
16089 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16091 when Pragma_License
=>
16094 -- Do not analyze pragma any further in CodePeer mode, to avoid
16095 -- extraneous errors in this implementation-dependent pragma,
16096 -- which has a different profile on other compilers.
16098 if CodePeer_Mode
then
16102 Check_Arg_Count
(1);
16103 Check_No_Identifiers
;
16104 Check_Valid_Configuration_Pragma
;
16105 Check_Arg_Is_Identifier
(Arg1
);
16108 Sind
: constant Source_File_Index
:=
16109 Source_Index
(Current_Sem_Unit
);
16112 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16114 Set_License
(Sind
, GPL
);
16116 when Name_Modified_GPL
=>
16117 Set_License
(Sind
, Modified_GPL
);
16119 when Name_Restricted
=>
16120 Set_License
(Sind
, Restricted
);
16122 when Name_Unrestricted
=>
16123 Set_License
(Sind
, Unrestricted
);
16126 Error_Pragma_Arg
("invalid license name", Arg1
);
16134 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16136 when Pragma_Link_With
=> Link_With
: declare
16142 if Operating_Mode
= Generate_Code
16143 and then In_Extended_Main_Source_Unit
(N
)
16145 Check_At_Least_N_Arguments
(1);
16146 Check_No_Identifiers
;
16147 Check_Is_In_Decl_Part_Or_Package_Spec
;
16148 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16152 while Present
(Arg
) loop
16153 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16155 -- Store argument, converting sequences of spaces to a
16156 -- single null character (this is one of the differences
16157 -- in processing between Link_With and Linker_Options).
16159 Arg_Store
: declare
16160 C
: constant Char_Code
:= Get_Char_Code
(' ');
16161 S
: constant String_Id
:=
16162 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16163 L
: constant Nat
:= String_Length
(S
);
16166 procedure Skip_Spaces
;
16167 -- Advance F past any spaces
16173 procedure Skip_Spaces
is
16175 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16180 -- Start of processing for Arg_Store
16183 Skip_Spaces
; -- skip leading spaces
16185 -- Loop through characters, changing any embedded
16186 -- sequence of spaces to a single null character (this
16187 -- is how Link_With/Linker_Options differ)
16190 if Get_String_Char
(S
, F
) = C
then
16193 Store_String_Char
(ASCII
.NUL
);
16196 Store_String_Char
(Get_String_Char
(S
, F
));
16204 if Present
(Arg
) then
16205 Store_String_Char
(ASCII
.NUL
);
16209 Store_Linker_Option_String
(End_String
);
16217 -- pragma Linker_Alias (
16218 -- [Entity =>] LOCAL_NAME
16219 -- [Target =>] static_string_EXPRESSION);
16221 when Pragma_Linker_Alias
=>
16223 Check_Arg_Order
((Name_Entity
, Name_Target
));
16224 Check_Arg_Count
(2);
16225 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16226 Check_Optional_Identifier
(Arg2
, Name_Target
);
16227 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16228 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16230 -- The only processing required is to link this item on to the
16231 -- list of rep items for the given entity. This is accomplished
16232 -- by the call to Rep_Item_Too_Late (when no error is detected
16233 -- and False is returned).
16235 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16238 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16241 ------------------------
16242 -- Linker_Constructor --
16243 ------------------------
16245 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16247 -- Code is shared with Linker_Destructor
16249 -----------------------
16250 -- Linker_Destructor --
16251 -----------------------
16253 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16255 when Pragma_Linker_Constructor |
16256 Pragma_Linker_Destructor
=>
16257 Linker_Constructor
: declare
16263 Check_Arg_Count
(1);
16264 Check_No_Identifiers
;
16265 Check_Arg_Is_Local_Name
(Arg1
);
16266 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16268 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16270 if not Is_Library_Level_Entity
(Proc
) then
16272 ("argument for pragma% must be library level entity", Arg1
);
16275 -- The only processing required is to link this item on to the
16276 -- list of rep items for the given entity. This is accomplished
16277 -- by the call to Rep_Item_Too_Late (when no error is detected
16278 -- and False is returned).
16280 if Rep_Item_Too_Late
(Proc
, N
) then
16283 Set_Has_Gigi_Rep_Item
(Proc
);
16285 end Linker_Constructor
;
16287 --------------------
16288 -- Linker_Options --
16289 --------------------
16291 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16293 when Pragma_Linker_Options
=> Linker_Options
: declare
16297 Check_Ada_83_Warning
;
16298 Check_No_Identifiers
;
16299 Check_Arg_Count
(1);
16300 Check_Is_In_Decl_Part_Or_Package_Spec
;
16301 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16302 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16305 while Present
(Arg
) loop
16306 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16307 Store_String_Char
(ASCII
.NUL
);
16309 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16313 if Operating_Mode
= Generate_Code
16314 and then In_Extended_Main_Source_Unit
(N
)
16316 Store_Linker_Option_String
(End_String
);
16318 end Linker_Options
;
16320 --------------------
16321 -- Linker_Section --
16322 --------------------
16324 -- pragma Linker_Section (
16325 -- [Entity =>] LOCAL_NAME
16326 -- [Section =>] static_string_EXPRESSION);
16328 when Pragma_Linker_Section
=> Linker_Section
: declare
16335 Check_Arg_Order
((Name_Entity
, Name_Section
));
16336 Check_Arg_Count
(2);
16337 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16338 Check_Optional_Identifier
(Arg2
, Name_Section
);
16339 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16340 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16342 -- Check kind of entity
16344 Arg
:= Get_Pragma_Arg
(Arg1
);
16345 Ent
:= Entity
(Arg
);
16347 case Ekind
(Ent
) is
16349 -- Objects (constants and variables) and types. For these cases
16350 -- all we need to do is to set the Linker_Section_pragma field,
16351 -- checking that we do not have a duplicate.
16353 when E_Constant | E_Variable | Type_Kind
=>
16354 LPE
:= Linker_Section_Pragma
(Ent
);
16356 if Present
(LPE
) then
16357 Error_Msg_Sloc
:= Sloc
(LPE
);
16359 ("Linker_Section already specified for &#", Arg1
, Ent
);
16362 Set_Linker_Section_Pragma
(Ent
, N
);
16366 when Subprogram_Kind
=>
16368 -- Aspect case, entity already set
16370 if From_Aspect_Specification
(N
) then
16371 Set_Linker_Section_Pragma
16372 (Entity
(Corresponding_Aspect
(N
)), N
);
16374 -- Pragma case, we must climb the homonym chain, but skip
16375 -- any for which the linker section is already set.
16379 if No
(Linker_Section_Pragma
(Ent
)) then
16380 Set_Linker_Section_Pragma
(Ent
, N
);
16383 Ent
:= Homonym
(Ent
);
16385 or else Scope
(Ent
) /= Current_Scope
;
16389 -- All other cases are illegal
16393 ("pragma% applies only to objects, subprograms, and types",
16396 end Linker_Section
;
16402 -- pragma List (On | Off)
16404 -- There is nothing to do here, since we did all the processing for
16405 -- this pragma in Par.Prag (so that it works properly even in syntax
16408 when Pragma_List
=>
16415 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16417 when Pragma_Lock_Free
=> Lock_Free
: declare
16418 P
: constant Node_Id
:= Parent
(N
);
16424 Check_No_Identifiers
;
16425 Check_At_Most_N_Arguments
(1);
16427 -- Protected definition case
16429 if Nkind
(P
) = N_Protected_Definition
then
16430 Ent
:= Defining_Identifier
(Parent
(P
));
16434 if Arg_Count
= 1 then
16435 Arg
:= Get_Pragma_Arg
(Arg1
);
16436 Val
:= Is_True
(Static_Boolean
(Arg
));
16438 -- No arguments (expression is considered to be True)
16444 -- Check duplicate pragma before we chain the pragma in the Rep
16445 -- Item chain of Ent.
16447 Check_Duplicate_Pragma
(Ent
);
16448 Record_Rep_Item
(Ent
, N
);
16449 Set_Uses_Lock_Free
(Ent
, Val
);
16451 -- Anything else is incorrect placement
16458 --------------------
16459 -- Locking_Policy --
16460 --------------------
16462 -- pragma Locking_Policy (policy_IDENTIFIER);
16464 when Pragma_Locking_Policy
=> declare
16465 subtype LP_Range
is Name_Id
16466 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16471 Check_Ada_83_Warning
;
16472 Check_Arg_Count
(1);
16473 Check_No_Identifiers
;
16474 Check_Arg_Is_Locking_Policy
(Arg1
);
16475 Check_Valid_Configuration_Pragma
;
16476 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16479 when Name_Ceiling_Locking
=>
16481 when Name_Inheritance_Locking
=>
16483 when Name_Concurrent_Readers_Locking
=>
16487 if Locking_Policy
/= ' '
16488 and then Locking_Policy
/= LP
16490 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16491 Error_Pragma
("locking policy incompatible with policy#");
16493 -- Set new policy, but always preserve System_Location since we
16494 -- like the error message with the run time name.
16497 Locking_Policy
:= LP
;
16499 if Locking_Policy_Sloc
/= System_Location
then
16500 Locking_Policy_Sloc
:= Loc
;
16505 -------------------
16506 -- Loop_Optimize --
16507 -------------------
16509 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16511 -- OPTIMIZATION_HINT ::=
16512 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16514 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16519 Check_At_Least_N_Arguments
(1);
16520 Check_No_Identifiers
;
16522 Hint
:= First
(Pragma_Argument_Associations
(N
));
16523 while Present
(Hint
) loop
16524 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16532 Check_Loop_Pragma_Placement
;
16539 -- pragma Loop_Variant
16540 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16542 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16544 -- CHANGE_DIRECTION ::= Increases | Decreases
16546 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16551 Check_At_Least_N_Arguments
(1);
16552 Check_Loop_Pragma_Placement
;
16554 -- Process all increasing / decreasing expressions
16556 Variant
:= First
(Pragma_Argument_Associations
(N
));
16557 while Present
(Variant
) loop
16558 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16561 Error_Pragma_Arg
("wrong change modifier", Variant
);
16564 Preanalyze_Assert_Expression
16565 (Expression
(Variant
), Any_Discrete
);
16571 -----------------------
16572 -- Machine_Attribute --
16573 -----------------------
16575 -- pragma Machine_Attribute (
16576 -- [Entity =>] LOCAL_NAME,
16577 -- [Attribute_Name =>] static_string_EXPRESSION
16578 -- [, [Info =>] static_EXPRESSION] );
16580 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16581 Def_Id
: Entity_Id
;
16585 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16587 if Arg_Count
= 3 then
16588 Check_Optional_Identifier
(Arg3
, Name_Info
);
16589 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16591 Check_Arg_Count
(2);
16594 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16595 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16596 Check_Arg_Is_Local_Name
(Arg1
);
16597 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16598 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16600 if Is_Access_Type
(Def_Id
) then
16601 Def_Id
:= Designated_Type
(Def_Id
);
16604 if Rep_Item_Too_Early
(Def_Id
, N
) then
16608 Def_Id
:= Underlying_Type
(Def_Id
);
16610 -- The only processing required is to link this item on to the
16611 -- list of rep items for the given entity. This is accomplished
16612 -- by the call to Rep_Item_Too_Late (when no error is detected
16613 -- and False is returned).
16615 if Rep_Item_Too_Late
(Def_Id
, N
) then
16618 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16620 end Machine_Attribute
;
16627 -- (MAIN_OPTION [, MAIN_OPTION]);
16630 -- [STACK_SIZE =>] static_integer_EXPRESSION
16631 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16632 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16634 when Pragma_Main
=> Main
: declare
16635 Args
: Args_List
(1 .. 3);
16636 Names
: constant Name_List
(1 .. 3) := (
16638 Name_Task_Stack_Size_Default
,
16639 Name_Time_Slicing_Enabled
);
16645 Gather_Associations
(Names
, Args
);
16647 for J
in 1 .. 2 loop
16648 if Present
(Args
(J
)) then
16649 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16653 if Present
(Args
(3)) then
16654 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16658 while Present
(Nod
) loop
16659 if Nkind
(Nod
) = N_Pragma
16660 and then Pragma_Name
(Nod
) = Name_Main
16662 Error_Msg_Name_1
:= Pname
;
16663 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16674 -- pragma Main_Storage
16675 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16677 -- MAIN_STORAGE_OPTION ::=
16678 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16679 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16681 when Pragma_Main_Storage
=> Main_Storage
: declare
16682 Args
: Args_List
(1 .. 2);
16683 Names
: constant Name_List
(1 .. 2) := (
16684 Name_Working_Storage
,
16691 Gather_Associations
(Names
, Args
);
16693 for J
in 1 .. 2 loop
16694 if Present
(Args
(J
)) then
16695 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16699 Check_In_Main_Program
;
16702 while Present
(Nod
) loop
16703 if Nkind
(Nod
) = N_Pragma
16704 and then Pragma_Name
(Nod
) = Name_Main_Storage
16706 Error_Msg_Name_1
:= Pname
;
16707 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16718 -- pragma Memory_Size (NUMERIC_LITERAL)
16720 when Pragma_Memory_Size
=>
16723 -- Memory size is simply ignored
16725 Check_No_Identifiers
;
16726 Check_Arg_Count
(1);
16727 Check_Arg_Is_Integer_Literal
(Arg1
);
16735 -- The only correct use of this pragma is on its own in a file, in
16736 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16737 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16738 -- check for a file containing nothing but a No_Body pragma). If we
16739 -- attempt to process it during normal semantics processing, it means
16740 -- it was misplaced.
16742 when Pragma_No_Body
=>
16746 -----------------------------
16747 -- No_Elaboration_Code_All --
16748 -----------------------------
16750 -- pragma No_Elaboration_Code_All;
16752 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16755 Check_Valid_Library_Unit_Pragma
;
16757 if Nkind
(N
) = N_Null_Statement
then
16761 -- Must appear for a spec or generic spec
16763 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16764 N_Generic_Package_Declaration
,
16765 N_Generic_Subprogram_Declaration
,
16766 N_Package_Declaration
,
16767 N_Subprogram_Declaration
)
16771 ("pragma% can only occur for package "
16772 & "or subprogram spec"));
16775 -- Set flag in unit table
16777 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16779 -- Set restriction No_Elaboration_Code
16781 Set_Restriction
(No_Elaboration_Code
, N
);
16783 -- If we are in the main unit or in an extended main source unit,
16784 -- then we also add it to the configuration restrictions so that
16785 -- it will apply to all units in the extended main source.
16787 if Current_Sem_Unit
= Main_Unit
16788 or else In_Extended_Main_Source_Unit
(N
)
16790 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16793 -- If in main extended unit, activate transitive with test
16795 if In_Extended_Main_Source_Unit
(N
) then
16796 Opt
.No_Elab_Code_All_Pragma
:= N
;
16804 -- pragma No_Inline ( NAME {, NAME} );
16806 when Pragma_No_Inline
=>
16808 Process_Inline
(Suppressed
);
16814 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16816 when Pragma_No_Return
=> No_Return
: declare
16824 Check_At_Least_N_Arguments
(1);
16826 -- Loop through arguments of pragma
16829 while Present
(Arg
) loop
16830 Check_Arg_Is_Local_Name
(Arg
);
16831 Id
:= Get_Pragma_Arg
(Arg
);
16834 if not Is_Entity_Name
(Id
) then
16835 Error_Pragma_Arg
("entity name required", Arg
);
16838 if Etype
(Id
) = Any_Type
then
16842 -- Loop to find matching procedures
16847 and then Scope
(E
) = Current_Scope
16849 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16852 -- Set flag on any alias as well
16854 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16855 Set_No_Return
(Alias
(E
));
16861 exit when From_Aspect_Specification
(N
);
16865 -- If entity in not in current scope it may be the enclosing
16866 -- suprogram body to which the aspect applies.
16869 if Entity
(Id
) = Current_Scope
16870 and then From_Aspect_Specification
(N
)
16872 Set_No_Return
(Entity
(Id
));
16874 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16886 -- pragma No_Run_Time;
16888 -- Note: this pragma is retained for backwards compatibility. See
16889 -- body of Rtsfind for full details on its handling.
16891 when Pragma_No_Run_Time
=>
16893 Check_Valid_Configuration_Pragma
;
16894 Check_Arg_Count
(0);
16896 No_Run_Time_Mode
:= True;
16897 Configurable_Run_Time_Mode
:= True;
16899 -- Set Duration to 32 bits if word size is 32
16901 if Ttypes
.System_Word_Size
= 32 then
16902 Duration_32_Bits_On_Target
:= True;
16905 -- Set appropriate restrictions
16907 Set_Restriction
(No_Finalization
, N
);
16908 Set_Restriction
(No_Exception_Handlers
, N
);
16909 Set_Restriction
(Max_Tasks
, N
, 0);
16910 Set_Restriction
(No_Tasking
, N
);
16912 -----------------------
16913 -- No_Tagged_Streams --
16914 -----------------------
16916 -- pragma No_Tagged_Streams;
16917 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16919 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16925 Check_At_Most_N_Arguments
(1);
16927 -- One argument case
16929 if Arg_Count
= 1 then
16930 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16931 Check_Arg_Is_Local_Name
(Arg1
);
16932 E_Id
:= Get_Pragma_Arg
(Arg1
);
16934 if Etype
(E_Id
) = Any_Type
then
16938 E
:= Entity
(E_Id
);
16940 Check_Duplicate_Pragma
(E
);
16942 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16944 ("argument for pragma% must be root tagged type", Arg1
);
16947 if Rep_Item_Too_Early
(E
, N
)
16949 Rep_Item_Too_Late
(E
, N
)
16953 Set_No_Tagged_Streams_Pragma
(E
, N
);
16956 -- Zero argument case
16959 Check_Is_In_Decl_Part_Or_Package_Spec
;
16960 No_Tagged_Streams
:= N
;
16962 end No_Tagged_Strms
;
16964 ------------------------
16965 -- No_Strict_Aliasing --
16966 ------------------------
16968 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16970 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16975 Check_At_Most_N_Arguments
(1);
16977 if Arg_Count
= 0 then
16978 Check_Valid_Configuration_Pragma
;
16979 Opt
.No_Strict_Aliasing
:= True;
16982 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16983 Check_Arg_Is_Local_Name
(Arg1
);
16984 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16986 if E_Id
= Any_Type
then
16988 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16989 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16992 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16994 end No_Strict_Aliasing
;
16996 -----------------------
16997 -- Normalize_Scalars --
16998 -----------------------
17000 -- pragma Normalize_Scalars;
17002 when Pragma_Normalize_Scalars
=>
17003 Check_Ada_83_Warning
;
17004 Check_Arg_Count
(0);
17005 Check_Valid_Configuration_Pragma
;
17007 -- Normalize_Scalars creates false positives in CodePeer, and
17008 -- incorrect negative results in GNATprove mode, so ignore this
17009 -- pragma in these modes.
17011 if not (CodePeer_Mode
or GNATprove_Mode
) then
17012 Normalize_Scalars
:= True;
17013 Init_Or_Norm_Scalars
:= True;
17020 -- pragma Obsolescent;
17022 -- pragma Obsolescent (
17023 -- [Message =>] static_string_EXPRESSION
17024 -- [,[Version =>] Ada_05]]);
17026 -- pragma Obsolescent (
17027 -- [Entity =>] NAME
17028 -- [,[Message =>] static_string_EXPRESSION
17029 -- [,[Version =>] Ada_05]] );
17031 when Pragma_Obsolescent
=> Obsolescent
: declare
17035 procedure Set_Obsolescent
(E
: Entity_Id
);
17036 -- Given an entity Ent, mark it as obsolescent if appropriate
17038 ---------------------
17039 -- Set_Obsolescent --
17040 ---------------------
17042 procedure Set_Obsolescent
(E
: Entity_Id
) is
17051 -- Entity name was given
17053 if Present
(Ename
) then
17055 -- If entity name matches, we are fine. Save entity in
17056 -- pragma argument, for ASIS use.
17058 if Chars
(Ename
) = Chars
(Ent
) then
17059 Set_Entity
(Ename
, Ent
);
17060 Generate_Reference
(Ent
, Ename
);
17062 -- If entity name does not match, only possibility is an
17063 -- enumeration literal from an enumeration type declaration.
17065 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17067 ("pragma % entity name does not match declaration");
17070 Ent
:= First_Literal
(E
);
17074 ("pragma % entity name does not match any "
17075 & "enumeration literal");
17077 elsif Chars
(Ent
) = Chars
(Ename
) then
17078 Set_Entity
(Ename
, Ent
);
17079 Generate_Reference
(Ent
, Ename
);
17083 Ent
:= Next_Literal
(Ent
);
17089 -- Ent points to entity to be marked
17091 if Arg_Count
>= 1 then
17093 -- Deal with static string argument
17095 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17096 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17098 for J
in 1 .. String_Length
(S
) loop
17099 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17101 ("pragma% argument does not allow wide characters",
17106 Obsolescent_Warnings
.Append
17107 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17109 -- Check for Ada_05 parameter
17111 if Arg_Count
/= 1 then
17112 Check_Arg_Count
(2);
17115 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17118 Check_Arg_Is_Identifier
(Argx
);
17120 if Chars
(Argx
) /= Name_Ada_05
then
17121 Error_Msg_Name_2
:= Name_Ada_05
;
17123 ("only allowed argument for pragma% is %", Argx
);
17126 if Ada_Version_Explicit
< Ada_2005
17127 or else not Warn_On_Ada_2005_Compatibility
17135 -- Set flag if pragma active
17138 Set_Is_Obsolescent
(Ent
);
17142 end Set_Obsolescent
;
17144 -- Start of processing for pragma Obsolescent
17149 Check_At_Most_N_Arguments
(3);
17151 -- See if first argument specifies an entity name
17155 (Chars
(Arg1
) = Name_Entity
17157 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17159 N_Operator_Symbol
))
17161 Ename
:= Get_Pragma_Arg
(Arg1
);
17163 -- Eliminate first argument, so we can share processing
17167 Arg_Count
:= Arg_Count
- 1;
17169 -- No Entity name argument given
17175 if Arg_Count
>= 1 then
17176 Check_Optional_Identifier
(Arg1
, Name_Message
);
17178 if Arg_Count
= 2 then
17179 Check_Optional_Identifier
(Arg2
, Name_Version
);
17183 -- Get immediately preceding declaration
17186 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17190 -- Cases where we do not follow anything other than another pragma
17194 -- First case: library level compilation unit declaration with
17195 -- the pragma immediately following the declaration.
17197 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17199 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17202 -- Case 2: library unit placement for package
17206 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17208 if Is_Package_Or_Generic_Package
(Ent
) then
17209 Set_Obsolescent
(Ent
);
17215 -- Cases where we must follow a declaration
17218 if Nkind
(Decl
) not in N_Declaration
17219 and then Nkind
(Decl
) not in N_Later_Decl_Item
17220 and then Nkind
(Decl
) not in N_Generic_Declaration
17221 and then Nkind
(Decl
) not in N_Renaming_Declaration
17224 ("pragma% misplaced, "
17225 & "must immediately follow a declaration");
17228 Set_Obsolescent
(Defining_Entity
(Decl
));
17238 -- pragma Optimize (Time | Space | Off);
17240 -- The actual check for optimize is done in Gigi. Note that this
17241 -- pragma does not actually change the optimization setting, it
17242 -- simply checks that it is consistent with the pragma.
17244 when Pragma_Optimize
=>
17245 Check_No_Identifiers
;
17246 Check_Arg_Count
(1);
17247 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17249 ------------------------
17250 -- Optimize_Alignment --
17251 ------------------------
17253 -- pragma Optimize_Alignment (Time | Space | Off);
17255 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17257 Check_No_Identifiers
;
17258 Check_Arg_Count
(1);
17259 Check_Valid_Configuration_Pragma
;
17262 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17266 Opt
.Optimize_Alignment
:= 'T';
17268 Opt
.Optimize_Alignment
:= 'S';
17270 Opt
.Optimize_Alignment
:= 'O';
17272 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17276 -- Set indication that mode is set locally. If we are in fact in a
17277 -- configuration pragma file, this setting is harmless since the
17278 -- switch will get reset anyway at the start of each unit.
17280 Optimize_Alignment_Local
:= True;
17281 end Optimize_Alignment
;
17287 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17289 when Pragma_Ordered
=> Ordered
: declare
17290 Assoc
: constant Node_Id
:= Arg1
;
17296 Check_No_Identifiers
;
17297 Check_Arg_Count
(1);
17298 Check_Arg_Is_Local_Name
(Arg1
);
17300 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17301 Find_Type
(Type_Id
);
17302 Typ
:= Entity
(Type_Id
);
17304 if Typ
= Any_Type
then
17307 Typ
:= Underlying_Type
(Typ
);
17310 if not Is_Enumeration_Type
(Typ
) then
17311 Error_Pragma
("pragma% must specify enumeration type");
17314 Check_First_Subtype
(Arg1
);
17315 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17318 -------------------
17319 -- Overflow_Mode --
17320 -------------------
17322 -- pragma Overflow_Mode
17323 -- ([General => ] MODE [, [Assertions => ] MODE]);
17325 -- MODE := STRICT | MINIMIZED | ELIMINATED
17327 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17328 -- since System.Bignums makes this assumption. This is true of nearly
17329 -- all (all?) targets.
17331 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17332 function Get_Overflow_Mode
17334 Arg
: Node_Id
) return Overflow_Mode_Type
;
17335 -- Function to process one pragma argument, Arg. If an identifier
17336 -- is present, it must be Name. Mode type is returned if a valid
17337 -- argument exists, otherwise an error is signalled.
17339 -----------------------
17340 -- Get_Overflow_Mode --
17341 -----------------------
17343 function Get_Overflow_Mode
17345 Arg
: Node_Id
) return Overflow_Mode_Type
17347 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17350 Check_Optional_Identifier
(Arg
, Name
);
17351 Check_Arg_Is_Identifier
(Argx
);
17353 if Chars
(Argx
) = Name_Strict
then
17356 elsif Chars
(Argx
) = Name_Minimized
then
17359 elsif Chars
(Argx
) = Name_Eliminated
then
17360 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17362 ("Eliminated not implemented on this target", Argx
);
17368 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17370 end Get_Overflow_Mode
;
17372 -- Start of processing for Overflow_Mode
17376 Check_At_Least_N_Arguments
(1);
17377 Check_At_Most_N_Arguments
(2);
17379 -- Process first argument
17381 Scope_Suppress
.Overflow_Mode_General
:=
17382 Get_Overflow_Mode
(Name_General
, Arg1
);
17384 -- Case of only one argument
17386 if Arg_Count
= 1 then
17387 Scope_Suppress
.Overflow_Mode_Assertions
:=
17388 Scope_Suppress
.Overflow_Mode_General
;
17390 -- Case of two arguments present
17393 Scope_Suppress
.Overflow_Mode_Assertions
:=
17394 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17398 --------------------------
17399 -- Overriding Renamings --
17400 --------------------------
17402 -- pragma Overriding_Renamings;
17404 when Pragma_Overriding_Renamings
=>
17406 Check_Arg_Count
(0);
17407 Check_Valid_Configuration_Pragma
;
17408 Overriding_Renamings
:= True;
17414 -- pragma Pack (first_subtype_LOCAL_NAME);
17416 when Pragma_Pack
=> Pack
: declare
17417 Assoc
: constant Node_Id
:= Arg1
;
17421 Ignore
: Boolean := False;
17424 Check_No_Identifiers
;
17425 Check_Arg_Count
(1);
17426 Check_Arg_Is_Local_Name
(Arg1
);
17427 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17429 if not Is_Entity_Name
(Type_Id
)
17430 or else not Is_Type
(Entity
(Type_Id
))
17433 ("argument for pragma% must be type or subtype", Arg1
);
17436 Find_Type
(Type_Id
);
17437 Typ
:= Entity
(Type_Id
);
17440 or else Rep_Item_Too_Early
(Typ
, N
)
17444 Typ
:= Underlying_Type
(Typ
);
17447 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17448 Error_Pragma
("pragma% must specify array or record type");
17451 Check_First_Subtype
(Arg1
);
17452 Check_Duplicate_Pragma
(Typ
);
17456 if Is_Array_Type
(Typ
) then
17457 Ctyp
:= Component_Type
(Typ
);
17459 -- Ignore pack that does nothing
17461 if Known_Static_Esize
(Ctyp
)
17462 and then Known_Static_RM_Size
(Ctyp
)
17463 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17464 and then Addressable
(Esize
(Ctyp
))
17469 -- Process OK pragma Pack. Note that if there is a separate
17470 -- component clause present, the Pack will be cancelled. This
17471 -- processing is in Freeze.
17473 if not Rep_Item_Too_Late
(Typ
, N
) then
17475 -- In CodePeer mode, we do not need complex front-end
17476 -- expansions related to pragma Pack, so disable handling
17479 if CodePeer_Mode
then
17482 -- Don't attempt any packing for VM targets. We possibly
17483 -- could deal with some cases of array bit-packing, but we
17484 -- don't bother, since this is not a typical kind of
17485 -- representation in the VM context anyway (and would not
17486 -- for example work nicely with the debugger).
17488 elsif VM_Target
/= No_VM
then
17489 if not GNAT_Mode
then
17491 ("??pragma% ignored in this configuration");
17494 -- Normal case where we do the pack action
17498 Set_Is_Packed
(Base_Type
(Typ
));
17499 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17502 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17506 -- For record types, the pack is always effective
17508 else pragma Assert
(Is_Record_Type
(Typ
));
17509 if not Rep_Item_Too_Late
(Typ
, N
) then
17511 -- Ignore pack request with warning in VM mode (skip warning
17512 -- if we are compiling GNAT run time library).
17514 if VM_Target
/= No_VM
then
17515 if not GNAT_Mode
then
17517 ("??pragma% ignored in this configuration");
17520 -- Normal case of pack request active
17523 Set_Is_Packed
(Base_Type
(Typ
));
17524 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17525 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17537 -- There is nothing to do here, since we did all the processing for
17538 -- this pragma in Par.Prag (so that it works properly even in syntax
17541 when Pragma_Page
=>
17548 -- pragma Part_Of (ABSTRACT_STATE);
17550 -- ABSTRACT_STATE ::= NAME
17552 when Pragma_Part_Of
=> Part_Of
: declare
17553 procedure Propagate_Part_Of
17554 (Pack_Id
: Entity_Id
;
17555 State_Id
: Entity_Id
;
17556 Instance
: Node_Id
);
17557 -- Propagate the Part_Of indicator to all abstract states and
17558 -- variables declared in the visible state space of a package
17559 -- denoted by Pack_Id. State_Id is the encapsulating state.
17560 -- Instance is the package instantiation node.
17562 -----------------------
17563 -- Propagate_Part_Of --
17564 -----------------------
17566 procedure Propagate_Part_Of
17567 (Pack_Id
: Entity_Id
;
17568 State_Id
: Entity_Id
;
17569 Instance
: Node_Id
)
17571 Has_Item
: Boolean := False;
17572 -- Flag set when the visible state space contains at least one
17573 -- abstract state or variable.
17575 procedure Propagate_Part_Of
(Pack_Id
: Entity_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.
17580 -----------------------
17581 -- Propagate_Part_Of --
17582 -----------------------
17584 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17585 Item_Id
: Entity_Id
;
17588 -- Traverse the entity chain of the package and set relevant
17589 -- attributes of abstract states and variables declared in
17590 -- the visible state space of the package.
17592 Item_Id
:= First_Entity
(Pack_Id
);
17593 while Present
(Item_Id
)
17594 and then not In_Private_Part
(Item_Id
)
17596 -- Do not consider internally generated items
17598 if not Comes_From_Source
(Item_Id
) then
17601 -- The Part_Of indicator turns an abstract state or
17602 -- variable into a constituent of the encapsulating
17605 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17610 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17611 Set_Encapsulating_State
(Item_Id
, State_Id
);
17613 -- Recursively handle nested packages and instantiations
17615 elsif Ekind
(Item_Id
) = E_Package
then
17616 Propagate_Part_Of
(Item_Id
);
17619 Next_Entity
(Item_Id
);
17621 end Propagate_Part_Of
;
17623 -- Start of processing for Propagate_Part_Of
17626 Propagate_Part_Of
(Pack_Id
);
17628 -- Detect a package instantiation that is subject to a Part_Of
17629 -- indicator, but has no visible state.
17631 if not Has_Item
then
17633 ("package instantiation & has Part_Of indicator but "
17634 & "lacks visible state", Instance
, Pack_Id
);
17636 end Propagate_Part_Of
;
17640 Item_Id
: Entity_Id
;
17643 State_Id
: Entity_Id
;
17646 -- Start of processing for Part_Of
17650 Check_No_Identifiers
;
17651 Check_Arg_Count
(1);
17653 -- Ensure the proper placement of the pragma. Part_Of must appear
17654 -- on a variable declaration or a package instantiation.
17657 while Present
(Stmt
) loop
17659 -- Skip prior pragmas, but check for duplicates
17661 if Nkind
(Stmt
) = N_Pragma
then
17662 if Pragma_Name
(Stmt
) = Pname
then
17663 Error_Msg_Name_1
:= Pname
;
17664 Error_Msg_Sloc
:= Sloc
(Stmt
);
17665 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17668 -- Skip internally generated code
17670 elsif not Comes_From_Source
(Stmt
) then
17673 -- The pragma applies to an object declaration (possibly a
17674 -- variable) or a package instantiation. Stop the traversal
17675 -- and continue the analysis.
17677 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17678 N_Package_Instantiation
)
17682 -- The pragma does not apply to a legal construct, issue an
17683 -- error and stop the analysis.
17690 Stmt
:= Prev
(Stmt
);
17693 -- When the context is an object declaration, ensure that we are
17694 -- dealing with a variable.
17696 if Nkind
(Stmt
) = N_Object_Declaration
17697 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17699 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17703 -- Extract the entity of the related object declaration or package
17704 -- instantiation. In the case of the instantiation, use the entity
17705 -- of the instance spec.
17707 if Nkind
(Stmt
) = N_Package_Instantiation
then
17708 Stmt
:= Instance_Spec
(Stmt
);
17711 Item_Id
:= Defining_Entity
(Stmt
);
17712 State
:= Get_Pragma_Arg
(Arg1
);
17714 -- Detect any discrepancies between the placement of the object
17715 -- or package instantiation with respect to state space and the
17716 -- encapsulating state.
17719 (Item_Id
=> Item_Id
,
17725 State_Id
:= Entity
(State
);
17727 -- Add the pragma to the contract of the item. This aids with
17728 -- the detection of a missing but required Part_Of indicator.
17730 Add_Contract_Item
(N
, Item_Id
);
17732 -- The Part_Of indicator turns a variable into a constituent
17733 -- of the encapsulating state.
17735 if Ekind
(Item_Id
) = E_Variable
then
17736 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17737 Set_Encapsulating_State
(Item_Id
, State_Id
);
17739 -- Propagate the Part_Of indicator to the visible state space
17740 -- of the package instantiation.
17744 (Pack_Id
=> Item_Id
,
17745 State_Id
=> State_Id
,
17751 ----------------------------------
17752 -- Partition_Elaboration_Policy --
17753 ----------------------------------
17755 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17757 when Pragma_Partition_Elaboration_Policy
=> declare
17758 subtype PEP_Range
is Name_Id
17759 range First_Partition_Elaboration_Policy_Name
17760 .. Last_Partition_Elaboration_Policy_Name
;
17761 PEP_Val
: PEP_Range
;
17766 Check_Arg_Count
(1);
17767 Check_No_Identifiers
;
17768 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17769 Check_Valid_Configuration_Pragma
;
17770 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17773 when Name_Concurrent
=>
17775 when Name_Sequential
=>
17779 if Partition_Elaboration_Policy
/= ' '
17780 and then Partition_Elaboration_Policy
/= PEP
17782 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17784 ("partition elaboration policy incompatible with policy#");
17786 -- Set new policy, but always preserve System_Location since we
17787 -- like the error message with the run time name.
17790 Partition_Elaboration_Policy
:= PEP
;
17792 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17793 Partition_Elaboration_Policy_Sloc
:= Loc
;
17802 -- pragma Passive [(PASSIVE_FORM)];
17804 -- PASSIVE_FORM ::= Semaphore | No
17806 when Pragma_Passive
=>
17809 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17810 Error_Pragma
("pragma% must be within task definition");
17813 if Arg_Count
/= 0 then
17814 Check_Arg_Count
(1);
17815 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17818 ----------------------------------
17819 -- Preelaborable_Initialization --
17820 ----------------------------------
17822 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17824 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17829 Check_Arg_Count
(1);
17830 Check_No_Identifiers
;
17831 Check_Arg_Is_Identifier
(Arg1
);
17832 Check_Arg_Is_Local_Name
(Arg1
);
17833 Check_First_Subtype
(Arg1
);
17834 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17836 -- The pragma may come from an aspect on a private declaration,
17837 -- even if the freeze point at which this is analyzed in the
17838 -- private part after the full view.
17840 if Has_Private_Declaration
(Ent
)
17841 and then From_Aspect_Specification
(N
)
17845 elsif Is_Private_Type
(Ent
)
17846 or else Is_Protected_Type
(Ent
)
17847 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17853 ("pragma % can only be applied to private, formal derived or "
17854 & "protected type",
17858 -- Give an error if the pragma is applied to a protected type that
17859 -- does not qualify (due to having entries, or due to components
17860 -- that do not qualify).
17862 if Is_Protected_Type
(Ent
)
17863 and then not Has_Preelaborable_Initialization
(Ent
)
17866 ("protected type & does not have preelaborable "
17867 & "initialization", Ent
);
17869 -- Otherwise mark the type as definitely having preelaborable
17873 Set_Known_To_Have_Preelab_Init
(Ent
);
17876 if Has_Pragma_Preelab_Init
(Ent
)
17877 and then Warn_On_Redundant_Constructs
17879 Error_Pragma
("?r?duplicate pragma%!");
17881 Set_Has_Pragma_Preelab_Init
(Ent
);
17885 --------------------
17886 -- Persistent_BSS --
17887 --------------------
17889 -- pragma Persistent_BSS [(object_NAME)];
17891 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17898 Check_At_Most_N_Arguments
(1);
17900 -- Case of application to specific object (one argument)
17902 if Arg_Count
= 1 then
17903 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17905 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17907 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17910 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17913 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17914 Decl
:= Parent
(Ent
);
17916 -- Check for duplication before inserting in list of
17917 -- representation items.
17919 Check_Duplicate_Pragma
(Ent
);
17921 if Rep_Item_Too_Late
(Ent
, N
) then
17925 if Present
(Expression
(Decl
)) then
17927 ("object for pragma% cannot have initialization", Arg1
);
17930 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17932 ("object type for pragma% is not potentially persistent",
17937 Make_Linker_Section_Pragma
17938 (Ent
, Sloc
(N
), ".persistent.bss");
17939 Insert_After
(N
, Prag
);
17942 -- Case of use as configuration pragma with no arguments
17945 Check_Valid_Configuration_Pragma
;
17946 Persistent_BSS_Mode
:= True;
17948 end Persistent_BSS
;
17954 -- pragma Polling (ON | OFF);
17956 when Pragma_Polling
=>
17958 Check_Arg_Count
(1);
17959 Check_No_Identifiers
;
17960 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17961 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17967 -- pragma Post (Boolean_EXPRESSION);
17968 -- pragma Post_Class (Boolean_EXPRESSION);
17970 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
17971 PC_Pragma
: Node_Id
;
17975 Check_Arg_Count
(1);
17976 Check_No_Identifiers
;
17979 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
17980 -- flag Class_Present to True for the Post_Class case.
17982 Set_Class_Present
(N
, Prag_Id
= Pragma_Post_Class
);
17983 PC_Pragma
:= New_Copy
(N
);
17984 Set_Pragma_Identifier
17985 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
17986 Rewrite
(N
, PC_Pragma
);
17987 Set_Analyzed
(N
, False);
17991 -------------------
17992 -- Postcondition --
17993 -------------------
17995 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17996 -- [,[Message =>] String_EXPRESSION]);
17998 when Pragma_Postcondition
=> Postcondition
: declare
18003 Check_At_Least_N_Arguments
(1);
18004 Check_At_Most_N_Arguments
(2);
18005 Check_Optional_Identifier
(Arg1
, Name_Check
);
18007 -- Verify the proper placement of the pragma. The remainder of the
18008 -- processing is found in Sem_Ch6/Sem_Ch7.
18010 Check_Precondition_Postcondition
(In_Body
);
18012 -- When the pragma is a source construct appearing inside a body,
18013 -- preanalyze the boolean_expression to detect illegal forward
18017 -- pragma Postcondition (X'Old ...);
18020 if Comes_From_Source
(N
) and then In_Body
then
18021 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
18029 -- pragma Pre (Boolean_EXPRESSION);
18030 -- pragma Pre_Class (Boolean_EXPRESSION);
18032 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
18033 PC_Pragma
: Node_Id
;
18037 Check_Arg_Count
(1);
18038 Check_No_Identifiers
;
18041 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
18042 -- flag Class_Present to True for the Pre_Class case.
18044 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
18045 PC_Pragma
:= New_Copy
(N
);
18046 Set_Pragma_Identifier
18047 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
18048 Rewrite
(N
, PC_Pragma
);
18049 Set_Analyzed
(N
, False);
18057 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18058 -- [,[Message =>] String_EXPRESSION]);
18060 when Pragma_Precondition
=> Precondition
: declare
18065 Check_At_Least_N_Arguments
(1);
18066 Check_At_Most_N_Arguments
(2);
18067 Check_Optional_Identifier
(Arg1
, Name_Check
);
18068 Check_Precondition_Postcondition
(In_Body
);
18070 -- If in spec, nothing more to do. If in body, then we convert
18071 -- the pragma to an equivalent pragma Check. That works fine since
18072 -- pragma Check will analyze the condition in the proper context.
18074 -- The form of the pragma Check is either:
18076 -- pragma Check (Precondition, cond [, msg])
18078 -- pragma Check (Pre, cond [, msg])
18080 -- We use the Pre form if this pragma derived from a Pre aspect.
18081 -- This is needed to make sure that the right set of Policy
18082 -- pragmas are checked.
18086 -- Rewrite as Check pragma
18090 Chars
=> Name_Check
,
18091 Pragma_Argument_Associations
=> New_List
(
18092 Make_Pragma_Argument_Association
(Loc
,
18093 Expression
=> Make_Identifier
(Loc
, Pname
)),
18095 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
18097 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
18099 if Arg_Count
= 2 then
18100 Append_To
(Pragma_Argument_Associations
(N
),
18101 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
18103 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
18114 -- pragma Predicate
18115 -- ([Entity =>] type_LOCAL_NAME,
18116 -- [Check =>] boolean_EXPRESSION);
18118 when Pragma_Predicate
=> Predicate
: declare
18125 Check_Arg_Count
(2);
18126 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18127 Check_Optional_Identifier
(Arg2
, Name_Check
);
18129 Check_Arg_Is_Local_Name
(Arg1
);
18131 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18132 Find_Type
(Type_Id
);
18133 Typ
:= Entity
(Type_Id
);
18135 if Typ
= Any_Type
then
18139 -- The remaining processing is simply to link the pragma on to
18140 -- the rep item chain, for processing when the type is frozen.
18141 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18142 -- mark the type as having predicates.
18144 Set_Has_Predicates
(Typ
);
18145 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18152 -- pragma Preelaborate [(library_unit_NAME)];
18154 -- Set the flag Is_Preelaborated of program unit name entity
18156 when Pragma_Preelaborate
=> Preelaborate
: declare
18157 Pa
: constant Node_Id
:= Parent
(N
);
18158 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18162 Check_Ada_83_Warning
;
18163 Check_Valid_Library_Unit_Pragma
;
18165 if Nkind
(N
) = N_Null_Statement
then
18169 Ent
:= Find_Lib_Unit_Name
;
18170 Check_Duplicate_Pragma
(Ent
);
18172 -- This filters out pragmas inside generic parents that show up
18173 -- inside instantiations. Pragmas that come from aspects in the
18174 -- unit are not ignored.
18176 if Present
(Ent
) then
18177 if Pk
= N_Package_Specification
18178 and then Present
(Generic_Parent
(Pa
))
18179 and then not From_Aspect_Specification
(N
)
18184 if not Debug_Flag_U
then
18185 Set_Is_Preelaborated
(Ent
);
18186 Set_Suppress_Elaboration_Warnings
(Ent
);
18192 -------------------------------
18193 -- Prefix_Exception_Messages --
18194 -------------------------------
18196 -- pragma Prefix_Exception_Messages;
18198 when Pragma_Prefix_Exception_Messages
=>
18200 Check_Valid_Configuration_Pragma
;
18201 Check_Arg_Count
(0);
18202 Prefix_Exception_Messages
:= True;
18208 -- pragma Priority (EXPRESSION);
18210 when Pragma_Priority
=> Priority
: declare
18211 P
: constant Node_Id
:= Parent
(N
);
18216 Check_No_Identifiers
;
18217 Check_Arg_Count
(1);
18221 if Nkind
(P
) = N_Subprogram_Body
then
18222 Check_In_Main_Program
;
18224 Ent
:= Defining_Unit_Name
(Specification
(P
));
18226 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18227 Ent
:= Defining_Identifier
(Ent
);
18230 Arg
:= Get_Pragma_Arg
(Arg1
);
18231 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18235 if not Is_OK_Static_Expression
(Arg
) then
18236 Flag_Non_Static_Expr
18237 ("main subprogram priority is not static!", Arg
);
18240 -- If constraint error, then we already signalled an error
18242 elsif Raises_Constraint_Error
(Arg
) then
18245 -- Otherwise check in range except if Relaxed_RM_Semantics
18246 -- where we ignore the value if out of range.
18250 Val
: constant Uint
:= Expr_Value
(Arg
);
18252 if not Relaxed_RM_Semantics
18255 or else Val
> Expr_Value
(Expression
18256 (Parent
(RTE
(RE_Max_Priority
)))))
18259 ("main subprogram priority is out of range", Arg1
);
18262 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18267 -- Load an arbitrary entity from System.Tasking.Stages or
18268 -- System.Tasking.Restricted.Stages (depending on the
18269 -- supported profile) to make sure that one of these packages
18270 -- is implicitly with'ed, since we need to have the tasking
18271 -- run time active for the pragma Priority to have any effect.
18272 -- Previously we with'ed the package System.Tasking, but this
18273 -- package does not trigger the required initialization of the
18274 -- run-time library.
18277 Discard
: Entity_Id
;
18278 pragma Warnings
(Off
, Discard
);
18280 if Restricted_Profile
then
18281 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18283 Discard
:= RTE
(RE_Activate_Tasks
);
18287 -- Task or Protected, must be of type Integer
18289 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18290 Arg
:= Get_Pragma_Arg
(Arg1
);
18291 Ent
:= Defining_Identifier
(Parent
(P
));
18293 -- The expression must be analyzed in the special manner
18294 -- described in "Handling of Default and Per-Object
18295 -- Expressions" in sem.ads.
18297 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18299 if not Is_OK_Static_Expression
(Arg
) then
18300 Check_Restriction
(Static_Priorities
, Arg
);
18303 -- Anything else is incorrect
18309 -- Check duplicate pragma before we chain the pragma in the Rep
18310 -- Item chain of Ent.
18312 Check_Duplicate_Pragma
(Ent
);
18313 Record_Rep_Item
(Ent
, N
);
18316 -----------------------------------
18317 -- Priority_Specific_Dispatching --
18318 -----------------------------------
18320 -- pragma Priority_Specific_Dispatching (
18321 -- policy_IDENTIFIER,
18322 -- first_priority_EXPRESSION,
18323 -- last_priority_EXPRESSION);
18325 when Pragma_Priority_Specific_Dispatching
=>
18326 Priority_Specific_Dispatching
: declare
18327 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18328 -- This is the entity System.Any_Priority;
18331 Lower_Bound
: Node_Id
;
18332 Upper_Bound
: Node_Id
;
18338 Check_Arg_Count
(3);
18339 Check_No_Identifiers
;
18340 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18341 Check_Valid_Configuration_Pragma
;
18342 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18343 DP
:= Fold_Upper
(Name_Buffer
(1));
18345 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18346 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18347 Lower_Val
:= Expr_Value
(Lower_Bound
);
18349 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18350 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18351 Upper_Val
:= Expr_Value
(Upper_Bound
);
18353 -- It is not allowed to use Task_Dispatching_Policy and
18354 -- Priority_Specific_Dispatching in the same partition.
18356 if Task_Dispatching_Policy
/= ' ' then
18357 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18359 ("pragma% incompatible with Task_Dispatching_Policy#");
18361 -- Check lower bound in range
18363 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18365 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18368 ("first_priority is out of range", Arg2
);
18370 -- Check upper bound in range
18372 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18374 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18377 ("last_priority is out of range", Arg3
);
18379 -- Check that the priority range is valid
18381 elsif Lower_Val
> Upper_Val
then
18383 ("last_priority_expression must be greater than or equal to "
18384 & "first_priority_expression");
18386 -- Store the new policy, but always preserve System_Location since
18387 -- we like the error message with the run-time name.
18390 -- Check overlapping in the priority ranges specified in other
18391 -- Priority_Specific_Dispatching pragmas within the same
18392 -- partition. We can only check those we know about.
18395 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18397 if Specific_Dispatching
.Table
(J
).First_Priority
in
18398 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18399 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18400 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18403 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18405 ("priority range overlaps with "
18406 & "Priority_Specific_Dispatching#");
18410 -- The use of Priority_Specific_Dispatching is incompatible
18411 -- with Task_Dispatching_Policy.
18413 if Task_Dispatching_Policy
/= ' ' then
18414 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18416 ("Priority_Specific_Dispatching incompatible "
18417 & "with Task_Dispatching_Policy#");
18420 -- The use of Priority_Specific_Dispatching forces ceiling
18423 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18424 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18426 ("Priority_Specific_Dispatching incompatible "
18427 & "with Locking_Policy#");
18429 -- Set the Ceiling_Locking policy, but preserve System_Location
18430 -- since we like the error message with the run time name.
18433 Locking_Policy
:= 'C';
18435 if Locking_Policy_Sloc
/= System_Location
then
18436 Locking_Policy_Sloc
:= Loc
;
18440 -- Add entry in the table
18442 Specific_Dispatching
.Append
18443 ((Dispatching_Policy
=> DP
,
18444 First_Priority
=> UI_To_Int
(Lower_Val
),
18445 Last_Priority
=> UI_To_Int
(Upper_Val
),
18446 Pragma_Loc
=> Loc
));
18448 end Priority_Specific_Dispatching
;
18454 -- pragma Profile (profile_IDENTIFIER);
18456 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18458 when Pragma_Profile
=>
18460 Check_Arg_Count
(1);
18461 Check_Valid_Configuration_Pragma
;
18462 Check_No_Identifiers
;
18465 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18468 if Chars
(Argx
) = Name_Ravenscar
then
18469 Set_Ravenscar_Profile
(N
);
18471 elsif Chars
(Argx
) = Name_Restricted
then
18472 Set_Profile_Restrictions
18474 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18476 elsif Chars
(Argx
) = Name_Rational
then
18477 Set_Rational_Profile
;
18479 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18480 Set_Profile_Restrictions
18481 (No_Implementation_Extensions
,
18482 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18485 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18489 ----------------------
18490 -- Profile_Warnings --
18491 ----------------------
18493 -- pragma Profile_Warnings (profile_IDENTIFIER);
18495 -- profile_IDENTIFIER => Restricted | Ravenscar
18497 when Pragma_Profile_Warnings
=>
18499 Check_Arg_Count
(1);
18500 Check_Valid_Configuration_Pragma
;
18501 Check_No_Identifiers
;
18504 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18507 if Chars
(Argx
) = Name_Ravenscar
then
18508 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18510 elsif Chars
(Argx
) = Name_Restricted
then
18511 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18513 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18514 Set_Profile_Restrictions
18515 (No_Implementation_Extensions
, N
, Warn
=> True);
18518 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18522 --------------------------
18523 -- Propagate_Exceptions --
18524 --------------------------
18526 -- pragma Propagate_Exceptions;
18528 -- Note: this pragma is obsolete and has no effect
18530 when Pragma_Propagate_Exceptions
=>
18532 Check_Arg_Count
(0);
18534 if Warn_On_Obsolescent_Feature
then
18536 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18537 "and has no effect?j?", N
);
18540 -----------------------------
18541 -- Provide_Shift_Operators --
18542 -----------------------------
18544 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18546 when Pragma_Provide_Shift_Operators
=>
18547 Provide_Shift_Operators
: declare
18550 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18551 -- Insert declaration and pragma Instrinsic for named shift op
18553 ----------------------------
18554 -- Declare_Shift_Operator --
18555 ----------------------------
18557 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18563 Make_Subprogram_Declaration
(Loc
,
18564 Make_Function_Specification
(Loc
,
18565 Defining_Unit_Name
=>
18566 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18568 Result_Definition
=>
18569 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18571 Parameter_Specifications
=> New_List
(
18572 Make_Parameter_Specification
(Loc
,
18573 Defining_Identifier
=>
18574 Make_Defining_Identifier
(Loc
, Name_Value
),
18576 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18578 Make_Parameter_Specification
(Loc
,
18579 Defining_Identifier
=>
18580 Make_Defining_Identifier
(Loc
, Name_Amount
),
18582 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18586 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18587 Pragma_Argument_Associations
=> New_List
(
18588 Make_Pragma_Argument_Association
(Loc
,
18589 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18590 Make_Pragma_Argument_Association
(Loc
,
18591 Expression
=> Make_Identifier
(Loc
, Nam
))));
18593 Insert_After
(N
, Import
);
18594 Insert_After
(N
, Func
);
18595 end Declare_Shift_Operator
;
18597 -- Start of processing for Provide_Shift_Operators
18601 Check_Arg_Count
(1);
18602 Check_Arg_Is_Local_Name
(Arg1
);
18604 Arg1
:= Get_Pragma_Arg
(Arg1
);
18606 -- We must have an entity name
18608 if not Is_Entity_Name
(Arg1
) then
18610 ("pragma % must apply to integer first subtype", Arg1
);
18613 -- If no Entity, means there was a prior error so ignore
18615 if Present
(Entity
(Arg1
)) then
18616 Ent
:= Entity
(Arg1
);
18618 -- Apply error checks
18620 if not Is_First_Subtype
(Ent
) then
18622 ("cannot apply pragma %",
18623 "\& is not a first subtype",
18626 elsif not Is_Integer_Type
(Ent
) then
18628 ("cannot apply pragma %",
18629 "\& is not an integer type",
18632 elsif Has_Shift_Operator
(Ent
) then
18634 ("cannot apply pragma %",
18635 "\& already has declared shift operators",
18638 elsif Is_Frozen
(Ent
) then
18640 ("pragma % appears too late",
18641 "\& is already frozen",
18645 -- Now declare the operators. We do this during analysis rather
18646 -- than expansion, since we want the operators available if we
18647 -- are operating in -gnatc or ASIS mode.
18649 Declare_Shift_Operator
(Name_Rotate_Left
);
18650 Declare_Shift_Operator
(Name_Rotate_Right
);
18651 Declare_Shift_Operator
(Name_Shift_Left
);
18652 Declare_Shift_Operator
(Name_Shift_Right
);
18653 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18655 end Provide_Shift_Operators
;
18661 -- pragma Psect_Object (
18662 -- [Internal =>] LOCAL_NAME,
18663 -- [, [External =>] EXTERNAL_SYMBOL]
18664 -- [, [Size =>] EXTERNAL_SYMBOL]);
18666 when Pragma_Psect_Object | Pragma_Common_Object
=>
18667 Psect_Object
: declare
18668 Args
: Args_List
(1 .. 3);
18669 Names
: constant Name_List
(1 .. 3) := (
18674 Internal
: Node_Id
renames Args
(1);
18675 External
: Node_Id
renames Args
(2);
18676 Size
: Node_Id
renames Args
(3);
18678 Def_Id
: Entity_Id
;
18680 procedure Check_Arg
(Arg
: Node_Id
);
18681 -- Checks that argument is either a string literal or an
18682 -- identifier, and posts error message if not.
18688 procedure Check_Arg
(Arg
: Node_Id
) is
18690 if not Nkind_In
(Original_Node
(Arg
),
18695 ("inappropriate argument for pragma %", Arg
);
18699 -- Start of processing for Common_Object/Psect_Object
18703 Gather_Associations
(Names
, Args
);
18704 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18706 Def_Id
:= Entity
(Internal
);
18708 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18710 ("pragma% must designate an object", Internal
);
18713 Check_Arg
(Internal
);
18715 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18717 ("cannot use pragma% for imported/exported object",
18721 if Is_Concurrent_Type
(Etype
(Internal
)) then
18723 ("cannot specify pragma % for task/protected object",
18727 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18729 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18731 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18734 if Ekind
(Def_Id
) = E_Constant
then
18736 ("cannot specify pragma % for a constant", Internal
);
18739 if Is_Record_Type
(Etype
(Internal
)) then
18745 Ent
:= First_Entity
(Etype
(Internal
));
18746 while Present
(Ent
) loop
18747 Decl
:= Declaration_Node
(Ent
);
18749 if Ekind
(Ent
) = E_Component
18750 and then Nkind
(Decl
) = N_Component_Declaration
18751 and then Present
(Expression
(Decl
))
18752 and then Warn_On_Export_Import
18755 ("?x?object for pragma % has defaults", Internal
);
18765 if Present
(Size
) then
18769 if Present
(External
) then
18770 Check_Arg_Is_External_Name
(External
);
18773 -- If all error tests pass, link pragma on to the rep item chain
18775 Record_Rep_Item
(Def_Id
, N
);
18782 -- pragma Pure [(library_unit_NAME)];
18784 when Pragma_Pure
=> Pure
: declare
18788 Check_Ada_83_Warning
;
18789 Check_Valid_Library_Unit_Pragma
;
18791 if Nkind
(N
) = N_Null_Statement
then
18795 Ent
:= Find_Lib_Unit_Name
;
18797 Set_Has_Pragma_Pure
(Ent
);
18798 Set_Suppress_Elaboration_Warnings
(Ent
);
18801 -------------------
18802 -- Pure_Function --
18803 -------------------
18805 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18807 when Pragma_Pure_Function
=> Pure_Function
: declare
18810 Def_Id
: Entity_Id
;
18811 Effective
: Boolean := False;
18815 Check_Arg_Count
(1);
18816 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18817 Check_Arg_Is_Local_Name
(Arg1
);
18818 E_Id
:= Get_Pragma_Arg
(Arg1
);
18820 if Error_Posted
(E_Id
) then
18824 -- Loop through homonyms (overloadings) of referenced entity
18826 E
:= Entity
(E_Id
);
18828 if Present
(E
) then
18830 Def_Id
:= Get_Base_Subprogram
(E
);
18832 if not Ekind_In
(Def_Id
, E_Function
,
18833 E_Generic_Function
,
18837 ("pragma% requires a function name", Arg1
);
18840 Set_Is_Pure
(Def_Id
);
18842 if not Has_Pragma_Pure_Function
(Def_Id
) then
18843 Set_Has_Pragma_Pure_Function
(Def_Id
);
18847 exit when From_Aspect_Specification
(N
);
18849 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18853 and then Warn_On_Redundant_Constructs
18856 ("pragma Pure_Function on& is redundant?r?",
18862 --------------------
18863 -- Queuing_Policy --
18864 --------------------
18866 -- pragma Queuing_Policy (policy_IDENTIFIER);
18868 when Pragma_Queuing_Policy
=> declare
18872 Check_Ada_83_Warning
;
18873 Check_Arg_Count
(1);
18874 Check_No_Identifiers
;
18875 Check_Arg_Is_Queuing_Policy
(Arg1
);
18876 Check_Valid_Configuration_Pragma
;
18877 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18878 QP
:= Fold_Upper
(Name_Buffer
(1));
18880 if Queuing_Policy
/= ' '
18881 and then Queuing_Policy
/= QP
18883 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18884 Error_Pragma
("queuing policy incompatible with policy#");
18886 -- Set new policy, but always preserve System_Location since we
18887 -- like the error message with the run time name.
18890 Queuing_Policy
:= QP
;
18892 if Queuing_Policy_Sloc
/= System_Location
then
18893 Queuing_Policy_Sloc
:= Loc
;
18902 -- pragma Rational, for compatibility with foreign compiler
18904 when Pragma_Rational
=>
18905 Set_Rational_Profile
;
18907 ------------------------------------
18908 -- Refined_Depends/Refined_Global --
18909 ------------------------------------
18911 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18913 -- DEPENDENCY_RELATION ::=
18915 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18917 -- DEPENDENCY_CLAUSE ::=
18918 -- OUTPUT_LIST =>[+] INPUT_LIST
18919 -- | NULL_DEPENDENCY_CLAUSE
18921 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18923 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18925 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18927 -- OUTPUT ::= NAME | FUNCTION_RESULT
18930 -- where FUNCTION_RESULT is a function Result attribute_reference
18932 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18934 -- GLOBAL_SPECIFICATION ::=
18937 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18939 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18941 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18942 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18943 -- GLOBAL_ITEM ::= NAME
18945 when Pragma_Refined_Depends |
18946 Pragma_Refined_Global
=> Refined_Depends_Global
:
18948 Body_Id
: Entity_Id
;
18950 Spec_Id
: Entity_Id
;
18953 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18955 -- Save the pragma in the contract of the subprogram body. The
18956 -- remaining analysis is performed at the end of the enclosing
18960 Add_Contract_Item
(N
, Body_Id
);
18962 end Refined_Depends_Global
;
18968 -- pragma Refined_Post (boolean_EXPRESSION);
18970 when Pragma_Refined_Post
=> Refined_Post
: declare
18971 Body_Id
: Entity_Id
;
18973 Result_Seen
: Boolean := False;
18974 Spec_Id
: Entity_Id
;
18977 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18979 -- Analyze the boolean expression as a "spec expression"
18982 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
18984 -- Verify that the refined postcondition mentions attribute
18985 -- 'Result and its expression introduces a post-state.
18987 if Warn_On_Suspicious_Contract
18988 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
18990 Check_Result_And_Post_State
(N
, Result_Seen
);
18992 if not Result_Seen
then
18994 ("pragma % does not mention function result?T?");
18998 -- Chain the pragma on the contract for easy retrieval
19000 Add_Contract_Item
(N
, Body_Id
);
19004 -------------------
19005 -- Refined_State --
19006 -------------------
19008 -- pragma Refined_State (REFINEMENT_LIST);
19010 -- REFINEMENT_LIST ::=
19011 -- REFINEMENT_CLAUSE
19012 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19014 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19016 -- CONSTITUENT_LIST ::=
19019 -- | (CONSTITUENT {, CONSTITUENT})
19021 -- CONSTITUENT ::= object_NAME | state_NAME
19023 when Pragma_Refined_State
=> Refined_State
: declare
19024 Context
: constant Node_Id
:= Parent
(N
);
19025 Spec_Id
: Entity_Id
;
19030 Check_No_Identifiers
;
19031 Check_Arg_Count
(1);
19033 -- Ensure the proper placement of the pragma. Refined states must
19034 -- be associated with a package body.
19036 if Nkind
(Context
) /= N_Package_Body
then
19042 while Present
(Stmt
) loop
19044 -- Skip prior pragmas, but check for duplicates
19046 if Nkind
(Stmt
) = N_Pragma
then
19047 if Pragma_Name
(Stmt
) = Pname
then
19048 Error_Msg_Name_1
:= Pname
;
19049 Error_Msg_Sloc
:= Sloc
(Stmt
);
19050 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
19053 -- Skip internally generated code
19055 elsif not Comes_From_Source
(Stmt
) then
19058 -- The pragma does not apply to a legal construct, issue an
19059 -- error and stop the analysis.
19066 Stmt
:= Prev
(Stmt
);
19069 Spec_Id
:= Corresponding_Spec
(Context
);
19071 -- State refinement is allowed only when the corresponding package
19072 -- declaration has non-null pragma Abstract_State. Refinement not
19073 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19075 if SPARK_Mode
/= Off
19077 (No
(Abstract_States
(Spec_Id
))
19078 or else Has_Null_Abstract_State
(Spec_Id
))
19081 ("useless refinement, package & does not define abstract "
19082 & "states", N
, Spec_Id
);
19086 -- The pragma must be analyzed at the end of the declarations as
19087 -- it has visibility over the whole declarative region. Save the
19088 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19089 -- adding it to the contract of the package body.
19091 Add_Contract_Item
(N
, Defining_Entity
(Context
));
19094 -----------------------
19095 -- Relative_Deadline --
19096 -----------------------
19098 -- pragma Relative_Deadline (time_span_EXPRESSION);
19100 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19101 P
: constant Node_Id
:= Parent
(N
);
19106 Check_No_Identifiers
;
19107 Check_Arg_Count
(1);
19109 Arg
:= Get_Pragma_Arg
(Arg1
);
19111 -- The expression must be analyzed in the special manner described
19112 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19114 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19118 if Nkind
(P
) = N_Subprogram_Body
then
19119 Check_In_Main_Program
;
19121 -- Only Task and subprogram cases allowed
19123 elsif Nkind
(P
) /= N_Task_Definition
then
19127 -- Check duplicate pragma before we set the corresponding flag
19129 if Has_Relative_Deadline_Pragma
(P
) then
19130 Error_Pragma
("duplicate pragma% not allowed");
19133 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19134 -- Relative_Deadline pragma node cannot be inserted in the Rep
19135 -- Item chain of Ent since it is rewritten by the expander as a
19136 -- procedure call statement that will break the chain.
19138 Set_Has_Relative_Deadline_Pragma
(P
, True);
19139 end Relative_Deadline
;
19141 ------------------------
19142 -- Remote_Access_Type --
19143 ------------------------
19145 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19147 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19152 Check_Arg_Count
(1);
19153 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19154 Check_Arg_Is_Local_Name
(Arg1
);
19156 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19158 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19159 and then Ekind
(E
) = E_General_Access_Type
19160 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19161 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19163 and then Is_Valid_Remote_Object_Type
19164 (Root_Type
(Directly_Designated_Type
(E
)))
19166 Set_Is_Remote_Types
(E
);
19170 ("pragma% applies only to formal access to classwide types",
19173 end Remote_Access_Type
;
19175 ---------------------------
19176 -- Remote_Call_Interface --
19177 ---------------------------
19179 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19181 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19182 Cunit_Node
: Node_Id
;
19183 Cunit_Ent
: Entity_Id
;
19187 Check_Ada_83_Warning
;
19188 Check_Valid_Library_Unit_Pragma
;
19190 if Nkind
(N
) = N_Null_Statement
then
19194 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19195 K
:= Nkind
(Unit
(Cunit_Node
));
19196 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19198 if K
= N_Package_Declaration
19199 or else K
= N_Generic_Package_Declaration
19200 or else K
= N_Subprogram_Declaration
19201 or else K
= N_Generic_Subprogram_Declaration
19202 or else (K
= N_Subprogram_Body
19203 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19208 "pragma% must apply to package or subprogram declaration");
19211 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19212 end Remote_Call_Interface
;
19218 -- pragma Remote_Types [(library_unit_NAME)];
19220 when Pragma_Remote_Types
=> Remote_Types
: declare
19221 Cunit_Node
: Node_Id
;
19222 Cunit_Ent
: Entity_Id
;
19225 Check_Ada_83_Warning
;
19226 Check_Valid_Library_Unit_Pragma
;
19228 if Nkind
(N
) = N_Null_Statement
then
19232 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19233 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19235 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19236 N_Generic_Package_Declaration
)
19239 ("pragma% can only apply to a package declaration");
19242 Set_Is_Remote_Types
(Cunit_Ent
);
19249 -- pragma Ravenscar;
19251 when Pragma_Ravenscar
=>
19253 Check_Arg_Count
(0);
19254 Check_Valid_Configuration_Pragma
;
19255 Set_Ravenscar_Profile
(N
);
19257 if Warn_On_Obsolescent_Feature
then
19259 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19261 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19264 -------------------------
19265 -- Restricted_Run_Time --
19266 -------------------------
19268 -- pragma Restricted_Run_Time;
19270 when Pragma_Restricted_Run_Time
=>
19272 Check_Arg_Count
(0);
19273 Check_Valid_Configuration_Pragma
;
19274 Set_Profile_Restrictions
19275 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19277 if Warn_On_Obsolescent_Feature
then
19279 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19282 ("|use pragma Profile (Restricted) instead?j?", N
);
19289 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19292 -- restriction_IDENTIFIER
19293 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19295 when Pragma_Restrictions
=>
19296 Process_Restrictions_Or_Restriction_Warnings
19297 (Warn
=> Treat_Restrictions_As_Warnings
);
19299 --------------------------
19300 -- Restriction_Warnings --
19301 --------------------------
19303 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19306 -- restriction_IDENTIFIER
19307 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19309 when Pragma_Restriction_Warnings
=>
19311 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19317 -- pragma Reviewable;
19319 when Pragma_Reviewable
=>
19320 Check_Ada_83_Warning
;
19321 Check_Arg_Count
(0);
19323 -- Call dummy debugging function rv. This is done to assist front
19324 -- end debugging. By placing a Reviewable pragma in the source
19325 -- program, a breakpoint on rv catches this place in the source,
19326 -- allowing convenient stepping to the point of interest.
19330 --------------------------
19331 -- Short_Circuit_And_Or --
19332 --------------------------
19334 -- pragma Short_Circuit_And_Or;
19336 when Pragma_Short_Circuit_And_Or
=>
19338 Check_Arg_Count
(0);
19339 Check_Valid_Configuration_Pragma
;
19340 Short_Circuit_And_Or
:= True;
19342 -------------------
19343 -- Share_Generic --
19344 -------------------
19346 -- pragma Share_Generic (GNAME {, GNAME});
19348 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19350 when Pragma_Share_Generic
=>
19352 Process_Generic_List
;
19358 -- pragma Shared (LOCAL_NAME);
19360 when Pragma_Shared
=>
19362 Process_Atomic_Shared_Volatile
;
19364 --------------------
19365 -- Shared_Passive --
19366 --------------------
19368 -- pragma Shared_Passive [(library_unit_NAME)];
19370 -- Set the flag Is_Shared_Passive of program unit name entity
19372 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19373 Cunit_Node
: Node_Id
;
19374 Cunit_Ent
: Entity_Id
;
19377 Check_Ada_83_Warning
;
19378 Check_Valid_Library_Unit_Pragma
;
19380 if Nkind
(N
) = N_Null_Statement
then
19384 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19385 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19387 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19388 N_Generic_Package_Declaration
)
19391 ("pragma% can only apply to a package declaration");
19394 Set_Is_Shared_Passive
(Cunit_Ent
);
19395 end Shared_Passive
;
19397 -----------------------
19398 -- Short_Descriptors --
19399 -----------------------
19401 -- pragma Short_Descriptors;
19403 -- Recognize and validate, but otherwise ignore
19405 when Pragma_Short_Descriptors
=>
19407 Check_Arg_Count
(0);
19408 Check_Valid_Configuration_Pragma
;
19410 ------------------------------
19411 -- Simple_Storage_Pool_Type --
19412 ------------------------------
19414 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19416 when Pragma_Simple_Storage_Pool_Type
=>
19417 Simple_Storage_Pool_Type
: declare
19423 Check_Arg_Count
(1);
19424 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19426 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19427 Find_Type
(Type_Id
);
19428 Typ
:= Entity
(Type_Id
);
19430 if Typ
= Any_Type
then
19434 -- We require the pragma to apply to a type declared in a package
19435 -- declaration, but not (immediately) within a package body.
19437 if Ekind
(Current_Scope
) /= E_Package
19438 or else In_Package_Body
(Current_Scope
)
19441 ("pragma% can only apply to type declared immediately "
19442 & "within a package declaration");
19445 -- A simple storage pool type must be an immutably limited record
19446 -- or private type. If the pragma is given for a private type,
19447 -- the full type is similarly restricted (which is checked later
19448 -- in Freeze_Entity).
19450 if Is_Record_Type
(Typ
)
19451 and then not Is_Limited_View
(Typ
)
19454 ("pragma% can only apply to explicitly limited record type");
19456 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19458 ("pragma% can only apply to a private type that is limited");
19460 elsif not Is_Record_Type
(Typ
)
19461 and then not Is_Private_Type
(Typ
)
19464 ("pragma% can only apply to limited record or private type");
19467 Record_Rep_Item
(Typ
, N
);
19468 end Simple_Storage_Pool_Type
;
19470 ----------------------
19471 -- Source_File_Name --
19472 ----------------------
19474 -- There are five forms for this pragma:
19476 -- pragma Source_File_Name (
19477 -- [UNIT_NAME =>] unit_NAME,
19478 -- BODY_FILE_NAME => STRING_LITERAL
19479 -- [, [INDEX =>] INTEGER_LITERAL]);
19481 -- pragma Source_File_Name (
19482 -- [UNIT_NAME =>] unit_NAME,
19483 -- SPEC_FILE_NAME => STRING_LITERAL
19484 -- [, [INDEX =>] INTEGER_LITERAL]);
19486 -- pragma Source_File_Name (
19487 -- BODY_FILE_NAME => STRING_LITERAL
19488 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19489 -- [, CASING => CASING_SPEC]);
19491 -- pragma Source_File_Name (
19492 -- SPEC_FILE_NAME => STRING_LITERAL
19493 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19494 -- [, CASING => CASING_SPEC]);
19496 -- pragma Source_File_Name (
19497 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19498 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19499 -- [, CASING => CASING_SPEC]);
19501 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19503 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19504 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19505 -- only be used when no project file is used, while SFNP can only be
19506 -- used when a project file is used.
19508 -- No processing here. Processing was completed during parsing, since
19509 -- we need to have file names set as early as possible. Units are
19510 -- loaded well before semantic processing starts.
19512 -- The only processing we defer to this point is the check for
19513 -- correct placement.
19515 when Pragma_Source_File_Name
=>
19517 Check_Valid_Configuration_Pragma
;
19519 ------------------------------
19520 -- Source_File_Name_Project --
19521 ------------------------------
19523 -- See Source_File_Name for syntax
19525 -- No processing here. Processing was completed during parsing, since
19526 -- we need to have file names set as early as possible. Units are
19527 -- loaded well before semantic processing starts.
19529 -- The only processing we defer to this point is the check for
19530 -- correct placement.
19532 when Pragma_Source_File_Name_Project
=>
19534 Check_Valid_Configuration_Pragma
;
19536 -- Check that a pragma Source_File_Name_Project is used only in a
19537 -- configuration pragmas file.
19539 -- Pragmas Source_File_Name_Project should only be generated by
19540 -- the Project Manager in configuration pragmas files.
19542 -- This is really an ugly test. It seems to depend on some
19543 -- accidental and undocumented property. At the very least it
19544 -- needs to be documented, but it would be better to have a
19545 -- clean way of testing if we are in a configuration file???
19547 if Present
(Parent
(N
)) then
19549 ("pragma% can only appear in a configuration pragmas file");
19552 ----------------------
19553 -- Source_Reference --
19554 ----------------------
19556 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19558 -- Nothing to do, all processing completed in Par.Prag, since we need
19559 -- the information for possible parser messages that are output.
19561 when Pragma_Source_Reference
=>
19568 -- pragma SPARK_Mode [(On | Off)];
19570 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19571 Mode_Id
: SPARK_Mode_Type
;
19573 procedure Check_Pragma_Conformance
19574 (Context_Pragma
: Node_Id
;
19575 Entity_Pragma
: Node_Id
;
19576 Entity
: Entity_Id
);
19577 -- If Context_Pragma is not Empty, verify that the new pragma N
19578 -- is compatible with the pragma Context_Pragma that was inherited
19579 -- from the context:
19580 -- . if Context_Pragma is ON, then the new mode can be anything
19581 -- . if Context_Pragma is OFF, then the only allowed new mode is
19584 -- If Entity is not Empty, verify that the new pragma N is
19585 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19586 -- for Entity (which may be Empty):
19587 -- . if Entity_Pragma is ON, then the new mode can be anything
19588 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19590 -- . if Entity_Pragma is Empty, we always issue an error, as this
19591 -- corresponds to a case where a previous section of Entity
19592 -- had no SPARK_Mode set.
19594 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19595 -- Verify that pragma is applied to library-level entity E
19597 procedure Set_SPARK_Flags
;
19598 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19599 -- and ensures that Dynamic_Elaboration_Checks are off if the
19600 -- call sets SPARK_Mode On.
19602 ------------------------------
19603 -- Check_Pragma_Conformance --
19604 ------------------------------
19606 procedure Check_Pragma_Conformance
19607 (Context_Pragma
: Node_Id
;
19608 Entity_Pragma
: Node_Id
;
19609 Entity
: Entity_Id
)
19612 if Present
(Context_Pragma
) then
19613 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19615 -- New mode less restrictive than the established mode
19617 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19618 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19621 ("cannot change SPARK_Mode from Off to On", Arg1
);
19622 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19623 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg1
);
19628 if Present
(Entity
) then
19629 if Present
(Entity_Pragma
) then
19630 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19631 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19633 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19634 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19636 ("\value Off was set for SPARK_Mode on&#",
19642 Error_Msg_N
("incorrect use of SPARK_Mode", Arg1
);
19643 Error_Msg_Sloc
:= Sloc
(Entity
);
19645 ("\no value was set for SPARK_Mode on&#",
19650 end Check_Pragma_Conformance
;
19652 --------------------------------
19653 -- Check_Library_Level_Entity --
19654 --------------------------------
19656 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19657 MsgF
: constant String := "incorrect placement of pragma%";
19660 if not Is_Library_Level_Entity
(E
) then
19661 Error_Msg_Name_1
:= Pname
;
19662 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19664 if Ekind_In
(E
, E_Generic_Package
,
19669 ("\& is not a library-level package", N
, E
);
19672 ("\& is not a library-level subprogram", N
, E
);
19677 end Check_Library_Level_Entity
;
19679 ---------------------
19680 -- Set_SPARK_Flags --
19681 ---------------------
19683 procedure Set_SPARK_Flags
is
19685 SPARK_Mode
:= Mode_Id
;
19686 SPARK_Mode_Pragma
:= N
;
19688 if SPARK_Mode
= On
then
19689 Dynamic_Elaboration_Checks
:= False;
19691 end Set_SPARK_Flags
;
19695 Body_Id
: Entity_Id
;
19698 Spec_Id
: Entity_Id
;
19701 -- Start of processing for Do_SPARK_Mode
19704 -- When a SPARK_Mode pragma appears inside an instantiation whose
19705 -- enclosing context has SPARK_Mode set to "off", the pragma has
19706 -- no semantic effect.
19708 if Ignore_Pragma_SPARK_Mode
then
19709 Rewrite
(N
, Make_Null_Statement
(Loc
));
19715 Check_No_Identifiers
;
19716 Check_At_Most_N_Arguments
(1);
19718 -- Check the legality of the mode (no argument = ON)
19720 if Arg_Count
= 1 then
19721 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19722 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19727 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19728 Context
:= Parent
(N
);
19730 -- The pragma appears in a configuration pragmas file
19732 if No
(Context
) then
19733 Check_Valid_Configuration_Pragma
;
19735 if Present
(SPARK_Mode_Pragma
) then
19736 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19737 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19743 -- The pragma acts as a configuration pragma in a compilation unit
19745 -- pragma SPARK_Mode ...;
19746 -- package Pack is ...;
19748 elsif Nkind
(Context
) = N_Compilation_Unit
19749 and then List_Containing
(N
) = Context_Items
(Context
)
19751 Check_Valid_Configuration_Pragma
;
19754 -- Otherwise the placement of the pragma within the tree dictates
19755 -- its associated construct. Inspect the declarative list where
19756 -- the pragma resides to find a potential construct.
19760 while Present
(Stmt
) loop
19762 -- Skip prior pragmas, but check for duplicates
19764 if Nkind
(Stmt
) = N_Pragma
then
19765 if Pragma_Name
(Stmt
) = Pname
then
19766 Error_Msg_Name_1
:= Pname
;
19767 Error_Msg_Sloc
:= Sloc
(Stmt
);
19768 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19772 -- The pragma applies to a [generic] subprogram declaration.
19773 -- Note that this case covers an internally generated spec
19774 -- for a stand alone body.
19777 -- procedure Proc ...;
19778 -- pragma SPARK_Mode ..;
19780 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19781 N_Subprogram_Declaration
)
19783 Spec_Id
:= Defining_Entity
(Stmt
);
19784 Check_Library_Level_Entity
(Spec_Id
);
19785 Check_Pragma_Conformance
19786 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19787 Entity_Pragma
=> Empty
,
19790 Set_SPARK_Pragma
(Spec_Id
, N
);
19791 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19794 -- Skip internally generated code
19796 elsif not Comes_From_Source
(Stmt
) then
19799 -- Otherwise the pragma does not apply to a legal construct
19800 -- or it does not appear at the top of a declarative or a
19801 -- statement list. Issue an error and stop the analysis.
19811 -- The pragma applies to a package or a subprogram that acts as
19812 -- a compilation unit.
19814 -- procedure Proc ...;
19815 -- pragma SPARK_Mode ...;
19817 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19818 Context
:= Unit
(Parent
(Context
));
19821 -- The pragma appears within package declarations
19823 if Nkind
(Context
) = N_Package_Specification
then
19824 Spec_Id
:= Defining_Entity
(Context
);
19825 Check_Library_Level_Entity
(Spec_Id
);
19827 -- The pragma is at the top of the visible declarations
19830 -- pragma SPARK_Mode ...;
19832 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19833 Check_Pragma_Conformance
19834 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19835 Entity_Pragma
=> Empty
,
19839 Set_SPARK_Pragma
(Spec_Id
, N
);
19840 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19841 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19842 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19844 -- The pragma is at the top of the private declarations
19848 -- pragma SPARK_Mode ...;
19851 Check_Pragma_Conformance
19852 (Context_Pragma
=> Empty
,
19853 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19854 Entity
=> Spec_Id
);
19857 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19858 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19861 -- The pragma appears at the top of package body declarations
19863 -- package body Pack is
19864 -- pragma SPARK_Mode ...;
19866 elsif Nkind
(Context
) = N_Package_Body
then
19867 Spec_Id
:= Corresponding_Spec
(Context
);
19868 Body_Id
:= Defining_Entity
(Context
);
19869 Check_Library_Level_Entity
(Body_Id
);
19870 Check_Pragma_Conformance
19871 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19872 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19873 Entity
=> Spec_Id
);
19876 Set_SPARK_Pragma
(Body_Id
, N
);
19877 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19878 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19879 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19881 -- The pragma appears at the top of package body statements
19883 -- package body Pack is
19885 -- pragma SPARK_Mode;
19887 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19888 and then Nkind
(Parent
(Context
)) = N_Package_Body
19890 Context
:= Parent
(Context
);
19891 Spec_Id
:= Corresponding_Spec
(Context
);
19892 Body_Id
:= Defining_Entity
(Context
);
19893 Check_Library_Level_Entity
(Body_Id
);
19894 Check_Pragma_Conformance
19895 (Context_Pragma
=> Empty
,
19896 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19897 Entity
=> Body_Id
);
19900 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19901 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19903 -- The pragma appeared as an aspect of a [generic] subprogram
19904 -- declaration that acts as a compilation unit.
19907 -- procedure Proc ...;
19908 -- pragma SPARK_Mode ...;
19910 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19911 N_Subprogram_Declaration
)
19913 Spec_Id
:= Defining_Entity
(Context
);
19914 Check_Library_Level_Entity
(Spec_Id
);
19915 Check_Pragma_Conformance
19916 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19917 Entity_Pragma
=> Empty
,
19920 Set_SPARK_Pragma
(Spec_Id
, N
);
19921 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19923 -- The pragma appears at the top of subprogram body
19926 -- procedure Proc ... is
19927 -- pragma SPARK_Mode;
19929 elsif Nkind
(Context
) = N_Subprogram_Body
then
19930 Spec_Id
:= Corresponding_Spec
(Context
);
19931 Context
:= Specification
(Context
);
19932 Body_Id
:= Defining_Entity
(Context
);
19934 -- Ignore pragma when applied to the special body created
19935 -- for inlining, recognized by its internal name _Parent.
19937 if Chars
(Body_Id
) = Name_uParent
then
19941 Check_Library_Level_Entity
(Body_Id
);
19943 -- The body is a completion of a previous declaration
19945 if Present
(Spec_Id
) then
19946 Check_Pragma_Conformance
19947 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19948 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19949 Entity
=> Spec_Id
);
19951 -- The body acts as spec
19954 Check_Pragma_Conformance
19955 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19956 Entity_Pragma
=> Empty
,
19962 Set_SPARK_Pragma
(Body_Id
, N
);
19963 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19965 -- The pragma does not apply to a legal construct, issue error
19973 --------------------------------
19974 -- Static_Elaboration_Desired --
19975 --------------------------------
19977 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19979 when Pragma_Static_Elaboration_Desired
=>
19981 Check_At_Most_N_Arguments
(1);
19983 if Is_Compilation_Unit
(Current_Scope
)
19984 and then Ekind
(Current_Scope
) = E_Package
19986 Set_Static_Elaboration_Desired
(Current_Scope
, True);
19988 Error_Pragma
("pragma% must apply to a library-level package");
19995 -- pragma Storage_Size (EXPRESSION);
19997 when Pragma_Storage_Size
=> Storage_Size
: declare
19998 P
: constant Node_Id
:= Parent
(N
);
20002 Check_No_Identifiers
;
20003 Check_Arg_Count
(1);
20005 -- The expression must be analyzed in the special manner described
20006 -- in "Handling of Default Expressions" in sem.ads.
20008 Arg
:= Get_Pragma_Arg
(Arg1
);
20009 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20011 if not Is_OK_Static_Expression
(Arg
) then
20012 Check_Restriction
(Static_Storage_Size
, Arg
);
20015 if Nkind
(P
) /= N_Task_Definition
then
20020 if Has_Storage_Size_Pragma
(P
) then
20021 Error_Pragma
("duplicate pragma% not allowed");
20023 Set_Has_Storage_Size_Pragma
(P
, True);
20026 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20034 -- pragma Storage_Unit (NUMERIC_LITERAL);
20036 -- Only permitted argument is System'Storage_Unit value
20038 when Pragma_Storage_Unit
=>
20039 Check_No_Identifiers
;
20040 Check_Arg_Count
(1);
20041 Check_Arg_Is_Integer_Literal
(Arg1
);
20043 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20044 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20046 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20048 ("the only allowed argument for pragma% is ^", Arg1
);
20051 --------------------
20052 -- Stream_Convert --
20053 --------------------
20055 -- pragma Stream_Convert (
20056 -- [Entity =>] type_LOCAL_NAME,
20057 -- [Read =>] function_NAME,
20058 -- [Write =>] function NAME);
20060 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20062 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20063 -- Check that the given argument is the name of a local function
20064 -- of one argument that is not overloaded earlier in the current
20065 -- local scope. A check is also made that the argument is a
20066 -- function with one parameter.
20068 --------------------------------------
20069 -- Check_OK_Stream_Convert_Function --
20070 --------------------------------------
20072 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20076 Check_Arg_Is_Local_Name
(Arg
);
20077 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20079 if Has_Homonym
(Ent
) then
20081 ("argument for pragma% may not be overloaded", Arg
);
20084 if Ekind
(Ent
) /= E_Function
20085 or else No
(First_Formal
(Ent
))
20086 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20089 ("argument for pragma% must be function of one argument",
20092 end Check_OK_Stream_Convert_Function
;
20094 -- Start of processing for Stream_Convert
20098 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20099 Check_Arg_Count
(3);
20100 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20101 Check_Optional_Identifier
(Arg2
, Name_Read
);
20102 Check_Optional_Identifier
(Arg3
, Name_Write
);
20103 Check_Arg_Is_Local_Name
(Arg1
);
20104 Check_OK_Stream_Convert_Function
(Arg2
);
20105 Check_OK_Stream_Convert_Function
(Arg3
);
20108 Typ
: constant Entity_Id
:=
20109 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20110 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20111 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20114 Check_First_Subtype
(Arg1
);
20116 -- Check for too early or too late. Note that we don't enforce
20117 -- the rule about primitive operations in this case, since, as
20118 -- is the case for explicit stream attributes themselves, these
20119 -- restrictions are not appropriate. Note that the chaining of
20120 -- the pragma by Rep_Item_Too_Late is actually the critical
20121 -- processing done for this pragma.
20123 if Rep_Item_Too_Early
(Typ
, N
)
20125 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20130 -- Return if previous error
20132 if Etype
(Typ
) = Any_Type
20134 Etype
(Read
) = Any_Type
20136 Etype
(Write
) = Any_Type
20143 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20145 ("incorrect return type for function&", Arg2
);
20148 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20150 ("incorrect parameter type for function&", Arg3
);
20153 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20154 Underlying_Type
(Etype
(Write
))
20157 ("result type of & does not match Read parameter type",
20161 end Stream_Convert
;
20167 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20169 -- This is processed by the parser since some of the style checks
20170 -- take place during source scanning and parsing. This means that
20171 -- we don't need to issue error messages here.
20173 when Pragma_Style_Checks
=> Style_Checks
: declare
20174 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20180 Check_No_Identifiers
;
20182 -- Two argument form
20184 if Arg_Count
= 2 then
20185 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20192 E_Id
:= Get_Pragma_Arg
(Arg2
);
20195 if not Is_Entity_Name
(E_Id
) then
20197 ("second argument of pragma% must be entity name",
20201 E
:= Entity
(E_Id
);
20203 if not Ignore_Style_Checks_Pragmas
then
20208 Set_Suppress_Style_Checks
20209 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20210 exit when No
(Homonym
(E
));
20217 -- One argument form
20220 Check_Arg_Count
(1);
20222 if Nkind
(A
) = N_String_Literal
then
20226 Slen
: constant Natural := Natural (String_Length
(S
));
20227 Options
: String (1 .. Slen
);
20233 C
:= Get_String_Char
(S
, Int
(J
));
20234 exit when not In_Character_Range
(C
);
20235 Options
(J
) := Get_Character
(C
);
20237 -- If at end of string, set options. As per discussion
20238 -- above, no need to check for errors, since we issued
20239 -- them in the parser.
20242 if not Ignore_Style_Checks_Pragmas
then
20243 Set_Style_Check_Options
(Options
);
20253 elsif Nkind
(A
) = N_Identifier
then
20254 if Chars
(A
) = Name_All_Checks
then
20255 if not Ignore_Style_Checks_Pragmas
then
20257 Set_GNAT_Style_Check_Options
;
20259 Set_Default_Style_Check_Options
;
20263 elsif Chars
(A
) = Name_On
then
20264 if not Ignore_Style_Checks_Pragmas
then
20265 Style_Check
:= True;
20268 elsif Chars
(A
) = Name_Off
then
20269 if not Ignore_Style_Checks_Pragmas
then
20270 Style_Check
:= False;
20281 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20283 when Pragma_Subtitle
=>
20285 Check_Arg_Count
(1);
20286 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20287 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20294 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20296 when Pragma_Suppress
=>
20297 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
20303 -- pragma Suppress_All;
20305 -- The only check made here is that the pragma has no arguments.
20306 -- There are no placement rules, and the processing required (setting
20307 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20308 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20309 -- then creates and inserts a pragma Suppress (All_Checks).
20311 when Pragma_Suppress_All
=>
20313 Check_Arg_Count
(0);
20315 -------------------------
20316 -- Suppress_Debug_Info --
20317 -------------------------
20319 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20321 when Pragma_Suppress_Debug_Info
=>
20323 Check_Arg_Count
(1);
20324 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20325 Check_Arg_Is_Local_Name
(Arg1
);
20326 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20328 ----------------------------------
20329 -- Suppress_Exception_Locations --
20330 ----------------------------------
20332 -- pragma Suppress_Exception_Locations;
20334 when Pragma_Suppress_Exception_Locations
=>
20336 Check_Arg_Count
(0);
20337 Check_Valid_Configuration_Pragma
;
20338 Exception_Locations_Suppressed
:= True;
20340 -----------------------------
20341 -- Suppress_Initialization --
20342 -----------------------------
20344 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20346 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20352 Check_Arg_Count
(1);
20353 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20354 Check_Arg_Is_Local_Name
(Arg1
);
20356 E_Id
:= Get_Pragma_Arg
(Arg1
);
20358 if Etype
(E_Id
) = Any_Type
then
20362 E
:= Entity
(E_Id
);
20364 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20366 ("pragma% requires variable, type or subtype", Arg1
);
20369 if Rep_Item_Too_Early
(E
, N
)
20371 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20376 -- For incomplete/private type, set flag on full view
20378 if Is_Incomplete_Or_Private_Type
(E
) then
20379 if No
(Full_View
(Base_Type
(E
))) then
20381 ("argument of pragma% cannot be an incomplete type", Arg1
);
20383 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20386 -- For first subtype, set flag on base type
20388 elsif Is_First_Subtype
(E
) then
20389 Set_Suppress_Initialization
(Base_Type
(E
));
20391 -- For other than first subtype, set flag on subtype or variable
20394 Set_Suppress_Initialization
(E
);
20402 -- pragma System_Name (DIRECT_NAME);
20404 -- Syntax check: one argument, which must be the identifier GNAT or
20405 -- the identifier GCC, no other identifiers are acceptable.
20407 when Pragma_System_Name
=>
20409 Check_No_Identifiers
;
20410 Check_Arg_Count
(1);
20411 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20413 -----------------------------
20414 -- Task_Dispatching_Policy --
20415 -----------------------------
20417 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20419 when Pragma_Task_Dispatching_Policy
=> declare
20423 Check_Ada_83_Warning
;
20424 Check_Arg_Count
(1);
20425 Check_No_Identifiers
;
20426 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20427 Check_Valid_Configuration_Pragma
;
20428 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20429 DP
:= Fold_Upper
(Name_Buffer
(1));
20431 if Task_Dispatching_Policy
/= ' '
20432 and then Task_Dispatching_Policy
/= DP
20434 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20436 ("task dispatching policy incompatible with policy#");
20438 -- Set new policy, but always preserve System_Location since we
20439 -- like the error message with the run time name.
20442 Task_Dispatching_Policy
:= DP
;
20444 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20445 Task_Dispatching_Policy_Sloc
:= Loc
;
20454 -- pragma Task_Info (EXPRESSION);
20456 when Pragma_Task_Info
=> Task_Info
: declare
20457 P
: constant Node_Id
:= Parent
(N
);
20463 if Warn_On_Obsolescent_Feature
then
20465 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20466 & "instead?j?", N
);
20469 if Nkind
(P
) /= N_Task_Definition
then
20470 Error_Pragma
("pragma% must appear in task definition");
20473 Check_No_Identifiers
;
20474 Check_Arg_Count
(1);
20476 Analyze_And_Resolve
20477 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20479 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20483 Ent
:= Defining_Identifier
(Parent
(P
));
20485 -- Check duplicate pragma before we chain the pragma in the Rep
20486 -- Item chain of Ent.
20489 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20491 Error_Pragma
("duplicate pragma% not allowed");
20494 Record_Rep_Item
(Ent
, N
);
20501 -- pragma Task_Name (string_EXPRESSION);
20503 when Pragma_Task_Name
=> Task_Name
: declare
20504 P
: constant Node_Id
:= Parent
(N
);
20509 Check_No_Identifiers
;
20510 Check_Arg_Count
(1);
20512 Arg
:= Get_Pragma_Arg
(Arg1
);
20514 -- The expression is used in the call to Create_Task, and must be
20515 -- expanded there, not in the context of the current spec. It must
20516 -- however be analyzed to capture global references, in case it
20517 -- appears in a generic context.
20519 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20521 if Nkind
(P
) /= N_Task_Definition
then
20525 Ent
:= Defining_Identifier
(Parent
(P
));
20527 -- Check duplicate pragma before we chain the pragma in the Rep
20528 -- Item chain of Ent.
20531 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20533 Error_Pragma
("duplicate pragma% not allowed");
20536 Record_Rep_Item
(Ent
, N
);
20543 -- pragma Task_Storage (
20544 -- [Task_Type =>] LOCAL_NAME,
20545 -- [Top_Guard =>] static_integer_EXPRESSION);
20547 when Pragma_Task_Storage
=> Task_Storage
: declare
20548 Args
: Args_List
(1 .. 2);
20549 Names
: constant Name_List
(1 .. 2) := (
20553 Task_Type
: Node_Id
renames Args
(1);
20554 Top_Guard
: Node_Id
renames Args
(2);
20560 Gather_Associations
(Names
, Args
);
20562 if No
(Task_Type
) then
20564 ("missing task_type argument for pragma%");
20567 Check_Arg_Is_Local_Name
(Task_Type
);
20569 Ent
:= Entity
(Task_Type
);
20571 if not Is_Task_Type
(Ent
) then
20573 ("argument for pragma% must be task type", Task_Type
);
20576 if No
(Top_Guard
) then
20578 ("pragma% takes two arguments", Task_Type
);
20580 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20583 Check_First_Subtype
(Task_Type
);
20585 if Rep_Item_Too_Late
(Ent
, N
) then
20594 -- pragma Test_Case
20595 -- ([Name =>] Static_String_EXPRESSION
20596 -- ,[Mode =>] MODE_TYPE
20597 -- [, Requires => Boolean_EXPRESSION]
20598 -- [, Ensures => Boolean_EXPRESSION]);
20600 -- MODE_TYPE ::= Nominal | Robustness
20602 when Pragma_Test_Case
=>
20606 --------------------------
20607 -- Thread_Local_Storage --
20608 --------------------------
20610 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20612 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20618 Check_Arg_Count
(1);
20619 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20620 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20622 Id
:= Get_Pragma_Arg
(Arg1
);
20625 if not Is_Entity_Name
(Id
)
20626 or else Ekind
(Entity
(Id
)) /= E_Variable
20628 Error_Pragma_Arg
("local variable name required", Arg1
);
20633 if Rep_Item_Too_Early
(E
, N
)
20634 or else Rep_Item_Too_Late
(E
, N
)
20639 Set_Has_Pragma_Thread_Local_Storage
(E
);
20640 Set_Has_Gigi_Rep_Item
(E
);
20641 end Thread_Local_Storage
;
20647 -- pragma Time_Slice (static_duration_EXPRESSION);
20649 when Pragma_Time_Slice
=> Time_Slice
: declare
20655 Check_Arg_Count
(1);
20656 Check_No_Identifiers
;
20657 Check_In_Main_Program
;
20658 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20660 if not Error_Posted
(Arg1
) then
20662 while Present
(Nod
) loop
20663 if Nkind
(Nod
) = N_Pragma
20664 and then Pragma_Name
(Nod
) = Name_Time_Slice
20666 Error_Msg_Name_1
:= Pname
;
20667 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20674 -- Process only if in main unit
20676 if Get_Source_Unit
(Loc
) = Main_Unit
then
20677 Opt
.Time_Slice_Set
:= True;
20678 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20680 if Val
<= Ureal_0
then
20681 Opt
.Time_Slice_Value
:= 0;
20683 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20684 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20687 Opt
.Time_Slice_Value
:=
20688 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20697 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20699 -- TITLING_OPTION ::=
20700 -- [Title =>] STRING_LITERAL
20701 -- | [Subtitle =>] STRING_LITERAL
20703 when Pragma_Title
=> Title
: declare
20704 Args
: Args_List
(1 .. 2);
20705 Names
: constant Name_List
(1 .. 2) := (
20711 Gather_Associations
(Names
, Args
);
20714 for J
in 1 .. 2 loop
20715 if Present
(Args
(J
)) then
20716 Check_Arg_Is_OK_Static_Expression
20717 (Args
(J
), Standard_String
);
20722 ----------------------------
20723 -- Type_Invariant[_Class] --
20724 ----------------------------
20726 -- pragma Type_Invariant[_Class]
20727 -- ([Entity =>] type_LOCAL_NAME,
20728 -- [Check =>] EXPRESSION);
20730 when Pragma_Type_Invariant |
20731 Pragma_Type_Invariant_Class
=>
20732 Type_Invariant
: declare
20733 I_Pragma
: Node_Id
;
20736 Check_Arg_Count
(2);
20738 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20739 -- setting Class_Present for the Type_Invariant_Class case.
20741 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20742 I_Pragma
:= New_Copy
(N
);
20743 Set_Pragma_Identifier
20744 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20745 Rewrite
(N
, I_Pragma
);
20746 Set_Analyzed
(N
, False);
20748 end Type_Invariant
;
20750 ---------------------
20751 -- Unchecked_Union --
20752 ---------------------
20754 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20756 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20757 Assoc
: constant Node_Id
:= Arg1
;
20758 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20768 Check_No_Identifiers
;
20769 Check_Arg_Count
(1);
20770 Check_Arg_Is_Local_Name
(Arg1
);
20772 Find_Type
(Type_Id
);
20774 Typ
:= Entity
(Type_Id
);
20777 or else Rep_Item_Too_Early
(Typ
, N
)
20781 Typ
:= Underlying_Type
(Typ
);
20784 if Rep_Item_Too_Late
(Typ
, N
) then
20788 Check_First_Subtype
(Arg1
);
20790 -- Note remaining cases are references to a type in the current
20791 -- declarative part. If we find an error, we post the error on
20792 -- the relevant type declaration at an appropriate point.
20794 if not Is_Record_Type
(Typ
) then
20795 Error_Msg_N
("unchecked union must be record type", Typ
);
20798 elsif Is_Tagged_Type
(Typ
) then
20799 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20802 elsif not Has_Discriminants
(Typ
) then
20804 ("unchecked union must have one discriminant", Typ
);
20807 -- Note: in previous versions of GNAT we used to check for limited
20808 -- types and give an error, but in fact the standard does allow
20809 -- Unchecked_Union on limited types, so this check was removed.
20811 -- Similarly, GNAT used to require that all discriminants have
20812 -- default values, but this is not mandated by the RM.
20814 -- Proceed with basic error checks completed
20817 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20818 Clist
:= Component_List
(Tdef
);
20820 -- Check presence of component list and variant part
20822 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20824 ("unchecked union must have variant part", Tdef
);
20828 -- Check components
20830 Comp
:= First
(Component_Items
(Clist
));
20831 while Present
(Comp
) loop
20832 Check_Component
(Comp
, Typ
);
20836 -- Check variant part
20838 Vpart
:= Variant_Part
(Clist
);
20840 Variant
:= First
(Variants
(Vpart
));
20841 while Present
(Variant
) loop
20842 Check_Variant
(Variant
, Typ
);
20847 Set_Is_Unchecked_Union
(Typ
);
20848 Set_Convention
(Typ
, Convention_C
);
20849 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20850 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20851 end Unchecked_Union
;
20853 ------------------------
20854 -- Unimplemented_Unit --
20855 ------------------------
20857 -- pragma Unimplemented_Unit;
20859 -- Note: this only gives an error if we are generating code, or if
20860 -- we are in a generic library unit (where the pragma appears in the
20861 -- body, not in the spec).
20863 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20864 Cunitent
: constant Entity_Id
:=
20865 Cunit_Entity
(Get_Source_Unit
(Loc
));
20866 Ent_Kind
: constant Entity_Kind
:=
20871 Check_Arg_Count
(0);
20873 if Operating_Mode
= Generate_Code
20874 or else Ent_Kind
= E_Generic_Function
20875 or else Ent_Kind
= E_Generic_Procedure
20876 or else Ent_Kind
= E_Generic_Package
20878 Get_Name_String
(Chars
(Cunitent
));
20879 Set_Casing
(Mixed_Case
);
20880 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20881 Write_Str
(" is not supported in this configuration");
20883 raise Unrecoverable_Error
;
20885 end Unimplemented_Unit
;
20887 ------------------------
20888 -- Universal_Aliasing --
20889 ------------------------
20891 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20893 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20898 Check_Arg_Count
(1);
20899 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20900 Check_Arg_Is_Local_Name
(Arg1
);
20901 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20903 if E_Id
= Any_Type
then
20905 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20906 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20909 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20910 Record_Rep_Item
(E_Id
, N
);
20911 end Universal_Alias
;
20913 --------------------
20914 -- Universal_Data --
20915 --------------------
20917 -- pragma Universal_Data [(library_unit_NAME)];
20919 when Pragma_Universal_Data
=>
20922 -- If this is a configuration pragma, then set the universal
20923 -- addressing option, otherwise confirm that the pragma satisfies
20924 -- the requirements of library unit pragma placement and leave it
20925 -- to the GNAAMP back end to detect the pragma (avoids transitive
20926 -- setting of the option due to withed units).
20928 if Is_Configuration_Pragma
then
20929 Universal_Addressing_On_AAMP
:= True;
20931 Check_Valid_Library_Unit_Pragma
;
20934 if not AAMP_On_Target
then
20935 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20942 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20944 when Pragma_Unmodified
=> Unmodified
: declare
20945 Arg_Node
: Node_Id
;
20946 Arg_Expr
: Node_Id
;
20947 Arg_Ent
: Entity_Id
;
20951 Check_At_Least_N_Arguments
(1);
20953 -- Loop through arguments
20956 while Present
(Arg_Node
) loop
20957 Check_No_Identifier
(Arg_Node
);
20959 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
20960 -- in fact generate reference, so that the entity will have a
20961 -- reference, which will inhibit any warnings about it not
20962 -- being referenced, and also properly show up in the ali file
20963 -- as a reference. But this reference is recorded before the
20964 -- Has_Pragma_Unreferenced flag is set, so that no warning is
20965 -- generated for this reference.
20967 Check_Arg_Is_Local_Name
(Arg_Node
);
20968 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20970 if Is_Entity_Name
(Arg_Expr
) then
20971 Arg_Ent
:= Entity
(Arg_Expr
);
20973 if not Is_Assignable
(Arg_Ent
) then
20975 ("pragma% can only be applied to a variable",
20978 Set_Has_Pragma_Unmodified
(Arg_Ent
);
20990 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
20992 -- or when used in a context clause:
20994 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
20996 when Pragma_Unreferenced
=> Unreferenced
: declare
20997 Arg_Node
: Node_Id
;
20998 Arg_Expr
: Node_Id
;
20999 Arg_Ent
: Entity_Id
;
21004 Check_At_Least_N_Arguments
(1);
21006 -- Check case of appearing within context clause
21008 if Is_In_Context_Clause
then
21010 -- The arguments must all be units mentioned in a with clause
21011 -- in the same context clause. Note we already checked (in
21012 -- Par.Prag) that the arguments are either identifiers or
21013 -- selected components.
21016 while Present
(Arg_Node
) loop
21017 Citem
:= First
(List_Containing
(N
));
21018 while Citem
/= N
loop
21019 if Nkind
(Citem
) = N_With_Clause
21021 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21023 Set_Has_Pragma_Unreferenced
21026 (Library_Unit
(Citem
))));
21028 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21037 ("argument of pragma% is not withed unit", Arg_Node
);
21043 -- Case of not in list of context items
21047 while Present
(Arg_Node
) loop
21048 Check_No_Identifier
(Arg_Node
);
21050 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21051 -- will in fact generate reference, so that the entity will
21052 -- have a reference, which will inhibit any warnings about
21053 -- it not being referenced, and also properly show up in the
21054 -- ali file as a reference. But this reference is recorded
21055 -- before the Has_Pragma_Unreferenced flag is set, so that
21056 -- no warning is generated for this reference.
21058 Check_Arg_Is_Local_Name
(Arg_Node
);
21059 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21061 if Is_Entity_Name
(Arg_Expr
) then
21062 Arg_Ent
:= Entity
(Arg_Expr
);
21064 -- If the entity is overloaded, the pragma applies to the
21065 -- most recent overloading, as documented. In this case,
21066 -- name resolution does not generate a reference, so it
21067 -- must be done here explicitly.
21069 if Is_Overloaded
(Arg_Expr
) then
21070 Generate_Reference
(Arg_Ent
, N
);
21073 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21081 --------------------------
21082 -- Unreferenced_Objects --
21083 --------------------------
21085 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21087 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21088 Arg_Node
: Node_Id
;
21089 Arg_Expr
: Node_Id
;
21093 Check_At_Least_N_Arguments
(1);
21096 while Present
(Arg_Node
) loop
21097 Check_No_Identifier
(Arg_Node
);
21098 Check_Arg_Is_Local_Name
(Arg_Node
);
21099 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21101 if not Is_Entity_Name
(Arg_Expr
)
21102 or else not Is_Type
(Entity
(Arg_Expr
))
21105 ("argument for pragma% must be type or subtype", Arg_Node
);
21108 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21111 end Unreferenced_Objects
;
21113 ------------------------------
21114 -- Unreserve_All_Interrupts --
21115 ------------------------------
21117 -- pragma Unreserve_All_Interrupts;
21119 when Pragma_Unreserve_All_Interrupts
=>
21121 Check_Arg_Count
(0);
21123 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21124 Unreserve_All_Interrupts
:= True;
21131 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21133 when Pragma_Unsuppress
=>
21135 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
21137 ----------------------------
21138 -- Unevaluated_Use_Of_Old --
21139 ----------------------------
21141 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21143 when Pragma_Unevaluated_Use_Of_Old
=>
21145 Check_Arg_Count
(1);
21146 Check_No_Identifiers
;
21147 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
21149 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21150 -- a declarative part or a package spec.
21152 if not Is_Configuration_Pragma
then
21153 Check_Is_In_Decl_Part_Or_Package_Spec
;
21156 -- Store proper setting of Uneval_Old
21158 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21159 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
21161 -------------------
21162 -- Use_VADS_Size --
21163 -------------------
21165 -- pragma Use_VADS_Size;
21167 when Pragma_Use_VADS_Size
=>
21169 Check_Arg_Count
(0);
21170 Check_Valid_Configuration_Pragma
;
21171 Use_VADS_Size
:= True;
21173 ---------------------
21174 -- Validity_Checks --
21175 ---------------------
21177 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21179 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21180 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21186 Check_Arg_Count
(1);
21187 Check_No_Identifiers
;
21189 -- Pragma always active unless in CodePeer or GNATprove modes,
21190 -- which use a fixed configuration of validity checks.
21192 if not (CodePeer_Mode
or GNATprove_Mode
) then
21193 if Nkind
(A
) = N_String_Literal
then
21197 Slen
: constant Natural := Natural (String_Length
(S
));
21198 Options
: String (1 .. Slen
);
21202 -- Couldn't we use a for loop here over Options'Range???
21206 C
:= Get_String_Char
(S
, Int
(J
));
21208 -- This is a weird test, it skips setting validity
21209 -- checks entirely if any element of S is out of
21210 -- range of Character, what is that about ???
21212 exit when not In_Character_Range
(C
);
21213 Options
(J
) := Get_Character
(C
);
21216 Set_Validity_Check_Options
(Options
);
21224 elsif Nkind
(A
) = N_Identifier
then
21225 if Chars
(A
) = Name_All_Checks
then
21226 Set_Validity_Check_Options
("a");
21227 elsif Chars
(A
) = Name_On
then
21228 Validity_Checks_On
:= True;
21229 elsif Chars
(A
) = Name_Off
then
21230 Validity_Checks_On
:= False;
21234 end Validity_Checks
;
21240 -- pragma Volatile (LOCAL_NAME);
21242 when Pragma_Volatile
=>
21243 Process_Atomic_Shared_Volatile
;
21245 -------------------------
21246 -- Volatile_Components --
21247 -------------------------
21249 -- pragma Volatile_Components (array_LOCAL_NAME);
21251 -- Volatile is handled by the same circuit as Atomic_Components
21253 ----------------------
21254 -- Warning_As_Error --
21255 ----------------------
21257 -- pragma Warning_As_Error (static_string_EXPRESSION);
21259 when Pragma_Warning_As_Error
=>
21261 Check_Arg_Count
(1);
21262 Check_No_Identifiers
;
21263 Check_Valid_Configuration_Pragma
;
21265 if not Is_Static_String_Expression
(Arg1
) then
21267 ("argument of pragma% must be static string expression",
21270 -- OK static string expression
21273 Acquire_Warning_Match_String
(Arg1
);
21274 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21275 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21276 new String'(Name_Buffer (1 .. Name_Len));
21283 -- pragma Warnings (On | Off [,REASON]);
21284 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
21285 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
21286 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
21288 -- REASON ::= Reason => Static_String_Expression
21290 when Pragma_Warnings => Warnings : declare
21291 Reason : String_Id;
21295 Check_At_Least_N_Arguments (1);
21297 -- See if last argument is labeled Reason. If so, make sure we
21298 -- have a static string expression, and acquire the REASON string.
21299 -- Then remove the REASON argument by decreasing Num_Args by one;
21300 -- Remaining processing looks only at first Num_Args arguments).
21303 Last_Arg : constant Node_Id :=
21304 Last (Pragma_Argument_Associations (N));
21307 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21308 and then Chars (Last_Arg) = Name_Reason
21311 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21312 Reason := End_String;
21313 Arg_Count := Arg_Count - 1;
21315 -- Not allowed in compiler units (bootstrap issues)
21317 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21319 -- No REASON string, set null string as reason
21322 Reason := Null_String_Id;
21326 -- Now proceed with REASON taken care of and eliminated
21328 Check_No_Identifiers;
21330 -- If debug flag -gnatd.i is set, pragma is ignored
21332 if Debug_Flag_Dot_I then
21336 -- Process various forms of the pragma
21339 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21342 -- One argument case
21344 if Arg_Count = 1 then
21346 -- On/Off one argument case was processed by parser
21348 if Nkind (Argx) = N_Identifier
21349 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21353 -- One argument case must be ON/OFF or static string expr
21355 elsif not Is_Static_String_Expression (Arg1) then
21357 ("argument of pragma% must be On/Off or static string "
21358 & "expression", Arg1);
21360 -- One argument string expression case
21364 Lit : constant Node_Id := Expr_Value_S (Argx);
21365 Str : constant String_Id := Strval (Lit);
21366 Len : constant Nat := String_Length (Str);
21374 while J <= Len loop
21375 C := Get_String_Char (Str, J);
21376 OK := In_Character_Range (C);
21379 Chr := Get_Character (C);
21381 -- Dash case: only -Wxxx is accepted
21388 C := Get_String_Char (Str, J);
21389 Chr := Get_Character (C);
21390 exit when Chr = 'W
';
21395 elsif J < Len and then Chr = '.' then
21397 C := Get_String_Char (Str, J);
21398 Chr := Get_Character (C);
21400 if not Set_Dot_Warning_Switch (Chr) then
21402 ("invalid warning switch character "
21403 & '.' & Chr, Arg1);
21409 OK := Set_Warning_Switch (Chr);
21415 ("invalid warning switch character " & Chr,
21424 -- Two or more arguments (must be two)
21427 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21428 Check_Arg_Count (2);
21436 E_Id := Get_Pragma_Arg (Arg2);
21439 -- In the expansion of an inlined body, a reference to
21440 -- the formal may be wrapped in a conversion if the
21441 -- actual is a conversion. Retrieve the real entity name.
21443 if (In_Instance_Body or In_Inlined_Body)
21444 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21446 E_Id := Expression (E_Id);
21449 -- Entity name case
21451 if Is_Entity_Name (E_Id) then
21452 E := Entity (E_Id);
21459 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21462 -- For OFF case, make entry in warnings off
21463 -- pragma table for later processing. But we do
21464 -- not do that within an instance, since these
21465 -- warnings are about what is needed in the
21466 -- template, not an instance of it.
21468 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21469 and then Warn_On_Warnings_Off
21470 and then not In_Instance
21472 Warnings_Off_Pragmas.Append ((N, E, Reason));
21475 if Is_Enumeration_Type (E) then
21479 Lit := First_Literal (E);
21480 while Present (Lit) loop
21481 Set_Warnings_Off (Lit);
21482 Next_Literal (Lit);
21487 exit when No (Homonym (E));
21492 -- Error if not entity or static string expression case
21494 elsif not Is_Static_String_Expression (Arg2) then
21496 ("second argument of pragma% must be entity name "
21497 & "or static string expression", Arg2);
21499 -- Static string expression case
21502 Acquire_Warning_Match_String (Arg2);
21504 -- Note on configuration pragma case: If this is a
21505 -- configuration pragma, then for an OFF pragma, we
21506 -- just set Config True in the call, which is all
21507 -- that needs to be done. For the case of ON, this
21508 -- is normally an error, unless it is canceling the
21509 -- effect of a previous OFF pragma in the same file.
21510 -- In any other case, an error will be signalled (ON
21511 -- with no matching OFF).
21513 -- Note: We set Used if we are inside a generic to
21514 -- disable the test that the non-config case actually
21515 -- cancels a warning. That's because we can't be sure
21516 -- there isn't an instantiation in some other unit
21517 -- where a warning is suppressed.
21519 -- We could do a little better here by checking if the
21520 -- generic unit we are inside is public, but for now
21521 -- we don't bother with that refinement.
21523 if Chars (Argx) = Name_Off then
21524 Set_Specific_Warning_Off
21525 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21526 Config => Is_Configuration_Pragma,
21527 Used => Inside_A_Generic or else In_Instance);
21529 elsif Chars (Argx) = Name_On then
21530 Set_Specific_Warning_On
21531 (Loc, Name_Buffer (1 .. Name_Len), Err);
21535 ("??pragma Warnings On with no matching "
21536 & "Warnings Off", Loc);
21545 -------------------
21546 -- Weak_External --
21547 -------------------
21549 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21551 when Pragma_Weak_External => Weak_External : declare
21556 Check_Arg_Count (1);
21557 Check_Optional_Identifier (Arg1, Name_Entity);
21558 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21559 Ent := Entity (Get_Pragma_Arg (Arg1));
21561 if Rep_Item_Too_Early (Ent, N) then
21564 Ent := Underlying_Type (Ent);
21567 -- The only processing required is to link this item on to the
21568 -- list of rep items for the given entity. This is accomplished
21569 -- by the call to Rep_Item_Too_Late (when no error is detected
21570 -- and False is returned).
21572 if Rep_Item_Too_Late (Ent, N) then
21575 Set_Has_Gigi_Rep_Item (Ent);
21579 -----------------------------
21580 -- Wide_Character_Encoding --
21581 -----------------------------
21583 -- pragma Wide_Character_Encoding (IDENTIFIER);
21585 when Pragma_Wide_Character_Encoding =>
21588 -- Nothing to do, handled in parser. Note that we do not enforce
21589 -- configuration pragma placement, this pragma can appear at any
21590 -- place in the source, allowing mixed encodings within a single
21595 --------------------
21596 -- Unknown_Pragma --
21597 --------------------
21599 -- Should be impossible, since the case of an unknown pragma is
21600 -- separately processed before the case statement is entered.
21602 when Unknown_Pragma =>
21603 raise Program_Error;
21606 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21607 -- until AI is formally approved.
21609 -- Check_Order_Dependence;
21612 when Pragma_Exit => null;
21613 end Analyze_Pragma;
21615 ---------------------------------------------
21616 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21617 ---------------------------------------------
21619 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21621 Subp_Id : Entity_Id)
21623 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21624 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21627 Restore_Scope : Boolean := False;
21628 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21631 -- Ensure that the subprogram and its formals are visible when analyzing
21632 -- the expression of the pragma.
21634 if not In_Open_Scopes (Subp_Id) then
21635 Restore_Scope := True;
21636 Push_Scope (Subp_Id);
21637 Install_Formals (Subp_Id);
21640 -- Preanalyze the boolean expression, we treat this as a spec expression
21641 -- (i.e. similar to a default expression).
21643 Expr := Get_Pragma_Arg (Arg1);
21645 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21646 -- the original aspect expression, which is shared with the generated
21649 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21650 Expr := Expression (Corresponding_Aspect (Prag));
21653 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21655 -- For a class-wide condition, a reference to a controlling formal must
21656 -- be interpreted as having the class-wide type (or an access to such)
21657 -- so that the inherited condition can be properly applied to any
21658 -- overriding operation (see ARM12 6.6.1 (7)).
21660 if Class_Present (Prag) then
21661 Class_Wide_Condition : declare
21662 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21664 ACW : Entity_Id := Empty;
21665 -- Access to T'class, created if there is a controlling formal
21666 -- that is an access parameter.
21668 function Get_ACW return Entity_Id;
21669 -- If the expression has a reference to an controlling access
21670 -- parameter, create an access to T'class for the necessary
21671 -- conversions if one does not exist.
21673 function Process (N : Node_Id) return Traverse_Result;
21674 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21675 -- aspect for a primitive subprogram of a tagged type T, a name
21676 -- that denotes a formal parameter of type T is interpreted as
21677 -- having type T'Class. Similarly, a name that denotes a formal
21678 -- accessparameter of type access-to-T is interpreted as having
21679 -- type access-to-T'Class. This ensures the expression is well-
21680 -- defined for a primitive subprogram of a type descended from T.
21681 -- Note that this replacement is not done for selector names in
21682 -- parameter associations. These carry an entity for reference
21683 -- purposes, but semantically they are just identifiers.
21689 function Get_ACW return Entity_Id is
21690 Loc : constant Source_Ptr := Sloc (Prag);
21696 Make_Full_Type_Declaration (Loc,
21697 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21699 Make_Access_To_Object_Definition (Loc,
21700 Subtype_Indication =>
21701 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21702 All_Present => True));
21704 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21706 ACW := Defining_Identifier (Decl);
21707 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21717 function Process (N : Node_Id) return Traverse_Result is
21718 Loc : constant Source_Ptr := Sloc (N);
21722 if Is_Entity_Name (N)
21723 and then Present (Entity (N))
21724 and then Is_Formal (Entity (N))
21725 and then Nkind (Parent (N)) /= N_Type_Conversion
21727 (Nkind (Parent (N)) /= N_Parameter_Association
21728 or else N /= Selector_Name (Parent (N)))
21730 if Etype (Entity (N)) = T then
21731 Typ := Class_Wide_Type (T);
21733 elsif Is_Access_Type (Etype (Entity (N)))
21734 and then Designated_Type (Etype (Entity (N))) = T
21741 if Present (Typ) then
21743 Make_Type_Conversion (Loc,
21745 New_Occurrence_Of (Typ, Loc),
21746 Expression => New_Occurrence_Of (Entity (N), Loc)));
21747 Set_Etype (N, Typ);
21754 procedure Replace_Type is new Traverse_Proc (Process);
21756 -- Start of processing for Class_Wide_Condition
21759 if not Present (T) then
21761 -- Pre'Class/Post'Class aspect cases
21763 if From_Aspect_Specification (Prag) then
21764 if Nam = Name_uPre then
21765 Error_Msg_Name_1 := Name_Pre;
21767 Error_Msg_Name_1 := Name_Post;
21770 Error_Msg_Name_2 := Name_Class;
21773 ("aspect `%''%` can only be specified for a primitive "
21774 & "operation of a tagged type",
21775 Corresponding_Aspect (Prag));
21777 -- Pre_Class, Post_Class pragma cases
21780 if Nam = Name_uPre then
21781 Error_Msg_Name_1 := Name_Pre_Class;
21783 Error_Msg_Name_1 := Name_Post_Class;
21787 ("pragma% can only be specified for a primitive "
21788 & "operation of a tagged type",
21789 Corresponding_Aspect (Prag));
21793 Replace_Type (Get_Pragma_Arg (Arg1));
21794 end Class_Wide_Condition;
21797 -- Remove the subprogram from the scope stack now that the pre-analysis
21798 -- of the precondition/postcondition is done.
21800 if Restore_Scope then
21803 end Analyze_Pre_Post_Condition_In_Decl_Part;
21805 ------------------------------------------
21806 -- Analyze_Refined_Depends_In_Decl_Part --
21807 ------------------------------------------
21809 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21810 Body_Inputs : Elist_Id := No_Elist;
21811 Body_Outputs : Elist_Id := No_Elist;
21812 -- The inputs and outputs of the subprogram body synthesized from pragma
21813 -- Refined_Depends.
21815 Dependencies : List_Id := No_List;
21817 -- The corresponding Depends pragma along with its clauses
21819 Matched_Items : Elist_Id := No_Elist;
21820 -- A list containing the entities of all successfully matched items
21821 -- found in pragma Depends.
21823 Refinements : List_Id := No_List;
21824 -- The clauses of pragma Refined_Depends
21826 Spec_Id : Entity_Id;
21827 -- The entity of the subprogram subject to pragma Refined_Depends
21829 Spec_Inputs : Elist_Id := No_Elist;
21830 Spec_Outputs : Elist_Id := No_Elist;
21831 -- The inputs and outputs of the subprogram spec synthesized from pragma
21834 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21835 -- Try to match a single dependency clause Dep_Clause against one or
21836 -- more refinement clauses found in list Refinements. Each successful
21837 -- match eliminates at least one refinement clause from Refinements.
21839 procedure Check_Output_States;
21840 -- Determine whether pragma Depends contains an output state with a
21841 -- visible refinement and if so, ensure that pragma Refined_Depends
21842 -- mentions all its constituents as outputs.
21844 procedure Normalize_Clauses (Clauses : List_Id);
21845 -- Given a list of dependence or refinement clauses Clauses, normalize
21846 -- each clause by creating multiple dependencies with exactly one input
21849 procedure Report_Extra_Clauses;
21850 -- Emit an error for each extra clause found in list Refinements
21852 -----------------------------
21853 -- Check_Dependency_Clause --
21854 -----------------------------
21856 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21857 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21858 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21860 function Is_In_Out_State_Clause return Boolean;
21861 -- Determine whether dependence clause Dep_Clause denotes an abstract
21862 -- state that depends on itself (State => State).
21864 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21865 -- Determine whether item Item denotes an abstract state with visible
21866 -- null refinement.
21868 procedure Match_Items
21869 (Dep_Item : Node_Id;
21870 Ref_Item : Node_Id;
21871 Matched : out Boolean);
21872 -- Try to match dependence item Dep_Item against refinement item
21873 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21874 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21875 -- the following conformance scenarios is in effect:
21876 -- 1) Both items denote null
21877 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21878 -- 3) Both items denote attribute 'Result
21879 -- 4) Both items denote the same formal parameter
21880 -- 5) Both items denote the same variable
21881 -- 6) Dep_Item is an abstract state with visible null refinement
21882 -- and Ref_Item denotes null.
21883 -- 7) Dep_Item is an abstract state with visible null refinement
21884 -- and Ref_Item is Empty (special case).
21885 -- 8) Dep_Item is an abstract state with visible non-null
21886 -- refinement and Ref_Item denotes one of its constituents.
21887 -- 9) Dep_Item is an abstract state without a visible refinement
21888 -- and Ref_Item denotes the same state.
21889 -- When scenario 8 is in effect, the entity of the abstract state
21890 -- denoted by Dep_Item is added to list Refined_States.
21892 procedure Record_Item
(Item_Id
: Entity_Id
);
21893 -- Store the entity of an item denoted by Item_Id in Matched_Items
21895 ----------------------------
21896 -- Is_In_Out_State_Clause --
21897 ----------------------------
21899 function Is_In_Out_State_Clause
return Boolean is
21900 Dep_Input_Id
: Entity_Id
;
21901 Dep_Output_Id
: Entity_Id
;
21904 -- Detect the following clause:
21907 if Is_Entity_Name
(Dep_Input
)
21908 and then Is_Entity_Name
(Dep_Output
)
21910 -- Handle abstract views generated for limited with clauses
21912 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
21913 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
21916 Ekind
(Dep_Input_Id
) = E_Abstract_State
21917 and then Dep_Input_Id
= Dep_Output_Id
;
21921 end Is_In_Out_State_Clause
;
21923 ---------------------------
21924 -- Is_Null_Refined_State --
21925 ---------------------------
21927 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
21928 Item_Id
: Entity_Id
;
21931 if Is_Entity_Name
(Item
) then
21933 -- Handle abstract views generated for limited with clauses
21935 Item_Id
:= Available_View
(Entity_Of
(Item
));
21937 return Ekind
(Item_Id
) = E_Abstract_State
21938 and then Has_Null_Refinement
(Item_Id
);
21943 end Is_Null_Refined_State
;
21949 procedure Match_Items
21950 (Dep_Item
: Node_Id
;
21951 Ref_Item
: Node_Id
;
21952 Matched
: out Boolean)
21954 Dep_Item_Id
: Entity_Id
;
21955 Ref_Item_Id
: Entity_Id
;
21958 -- Assume that the two items do not match
21962 -- A null matches null or Empty (special case)
21964 if Nkind
(Dep_Item
) = N_Null
21965 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21969 -- Attribute 'Result matches attribute 'Result
21971 elsif Is_Attribute_Result
(Dep_Item
)
21972 and then Is_Attribute_Result
(Dep_Item
)
21976 -- Abstract states, formal parameters and variables
21978 elsif Is_Entity_Name
(Dep_Item
) then
21980 -- Handle abstract views generated for limited with clauses
21982 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
21984 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
21986 -- An abstract state with visible null refinement matches
21987 -- null or Empty (special case).
21989 if Has_Null_Refinement
(Dep_Item_Id
)
21990 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21992 Record_Item
(Dep_Item_Id
);
21995 -- An abstract state with visible non-null refinement
21996 -- matches one of its constituents.
21998 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
21999 if Is_Entity_Name
(Ref_Item
) then
22000 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
22002 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
, E_Variable
)
22003 and then Present
(Encapsulating_State
(Ref_Item_Id
))
22004 and then Encapsulating_State
(Ref_Item_Id
) =
22007 Record_Item
(Dep_Item_Id
);
22012 -- An abstract state without a visible refinement matches
22015 elsif Is_Entity_Name
(Ref_Item
)
22016 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22018 Record_Item
(Dep_Item_Id
);
22022 -- A formal parameter or a variable matches itself
22024 elsif Is_Entity_Name
(Ref_Item
)
22025 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22027 Record_Item
(Dep_Item_Id
);
22037 procedure Record_Item
(Item_Id
: Entity_Id
) is
22039 if not Contains
(Matched_Items
, Item_Id
) then
22040 Add_Item
(Item_Id
, Matched_Items
);
22046 Clause_Matched
: Boolean := False;
22047 Dummy
: Boolean := False;
22048 Inputs_Match
: Boolean;
22049 Next_Ref_Clause
: Node_Id
;
22050 Outputs_Match
: Boolean;
22051 Ref_Clause
: Node_Id
;
22052 Ref_Input
: Node_Id
;
22053 Ref_Output
: Node_Id
;
22055 -- Start of processing for Check_Dependency_Clause
22058 -- Examine all refinement clauses and compare them against the
22059 -- dependence clause.
22061 Ref_Clause
:= First
(Refinements
);
22062 while Present
(Ref_Clause
) loop
22063 Next_Ref_Clause
:= Next
(Ref_Clause
);
22065 -- Obtain the attributes of the current refinement clause
22067 Ref_Input
:= Expression
(Ref_Clause
);
22068 Ref_Output
:= First
(Choices
(Ref_Clause
));
22070 -- The current refinement clause matches the dependence clause
22071 -- when both outputs match and both inputs match. See routine
22072 -- Match_Items for all possible conformance scenarios.
22074 -- Depends Dep_Output => Dep_Input
22078 -- Refined_Depends Ref_Output => Ref_Input
22081 (Dep_Item
=> Dep_Input
,
22082 Ref_Item
=> Ref_Input
,
22083 Matched
=> Inputs_Match
);
22086 (Dep_Item
=> Dep_Output
,
22087 Ref_Item
=> Ref_Output
,
22088 Matched
=> Outputs_Match
);
22090 -- An In_Out state clause may be matched against a refinement with
22091 -- a null input or null output as long as the non-null side of the
22092 -- relation contains a valid constituent of the In_Out_State.
22094 if Is_In_Out_State_Clause
then
22096 -- Depends => (State => State)
22097 -- Refined_Depends => (null => Constit) -- OK
22100 and then not Outputs_Match
22101 and then Nkind
(Ref_Output
) = N_Null
22103 Outputs_Match
:= True;
22106 -- Depends => (State => State)
22107 -- Refined_Depends => (Constit => null) -- OK
22109 if not Inputs_Match
22110 and then Outputs_Match
22111 and then Nkind
(Ref_Input
) = N_Null
22113 Inputs_Match
:= True;
22117 -- The current refinement clause is legally constructed following
22118 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22119 -- the pool of candidates. The seach continues because a single
22120 -- dependence clause may have multiple matching refinements.
22122 if Inputs_Match
and then Outputs_Match
then
22123 Clause_Matched
:= True;
22124 Remove
(Ref_Clause
);
22127 Ref_Clause
:= Next_Ref_Clause
;
22130 -- Depending on the order or composition of refinement clauses, an
22131 -- In_Out state clause may not be directly refinable.
22133 -- Depends => ((Output, State) => (Input, State))
22134 -- Refined_State => (State => (Constit_1, Constit_2))
22135 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22137 -- Matching normalized clause (State => State) fails because there is
22138 -- no direct refinement capable of satisfying this relation. Another
22139 -- similar case arises when clauses (Constit_1 => Input) and (Output
22140 -- => Constit_2) are matched first, leaving no candidates for clause
22141 -- (State => State). Both scenarios are legal as long as one of the
22142 -- previous clauses mentioned a valid constituent of State.
22144 if not Clause_Matched
22145 and then Is_In_Out_State_Clause
22147 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22149 Clause_Matched
:= True;
22152 -- A clause where the input is an abstract state with visible null
22153 -- refinement is implicitly matched when the output has already been
22154 -- matched in a previous clause.
22156 -- Depends => (Output => State) -- implicitly OK
22157 -- Refined_State => (State => null)
22158 -- Refined_Depends => (Output => ...)
22160 if not Clause_Matched
22161 and then Is_Null_Refined_State
(Dep_Input
)
22162 and then Is_Entity_Name
(Dep_Output
)
22164 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
22166 Clause_Matched
:= True;
22169 -- A clause where the output is an abstract state with visible null
22170 -- refinement is implicitly matched when the input has already been
22171 -- matched in a previous clause.
22173 -- Depends => (State => Input) -- implicitly OK
22174 -- Refined_State => (State => null)
22175 -- Refined_Depends => (... => Input)
22177 if not Clause_Matched
22178 and then Is_Null_Refined_State
(Dep_Output
)
22179 and then Is_Entity_Name
(Dep_Input
)
22181 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22183 Clause_Matched
:= True;
22186 -- At this point either all refinement clauses have been examined or
22187 -- pragma Refined_Depends contains a solitary null. Only an abstract
22188 -- state with null refinement can possibly match these cases.
22190 -- Depends => (State => null)
22191 -- Refined_State => (State => null)
22192 -- Refined_Depends => null -- OK
22194 if not Clause_Matched
then
22196 (Dep_Item
=> Dep_Input
,
22198 Matched
=> Inputs_Match
);
22201 (Dep_Item
=> Dep_Output
,
22203 Matched
=> Outputs_Match
);
22205 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
22208 -- If the contents of Refined_Depends are legal, then the current
22209 -- dependence clause should be satisfied either by an explicit match
22210 -- or by one of the special cases.
22212 if not Clause_Matched
then
22214 ("dependence clause of subprogram & has no matching refinement "
22215 & "in body", Dep_Clause
, Spec_Id
);
22217 end Check_Dependency_Clause
;
22219 -------------------------
22220 -- Check_Output_States --
22221 -------------------------
22223 procedure Check_Output_States
is
22224 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22225 -- Determine whether all constituents of state State_Id with visible
22226 -- refinement are used as outputs in pragma Refined_Depends. Emit an
22227 -- error if this is not the case.
22229 -----------------------------
22230 -- Check_Constituent_Usage --
22231 -----------------------------
22233 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22234 Constit_Elmt
: Elmt_Id
;
22235 Constit_Id
: Entity_Id
;
22236 Posted
: Boolean := False;
22239 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22240 while Present
(Constit_Elmt
) loop
22241 Constit_Id
:= Node
(Constit_Elmt
);
22243 -- The constituent acts as an input (SPARK RM 7.2.5(3))
22245 if Present
(Body_Inputs
)
22246 and then Appears_In
(Body_Inputs
, Constit_Id
)
22248 Error_Msg_Name_1
:= Chars
(State_Id
);
22250 ("constituent & of state % must act as output in "
22251 & "dependence refinement", N
, Constit_Id
);
22253 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22255 elsif No
(Body_Outputs
)
22256 or else not Appears_In
(Body_Outputs
, Constit_Id
)
22261 ("output state & must be replaced by all its "
22262 & "constituents in dependence refinement",
22267 ("\constituent & is missing in output list",
22271 Next_Elmt
(Constit_Elmt
);
22273 end Check_Constituent_Usage
;
22278 Item_Elmt
: Elmt_Id
;
22279 Item_Id
: Entity_Id
;
22281 -- Start of processing for Check_Output_States
22284 -- Inspect the outputs of pragma Depends looking for a state with a
22285 -- visible refinement.
22287 if Present
(Spec_Outputs
) then
22288 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
22289 while Present
(Item_Elmt
) loop
22290 Item
:= Node
(Item_Elmt
);
22292 -- Deal with the mixed nature of the input and output lists
22294 if Nkind
(Item
) = N_Defining_Identifier
then
22297 Item_Id
:= Available_View
(Entity_Of
(Item
));
22300 if Ekind
(Item_Id
) = E_Abstract_State
then
22302 -- The state acts as an input-output, skip it
22304 if Present
(Spec_Inputs
)
22305 and then Appears_In
(Spec_Inputs
, Item_Id
)
22309 -- Ensure that all of the constituents are utilized as
22310 -- outputs in pragma Refined_Depends.
22312 elsif Has_Non_Null_Refinement
(Item_Id
) then
22313 Check_Constituent_Usage
(Item_Id
);
22317 Next_Elmt
(Item_Elmt
);
22320 end Check_Output_States
;
22322 -----------------------
22323 -- Normalize_Clauses --
22324 -----------------------
22326 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22327 procedure Normalize_Inputs
(Clause
: Node_Id
);
22328 -- Normalize clause Clause by creating multiple clauses for each
22329 -- input item of Clause. It is assumed that Clause has exactly one
22330 -- output. The transformation is as follows:
22332 -- Output => (Input_1, Input_2) -- original
22334 -- Output => Input_1 -- normalizations
22335 -- Output => Input_2
22337 procedure Normalize_Outputs
(Clause
: Node_Id
);
22338 -- Normalize clause Clause by creating multiple clause for each
22339 -- output item of Clause. The transformation is as follows:
22341 -- (Output_1, Output_2) => Input -- original
22343 -- Output_1 => Input -- normalization
22344 -- Output_2 => Input
22346 ----------------------
22347 -- Normalize_Inputs --
22348 ----------------------
22350 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22351 Inputs
: constant Node_Id
:= Expression
(Clause
);
22352 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22353 Output
: constant List_Id
:= Choices
(Clause
);
22354 Last_Input
: Node_Id
;
22356 New_Clause
: Node_Id
;
22357 Next_Input
: Node_Id
;
22360 -- Normalization is performed only when the original clause has
22361 -- more than one input. Multiple inputs appear as an aggregate.
22363 if Nkind
(Inputs
) = N_Aggregate
then
22364 Last_Input
:= Last
(Expressions
(Inputs
));
22366 -- Create a new clause for each input
22368 Input
:= First
(Expressions
(Inputs
));
22369 while Present
(Input
) loop
22370 Next_Input
:= Next
(Input
);
22372 -- Unhook the current input from the original input list
22373 -- because it will be relocated to a new clause.
22377 -- Special processing for the last input. At this point the
22378 -- original aggregate has been stripped down to one element.
22379 -- Replace the aggregate by the element itself.
22381 if Input
= Last_Input
then
22382 Rewrite
(Inputs
, Input
);
22384 -- Generate a clause of the form:
22389 Make_Component_Association
(Loc
,
22390 Choices
=> New_Copy_List_Tree
(Output
),
22391 Expression
=> Input
);
22393 -- The new clause contains replicated content that has
22394 -- already been analyzed, mark the clause as analyzed.
22396 Set_Analyzed
(New_Clause
);
22397 Insert_After
(Clause
, New_Clause
);
22400 Input
:= Next_Input
;
22403 end Normalize_Inputs
;
22405 -----------------------
22406 -- Normalize_Outputs --
22407 -----------------------
22409 procedure Normalize_Outputs
(Clause
: Node_Id
) is
22410 Inputs
: constant Node_Id
:= Expression
(Clause
);
22411 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22412 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
22413 Last_Output
: Node_Id
;
22414 New_Clause
: Node_Id
;
22415 Next_Output
: Node_Id
;
22419 -- Multiple outputs appear as an aggregate. Nothing to do when
22420 -- the clause has exactly one output.
22422 if Nkind
(Outputs
) = N_Aggregate
then
22423 Last_Output
:= Last
(Expressions
(Outputs
));
22425 -- Create a clause for each output. Note that each time a new
22426 -- clause is created, the original output list slowly shrinks
22427 -- until there is one item left.
22429 Output
:= First
(Expressions
(Outputs
));
22430 while Present
(Output
) loop
22431 Next_Output
:= Next
(Output
);
22433 -- Unhook the output from the original output list as it
22434 -- will be relocated to a new clause.
22438 -- Special processing for the last output. At this point
22439 -- the original aggregate has been stripped down to one
22440 -- element. Replace the aggregate by the element itself.
22442 if Output
= Last_Output
then
22443 Rewrite
(Outputs
, Output
);
22446 -- Generate a clause of the form:
22447 -- (Output => Inputs)
22450 Make_Component_Association
(Loc
,
22451 Choices
=> New_List
(Output
),
22452 Expression
=> New_Copy_Tree
(Inputs
));
22454 -- The new clause contains replicated content that has
22455 -- already been analyzed. There is not need to reanalyze
22458 Set_Analyzed
(New_Clause
);
22459 Insert_After
(Clause
, New_Clause
);
22462 Output
:= Next_Output
;
22465 end Normalize_Outputs
;
22471 -- Start of processing for Normalize_Clauses
22474 Clause
:= First
(Clauses
);
22475 while Present
(Clause
) loop
22476 Normalize_Outputs
(Clause
);
22480 Clause
:= First
(Clauses
);
22481 while Present
(Clause
) loop
22482 Normalize_Inputs
(Clause
);
22485 end Normalize_Clauses
;
22487 --------------------------
22488 -- Report_Extra_Clauses --
22489 --------------------------
22491 procedure Report_Extra_Clauses
is
22495 if Present
(Refinements
) then
22496 Clause
:= First
(Refinements
);
22497 while Present
(Clause
) loop
22499 -- Do not complain about a null input refinement, since a null
22500 -- input legitimately matches anything.
22502 if Nkind
(Clause
) /= N_Component_Association
22503 or else Nkind
(Expression
(Clause
)) /= N_Null
22506 ("unmatched or extra clause in dependence refinement",
22513 end Report_Extra_Clauses
;
22517 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22518 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
22519 Errors
: constant Nat
:= Serious_Errors_Detected
;
22520 Refs
: constant Node_Id
:=
22521 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22526 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22529 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22530 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22532 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22535 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22537 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22538 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22540 if No
(Depends
) then
22542 ("useless refinement, declaration of subprogram & lacks aspect or "
22543 & "pragma Depends", N
, Spec_Id
);
22547 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
22549 -- A null dependency relation renders the refinement useless because it
22550 -- cannot possibly mention abstract states with visible refinement. Note
22551 -- that the inverse is not true as states may be refined to null
22552 -- (SPARK RM 7.2.5(2)).
22554 if Nkind
(Deps
) = N_Null
then
22556 ("useless refinement, subprogram & does not depend on abstract "
22557 & "state with visible refinement", N
, Spec_Id
);
22561 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22562 -- This ensures that the categorization of all refined dependency items
22563 -- is consistent with their role.
22565 Analyze_Depends_In_Decl_Part
(N
);
22567 -- Do not match dependencies against refinements if Refined_Depends is
22568 -- illegal to avoid emitting misleading error.
22570 if Serious_Errors_Detected
= Errors
then
22572 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
22573 -- the inputs and outputs of the subprogram spec and body to verify
22574 -- the use of states with visible refinement and their constituents.
22576 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
22577 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
22579 Collect_Subprogram_Inputs_Outputs
22580 (Subp_Id
=> Spec_Id
,
22581 Synthesize
=> True,
22582 Subp_Inputs
=> Spec_Inputs
,
22583 Subp_Outputs
=> Spec_Outputs
,
22584 Global_Seen
=> Dummy
);
22586 Collect_Subprogram_Inputs_Outputs
22587 (Subp_Id
=> Body_Id
,
22588 Synthesize
=> True,
22589 Subp_Inputs
=> Body_Inputs
,
22590 Subp_Outputs
=> Body_Outputs
,
22591 Global_Seen
=> Dummy
);
22593 -- For an output state with a visible refinement, ensure that all
22594 -- constituents appear as outputs in the dependency refinement.
22596 Check_Output_States
;
22599 -- Matching is disabled in ASIS because clauses are not normalized as
22600 -- this is a tree altering activity similar to expansion.
22606 -- Multiple dependency clauses appear as component associations of an
22607 -- aggregate. Note that the clauses are copied because the algorithm
22608 -- modifies them and this should not be visible in Depends.
22610 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22611 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22612 Normalize_Clauses
(Dependencies
);
22614 if Nkind
(Refs
) = N_Null
then
22615 Refinements
:= No_List
;
22617 -- Multiple dependency clauses appear as component associations of an
22618 -- aggregate. Note that the clauses are copied because the algorithm
22619 -- modifies them and this should not be visible in Refined_Depends.
22621 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22622 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22623 Normalize_Clauses
(Refinements
);
22626 -- At this point the clauses of pragmas Depends and Refined_Depends
22627 -- have been normalized into simple dependencies between one output
22628 -- and one input. Examine all clauses of pragma Depends looking for
22629 -- matching clauses in pragma Refined_Depends.
22631 Clause
:= First
(Dependencies
);
22632 while Present
(Clause
) loop
22633 Check_Dependency_Clause
(Clause
);
22637 if Serious_Errors_Detected
= Errors
then
22638 Report_Extra_Clauses
;
22641 end Analyze_Refined_Depends_In_Decl_Part
;
22643 -----------------------------------------
22644 -- Analyze_Refined_Global_In_Decl_Part --
22645 -----------------------------------------
22647 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22649 -- The corresponding Global pragma
22651 Has_In_State
: Boolean := False;
22652 Has_In_Out_State
: Boolean := False;
22653 Has_Out_State
: Boolean := False;
22654 Has_Proof_In_State
: Boolean := False;
22655 -- These flags are set when the corresponding Global pragma has a state
22656 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22659 Has_Null_State
: Boolean := False;
22660 -- This flag is set when the corresponding Global pragma has at least
22661 -- one state with a null refinement.
22663 In_Constits
: Elist_Id
:= No_Elist
;
22664 In_Out_Constits
: Elist_Id
:= No_Elist
;
22665 Out_Constits
: Elist_Id
:= No_Elist
;
22666 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22667 -- These lists contain the entities of all Input, In_Out, Output and
22668 -- Proof_In constituents that appear in Refined_Global and participate
22669 -- in state refinement.
22671 In_Items
: Elist_Id
:= No_Elist
;
22672 In_Out_Items
: Elist_Id
:= No_Elist
;
22673 Out_Items
: Elist_Id
:= No_Elist
;
22674 Proof_In_Items
: Elist_Id
:= No_Elist
;
22675 -- These list contain the entities of all Input, In_Out, Output and
22676 -- Proof_In items defined in the corresponding Global pragma.
22678 procedure Check_In_Out_States
;
22679 -- Determine whether the corresponding Global pragma mentions In_Out
22680 -- states with visible refinement and if so, ensure that one of the
22681 -- following completions apply to the constituents of the state:
22682 -- 1) there is at least one constituent of mode In_Out
22683 -- 2) there is at least one Input and one Output constituent
22684 -- 3) not all constituents are present and one of them is of mode
22686 -- This routine may remove elements from In_Constits, In_Out_Constits,
22687 -- Out_Constits and Proof_In_Constits.
22689 procedure Check_Input_States
;
22690 -- Determine whether the corresponding Global pragma mentions Input
22691 -- states with visible refinement and if so, ensure that at least one of
22692 -- its constituents appears as an Input item in Refined_Global.
22693 -- This routine may remove elements from In_Constits, In_Out_Constits,
22694 -- Out_Constits and Proof_In_Constits.
22696 procedure Check_Output_States
;
22697 -- Determine whether the corresponding Global pragma mentions Output
22698 -- states with visible refinement and if so, ensure that all of its
22699 -- constituents appear as Output items in Refined_Global.
22700 -- This routine may remove elements from In_Constits, In_Out_Constits,
22701 -- Out_Constits and Proof_In_Constits.
22703 procedure Check_Proof_In_States
;
22704 -- Determine whether the corresponding Global pragma mentions Proof_In
22705 -- states with visible refinement and if so, ensure that at least one of
22706 -- its constituents appears as a Proof_In item in Refined_Global.
22707 -- This routine may remove elements from In_Constits, In_Out_Constits,
22708 -- Out_Constits and Proof_In_Constits.
22710 procedure Check_Refined_Global_List
22712 Global_Mode
: Name_Id
:= Name_Input
);
22713 -- Verify the legality of a single global list declaration. Global_Mode
22714 -- denotes the current mode in effect.
22716 procedure Collect_Global_Items
(Prag
: Node_Id
);
22717 -- Gather all input, in out, output and Proof_In items of pragma Prag
22718 -- in lists In_Items, In_Out_Items, Out_Items and Proof_In_Items. Flags
22719 -- Has_In_State, Has_In_Out_State, Has_Out_State and Has_Proof_In_State
22720 -- are set when there is at least one abstract state with visible
22721 -- refinement available in the corresponding mode. Flag Has_Null_State
22722 -- is set when at least state has a null refinement.
22724 function Present_Then_Remove
22726 Item
: Entity_Id
) return Boolean;
22727 -- Search List for a particular entity Item. If Item has been found,
22728 -- remove it from List. This routine is used to strip lists In_Constits,
22729 -- In_Out_Constits and Out_Constits of valid constituents.
22731 procedure Report_Extra_Constituents
;
22732 -- Emit an error for each constituent found in lists In_Constits,
22733 -- In_Out_Constits and Out_Constits.
22735 -------------------------
22736 -- Check_In_Out_States --
22737 -------------------------
22739 procedure Check_In_Out_States
is
22740 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22741 -- Determine whether one of the following coverage scenarios is in
22743 -- 1) there is at least one constituent of mode In_Out
22744 -- 2) there is at least one Input and one Output constituent
22745 -- 3) not all constituents are present and one of them is of mode
22747 -- If this is not the case, emit an error.
22749 -----------------------------
22750 -- Check_Constituent_Usage --
22751 -----------------------------
22753 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22754 Constit_Elmt
: Elmt_Id
;
22755 Constit_Id
: Entity_Id
;
22756 Has_Missing
: Boolean := False;
22757 In_Out_Seen
: Boolean := False;
22758 In_Seen
: Boolean := False;
22759 Out_Seen
: Boolean := False;
22762 -- Process all the constituents of the state and note their modes
22763 -- within the global refinement.
22765 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22766 while Present
(Constit_Elmt
) loop
22767 Constit_Id
:= Node
(Constit_Elmt
);
22769 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22772 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22773 In_Out_Seen
:= True;
22775 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22778 -- A Proof_In constituent cannot participate in the completion
22779 -- of an Output state (SPARK RM 7.2.4(5)).
22781 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22782 Error_Msg_Name_1
:= Chars
(State_Id
);
22784 ("constituent & of state % must have mode Input, In_Out "
22785 & "or Output in global refinement",
22789 Has_Missing
:= True;
22792 Next_Elmt
(Constit_Elmt
);
22795 -- A single In_Out constituent is a valid completion
22797 if In_Out_Seen
then
22800 -- A pair of one Input and one Output constituent is a valid
22803 elsif In_Seen
and then Out_Seen
then
22806 -- A single Output constituent is a valid completion only when
22807 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22809 elsif Has_Missing
and then Out_Seen
then
22814 ("global refinement of state & redefines the mode of its "
22815 & "constituents", N
, State_Id
);
22817 end Check_Constituent_Usage
;
22821 Item_Elmt
: Elmt_Id
;
22822 Item_Id
: Entity_Id
;
22824 -- Start of processing for Check_In_Out_States
22827 -- Inspect the In_Out items of the corresponding Global pragma
22828 -- looking for a state with a visible refinement.
22830 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22831 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22832 while Present
(Item_Elmt
) loop
22833 Item_Id
:= Node
(Item_Elmt
);
22835 -- Ensure that one of the three coverage variants is satisfied
22837 if Ekind
(Item_Id
) = E_Abstract_State
22838 and then Has_Non_Null_Refinement
(Item_Id
)
22840 Check_Constituent_Usage
(Item_Id
);
22843 Next_Elmt
(Item_Elmt
);
22846 end Check_In_Out_States
;
22848 ------------------------
22849 -- Check_Input_States --
22850 ------------------------
22852 procedure Check_Input_States
is
22853 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22854 -- Determine whether at least one constituent of state State_Id with
22855 -- visible refinement is used and has mode Input. Ensure that the
22856 -- remaining constituents do not have In_Out, Output or Proof_In
22859 -----------------------------
22860 -- Check_Constituent_Usage --
22861 -----------------------------
22863 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22864 Constit_Elmt
: Elmt_Id
;
22865 Constit_Id
: Entity_Id
;
22866 In_Seen
: Boolean := False;
22869 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22870 while Present
(Constit_Elmt
) loop
22871 Constit_Id
:= Node
(Constit_Elmt
);
22873 -- At least one of the constituents appears as an Input
22875 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22878 -- The constituent appears in the global refinement, but has
22879 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22881 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22882 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22883 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22885 Error_Msg_Name_1
:= Chars
(State_Id
);
22887 ("constituent & of state % must have mode Input in global "
22888 & "refinement", N
, Constit_Id
);
22891 Next_Elmt
(Constit_Elmt
);
22894 -- Not one of the constituents appeared as Input
22896 if not In_Seen
then
22898 ("global refinement of state & must include at least one "
22899 & "constituent of mode Input", N
, State_Id
);
22901 end Check_Constituent_Usage
;
22905 Item_Elmt
: Elmt_Id
;
22906 Item_Id
: Entity_Id
;
22908 -- Start of processing for Check_Input_States
22911 -- Inspect the Input items of the corresponding Global pragma
22912 -- looking for a state with a visible refinement.
22914 if Has_In_State
and then Present
(In_Items
) then
22915 Item_Elmt
:= First_Elmt
(In_Items
);
22916 while Present
(Item_Elmt
) loop
22917 Item_Id
:= Node
(Item_Elmt
);
22919 -- Ensure that at least one of the constituents is utilized and
22920 -- is of mode Input.
22922 if Ekind
(Item_Id
) = E_Abstract_State
22923 and then Has_Non_Null_Refinement
(Item_Id
)
22925 Check_Constituent_Usage
(Item_Id
);
22928 Next_Elmt
(Item_Elmt
);
22931 end Check_Input_States
;
22933 -------------------------
22934 -- Check_Output_States --
22935 -------------------------
22937 procedure Check_Output_States
is
22938 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22939 -- Determine whether all constituents of state State_Id with visible
22940 -- refinement are used and have mode Output. Emit an error if this is
22943 -----------------------------
22944 -- Check_Constituent_Usage --
22945 -----------------------------
22947 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22948 Constit_Elmt
: Elmt_Id
;
22949 Constit_Id
: Entity_Id
;
22950 Posted
: Boolean := False;
22953 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22954 while Present
(Constit_Elmt
) loop
22955 Constit_Id
:= Node
(Constit_Elmt
);
22957 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22960 -- The constituent appears in the global refinement, but has
22961 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22963 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22964 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22965 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22967 Error_Msg_Name_1
:= Chars
(State_Id
);
22969 ("constituent & of state % must have mode Output in "
22970 & "global refinement", N
, Constit_Id
);
22972 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22978 ("output state & must be replaced by all its "
22979 & "constituents in global refinement", N
, State_Id
);
22983 ("\constituent & is missing in output list",
22987 Next_Elmt
(Constit_Elmt
);
22989 end Check_Constituent_Usage
;
22993 Item_Elmt
: Elmt_Id
;
22994 Item_Id
: Entity_Id
;
22996 -- Start of processing for Check_Output_States
22999 -- Inspect the Output items of the corresponding Global pragma
23000 -- looking for a state with a visible refinement.
23002 if Has_Out_State
and then Present
(Out_Items
) then
23003 Item_Elmt
:= First_Elmt
(Out_Items
);
23004 while Present
(Item_Elmt
) loop
23005 Item_Id
:= Node
(Item_Elmt
);
23007 -- Ensure that all of the constituents are utilized and they
23008 -- have mode Output.
23010 if Ekind
(Item_Id
) = E_Abstract_State
23011 and then Has_Non_Null_Refinement
(Item_Id
)
23013 Check_Constituent_Usage
(Item_Id
);
23016 Next_Elmt
(Item_Elmt
);
23019 end Check_Output_States
;
23021 ---------------------------
23022 -- Check_Proof_In_States --
23023 ---------------------------
23025 procedure Check_Proof_In_States
is
23026 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23027 -- Determine whether at least one constituent of state State_Id with
23028 -- visible refinement is used and has mode Proof_In. Ensure that the
23029 -- remaining constituents do not have Input, In_Out or Output modes.
23031 -----------------------------
23032 -- Check_Constituent_Usage --
23033 -----------------------------
23035 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23036 Constit_Elmt
: Elmt_Id
;
23037 Constit_Id
: Entity_Id
;
23038 Proof_In_Seen
: Boolean := False;
23041 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23042 while Present
(Constit_Elmt
) loop
23043 Constit_Id
:= Node
(Constit_Elmt
);
23045 -- At least one of the constituents appears as Proof_In
23047 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23048 Proof_In_Seen
:= True;
23050 -- The constituent appears in the global refinement, but has
23051 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23053 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23054 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23055 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23057 Error_Msg_Name_1
:= Chars
(State_Id
);
23059 ("constituent & of state % must have mode Proof_In in "
23060 & "global refinement", N
, Constit_Id
);
23063 Next_Elmt
(Constit_Elmt
);
23066 -- Not one of the constituents appeared as Proof_In
23068 if not Proof_In_Seen
then
23070 ("global refinement of state & must include at least one "
23071 & "constituent of mode Proof_In", N
, State_Id
);
23073 end Check_Constituent_Usage
;
23077 Item_Elmt
: Elmt_Id
;
23078 Item_Id
: Entity_Id
;
23080 -- Start of processing for Check_Proof_In_States
23083 -- Inspect the Proof_In items of the corresponding Global pragma
23084 -- looking for a state with a visible refinement.
23086 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23087 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23088 while Present
(Item_Elmt
) loop
23089 Item_Id
:= Node
(Item_Elmt
);
23091 -- Ensure that at least one of the constituents is utilized and
23092 -- is of mode Proof_In
23094 if Ekind
(Item_Id
) = E_Abstract_State
23095 and then Has_Non_Null_Refinement
(Item_Id
)
23097 Check_Constituent_Usage
(Item_Id
);
23100 Next_Elmt
(Item_Elmt
);
23103 end Check_Proof_In_States
;
23105 -------------------------------
23106 -- Check_Refined_Global_List --
23107 -------------------------------
23109 procedure Check_Refined_Global_List
23111 Global_Mode
: Name_Id
:= Name_Input
)
23113 procedure Check_Refined_Global_Item
23115 Global_Mode
: Name_Id
);
23116 -- Verify the legality of a single global item declaration. Parameter
23117 -- Global_Mode denotes the current mode in effect.
23119 -------------------------------
23120 -- Check_Refined_Global_Item --
23121 -------------------------------
23123 procedure Check_Refined_Global_Item
23125 Global_Mode
: Name_Id
)
23127 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23129 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23130 -- Issue a common error message for all mode mismatches. Expect
23131 -- denotes the expected mode.
23133 -----------------------------
23134 -- Inconsistent_Mode_Error --
23135 -----------------------------
23137 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23140 ("global item & has inconsistent modes", Item
, Item_Id
);
23142 Error_Msg_Name_1
:= Global_Mode
;
23143 Error_Msg_Name_2
:= Expect
;
23144 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
23145 end Inconsistent_Mode_Error
;
23147 -- Start of processing for Check_Refined_Global_Item
23150 -- When the state or variable acts as a constituent of another
23151 -- state with a visible refinement, collect it for the state
23152 -- completeness checks performed later on.
23154 if Present
(Encapsulating_State
(Item_Id
))
23155 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23157 if Global_Mode
= Name_Input
then
23158 Add_Item
(Item_Id
, In_Constits
);
23160 elsif Global_Mode
= Name_In_Out
then
23161 Add_Item
(Item_Id
, In_Out_Constits
);
23163 elsif Global_Mode
= Name_Output
then
23164 Add_Item
(Item_Id
, Out_Constits
);
23166 elsif Global_Mode
= Name_Proof_In
then
23167 Add_Item
(Item_Id
, Proof_In_Constits
);
23170 -- When not a constituent, ensure that both occurrences of the
23171 -- item in pragmas Global and Refined_Global match.
23173 elsif Contains
(In_Items
, Item_Id
) then
23174 if Global_Mode
/= Name_Input
then
23175 Inconsistent_Mode_Error
(Name_Input
);
23178 elsif Contains
(In_Out_Items
, Item_Id
) then
23179 if Global_Mode
/= Name_In_Out
then
23180 Inconsistent_Mode_Error
(Name_In_Out
);
23183 elsif Contains
(Out_Items
, Item_Id
) then
23184 if Global_Mode
/= Name_Output
then
23185 Inconsistent_Mode_Error
(Name_Output
);
23188 elsif Contains
(Proof_In_Items
, Item_Id
) then
23191 -- The item does not appear in the corresponding Global pragma,
23192 -- it must be an extra (SPARK RM 7.2.4(3)).
23195 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
23197 end Check_Refined_Global_Item
;
23203 -- Start of processing for Check_Refined_Global_List
23206 if Nkind
(List
) = N_Null
then
23209 -- Single global item declaration
23211 elsif Nkind_In
(List
, N_Expanded_Name
,
23213 N_Selected_Component
)
23215 Check_Refined_Global_Item
(List
, Global_Mode
);
23217 -- Simple global list or moded global list declaration
23219 elsif Nkind
(List
) = N_Aggregate
then
23221 -- The declaration of a simple global list appear as a collection
23224 if Present
(Expressions
(List
)) then
23225 Item
:= First
(Expressions
(List
));
23226 while Present
(Item
) loop
23227 Check_Refined_Global_Item
(Item
, Global_Mode
);
23232 -- The declaration of a moded global list appears as a collection
23233 -- of component associations where individual choices denote
23236 elsif Present
(Component_Associations
(List
)) then
23237 Item
:= First
(Component_Associations
(List
));
23238 while Present
(Item
) loop
23239 Check_Refined_Global_List
23240 (List
=> Expression
(Item
),
23241 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23249 raise Program_Error
;
23255 raise Program_Error
;
23257 end Check_Refined_Global_List
;
23259 --------------------------
23260 -- Collect_Global_Items --
23261 --------------------------
23263 procedure Collect_Global_Items
(Prag
: Node_Id
) is
23264 procedure Process_Global_List
23266 Mode
: Name_Id
:= Name_Input
);
23267 -- Collect all items housed in a global list. Formal Mode denotes the
23268 -- current mode in effect.
23270 -------------------------
23271 -- Process_Global_List --
23272 -------------------------
23274 procedure Process_Global_List
23276 Mode
: Name_Id
:= Name_Input
)
23278 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
23279 -- Add a single item to the appropriate list. Formal Mode denotes
23280 -- the current mode in effect.
23282 -------------------------
23283 -- Process_Global_Item --
23284 -------------------------
23286 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
23287 Item_Id
: constant Entity_Id
:=
23288 Available_View
(Entity_Of
(Item
));
23289 -- The above handles abstract views of variables and states
23290 -- built for limited with clauses.
23293 -- Signal that the global list contains at least one abstract
23294 -- state with a visible refinement. Note that the refinement
23295 -- may be null in which case there are no constituents.
23297 if Ekind
(Item_Id
) = E_Abstract_State
then
23298 if Has_Null_Refinement
(Item_Id
) then
23299 Has_Null_State
:= True;
23301 elsif Has_Non_Null_Refinement
(Item_Id
) then
23302 if Mode
= Name_Input
then
23303 Has_In_State
:= True;
23304 elsif Mode
= Name_In_Out
then
23305 Has_In_Out_State
:= True;
23306 elsif Mode
= Name_Output
then
23307 Has_Out_State
:= True;
23308 elsif Mode
= Name_Proof_In
then
23309 Has_Proof_In_State
:= True;
23314 -- Add the item to the proper list
23316 if Mode
= Name_Input
then
23317 Add_Item
(Item_Id
, In_Items
);
23318 elsif Mode
= Name_In_Out
then
23319 Add_Item
(Item_Id
, In_Out_Items
);
23320 elsif Mode
= Name_Output
then
23321 Add_Item
(Item_Id
, Out_Items
);
23322 elsif Mode
= Name_Proof_In
then
23323 Add_Item
(Item_Id
, Proof_In_Items
);
23325 end Process_Global_Item
;
23331 -- Start of processing for Process_Global_List
23334 if Nkind
(List
) = N_Null
then
23337 -- Single global item declaration
23339 elsif Nkind_In
(List
, N_Expanded_Name
,
23341 N_Selected_Component
)
23343 Process_Global_Item
(List
, Mode
);
23345 -- Single global list or moded global list declaration
23347 elsif Nkind
(List
) = N_Aggregate
then
23349 -- The declaration of a simple global list appear as a
23350 -- collection of expressions.
23352 if Present
(Expressions
(List
)) then
23353 Item
:= First
(Expressions
(List
));
23354 while Present
(Item
) loop
23355 Process_Global_Item
(Item
, Mode
);
23359 -- The declaration of a moded global list appears as a
23360 -- collection of component associations where individual
23361 -- choices denote mode.
23363 elsif Present
(Component_Associations
(List
)) then
23364 Item
:= First
(Component_Associations
(List
));
23365 while Present
(Item
) loop
23366 Process_Global_List
23367 (List
=> Expression
(Item
),
23368 Mode
=> Chars
(First
(Choices
(Item
))));
23376 raise Program_Error
;
23379 -- To accomodate partial decoration of disabled SPARK features,
23380 -- this routine may be called with illegal input. If this is the
23381 -- case, do not raise Program_Error.
23386 end Process_Global_List
;
23388 -- Start of processing for Collect_Global_Items
23391 Process_Global_List
23392 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
))));
23393 end Collect_Global_Items
;
23395 -------------------------
23396 -- Present_Then_Remove --
23397 -------------------------
23399 function Present_Then_Remove
23401 Item
: Entity_Id
) return Boolean
23406 if Present
(List
) then
23407 Elmt
:= First_Elmt
(List
);
23408 while Present
(Elmt
) loop
23409 if Node
(Elmt
) = Item
then
23410 Remove_Elmt
(List
, Elmt
);
23419 end Present_Then_Remove
;
23421 -------------------------------
23422 -- Report_Extra_Constituents --
23423 -------------------------------
23425 procedure Report_Extra_Constituents
is
23426 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23427 -- Emit an error for every element of List
23429 ---------------------------------------
23430 -- Report_Extra_Constituents_In_List --
23431 ---------------------------------------
23433 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23434 Constit_Elmt
: Elmt_Id
;
23437 if Present
(List
) then
23438 Constit_Elmt
:= First_Elmt
(List
);
23439 while Present
(Constit_Elmt
) loop
23440 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23441 Next_Elmt
(Constit_Elmt
);
23444 end Report_Extra_Constituents_In_List
;
23446 -- Start of processing for Report_Extra_Constituents
23449 Report_Extra_Constituents_In_List
(In_Constits
);
23450 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23451 Report_Extra_Constituents_In_List
(Out_Constits
);
23452 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23453 end Report_Extra_Constituents
;
23457 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23458 Errors
: constant Nat
:= Serious_Errors_Detected
;
23459 Items
: constant Node_Id
:=
23460 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23461 Spec_Id
: Entity_Id
;
23463 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23466 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23467 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23469 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23472 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23474 -- The subprogram declaration lacks pragma Global. This renders
23475 -- Refined_Global useless as there is nothing to refine.
23477 if No
(Global
) then
23479 ("useless refinement, declaration of subprogram & lacks aspect or "
23480 & "pragma Global", N
, Spec_Id
);
23484 -- Extract all relevant items from the corresponding Global pragma
23486 Collect_Global_Items
(Global
);
23488 -- Corresponding Global pragma must mention at least one state witha
23489 -- visible refinement at the point Refined_Global is processed. States
23490 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23492 if not Has_In_State
23493 and then not Has_In_Out_State
23494 and then not Has_Out_State
23495 and then not Has_Proof_In_State
23496 and then not Has_Null_State
23499 ("useless refinement, subprogram & does not depend on abstract "
23500 & "state with visible refinement", N
, Spec_Id
);
23504 -- The global refinement of inputs and outputs cannot be null when the
23505 -- corresponding Global pragma contains at least one item except in the
23506 -- case where we have states with null refinements.
23508 if Nkind
(Items
) = N_Null
23510 (Present
(In_Items
)
23511 or else Present
(In_Out_Items
)
23512 or else Present
(Out_Items
)
23513 or else Present
(Proof_In_Items
))
23514 and then not Has_Null_State
23517 ("refinement cannot be null, subprogram & has global items",
23522 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23523 -- This ensures that the categorization of all refined global items is
23524 -- consistent with their role.
23526 Analyze_Global_In_Decl_Part
(N
);
23528 -- Perform all refinement checks with respect to completeness and mode
23531 if Serious_Errors_Detected
= Errors
then
23532 Check_Refined_Global_List
(Items
);
23535 -- For Input states with visible refinement, at least one constituent
23536 -- must be used as an Input in the global refinement.
23538 if Serious_Errors_Detected
= Errors
then
23539 Check_Input_States
;
23542 -- Verify all possible completion variants for In_Out states with
23543 -- visible refinement.
23545 if Serious_Errors_Detected
= Errors
then
23546 Check_In_Out_States
;
23549 -- For Output states with visible refinement, all constituents must be
23550 -- used as Outputs in the global refinement.
23552 if Serious_Errors_Detected
= Errors
then
23553 Check_Output_States
;
23556 -- For Proof_In states with visible refinement, at least one constituent
23557 -- must be used as Proof_In in the global refinement.
23559 if Serious_Errors_Detected
= Errors
then
23560 Check_Proof_In_States
;
23563 -- Emit errors for all constituents that belong to other states with
23564 -- visible refinement that do not appear in Global.
23566 if Serious_Errors_Detected
= Errors
then
23567 Report_Extra_Constituents
;
23569 end Analyze_Refined_Global_In_Decl_Part
;
23571 ----------------------------------------
23572 -- Analyze_Refined_State_In_Decl_Part --
23573 ----------------------------------------
23575 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23576 Available_States
: Elist_Id
:= No_Elist
;
23577 -- A list of all abstract states defined in the package declaration that
23578 -- are available for refinement. The list is used to report unrefined
23581 Body_Id
: Entity_Id
;
23582 -- The body entity of the package subject to pragma Refined_State
23584 Body_States
: Elist_Id
:= No_Elist
;
23585 -- A list of all hidden states that appear in the body of the related
23586 -- package. The list is used to report unused hidden states.
23588 Constituents_Seen
: Elist_Id
:= No_Elist
;
23589 -- A list that contains all constituents processed so far. The list is
23590 -- used to detect multiple uses of the same constituent.
23592 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23593 -- A list that contains all refined states processed so far. The list is
23594 -- used to detect duplicate refinements.
23596 Spec_Id
: Entity_Id
;
23597 -- The spec entity of the package subject to pragma Refined_State
23599 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23600 -- Perform full analysis of a single refinement clause
23602 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23603 -- Gather the entities of all abstract states and variables declared in
23604 -- the body state space of package Pack_Id.
23606 procedure Report_Unrefined_States
(States
: Elist_Id
);
23607 -- Emit errors for all unrefined abstract states found in list States
23609 procedure Report_Unused_States
(States
: Elist_Id
);
23610 -- Emit errors for all unused states found in list States
23612 -------------------------------
23613 -- Analyze_Refinement_Clause --
23614 -------------------------------
23616 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23617 AR_Constit
: Entity_Id
:= Empty
;
23618 AW_Constit
: Entity_Id
:= Empty
;
23619 ER_Constit
: Entity_Id
:= Empty
;
23620 EW_Constit
: Entity_Id
:= Empty
;
23621 -- The entities of external constituents that contain one of the
23622 -- following enabled properties: Async_Readers, Async_Writers,
23623 -- Effective_Reads and Effective_Writes.
23625 External_Constit_Seen
: Boolean := False;
23626 -- Flag used to mark when at least one external constituent is part
23627 -- of the state refinement.
23629 Non_Null_Seen
: Boolean := False;
23630 Null_Seen
: Boolean := False;
23631 -- Flags used to detect multiple uses of null in a single clause or a
23632 -- mixture of null and non-null constituents.
23634 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23635 -- A list of all candidate constituents subject to indicator Part_Of
23636 -- where the encapsulating state is the current state.
23639 State_Id
: Entity_Id
;
23640 -- The current state being refined
23642 procedure Analyze_Constituent
(Constit
: Node_Id
);
23643 -- Perform full analysis of a single constituent
23645 procedure Check_External_Property
23646 (Prop_Nam
: Name_Id
;
23648 Constit
: Entity_Id
);
23649 -- Determine whether a property denoted by name Prop_Nam is present
23650 -- in both the refined state and constituent Constit. Flag Enabled
23651 -- should be set when the property applies to the refined state. If
23652 -- this is not the case, emit an error message.
23654 procedure Check_Matching_State
;
23655 -- Determine whether the state being refined appears in list
23656 -- Available_States. Emit an error when attempting to re-refine the
23657 -- state or when the state is not defined in the package declaration,
23658 -- otherwise remove the state from Available_States.
23660 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23661 -- Emit errors for all unused Part_Of constituents in list Constits
23663 -------------------------
23664 -- Analyze_Constituent --
23665 -------------------------
23667 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23668 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23669 -- Verify that the constituent Constit_Id is a Ghost entity if the
23670 -- abstract state being refined is also Ghost. If this is the case
23671 -- verify that the Ghost policy in effect at the point of state
23672 -- and constituent declaration is the same.
23674 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23675 -- Determine whether constituent Constit denoted by its entity
23676 -- Constit_Id appears in Hidden_States. Emit an error when the
23677 -- constituent is not a valid hidden state of the related package
23678 -- or when it is used more than once. Otherwise remove the
23679 -- constituent from Hidden_States.
23681 --------------------------------
23682 -- Check_Matching_Constituent --
23683 --------------------------------
23685 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23686 procedure Collect_Constituent
;
23687 -- Add constituent Constit_Id to the refinements of State_Id
23689 -------------------------
23690 -- Collect_Constituent --
23691 -------------------------
23693 procedure Collect_Constituent
is
23695 -- Add the constituent to the list of processed items to aid
23696 -- with the detection of duplicates.
23698 Add_Item
(Constit_Id
, Constituents_Seen
);
23700 -- Collect the constituent in the list of refinement items
23701 -- and establish a relation between the refined state and
23704 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23705 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23707 -- The state has at least one legal constituent, mark the
23708 -- start of the refinement region. The region ends when the
23709 -- body declarations end (see routine Analyze_Declarations).
23711 Set_Has_Visible_Refinement
(State_Id
);
23713 -- When the constituent is external, save its relevant
23714 -- property for further checks.
23716 if Async_Readers_Enabled
(Constit_Id
) then
23717 AR_Constit
:= Constit_Id
;
23718 External_Constit_Seen
:= True;
23721 if Async_Writers_Enabled
(Constit_Id
) then
23722 AW_Constit
:= Constit_Id
;
23723 External_Constit_Seen
:= True;
23726 if Effective_Reads_Enabled
(Constit_Id
) then
23727 ER_Constit
:= Constit_Id
;
23728 External_Constit_Seen
:= True;
23731 if Effective_Writes_Enabled
(Constit_Id
) then
23732 EW_Constit
:= Constit_Id
;
23733 External_Constit_Seen
:= True;
23735 end Collect_Constituent
;
23739 State_Elmt
: Elmt_Id
;
23741 -- Start of processing for Check_Matching_Constituent
23744 -- Detect a duplicate use of a constituent
23746 if Contains
(Constituents_Seen
, Constit_Id
) then
23748 ("duplicate use of constituent &", Constit
, Constit_Id
);
23752 -- The constituent is subject to a Part_Of indicator
23754 if Present
(Encapsulating_State
(Constit_Id
)) then
23755 if Encapsulating_State
(Constit_Id
) = State_Id
then
23756 Check_Ghost_Constituent
(Constit_Id
);
23757 Remove
(Part_Of_Constits
, Constit_Id
);
23758 Collect_Constituent
;
23760 -- The constituent is part of another state and is used
23761 -- incorrectly in the refinement of the current state.
23764 Error_Msg_Name_1
:= Chars
(State_Id
);
23766 ("& cannot act as constituent of state %",
23767 Constit
, Constit_Id
);
23769 ("\Part_Of indicator specifies & as encapsulating "
23770 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23773 -- The only other source of legal constituents is the body
23774 -- state space of the related package.
23777 if Present
(Body_States
) then
23778 State_Elmt
:= First_Elmt
(Body_States
);
23779 while Present
(State_Elmt
) loop
23781 -- Consume a valid constituent to signal that it has
23782 -- been encountered.
23784 if Node
(State_Elmt
) = Constit_Id
then
23785 Check_Ghost_Constituent
(Constit_Id
);
23787 Remove_Elmt
(Body_States
, State_Elmt
);
23788 Collect_Constituent
;
23792 Next_Elmt
(State_Elmt
);
23796 -- If we get here, then the constituent is not a hidden
23797 -- state of the related package and may not be used in a
23798 -- refinement (SPARK RM 7.2.2(9)).
23800 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23802 ("cannot use & in refinement, constituent is not a hidden "
23803 & "state of package %", Constit
, Constit_Id
);
23805 end Check_Matching_Constituent
;
23807 -----------------------------
23808 -- Check_Ghost_Constituent --
23809 -----------------------------
23811 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
23813 if Is_Ghost_Entity
(State_Id
) then
23814 if Is_Ghost_Entity
(Constit_Id
) then
23816 -- The Ghost policy in effect at the point of abstract
23817 -- state declaration and constituent must match
23818 -- (SPARK RM 6.9(16)).
23820 if Is_Checked_Ghost_Entity
(State_Id
)
23821 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
23823 Error_Msg_Sloc
:= Sloc
(Constit
);
23826 ("incompatible ghost policies in effect", State
);
23828 ("\abstract state & declared with ghost policy "
23829 & "Check", State
, State_Id
);
23831 ("\constituent & declared # with ghost policy "
23832 & "Ignore", State
, Constit_Id
);
23834 elsif Is_Ignored_Ghost_Entity
(State_Id
)
23835 and then Is_Checked_Ghost_Entity
(Constit_Id
)
23837 Error_Msg_Sloc
:= Sloc
(Constit
);
23840 ("incompatible ghost policies in effect", State
);
23842 ("\abstract state & declared with ghost policy "
23843 & "Ignore", State
, State_Id
);
23845 ("\constituent & declared # with ghost policy "
23846 & "Check", State
, Constit_Id
);
23849 -- A constituent of a Ghost abstract state must be a Ghost
23850 -- entity (SPARK RM 7.2.2(12)).
23854 ("constituent of ghost state & must be ghost",
23855 Constit
, State_Id
);
23858 end Check_Ghost_Constituent
;
23862 Constit_Id
: Entity_Id
;
23864 -- Start of processing for Analyze_Constituent
23867 -- Detect multiple uses of null in a single refinement clause or a
23868 -- mixture of null and non-null constituents.
23870 if Nkind
(Constit
) = N_Null
then
23873 ("multiple null constituents not allowed", Constit
);
23875 elsif Non_Null_Seen
then
23877 ("cannot mix null and non-null constituents", Constit
);
23882 -- Collect the constituent in the list of refinement items
23884 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23886 -- The state has at least one legal constituent, mark the
23887 -- start of the refinement region. The region ends when the
23888 -- body declarations end (see Analyze_Declarations).
23890 Set_Has_Visible_Refinement
(State_Id
);
23893 -- Non-null constituents
23896 Non_Null_Seen
:= True;
23900 ("cannot mix null and non-null constituents", Constit
);
23904 Resolve_State
(Constit
);
23906 -- Ensure that the constituent denotes a valid state or a
23909 if Is_Entity_Name
(Constit
) then
23910 Constit_Id
:= Entity_Of
(Constit
);
23912 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
23913 Check_Matching_Constituent
(Constit_Id
);
23917 ("constituent & must denote a variable or state (SPARK "
23918 & "RM 7.2.2(5))", Constit
, Constit_Id
);
23921 -- The constituent is illegal
23924 SPARK_Msg_N
("malformed constituent", Constit
);
23927 end Analyze_Constituent
;
23929 -----------------------------
23930 -- Check_External_Property --
23931 -----------------------------
23933 procedure Check_External_Property
23934 (Prop_Nam
: Name_Id
;
23936 Constit
: Entity_Id
)
23939 Error_Msg_Name_1
:= Prop_Nam
;
23941 -- The property is enabled in the related Abstract_State pragma
23942 -- that defines the state (SPARK RM 7.2.8(3)).
23945 if No
(Constit
) then
23947 ("external state & requires at least one constituent with "
23948 & "property %", State
, State_Id
);
23951 -- The property is missing in the declaration of the state, but
23952 -- a constituent is introducing it in the state refinement
23953 -- (SPARK RM 7.2.8(3)).
23955 elsif Present
(Constit
) then
23956 Error_Msg_Name_2
:= Chars
(Constit
);
23958 ("external state & lacks property % set by constituent %",
23961 end Check_External_Property
;
23963 --------------------------
23964 -- Check_Matching_State --
23965 --------------------------
23967 procedure Check_Matching_State
is
23968 State_Elmt
: Elmt_Id
;
23971 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23973 if Contains
(Refined_States_Seen
, State_Id
) then
23975 ("duplicate refinement of state &", State
, State_Id
);
23979 -- Inspect the abstract states defined in the package declaration
23980 -- looking for a match.
23982 State_Elmt
:= First_Elmt
(Available_States
);
23983 while Present
(State_Elmt
) loop
23985 -- A valid abstract state is being refined in the body. Add
23986 -- the state to the list of processed refined states to aid
23987 -- with the detection of duplicate refinements. Remove the
23988 -- state from Available_States to signal that it has already
23991 if Node
(State_Elmt
) = State_Id
then
23992 Add_Item
(State_Id
, Refined_States_Seen
);
23993 Remove_Elmt
(Available_States
, State_Elmt
);
23997 Next_Elmt
(State_Elmt
);
24000 -- If we get here, we are refining a state that is not defined in
24001 -- the package declaration.
24003 Error_Msg_Name_1
:= Chars
(Spec_Id
);
24005 ("cannot refine state, & is not defined in package %",
24007 end Check_Matching_State
;
24009 --------------------------------
24010 -- Report_Unused_Constituents --
24011 --------------------------------
24013 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
24014 Constit_Elmt
: Elmt_Id
;
24015 Constit_Id
: Entity_Id
;
24016 Posted
: Boolean := False;
24019 if Present
(Constits
) then
24020 Constit_Elmt
:= First_Elmt
(Constits
);
24021 while Present
(Constit_Elmt
) loop
24022 Constit_Id
:= Node
(Constit_Elmt
);
24024 -- Generate an error message of the form:
24026 -- state ... has unused Part_Of constituents
24027 -- abstract state ... defined at ...
24028 -- variable ... defined at ...
24033 ("state & has unused Part_Of constituents",
24037 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
24039 if Ekind
(Constit_Id
) = E_Abstract_State
then
24041 ("\abstract state & defined #", State
, Constit_Id
);
24044 ("\variable & defined #", State
, Constit_Id
);
24047 Next_Elmt
(Constit_Elmt
);
24050 end Report_Unused_Constituents
;
24052 -- Local declarations
24054 Body_Ref
: Node_Id
;
24055 Body_Ref_Elmt
: Elmt_Id
;
24057 Extra_State
: Node_Id
;
24059 -- Start of processing for Analyze_Refinement_Clause
24062 -- A refinement clause appears as a component association where the
24063 -- sole choice is the state and the expressions are the constituents.
24064 -- This is a syntax error, always report.
24066 if Nkind
(Clause
) /= N_Component_Association
then
24067 Error_Msg_N
("malformed state refinement clause", Clause
);
24071 -- Analyze the state name of a refinement clause
24073 State
:= First
(Choices
(Clause
));
24076 Resolve_State
(State
);
24078 -- Ensure that the state name denotes a valid abstract state that is
24079 -- defined in the spec of the related package.
24081 if Is_Entity_Name
(State
) then
24082 State_Id
:= Entity_Of
(State
);
24084 -- Catch any attempts to re-refine a state or refine a state that
24085 -- is not defined in the package declaration.
24087 if Ekind
(State_Id
) = E_Abstract_State
then
24088 Check_Matching_State
;
24091 ("& must denote an abstract state", State
, State_Id
);
24095 -- References to a state with visible refinement are illegal.
24096 -- When nested packages are involved, detecting such references is
24097 -- tricky because pragma Refined_State is analyzed later than the
24098 -- offending pragma Depends or Global. References that occur in
24099 -- such nested context are stored in a list. Emit errors for all
24100 -- references found in Body_References (SPARK RM 6.1.4(8)).
24102 if Present
(Body_References
(State_Id
)) then
24103 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
24104 while Present
(Body_Ref_Elmt
) loop
24105 Body_Ref
:= Node
(Body_Ref_Elmt
);
24107 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
24108 Error_Msg_Sloc
:= Sloc
(State
);
24109 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
24111 Next_Elmt
(Body_Ref_Elmt
);
24115 -- The state name is illegal. This is a syntax error, always report.
24118 Error_Msg_N
("malformed state name in refinement clause", State
);
24122 -- A refinement clause may only refine one state at a time
24124 Extra_State
:= Next
(State
);
24126 if Present
(Extra_State
) then
24128 ("refinement clause cannot cover multiple states", Extra_State
);
24131 -- Replicate the Part_Of constituents of the refined state because
24132 -- the algorithm will consume items.
24134 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
24136 -- Analyze all constituents of the refinement. Multiple constituents
24137 -- appear as an aggregate.
24139 Constit
:= Expression
(Clause
);
24141 if Nkind
(Constit
) = N_Aggregate
then
24142 if Present
(Component_Associations
(Constit
)) then
24144 ("constituents of refinement clause must appear in "
24145 & "positional form", Constit
);
24147 else pragma Assert
(Present
(Expressions
(Constit
)));
24148 Constit
:= First
(Expressions
(Constit
));
24149 while Present
(Constit
) loop
24150 Analyze_Constituent
(Constit
);
24156 -- Various forms of a single constituent. Note that these may include
24157 -- malformed constituents.
24160 Analyze_Constituent
(Constit
);
24163 -- A refined external state is subject to special rules with respect
24164 -- to its properties and constituents.
24166 if Is_External_State
(State_Id
) then
24168 -- The set of properties that all external constituents yield must
24169 -- match that of the refined state. There are two cases to detect:
24170 -- the refined state lacks a property or has an extra property.
24172 if External_Constit_Seen
then
24173 Check_External_Property
24174 (Prop_Nam
=> Name_Async_Readers
,
24175 Enabled
=> Async_Readers_Enabled
(State_Id
),
24176 Constit
=> AR_Constit
);
24178 Check_External_Property
24179 (Prop_Nam
=> Name_Async_Writers
,
24180 Enabled
=> Async_Writers_Enabled
(State_Id
),
24181 Constit
=> AW_Constit
);
24183 Check_External_Property
24184 (Prop_Nam
=> Name_Effective_Reads
,
24185 Enabled
=> Effective_Reads_Enabled
(State_Id
),
24186 Constit
=> ER_Constit
);
24188 Check_External_Property
24189 (Prop_Nam
=> Name_Effective_Writes
,
24190 Enabled
=> Effective_Writes_Enabled
(State_Id
),
24191 Constit
=> EW_Constit
);
24193 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24195 elsif Null_Seen
then
24198 -- The external state has constituents, but none of them are
24199 -- external (SPARK RM 7.2.8(2)).
24203 ("external state & requires at least one external "
24204 & "constituent or null refinement", State
, State_Id
);
24207 -- When a refined state is not external, it should not have external
24208 -- constituents (SPARK RM 7.2.8(1)).
24210 elsif External_Constit_Seen
then
24212 ("non-external state & cannot contain external constituents in "
24213 & "refinement", State
, State_Id
);
24216 -- Ensure that all Part_Of candidate constituents have been mentioned
24217 -- in the refinement clause.
24219 Report_Unused_Constituents
(Part_Of_Constits
);
24220 end Analyze_Refinement_Clause
;
24222 -------------------------
24223 -- Collect_Body_States --
24224 -------------------------
24226 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24227 Result
: Elist_Id
:= No_Elist
;
24228 -- A list containing all body states of Pack_Id
24230 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24231 -- Gather the entities of all abstract states and variables declared
24232 -- in the visible state space of package Pack_Id.
24234 ----------------------------
24235 -- Collect_Visible_States --
24236 ----------------------------
24238 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24239 Item_Id
: Entity_Id
;
24242 -- Traverse the entity chain of the package and inspect all
24245 Item_Id
:= First_Entity
(Pack_Id
);
24246 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24248 -- Do not consider internally generated items as those cannot
24249 -- be named and participate in refinement.
24251 if not Comes_From_Source
(Item_Id
) then
24254 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24255 Add_Item
(Item_Id
, Result
);
24257 -- Recursively gather the visible states of a nested package
24259 elsif Ekind
(Item_Id
) = E_Package
then
24260 Collect_Visible_States
(Item_Id
);
24263 Next_Entity
(Item_Id
);
24265 end Collect_Visible_States
;
24269 Pack_Body
: constant Node_Id
:=
24270 Declaration_Node
(Body_Entity
(Pack_Id
));
24272 Item_Id
: Entity_Id
;
24274 -- Start of processing for Collect_Body_States
24277 -- Inspect the declarations of the body looking for source variables,
24278 -- packages and package instantiations.
24280 Decl
:= First
(Declarations
(Pack_Body
));
24281 while Present
(Decl
) loop
24282 if Nkind
(Decl
) = N_Object_Declaration
then
24283 Item_Id
:= Defining_Entity
(Decl
);
24285 -- Capture source variables only as internally generated
24286 -- temporaries cannot be named and participate in refinement.
24288 if Ekind
(Item_Id
) = E_Variable
24289 and then Comes_From_Source
(Item_Id
)
24291 Add_Item
(Item_Id
, Result
);
24294 elsif Nkind
(Decl
) = N_Package_Declaration
then
24295 Item_Id
:= Defining_Entity
(Decl
);
24297 -- Capture the visible abstract states and variables of a
24298 -- source package [instantiation].
24300 if Comes_From_Source
(Item_Id
) then
24301 Collect_Visible_States
(Item_Id
);
24309 end Collect_Body_States
;
24311 -----------------------------
24312 -- Report_Unrefined_States --
24313 -----------------------------
24315 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24316 State_Elmt
: Elmt_Id
;
24319 if Present
(States
) then
24320 State_Elmt
:= First_Elmt
(States
);
24321 while Present
(State_Elmt
) loop
24323 ("abstract state & must be refined", Node
(State_Elmt
));
24325 Next_Elmt
(State_Elmt
);
24328 end Report_Unrefined_States
;
24330 --------------------------
24331 -- Report_Unused_States --
24332 --------------------------
24334 procedure Report_Unused_States
(States
: Elist_Id
) is
24335 Posted
: Boolean := False;
24336 State_Elmt
: Elmt_Id
;
24337 State_Id
: Entity_Id
;
24340 if Present
(States
) then
24341 State_Elmt
:= First_Elmt
(States
);
24342 while Present
(State_Elmt
) loop
24343 State_Id
:= Node
(State_Elmt
);
24345 -- Generate an error message of the form:
24347 -- body of package ... has unused hidden states
24348 -- abstract state ... defined at ...
24349 -- variable ... defined at ...
24354 ("body of package & has unused hidden states", Body_Id
);
24357 Error_Msg_Sloc
:= Sloc
(State_Id
);
24359 if Ekind
(State_Id
) = E_Abstract_State
then
24361 ("\abstract state & defined #", Body_Id
, State_Id
);
24364 ("\variable & defined #", Body_Id
, State_Id
);
24367 Next_Elmt
(State_Elmt
);
24370 end Report_Unused_States
;
24372 -- Local declarations
24374 Body_Decl
: constant Node_Id
:= Parent
(N
);
24375 Clauses
: constant Node_Id
:=
24376 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
24379 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24384 Body_Id
:= Defining_Entity
(Body_Decl
);
24385 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
24387 -- Replicate the abstract states declared by the package because the
24388 -- matching algorithm will consume states.
24390 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24392 -- Gather all abstract states and variables declared in the visible
24393 -- state space of the package body. These items must be utilized as
24394 -- constituents in a state refinement.
24396 Body_States
:= Collect_Body_States
(Spec_Id
);
24398 -- Multiple non-null state refinements appear as an aggregate
24400 if Nkind
(Clauses
) = N_Aggregate
then
24401 if Present
(Expressions
(Clauses
)) then
24403 ("state refinements must appear as component associations",
24406 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24407 Clause
:= First
(Component_Associations
(Clauses
));
24408 while Present
(Clause
) loop
24409 Analyze_Refinement_Clause
(Clause
);
24415 -- Various forms of a single state refinement. Note that these may
24416 -- include malformed refinements.
24419 Analyze_Refinement_Clause
(Clauses
);
24422 -- List all abstract states that were left unrefined
24424 Report_Unrefined_States
(Available_States
);
24426 -- Ensure that all abstract states and variables declared in the body
24427 -- state space of the related package are utilized as constituents.
24429 Report_Unused_States
(Body_States
);
24430 end Analyze_Refined_State_In_Decl_Part
;
24432 ------------------------------------
24433 -- Analyze_Test_Case_In_Decl_Part --
24434 ------------------------------------
24436 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
24438 -- Install formals and push subprogram spec onto scope stack so that we
24439 -- can see the formals from the pragma.
24442 Install_Formals
(S
);
24444 -- Preanalyze the boolean expressions, we treat these as spec
24445 -- expressions (i.e. similar to a default expression).
24447 if Pragma_Name
(N
) = Name_Test_Case
then
24448 Preanalyze_CTC_Args
24450 Get_Requires_From_CTC_Pragma
(N
),
24451 Get_Ensures_From_CTC_Pragma
(N
));
24454 -- Remove the subprogram from the scope stack now that the pre-analysis
24455 -- of the expressions in the contract case or test case is done.
24458 end Analyze_Test_Case_In_Decl_Part
;
24464 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24469 if Present
(List
) then
24470 Elmt
:= First_Elmt
(List
);
24471 while Present
(Elmt
) loop
24472 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24475 Id
:= Entity_Of
(Node
(Elmt
));
24478 if Id
= Item_Id
then
24489 -----------------------------
24490 -- Check_Applicable_Policy --
24491 -----------------------------
24493 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24497 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
24500 -- No effect if not valid assertion kind name
24502 if not Is_Valid_Assertion_Kind
(Ename
) then
24506 -- Loop through entries in check policy list
24508 PP
:= Opt
.Check_Policy_List
;
24509 while Present
(PP
) loop
24511 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24512 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24516 or else Pnm
= Name_Assertion
24517 or else (Pnm
= Name_Statement_Assertions
24518 and then Nam_In
(Ename
, Name_Assert
,
24519 Name_Assert_And_Cut
,
24521 Name_Loop_Invariant
,
24522 Name_Loop_Variant
))
24524 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24527 when Name_Off | Name_Ignore
=>
24528 Set_Is_Ignored
(N
, True);
24529 Set_Is_Checked
(N
, False);
24531 when Name_On | Name_Check
=>
24532 Set_Is_Checked
(N
, True);
24533 Set_Is_Ignored
(N
, False);
24535 when Name_Disable
=>
24536 Set_Is_Ignored
(N
, True);
24537 Set_Is_Checked
(N
, False);
24538 Set_Is_Disabled
(N
, True);
24540 -- That should be exhaustive, the null here is a defence
24541 -- against a malformed tree from previous errors.
24550 PP
:= Next_Pragma
(PP
);
24554 -- If there are no specific entries that matched, then we let the
24555 -- setting of assertions govern. Note that this provides the needed
24556 -- compatibility with the RM for the cases of assertion, invariant,
24557 -- precondition, predicate, and postcondition.
24559 if Assertions_Enabled
then
24560 Set_Is_Checked
(N
, True);
24561 Set_Is_Ignored
(N
, False);
24563 Set_Is_Checked
(N
, False);
24564 Set_Is_Ignored
(N
, True);
24566 end Check_Applicable_Policy
;
24568 -------------------------------
24569 -- Check_External_Properties --
24570 -------------------------------
24572 procedure Check_External_Properties
24580 -- All properties enabled
24582 if AR
and AW
and ER
and EW
then
24585 -- Async_Readers + Effective_Writes
24586 -- Async_Readers + Async_Writers + Effective_Writes
24588 elsif AR
and EW
and not ER
then
24591 -- Async_Writers + Effective_Reads
24592 -- Async_Readers + Async_Writers + Effective_Reads
24594 elsif AW
and ER
and not EW
then
24597 -- Async_Readers + Async_Writers
24599 elsif AR
and AW
and not ER
and not EW
then
24604 elsif AR
and not AW
and not ER
and not EW
then
24609 elsif AW
and not AR
and not ER
and not EW
then
24614 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24617 end Check_External_Properties
;
24623 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24627 -- Loop through entries in check policy list
24629 PP
:= Opt
.Check_Policy_List
;
24630 while Present
(PP
) loop
24632 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24633 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24637 or else (Pnm
= Name_Assertion
24638 and then Is_Valid_Assertion_Kind
(Nam
))
24639 or else (Pnm
= Name_Statement_Assertions
24640 and then Nam_In
(Nam
, Name_Assert
,
24641 Name_Assert_And_Cut
,
24643 Name_Loop_Invariant
,
24644 Name_Loop_Variant
))
24646 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24647 when Name_On | Name_Check
=>
24649 when Name_Off | Name_Ignore
=>
24650 return Name_Ignore
;
24651 when Name_Disable
=>
24652 return Name_Disable
;
24654 raise Program_Error
;
24658 PP
:= Next_Pragma
(PP
);
24663 -- If there are no specific entries that matched, then we let the
24664 -- setting of assertions govern. Note that this provides the needed
24665 -- compatibility with the RM for the cases of assertion, invariant,
24666 -- precondition, predicate, and postcondition.
24668 if Assertions_Enabled
then
24671 return Name_Ignore
;
24675 ---------------------------
24676 -- Check_Missing_Part_Of --
24677 ---------------------------
24679 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24680 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24681 -- Determine whether a package denoted by Pack_Id declares at least one
24684 -----------------------
24685 -- Has_Visible_State --
24686 -----------------------
24688 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24689 Item_Id
: Entity_Id
;
24692 -- Traverse the entity chain of the package trying to find at least
24693 -- one visible abstract state, variable or a package [instantiation]
24694 -- that declares a visible state.
24696 Item_Id
:= First_Entity
(Pack_Id
);
24697 while Present
(Item_Id
)
24698 and then not In_Private_Part
(Item_Id
)
24700 -- Do not consider internally generated items
24702 if not Comes_From_Source
(Item_Id
) then
24705 -- A visible state has been found
24707 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24710 -- Recursively peek into nested packages and instantiations
24712 elsif Ekind
(Item_Id
) = E_Package
24713 and then Has_Visible_State
(Item_Id
)
24718 Next_Entity
(Item_Id
);
24722 end Has_Visible_State
;
24726 Pack_Id
: Entity_Id
;
24727 Placement
: State_Space_Kind
;
24729 -- Start of processing for Check_Missing_Part_Of
24732 -- Do not consider abstract states, variables or package instantiations
24733 -- coming from an instance as those always inherit the Part_Of indicator
24734 -- of the instance itself.
24736 if In_Instance
then
24739 -- Do not consider internally generated entities as these can never
24740 -- have a Part_Of indicator.
24742 elsif not Comes_From_Source
(Item_Id
) then
24745 -- Perform these checks only when SPARK_Mode is enabled as they will
24746 -- interfere with standard Ada rules and produce false positives.
24748 elsif SPARK_Mode
/= On
then
24752 -- Find where the abstract state, variable or package instantiation
24753 -- lives with respect to the state space.
24755 Find_Placement_In_State_Space
24756 (Item_Id
=> Item_Id
,
24757 Placement
=> Placement
,
24758 Pack_Id
=> Pack_Id
);
24760 -- Items that appear in a non-package construct (subprogram, block, etc)
24761 -- do not require a Part_Of indicator because they can never act as a
24764 if Placement
= Not_In_Package
then
24767 -- An item declared in the body state space of a package always act as a
24768 -- constituent and does not need explicit Part_Of indicator.
24770 elsif Placement
= Body_State_Space
then
24773 -- In general an item declared in the visible state space of a package
24774 -- does not require a Part_Of indicator. The only exception is when the
24775 -- related package is a private child unit in which case Part_Of must
24776 -- denote a state in the parent unit or in one of its descendants.
24778 elsif Placement
= Visible_State_Space
then
24779 if Is_Child_Unit
(Pack_Id
)
24780 and then Is_Private_Descendant
(Pack_Id
)
24782 -- A package instantiation does not need a Part_Of indicator when
24783 -- the related generic template has no visible state.
24785 if Ekind
(Item_Id
) = E_Package
24786 and then Is_Generic_Instance
(Item_Id
)
24787 and then not Has_Visible_State
(Item_Id
)
24791 -- All other cases require Part_Of
24795 ("indicator Part_Of is required in this context "
24796 & "(SPARK RM 7.2.6(3))", Item_Id
);
24797 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24799 ("\& is declared in the visible part of private child "
24800 & "unit %", Item_Id
);
24804 -- When the item appears in the private state space of a packge, it must
24805 -- be a part of some state declared by the said package.
24807 else pragma Assert
(Placement
= Private_State_Space
);
24809 -- The related package does not declare a state, the item cannot act
24810 -- as a Part_Of constituent.
24812 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24815 -- A package instantiation does not need a Part_Of indicator when the
24816 -- related generic template has no visible state.
24818 elsif Ekind
(Pack_Id
) = E_Package
24819 and then Is_Generic_Instance
(Pack_Id
)
24820 and then not Has_Visible_State
(Pack_Id
)
24824 -- All other cases require Part_Of
24828 ("indicator Part_Of is required in this context "
24829 & "(SPARK RM 7.2.6(2))", Item_Id
);
24830 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24832 ("\& is declared in the private part of package %", Item_Id
);
24835 end Check_Missing_Part_Of
;
24837 ---------------------------------
24838 -- Check_SPARK_Aspect_For_ASIS --
24839 ---------------------------------
24841 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
24845 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
24846 Expr
:= Expression
(Corresponding_Aspect
(N
));
24847 if Nkind
(Expr
) /= N_Aggregate
then
24848 Preanalyze_And_Resolve
(Expr
);
24852 Comps
: constant List_Id
:= Component_Associations
(Expr
);
24853 Exprs
: constant List_Id
:= Expressions
(Expr
);
24858 E
:= First
(Exprs
);
24859 while Present
(E
) loop
24864 C
:= First
(Comps
);
24865 while Present
(C
) loop
24866 Analyze
(Expression
(C
));
24872 end Check_SPARK_Aspect_For_ASIS
;
24874 -------------------------------------
24875 -- Check_State_And_Constituent_Use --
24876 -------------------------------------
24878 procedure Check_State_And_Constituent_Use
24879 (States
: Elist_Id
;
24880 Constits
: Elist_Id
;
24883 function Find_Encapsulating_State
24884 (Constit_Id
: Entity_Id
) return Entity_Id
;
24885 -- Given the entity of a constituent, try to find a corresponding
24886 -- encapsulating state that appears in the same context. The routine
24887 -- returns Empty is no such state is found.
24889 ------------------------------
24890 -- Find_Encapsulating_State --
24891 ------------------------------
24893 function Find_Encapsulating_State
24894 (Constit_Id
: Entity_Id
) return Entity_Id
24896 State_Id
: Entity_Id
;
24899 -- Since a constituent may be part of a larger constituent set, climb
24900 -- the encapsulated state chain looking for a state that appears in
24901 -- the same context.
24903 State_Id
:= Encapsulating_State
(Constit_Id
);
24904 while Present
(State_Id
) loop
24905 if Contains
(States
, State_Id
) then
24909 State_Id
:= Encapsulating_State
(State_Id
);
24913 end Find_Encapsulating_State
;
24917 Constit_Elmt
: Elmt_Id
;
24918 Constit_Id
: Entity_Id
;
24919 State_Id
: Entity_Id
;
24921 -- Start of processing for Check_State_And_Constituent_Use
24924 -- Nothing to do if there are no states or constituents
24926 if No
(States
) or else No
(Constits
) then
24930 -- Inspect the list of constituents and try to determine whether its
24931 -- encapsulating state is in list States.
24933 Constit_Elmt
:= First_Elmt
(Constits
);
24934 while Present
(Constit_Elmt
) loop
24935 Constit_Id
:= Node
(Constit_Elmt
);
24937 -- Determine whether the constituent is part of an encapsulating
24938 -- state that appears in the same context and if this is the case,
24939 -- emit an error (SPARK RM 7.2.6(7)).
24941 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
24943 if Present
(State_Id
) then
24944 Error_Msg_Name_1
:= Chars
(Constit_Id
);
24946 ("cannot mention state & and its constituent % in the same "
24947 & "context", Context
, State_Id
);
24951 Next_Elmt
(Constit_Elmt
);
24953 end Check_State_And_Constituent_Use
;
24955 ---------------------------------------
24956 -- Collect_Subprogram_Inputs_Outputs --
24957 ---------------------------------------
24959 procedure Collect_Subprogram_Inputs_Outputs
24960 (Subp_Id
: Entity_Id
;
24961 Synthesize
: Boolean := False;
24962 Subp_Inputs
: in out Elist_Id
;
24963 Subp_Outputs
: in out Elist_Id
;
24964 Global_Seen
: out Boolean)
24966 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
24967 -- Collect all relevant items from a dependency clause
24969 procedure Collect_Global_List
24971 Mode
: Name_Id
:= Name_Input
);
24972 -- Collect all relevant items from a global list
24974 -------------------------------
24975 -- Collect_Dependency_Clause --
24976 -------------------------------
24978 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
24979 procedure Collect_Dependency_Item
24981 Is_Input
: Boolean);
24982 -- Add an item to the proper subprogram input or output collection
24984 -----------------------------
24985 -- Collect_Dependency_Item --
24986 -----------------------------
24988 procedure Collect_Dependency_Item
24990 Is_Input
: Boolean)
24995 -- Nothing to collect when the item is null
24997 if Nkind
(Item
) = N_Null
then
25000 -- Ditto for attribute 'Result
25002 elsif Is_Attribute_Result
(Item
) then
25005 -- Multiple items appear as an aggregate
25007 elsif Nkind
(Item
) = N_Aggregate
then
25008 Extra
:= First
(Expressions
(Item
));
25009 while Present
(Extra
) loop
25010 Collect_Dependency_Item
(Extra
, Is_Input
);
25014 -- Otherwise this is a solitary item
25018 Add_Item
(Item
, Subp_Inputs
);
25020 Add_Item
(Item
, Subp_Outputs
);
25023 end Collect_Dependency_Item
;
25025 -- Start of processing for Collect_Dependency_Clause
25028 if Nkind
(Clause
) = N_Null
then
25031 -- A dependency cause appears as component association
25033 elsif Nkind
(Clause
) = N_Component_Association
then
25034 Collect_Dependency_Item
25035 (Expression
(Clause
), Is_Input
=> True);
25036 Collect_Dependency_Item
25037 (First
(Choices
(Clause
)), Is_Input
=> False);
25039 -- To accomodate partial decoration of disabled SPARK features, this
25040 -- routine may be called with illegal input. If this is the case, do
25041 -- not raise Program_Error.
25046 end Collect_Dependency_Clause
;
25048 -------------------------
25049 -- Collect_Global_List --
25050 -------------------------
25052 procedure Collect_Global_List
25054 Mode
: Name_Id
:= Name_Input
)
25056 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25057 -- Add an item to the proper subprogram input or output collection
25059 -------------------------
25060 -- Collect_Global_Item --
25061 -------------------------
25063 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25065 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
25066 Add_Item
(Item
, Subp_Inputs
);
25069 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
25070 Add_Item
(Item
, Subp_Outputs
);
25072 end Collect_Global_Item
;
25079 -- Start of processing for Collect_Global_List
25082 if Nkind
(List
) = N_Null
then
25085 -- Single global item declaration
25087 elsif Nkind_In
(List
, N_Expanded_Name
,
25089 N_Selected_Component
)
25091 Collect_Global_Item
(List
, Mode
);
25093 -- Simple global list or moded global list declaration
25095 elsif Nkind
(List
) = N_Aggregate
then
25096 if Present
(Expressions
(List
)) then
25097 Item
:= First
(Expressions
(List
));
25098 while Present
(Item
) loop
25099 Collect_Global_Item
(Item
, Mode
);
25104 Assoc
:= First
(Component_Associations
(List
));
25105 while Present
(Assoc
) loop
25106 Collect_Global_List
25107 (List
=> Expression
(Assoc
),
25108 Mode
=> Chars
(First
(Choices
(Assoc
))));
25113 -- To accomodate partial decoration of disabled SPARK features, this
25114 -- routine may be called with illegal input. If this is the case, do
25115 -- not raise Program_Error.
25120 end Collect_Global_List
;
25124 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
25128 Formal
: Entity_Id
;
25131 Spec_Id
: Entity_Id
;
25133 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25136 Global_Seen
:= False;
25138 -- Find the entity of the corresponding spec when processing a body
25140 if Nkind
(Subp_Decl
) = N_Subprogram_Body
25141 and then Present
(Corresponding_Spec
(Subp_Decl
))
25143 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
25145 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25146 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25148 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
25151 Spec_Id
:= Subp_Id
;
25154 -- Process all formal parameters
25156 Formal
:= First_Formal
(Spec_Id
);
25157 while Present
(Formal
) loop
25158 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
25159 Add_Item
(Formal
, Subp_Inputs
);
25162 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
25163 Add_Item
(Formal
, Subp_Outputs
);
25165 -- Out parameters can act as inputs when the related type is
25166 -- tagged, unconstrained array, unconstrained record or record
25167 -- with unconstrained components.
25169 if Ekind
(Formal
) = E_Out_Parameter
25170 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25172 Add_Item
(Formal
, Subp_Inputs
);
25176 Next_Formal
(Formal
);
25179 -- When processing a subprogram body, look for pragmas Refined_Depends
25180 -- and Refined_Global as they specify the inputs and outputs.
25182 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25183 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
25184 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25186 -- Subprogram declaration case, look for pragmas Depends and Global
25189 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25190 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25193 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
25194 -- because it provides finer granularity of inputs and outputs.
25196 if Present
(Global
) then
25197 Global_Seen
:= True;
25198 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
25200 -- The pragma may not have been analyzed because of the arbitrary
25201 -- declaration order of aspects. Make sure that it is analyzed for
25202 -- the purposes of item extraction.
25204 if not Analyzed
(List
) then
25205 if Pragma_Name
(Global
) = Name_Refined_Global
then
25206 Analyze_Refined_Global_In_Decl_Part
(Global
);
25208 Analyze_Global_In_Decl_Part
(Global
);
25212 Collect_Global_List
(List
);
25214 -- When the related subprogram lacks pragma [Refined_]Global, fall back
25215 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
25216 -- the inputs and outputs from [Refined_]Depends.
25218 elsif Synthesize
and then Present
(Depends
) then
25220 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
25222 -- Multiple dependency clauses appear as an aggregate
25224 if Nkind
(Clauses
) = N_Aggregate
then
25225 Clause
:= First
(Component_Associations
(Clauses
));
25226 while Present
(Clause
) loop
25227 Collect_Dependency_Clause
(Clause
);
25231 -- Otherwise this is a single dependency clause
25234 Collect_Dependency_Clause
(Clauses
);
25237 end Collect_Subprogram_Inputs_Outputs
;
25239 ---------------------------------
25240 -- Delay_Config_Pragma_Analyze --
25241 ---------------------------------
25243 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25245 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25246 Name_Priority_Specific_Dispatching
);
25247 end Delay_Config_Pragma_Analyze
;
25249 -------------------------------------
25250 -- Find_Related_Subprogram_Or_Body --
25251 -------------------------------------
25253 function Find_Related_Subprogram_Or_Body
25255 Do_Checks
: Boolean := False) return Node_Id
25257 Context
: constant Node_Id
:= Parent
(Prag
);
25258 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25261 Look_For_Body
: constant Boolean :=
25262 Nam_In
(Nam
, Name_Refined_Depends
,
25263 Name_Refined_Global
,
25264 Name_Refined_Post
);
25265 -- Refinement pragmas must be associated with a subprogram body [stub]
25268 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
25270 -- If the pragma is a byproduct of aspect expansion, return the related
25271 -- context of the original aspect.
25273 if Present
(Corresponding_Aspect
(Prag
)) then
25274 return Parent
(Corresponding_Aspect
(Prag
));
25277 -- Otherwise the pragma is a source construct, most likely part of a
25278 -- declarative list. Skip preceding declarations while looking for a
25279 -- proper subprogram declaration.
25281 pragma Assert
(Is_List_Member
(Prag
));
25283 Stmt
:= Prev
(Prag
);
25284 while Present
(Stmt
) loop
25286 -- Skip prior pragmas, but check for duplicates
25288 if Nkind
(Stmt
) = N_Pragma
then
25289 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
25290 Error_Msg_Name_1
:= Nam
;
25291 Error_Msg_Sloc
:= Sloc
(Stmt
);
25292 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25295 -- Emit an error when a refinement pragma appears on an expression
25296 -- function without a completion.
25299 and then Look_For_Body
25300 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25301 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25302 and then not Has_Completion
(Defining_Entity
(Stmt
))
25304 Error_Msg_Name_1
:= Nam
;
25306 ("pragma % cannot apply to a stand alone expression function",
25311 -- The refinement pragma applies to a subprogram body stub
25313 elsif Look_For_Body
25314 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25318 -- Skip internally generated code
25320 elsif not Comes_From_Source
(Stmt
) then
25323 -- Return the current construct which is either a subprogram body,
25324 -- a subprogram declaration or is illegal.
25333 -- If we fall through, then the pragma was either the first declaration
25334 -- or it was preceded by other pragmas and no source constructs.
25336 -- The pragma is associated with a library-level subprogram
25338 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25339 return Unit
(Parent
(Context
));
25341 -- The pragma appears inside the declarative part of a subprogram body
25343 elsif Nkind
(Context
) = N_Subprogram_Body
then
25346 -- No candidate subprogram [body] found
25351 end Find_Related_Subprogram_Or_Body
;
25353 -------------------------
25354 -- Get_Base_Subprogram --
25355 -------------------------
25357 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25358 Result
: Entity_Id
;
25361 -- Follow subprogram renaming chain
25365 if Is_Subprogram
(Result
)
25367 Nkind
(Parent
(Declaration_Node
(Result
))) =
25368 N_Subprogram_Renaming_Declaration
25369 and then Present
(Alias
(Result
))
25371 Result
:= Alias
(Result
);
25375 end Get_Base_Subprogram
;
25377 -----------------------
25378 -- Get_SPARK_Mode_Type --
25379 -----------------------
25381 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25383 if N
= Name_On
then
25385 elsif N
= Name_Off
then
25388 -- Any other argument is illegal
25391 raise Program_Error
;
25393 end Get_SPARK_Mode_Type
;
25395 --------------------------------
25396 -- Get_SPARK_Mode_From_Pragma --
25397 --------------------------------
25399 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25404 pragma Assert
(Nkind
(N
) = N_Pragma
);
25405 Args
:= Pragma_Argument_Associations
(N
);
25407 -- Extract the mode from the argument list
25409 if Present
(Args
) then
25410 Mode
:= First
(Pragma_Argument_Associations
(N
));
25411 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25413 -- If SPARK_Mode pragma has no argument, default is ON
25418 end Get_SPARK_Mode_From_Pragma
;
25420 ---------------------------
25421 -- Has_Extra_Parentheses --
25422 ---------------------------
25424 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25428 -- The aggregate should not have an expression list because a clause
25429 -- is always interpreted as a component association. The only way an
25430 -- expression list can sneak in is by adding extra parentheses around
25431 -- the individual clauses:
25433 -- Depends (Output => Input) -- proper form
25434 -- Depends ((Output => Input)) -- extra parentheses
25436 -- Since the extra parentheses are not allowed by the syntax of the
25437 -- pragma, flag them now to avoid emitting misleading errors down the
25440 if Nkind
(Clause
) = N_Aggregate
25441 and then Present
(Expressions
(Clause
))
25443 Expr
:= First
(Expressions
(Clause
));
25444 while Present
(Expr
) loop
25446 -- A dependency clause surrounded by extra parentheses appears
25447 -- as an aggregate of component associations with an optional
25448 -- Paren_Count set.
25450 if Nkind
(Expr
) = N_Aggregate
25451 and then Present
(Component_Associations
(Expr
))
25454 ("dependency clause contains extra parentheses", Expr
);
25456 -- Otherwise the expression is a malformed construct
25459 SPARK_Msg_N
("malformed dependency clause", Expr
);
25469 end Has_Extra_Parentheses
;
25475 procedure Initialize
is
25486 Dummy
:= Dummy
+ 1;
25489 -----------------------------
25490 -- Is_Config_Static_String --
25491 -----------------------------
25493 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25495 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25496 -- This is an internal recursive function that is just like the outer
25497 -- function except that it adds the string to the name buffer rather
25498 -- than placing the string in the name buffer.
25500 ------------------------------
25501 -- Add_Config_Static_String --
25502 ------------------------------
25504 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25511 if Nkind
(N
) = N_Op_Concat
then
25512 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25513 N
:= Right_Opnd
(N
);
25519 if Nkind
(N
) /= N_String_Literal
then
25520 Error_Msg_N
("string literal expected for pragma argument", N
);
25524 for J
in 1 .. String_Length
(Strval
(N
)) loop
25525 C
:= Get_String_Char
(Strval
(N
), J
);
25527 if not In_Character_Range
(C
) then
25529 ("string literal contains invalid wide character",
25530 Sloc
(N
) + 1 + Source_Ptr
(J
));
25534 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25539 end Add_Config_Static_String
;
25541 -- Start of processing for Is_Config_Static_String
25546 return Add_Config_Static_String
(Arg
);
25547 end Is_Config_Static_String
;
25549 -------------------------------
25550 -- Is_Elaboration_SPARK_Mode --
25551 -------------------------------
25553 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
25556 (Nkind
(N
) = N_Pragma
25557 and then Pragma_Name
(N
) = Name_SPARK_Mode
25558 and then Is_List_Member
(N
));
25560 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25561 -- appears in the statement part of the body.
25564 Present
(Parent
(N
))
25565 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
25566 and then List_Containing
(N
) = Statements
(Parent
(N
))
25567 and then Present
(Parent
(Parent
(N
)))
25568 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
25569 end Is_Elaboration_SPARK_Mode
;
25571 -----------------------------------------
25572 -- Is_Non_Significant_Pragma_Reference --
25573 -----------------------------------------
25575 -- This function makes use of the following static table which indicates
25576 -- whether appearance of some name in a given pragma is to be considered
25577 -- as a reference for the purposes of warnings about unreferenced objects.
25579 -- -1 indicates that appearence in any argument is significant
25580 -- 0 indicates that appearance in any argument is not significant
25581 -- +n indicates that appearance as argument n is significant, but all
25582 -- other arguments are not significant
25583 -- 9n arguments from n on are significant, before n inisignificant
25585 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
25586 (Pragma_Abort_Defer
=> -1,
25587 Pragma_Abstract_State
=> -1,
25588 Pragma_Ada_83
=> -1,
25589 Pragma_Ada_95
=> -1,
25590 Pragma_Ada_05
=> -1,
25591 Pragma_Ada_2005
=> -1,
25592 Pragma_Ada_12
=> -1,
25593 Pragma_Ada_2012
=> -1,
25594 Pragma_All_Calls_Remote
=> -1,
25595 Pragma_Allow_Integer_Address
=> -1,
25596 Pragma_Annotate
=> 93,
25597 Pragma_Assert
=> -1,
25598 Pragma_Assert_And_Cut
=> -1,
25599 Pragma_Assertion_Policy
=> 0,
25600 Pragma_Assume
=> -1,
25601 Pragma_Assume_No_Invalid_Values
=> 0,
25602 Pragma_Async_Readers
=> 0,
25603 Pragma_Async_Writers
=> 0,
25604 Pragma_Asynchronous
=> 0,
25605 Pragma_Atomic
=> 0,
25606 Pragma_Atomic_Components
=> 0,
25607 Pragma_Attach_Handler
=> -1,
25608 Pragma_Attribute_Definition
=> 92,
25609 Pragma_Check
=> -1,
25610 Pragma_Check_Float_Overflow
=> 0,
25611 Pragma_Check_Name
=> 0,
25612 Pragma_Check_Policy
=> 0,
25613 Pragma_CIL_Constructor
=> 0,
25614 Pragma_CPP_Class
=> 0,
25615 Pragma_CPP_Constructor
=> 0,
25616 Pragma_CPP_Virtual
=> 0,
25617 Pragma_CPP_Vtable
=> 0,
25619 Pragma_C_Pass_By_Copy
=> 0,
25620 Pragma_Comment
=> -1,
25621 Pragma_Common_Object
=> 0,
25622 Pragma_Compile_Time_Error
=> -1,
25623 Pragma_Compile_Time_Warning
=> -1,
25624 Pragma_Compiler_Unit
=> -1,
25625 Pragma_Compiler_Unit_Warning
=> -1,
25626 Pragma_Complete_Representation
=> 0,
25627 Pragma_Complex_Representation
=> 0,
25628 Pragma_Component_Alignment
=> 0,
25629 Pragma_Contract_Cases
=> -1,
25630 Pragma_Controlled
=> 0,
25631 Pragma_Convention
=> 0,
25632 Pragma_Convention_Identifier
=> 0,
25633 Pragma_Debug
=> -1,
25634 Pragma_Debug_Policy
=> 0,
25635 Pragma_Detect_Blocking
=> 0,
25636 Pragma_Default_Initial_Condition
=> -1,
25637 Pragma_Default_Scalar_Storage_Order
=> 0,
25638 Pragma_Default_Storage_Pool
=> 0,
25639 Pragma_Depends
=> -1,
25640 Pragma_Disable_Atomic_Synchronization
=> 0,
25641 Pragma_Discard_Names
=> 0,
25642 Pragma_Dispatching_Domain
=> -1,
25643 Pragma_Effective_Reads
=> 0,
25644 Pragma_Effective_Writes
=> 0,
25645 Pragma_Elaborate
=> 0,
25646 Pragma_Elaborate_All
=> 0,
25647 Pragma_Elaborate_Body
=> 0,
25648 Pragma_Elaboration_Checks
=> 0,
25649 Pragma_Eliminate
=> 0,
25650 Pragma_Enable_Atomic_Synchronization
=> 0,
25651 Pragma_Export
=> -1,
25652 Pragma_Export_Function
=> -1,
25653 Pragma_Export_Object
=> -1,
25654 Pragma_Export_Procedure
=> -1,
25655 Pragma_Export_Value
=> -1,
25656 Pragma_Export_Valued_Procedure
=> -1,
25657 Pragma_Extend_System
=> -1,
25658 Pragma_Extensions_Allowed
=> 0,
25659 Pragma_Extensions_Visible
=> 0,
25660 Pragma_External
=> -1,
25661 Pragma_Favor_Top_Level
=> 0,
25662 Pragma_External_Name_Casing
=> 0,
25663 Pragma_Fast_Math
=> 0,
25664 Pragma_Finalize_Storage_Only
=> 0,
25666 Pragma_Global
=> -1,
25667 Pragma_Ident
=> -1,
25668 Pragma_Implementation_Defined
=> -1,
25669 Pragma_Implemented
=> -1,
25670 Pragma_Implicit_Packing
=> 0,
25671 Pragma_Import
=> 93,
25672 Pragma_Import_Function
=> 0,
25673 Pragma_Import_Object
=> 0,
25674 Pragma_Import_Procedure
=> 0,
25675 Pragma_Import_Valued_Procedure
=> 0,
25676 Pragma_Independent
=> 0,
25677 Pragma_Independent_Components
=> 0,
25678 Pragma_Initial_Condition
=> -1,
25679 Pragma_Initialize_Scalars
=> 0,
25680 Pragma_Initializes
=> -1,
25681 Pragma_Inline
=> 0,
25682 Pragma_Inline_Always
=> 0,
25683 Pragma_Inline_Generic
=> 0,
25684 Pragma_Inspection_Point
=> -1,
25685 Pragma_Interface
=> 92,
25686 Pragma_Interface_Name
=> 0,
25687 Pragma_Interrupt_Handler
=> -1,
25688 Pragma_Interrupt_Priority
=> -1,
25689 Pragma_Interrupt_State
=> -1,
25690 Pragma_Invariant
=> -1,
25691 Pragma_Java_Constructor
=> -1,
25692 Pragma_Java_Interface
=> -1,
25693 Pragma_Keep_Names
=> 0,
25694 Pragma_License
=> 0,
25695 Pragma_Link_With
=> -1,
25696 Pragma_Linker_Alias
=> -1,
25697 Pragma_Linker_Constructor
=> -1,
25698 Pragma_Linker_Destructor
=> -1,
25699 Pragma_Linker_Options
=> -1,
25700 Pragma_Linker_Section
=> 0,
25702 Pragma_Lock_Free
=> 0,
25703 Pragma_Locking_Policy
=> 0,
25704 Pragma_Loop_Invariant
=> -1,
25705 Pragma_Loop_Optimize
=> 0,
25706 Pragma_Loop_Variant
=> -1,
25707 Pragma_Machine_Attribute
=> -1,
25709 Pragma_Main_Storage
=> -1,
25710 Pragma_Memory_Size
=> 0,
25711 Pragma_No_Return
=> 0,
25712 Pragma_No_Body
=> 0,
25713 Pragma_No_Elaboration_Code_All
=> 0,
25714 Pragma_No_Inline
=> 0,
25715 Pragma_No_Run_Time
=> -1,
25716 Pragma_No_Strict_Aliasing
=> -1,
25717 Pragma_No_Tagged_Streams
=> 0,
25718 Pragma_Normalize_Scalars
=> 0,
25719 Pragma_Obsolescent
=> 0,
25720 Pragma_Optimize
=> 0,
25721 Pragma_Optimize_Alignment
=> 0,
25722 Pragma_Overflow_Mode
=> 0,
25723 Pragma_Overriding_Renamings
=> 0,
25724 Pragma_Ordered
=> 0,
25727 Pragma_Part_Of
=> 0,
25728 Pragma_Partition_Elaboration_Policy
=> 0,
25729 Pragma_Passive
=> 0,
25730 Pragma_Persistent_BSS
=> 0,
25731 Pragma_Polling
=> 0,
25732 Pragma_Prefix_Exception_Messages
=> 0,
25734 Pragma_Postcondition
=> -1,
25735 Pragma_Post_Class
=> -1,
25737 Pragma_Precondition
=> -1,
25738 Pragma_Predicate
=> -1,
25739 Pragma_Preelaborable_Initialization
=> -1,
25740 Pragma_Preelaborate
=> 0,
25741 Pragma_Pre_Class
=> -1,
25742 Pragma_Priority
=> -1,
25743 Pragma_Priority_Specific_Dispatching
=> 0,
25744 Pragma_Profile
=> 0,
25745 Pragma_Profile_Warnings
=> 0,
25746 Pragma_Propagate_Exceptions
=> 0,
25747 Pragma_Provide_Shift_Operators
=> 0,
25748 Pragma_Psect_Object
=> 0,
25750 Pragma_Pure_Function
=> 0,
25751 Pragma_Queuing_Policy
=> 0,
25752 Pragma_Rational
=> 0,
25753 Pragma_Ravenscar
=> 0,
25754 Pragma_Refined_Depends
=> -1,
25755 Pragma_Refined_Global
=> -1,
25756 Pragma_Refined_Post
=> -1,
25757 Pragma_Refined_State
=> -1,
25758 Pragma_Relative_Deadline
=> 0,
25759 Pragma_Remote_Access_Type
=> -1,
25760 Pragma_Remote_Call_Interface
=> -1,
25761 Pragma_Remote_Types
=> -1,
25762 Pragma_Restricted_Run_Time
=> 0,
25763 Pragma_Restriction_Warnings
=> 0,
25764 Pragma_Restrictions
=> 0,
25765 Pragma_Reviewable
=> -1,
25766 Pragma_Short_Circuit_And_Or
=> 0,
25767 Pragma_Share_Generic
=> 0,
25768 Pragma_Shared
=> 0,
25769 Pragma_Shared_Passive
=> 0,
25770 Pragma_Short_Descriptors
=> 0,
25771 Pragma_Simple_Storage_Pool_Type
=> 0,
25772 Pragma_Source_File_Name
=> 0,
25773 Pragma_Source_File_Name_Project
=> 0,
25774 Pragma_Source_Reference
=> 0,
25775 Pragma_SPARK_Mode
=> 0,
25776 Pragma_Storage_Size
=> -1,
25777 Pragma_Storage_Unit
=> 0,
25778 Pragma_Static_Elaboration_Desired
=> 0,
25779 Pragma_Stream_Convert
=> 0,
25780 Pragma_Style_Checks
=> 0,
25781 Pragma_Subtitle
=> 0,
25782 Pragma_Suppress
=> 0,
25783 Pragma_Suppress_Exception_Locations
=> 0,
25784 Pragma_Suppress_All
=> 0,
25785 Pragma_Suppress_Debug_Info
=> 0,
25786 Pragma_Suppress_Initialization
=> 0,
25787 Pragma_System_Name
=> 0,
25788 Pragma_Task_Dispatching_Policy
=> 0,
25789 Pragma_Task_Info
=> -1,
25790 Pragma_Task_Name
=> -1,
25791 Pragma_Task_Storage
=> -1,
25792 Pragma_Test_Case
=> -1,
25793 Pragma_Thread_Local_Storage
=> -1,
25794 Pragma_Time_Slice
=> -1,
25796 Pragma_Type_Invariant
=> -1,
25797 Pragma_Type_Invariant_Class
=> -1,
25798 Pragma_Unchecked_Union
=> 0,
25799 Pragma_Unimplemented_Unit
=> 0,
25800 Pragma_Universal_Aliasing
=> 0,
25801 Pragma_Universal_Data
=> 0,
25802 Pragma_Unmodified
=> 0,
25803 Pragma_Unreferenced
=> 0,
25804 Pragma_Unreferenced_Objects
=> 0,
25805 Pragma_Unreserve_All_Interrupts
=> 0,
25806 Pragma_Unsuppress
=> 0,
25807 Pragma_Unevaluated_Use_Of_Old
=> 0,
25808 Pragma_Use_VADS_Size
=> 0,
25809 Pragma_Validity_Checks
=> 0,
25810 Pragma_Volatile
=> 0,
25811 Pragma_Volatile_Components
=> 0,
25812 Pragma_Warning_As_Error
=> 0,
25813 Pragma_Warnings
=> 0,
25814 Pragma_Weak_External
=> 0,
25815 Pragma_Wide_Character_Encoding
=> 0,
25816 Unknown_Pragma
=> 0);
25818 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25824 function Arg_No
return Nat
;
25825 -- Returns an integer showing what argument we are in. A value of
25826 -- zero means we are not in any of the arguments.
25832 function Arg_No
return Nat
is
25837 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25851 -- Start of processing for Non_Significant_Pragma_Reference
25856 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25860 Id
:= Get_Pragma_Id
(Parent
(P
));
25861 C
:= Sig_Flags
(Id
);
25876 return AN
< (C
- 90);
25882 end Is_Non_Significant_Pragma_Reference
;
25884 ------------------------------
25885 -- Is_Pragma_String_Literal --
25886 ------------------------------
25888 -- This function returns true if the corresponding pragma argument is a
25889 -- static string expression. These are the only cases in which string
25890 -- literals can appear as pragma arguments. We also allow a string literal
25891 -- as the first argument to pragma Assert (although it will of course
25892 -- always generate a type error).
25894 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
25895 Pragn
: constant Node_Id
:= Parent
(Par
);
25896 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
25897 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
25903 N
:= First
(Assoc
);
25910 if Pname
= Name_Assert
then
25913 elsif Pname
= Name_Export
then
25916 elsif Pname
= Name_Ident
then
25919 elsif Pname
= Name_Import
then
25922 elsif Pname
= Name_Interface_Name
then
25925 elsif Pname
= Name_Linker_Alias
then
25928 elsif Pname
= Name_Linker_Section
then
25931 elsif Pname
= Name_Machine_Attribute
then
25934 elsif Pname
= Name_Source_File_Name
then
25937 elsif Pname
= Name_Source_Reference
then
25940 elsif Pname
= Name_Title
then
25943 elsif Pname
= Name_Subtitle
then
25949 end Is_Pragma_String_Literal
;
25951 ---------------------------
25952 -- Is_Private_SPARK_Mode --
25953 ---------------------------
25955 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
25958 (Nkind
(N
) = N_Pragma
25959 and then Pragma_Name
(N
) = Name_SPARK_Mode
25960 and then Is_List_Member
(N
));
25962 -- For pragma SPARK_Mode to be private, it has to appear in the private
25963 -- declarations of a package.
25966 Present
(Parent
(N
))
25967 and then Nkind
(Parent
(N
)) = N_Package_Specification
25968 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
25969 end Is_Private_SPARK_Mode
;
25971 -------------------------------------
25972 -- Is_Unconstrained_Or_Tagged_Item --
25973 -------------------------------------
25975 function Is_Unconstrained_Or_Tagged_Item
25976 (Item
: Entity_Id
) return Boolean
25978 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
25979 -- Determine whether record type Typ has at least one unconstrained
25982 ---------------------------------
25983 -- Has_Unconstrained_Component --
25984 ---------------------------------
25986 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
25990 Comp
:= First_Component
(Typ
);
25991 while Present
(Comp
) loop
25992 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
25996 Next_Component
(Comp
);
26000 end Has_Unconstrained_Component
;
26004 Typ
: constant Entity_Id
:= Etype
(Item
);
26006 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26009 if Is_Tagged_Type
(Typ
) then
26012 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
26015 elsif Is_Record_Type
(Typ
) then
26016 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
26019 return Has_Unconstrained_Component
(Typ
);
26022 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
26028 end Is_Unconstrained_Or_Tagged_Item
;
26030 -----------------------------
26031 -- Is_Valid_Assertion_Kind --
26032 -----------------------------
26034 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
26041 Name_Static_Predicate |
26042 Name_Dynamic_Predicate |
26047 Name_Type_Invariant |
26048 Name_uType_Invariant |
26052 Name_Assert_And_Cut |
26054 Name_Contract_Cases |
26056 Name_Default_Initial_Condition |
26058 Name_Initial_Condition |
26061 Name_Loop_Invariant |
26062 Name_Loop_Variant |
26063 Name_Postcondition |
26064 Name_Precondition |
26066 Name_Refined_Post |
26067 Name_Statement_Assertions
=> return True;
26069 when others => return False;
26071 end Is_Valid_Assertion_Kind
;
26073 -----------------------------------------
26074 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
26075 -----------------------------------------
26077 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
26078 Aspects
: constant List_Id
:= New_List
;
26079 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
26080 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
26082 Original_Aspects
: List_Id
;
26083 -- To capture global references, a copy of the created aspects must be
26084 -- inserted in the original tree.
26087 Prag_Arg_Ass
: Node_Id
;
26088 Prag_Id
: Pragma_Id
;
26091 -- Check for any PPC pragmas that appear within Decl
26093 Prag
:= Next
(Decl
);
26094 while Nkind
(Prag
) = N_Pragma
loop
26095 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
26098 when Pragma_Postcondition | Pragma_Precondition
=>
26099 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
26101 -- Make an aspect from any PPC pragma
26103 Append_To
(Aspects
,
26104 Make_Aspect_Specification
(Loc
,
26106 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
26108 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
26110 -- Generate the analysis information in the pragma expression
26111 -- and then set the pragma node analyzed to avoid any further
26114 Analyze
(Expression
(Prag_Arg_Ass
));
26115 Set_Analyzed
(Prag
, True);
26117 when others => null;
26123 -- Set all new aspects into the generic declaration node
26125 if Is_Non_Empty_List
(Aspects
) then
26127 -- Create the list of aspects to be inserted in the original tree
26129 Original_Aspects
:= Copy_Separate_List
(Aspects
);
26131 -- Check if Decl already has aspects
26133 -- Attach the new lists of aspects to both the generic copy and the
26136 if Has_Aspects
(Decl
) then
26137 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
26138 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
26141 Set_Parent
(Aspects
, Decl
);
26142 Set_Aspect_Specifications
(Decl
, Aspects
);
26143 Set_Parent
(Original_Aspects
, Or_Decl
);
26144 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
26147 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
26149 -------------------------
26150 -- Preanalyze_CTC_Args --
26151 -------------------------
26153 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
26155 -- Preanalyze the boolean expressions, we treat these as spec
26156 -- expressions (i.e. similar to a default expression).
26158 if Present
(Arg_Req
) then
26159 Preanalyze_Assert_Expression
26160 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
26162 -- In ASIS mode, for a pragma generated from a source aspect, also
26163 -- analyze the original aspect expression.
26165 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26166 Preanalyze_Assert_Expression
26167 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
26171 if Present
(Arg_Ens
) then
26172 Preanalyze_Assert_Expression
26173 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
26175 -- In ASIS mode, for a pragma generated from a source aspect, also
26176 -- analyze the original aspect expression.
26178 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26179 Preanalyze_Assert_Expression
26180 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
26183 end Preanalyze_CTC_Args
;
26185 --------------------------------------
26186 -- Process_Compilation_Unit_Pragmas --
26187 --------------------------------------
26189 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26191 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26192 -- strange because it comes at the end of the unit. Rational has the
26193 -- same name for a pragma, but treats it as a program unit pragma, In
26194 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26195 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26196 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26197 -- the context clause to ensure the correct processing.
26199 if Has_Pragma_Suppress_All
(N
) then
26200 Prepend_To
(Context_Items
(N
),
26201 Make_Pragma
(Sloc
(N
),
26202 Chars
=> Name_Suppress
,
26203 Pragma_Argument_Associations
=> New_List
(
26204 Make_Pragma_Argument_Association
(Sloc
(N
),
26205 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26208 -- Nothing else to do at the current time
26210 end Process_Compilation_Unit_Pragmas
;
26212 ------------------------------------
26213 -- Record_Possible_Body_Reference --
26214 ------------------------------------
26216 procedure Record_Possible_Body_Reference
26217 (State_Id
: Entity_Id
;
26221 Spec_Id
: Entity_Id
;
26224 -- Ensure that we are dealing with a reference to a state
26226 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26228 -- Climb the tree starting from the reference looking for a package body
26229 -- whose spec declares the referenced state. This criteria automatically
26230 -- excludes references in package specs which are legal. Note that it is
26231 -- not wise to emit an error now as the package body may lack pragma
26232 -- Refined_State or the referenced state may not be mentioned in the
26233 -- refinement. This approach avoids the generation of misleading errors.
26236 while Present
(Context
) loop
26237 if Nkind
(Context
) = N_Package_Body
then
26238 Spec_Id
:= Corresponding_Spec
(Context
);
26240 if Present
(Abstract_States
(Spec_Id
))
26241 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26243 if No
(Body_References
(State_Id
)) then
26244 Set_Body_References
(State_Id
, New_Elmt_List
);
26247 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
26252 Context
:= Parent
(Context
);
26254 end Record_Possible_Body_Reference
;
26256 ------------------------------
26257 -- Relocate_Pragmas_To_Body --
26258 ------------------------------
26260 procedure Relocate_Pragmas_To_Body
26261 (Subp_Body
: Node_Id
;
26262 Target_Body
: Node_Id
:= Empty
)
26264 procedure Relocate_Pragma
(Prag
: Node_Id
);
26265 -- Remove a single pragma from its current list and add it to the
26266 -- declarations of the proper body (either Subp_Body or Target_Body).
26268 ---------------------
26269 -- Relocate_Pragma --
26270 ---------------------
26272 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26277 -- When subprogram stubs or expression functions are involves, the
26278 -- destination declaration list belongs to the proper body.
26280 if Present
(Target_Body
) then
26281 Target
:= Target_Body
;
26283 Target
:= Subp_Body
;
26286 Decls
:= Declarations
(Target
);
26290 Set_Declarations
(Target
, Decls
);
26293 -- Unhook the pragma from its current list
26296 Prepend
(Prag
, Decls
);
26297 end Relocate_Pragma
;
26301 Body_Id
: constant Entity_Id
:=
26302 Defining_Unit_Name
(Specification
(Subp_Body
));
26303 Next_Stmt
: Node_Id
;
26306 -- Start of processing for Relocate_Pragmas_To_Body
26309 -- Do not process a body that comes from a separate unit as no construct
26310 -- can possibly follow it.
26312 if not Is_List_Member
(Subp_Body
) then
26315 -- Do not relocate pragmas that follow a stub if the stub does not have
26318 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26319 and then No
(Target_Body
)
26323 -- Do not process internally generated routine _Postconditions
26325 elsif Ekind
(Body_Id
) = E_Procedure
26326 and then Chars
(Body_Id
) = Name_uPostconditions
26331 -- Look at what is following the body. We are interested in certain kind
26332 -- of pragmas (either from source or byproducts of expansion) that can
26333 -- apply to a body [stub].
26335 Stmt
:= Next
(Subp_Body
);
26336 while Present
(Stmt
) loop
26338 -- Preserve the following statement for iteration purposes due to a
26339 -- possible relocation of a pragma.
26341 Next_Stmt
:= Next
(Stmt
);
26343 -- Move a candidate pragma following the body to the declarations of
26346 if Nkind
(Stmt
) = N_Pragma
26347 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26349 Relocate_Pragma
(Stmt
);
26351 -- Skip internally generated code
26353 elsif not Comes_From_Source
(Stmt
) then
26356 -- No candidate pragmas are available for relocation
26364 end Relocate_Pragmas_To_Body
;
26366 -------------------
26367 -- Resolve_State --
26368 -------------------
26370 procedure Resolve_State
(N
: Node_Id
) is
26375 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26376 Func
:= Entity
(N
);
26378 -- Handle overloading of state names by functions. Traverse the
26379 -- homonym chain looking for an abstract state.
26381 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26382 State
:= Homonym
(Func
);
26383 while Present
(State
) loop
26385 -- Resolve the overloading by setting the proper entity of the
26386 -- reference to that of the state.
26388 if Ekind
(State
) = E_Abstract_State
then
26389 Set_Etype
(N
, Standard_Void_Type
);
26390 Set_Entity
(N
, State
);
26391 Set_Associated_Node
(N
, State
);
26395 State
:= Homonym
(State
);
26398 -- A function can never act as a state. If the homonym chain does
26399 -- not contain a corresponding state, then something went wrong in
26400 -- the overloading mechanism.
26402 raise Program_Error
;
26407 ----------------------------
26408 -- Rewrite_Assertion_Kind --
26409 ----------------------------
26411 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26415 if Nkind
(N
) = N_Attribute_Reference
26416 and then Attribute_Name
(N
) = Name_Class
26417 and then Nkind
(Prefix
(N
)) = N_Identifier
26419 case Chars
(Prefix
(N
)) is
26424 when Name_Type_Invariant
=>
26425 Nam
:= Name_uType_Invariant
;
26426 when Name_Invariant
=>
26427 Nam
:= Name_uInvariant
;
26432 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26434 end Rewrite_Assertion_Kind
;
26442 Dummy
:= Dummy
+ 1;
26445 --------------------------------
26446 -- Set_Encoded_Interface_Name --
26447 --------------------------------
26449 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26450 Str
: constant String_Id
:= Strval
(S
);
26451 Len
: constant Int
:= String_Length
(Str
);
26456 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26459 -- Stores encoded value of character code CC. The encoding we use an
26460 -- underscore followed by four lower case hex digits.
26466 procedure Encode
is
26468 Store_String_Char
(Get_Char_Code
('_'));
26470 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26472 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26474 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26476 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26479 -- Start of processing for Set_Encoded_Interface_Name
26482 -- If first character is asterisk, this is a link name, and we leave it
26483 -- completely unmodified. We also ignore null strings (the latter case
26484 -- happens only in error cases) and no encoding should occur for Java or
26485 -- AAMP interface names.
26488 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26489 or else VM_Target
/= No_VM
26490 or else AAMP_On_Target
26492 Set_Interface_Name
(E
, S
);
26497 CC
:= Get_String_Char
(Str
, J
);
26499 exit when not In_Character_Range
(CC
);
26501 C
:= Get_Character
(CC
);
26503 exit when C
/= '_' and then C
/= '$'
26504 and then C
not in '0' .. '9'
26505 and then C
not in 'a' .. 'z'
26506 and then C
not in 'A' .. 'Z';
26509 Set_Interface_Name
(E
, S
);
26517 -- Here we need to encode. The encoding we use as follows:
26518 -- three underscores + four hex digits (lower case)
26522 for J
in 1 .. String_Length
(Str
) loop
26523 CC
:= Get_String_Char
(Str
, J
);
26525 if not In_Character_Range
(CC
) then
26528 C
:= Get_Character
(CC
);
26530 if C
= '_' or else C
= '$'
26531 or else C
in '0' .. '9'
26532 or else C
in 'a' .. 'z'
26533 or else C
in 'A' .. 'Z'
26535 Store_String_Char
(CC
);
26542 Set_Interface_Name
(E
,
26543 Make_String_Literal
(Sloc
(S
),
26544 Strval
=> End_String
));
26546 end Set_Encoded_Interface_Name
;
26548 -------------------
26549 -- Set_Unit_Name --
26550 -------------------
26552 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26557 if Nkind
(N
) = N_Identifier
26558 and then Nkind
(With_Item
) = N_Identifier
26560 Set_Entity
(N
, Entity
(With_Item
));
26562 elsif Nkind
(N
) = N_Selected_Component
then
26563 Change_Selected_Component_To_Expanded_Name
(N
);
26564 Set_Entity
(N
, Entity
(With_Item
));
26565 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26567 Pref
:= Prefix
(N
);
26568 Scop
:= Scope
(Entity
(N
));
26569 while Nkind
(Pref
) = N_Selected_Component
loop
26570 Change_Selected_Component_To_Expanded_Name
(Pref
);
26571 Set_Entity
(Selector_Name
(Pref
), Scop
);
26572 Set_Entity
(Pref
, Scop
);
26573 Pref
:= Prefix
(Pref
);
26574 Scop
:= Scope
(Scop
);
26577 Set_Entity
(Pref
, Scop
);