1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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
;
44 with Ghost
; use Ghost
;
46 with Lib
.Writ
; use Lib
.Writ
;
47 with Lib
.Xref
; use Lib
.Xref
;
48 with Namet
.Sp
; use Namet
.Sp
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
51 with Output
; use Output
;
52 with Par_SCO
; use Par_SCO
;
53 with Restrict
; use Restrict
;
54 with Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
57 with Sem_Aux
; use Sem_Aux
;
58 with Sem_Ch3
; use Sem_Ch3
;
59 with Sem_Ch6
; use Sem_Ch6
;
60 with Sem_Ch8
; use Sem_Ch8
;
61 with Sem_Ch12
; use Sem_Ch12
;
62 with Sem_Ch13
; use Sem_Ch13
;
63 with Sem_Disp
; use Sem_Disp
;
64 with Sem_Dist
; use Sem_Dist
;
65 with Sem_Elim
; use Sem_Elim
;
66 with Sem_Eval
; use Sem_Eval
;
67 with Sem_Intr
; use Sem_Intr
;
68 with Sem_Mech
; use Sem_Mech
;
69 with Sem_Res
; use Sem_Res
;
70 with Sem_Type
; use Sem_Type
;
71 with Sem_Util
; use Sem_Util
;
72 with Sem_Warn
; use Sem_Warn
;
73 with Stand
; use Stand
;
74 with Sinfo
; use Sinfo
;
75 with Sinfo
.CN
; use Sinfo
.CN
;
76 with Sinput
; use Sinput
;
77 with Stringt
; use Stringt
;
78 with Stylesw
; use Stylesw
;
80 with Targparm
; use Targparm
;
81 with Tbuild
; use Tbuild
;
83 with Uintp
; use Uintp
;
84 with Uname
; use Uname
;
85 with Urealp
; use Urealp
;
86 with Validsw
; use Validsw
;
87 with Warnsw
; use Warnsw
;
89 package body Sem_Prag
is
91 ----------------------------------------------
92 -- Common Handling of Import-Export Pragmas --
93 ----------------------------------------------
95 -- In the following section, a number of Import_xxx and Export_xxx pragmas
96 -- are defined by GNAT. These are compatible with the DEC pragmas of the
97 -- same name, and all have the following common form and processing:
100 -- [Internal =>] LOCAL_NAME
101 -- [, [External =>] EXTERNAL_SYMBOL]
102 -- [, other optional parameters ]);
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
109 -- EXTERNAL_SYMBOL ::=
111 -- | static_string_EXPRESSION
113 -- The internal LOCAL_NAME designates the entity that is imported or
114 -- exported, and must refer to an entity in the current declarative
115 -- part (as required by the rules for LOCAL_NAME).
117 -- The external linker name is designated by the External parameter if
118 -- given, or the Internal parameter if not (if there is no External
119 -- parameter, the External parameter is a copy of the Internal name).
121 -- If the External parameter is given as a string, then this string is
122 -- treated as an external name (exactly as though it had been given as an
123 -- External_Name parameter for a normal Import pragma).
125 -- If the External parameter is given as an identifier (or there is no
126 -- External parameter, so that the Internal identifier is used), then
127 -- the external name is the characters of the identifier, translated
128 -- to all lower case letters.
130 -- Note: the external name specified or implied by any of these special
131 -- Import_xxx or Export_xxx pragmas override an external or link name
132 -- specified in a previous Import or Export pragma.
134 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
135 -- named notation, following the standard rules for subprogram calls, i.e.
136 -- parameters can be given in any order if named notation is used, and
137 -- positional and named notation can be mixed, subject to the rule that all
138 -- positional parameters must appear first.
140 -- Note: All these pragmas are implemented exactly following the DEC design
141 -- and implementation and are intended to be fully compatible with the use
142 -- of these pragmas in the DEC Ada compiler.
144 --------------------------------------------
145 -- Checking for Duplicated External Names --
146 --------------------------------------------
148 -- It is suspicious if two separate Export pragmas use the same external
149 -- name. The following table is used to diagnose this situation so that
150 -- an appropriate warning can be issued.
152 -- The Node_Id stored is for the N_String_Literal node created to hold
153 -- the value of the external name. The Sloc of this node is used to
154 -- cross-reference the location of the duplication.
156 package Externals
is new Table
.Table
(
157 Table_Component_Type
=> Node_Id
,
158 Table_Index_Type
=> Int
,
159 Table_Low_Bound
=> 0,
160 Table_Initial
=> 100,
161 Table_Increment
=> 100,
162 Table_Name
=> "Name_Externals");
164 -------------------------------------
165 -- Local Subprograms and Variables --
166 -------------------------------------
168 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
);
169 -- Subsidiary routine to the analysis of pragmas Depends, Global and
170 -- Refined_State. Append an entity to a list. If the list is empty, create
173 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
174 -- This routine is used for possible casing adjustment of an explicit
175 -- external name supplied as a string literal (the node N), according to
176 -- the casing requirement of Opt.External_Name_Casing. If this is set to
177 -- As_Is, then the string literal is returned unchanged, but if it is set
178 -- to Uppercase or Lowercase, then a new string literal with appropriate
179 -- casing is constructed.
181 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
182 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
183 -- Query whether a particular item appears in a mixed list of nodes and
184 -- entities. It is assumed that all nodes in the list have entities.
186 function Check_Kind
(Nam
: Name_Id
) return Name_Id
;
187 -- This function is used in connection with pragmas Assert, Check,
188 -- and assertion aspects and pragmas, to determine if Check pragmas
189 -- (or corresponding assertion aspects or pragmas) are currently active
190 -- as determined by the presence of -gnata on the command line (which
191 -- sets the default), and the appearance of pragmas Check_Policy and
192 -- Assertion_Policy as configuration pragmas either in a configuration
193 -- pragma file, or at the start of the current unit, or locally given
194 -- Check_Policy and Assertion_Policy pragmas that are currently active.
196 -- The value returned is one of the names Check, Ignore, Disable (On
197 -- returns Check, and Off returns Ignore).
199 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
200 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
201 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
202 -- _Post, _Invariant, or _Type_Invariant, which are special names used
203 -- in identifiers to represent these attribute references.
205 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
);
206 -- In ASIS mode we need to analyze the original expression in the aspect
207 -- specification. For Initializes, Global, and related SPARK aspects, the
208 -- expression has a sui-generis syntax which may be a list, an expression,
211 procedure Check_State_And_Constituent_Use
215 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
216 -- Global and Initializes. Determine whether a state from list States and a
217 -- corresponding constituent from list Constits (if any) appear in the same
218 -- context denoted by Context. If this is the case, emit an error.
220 function Find_Related_Subprogram_Or_Body
222 Do_Checks
: Boolean := False) return Node_Id
;
223 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
224 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
225 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
226 -- Do_Checks is set, the routine reports duplicate pragmas and detects
227 -- improper use of refinement pragmas in stand alone expression functions.
228 -- The returned value depends on the related pragma as follows:
229 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
230 -- N_Subprogram_Declaration node or if the pragma applies to a stand
231 -- alone body, the N_Subprogram_Body node or Empty if illegal.
232 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
233 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
236 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
237 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
238 -- original one, following the renaming chain) is returned. Otherwise the
239 -- entity is returned unchanged. Should be in Einfo???
241 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
242 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
243 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
246 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
247 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
248 -- Determine whether dependency clause Clause is surrounded by extra
249 -- parentheses. If this is the case, issue an error message.
251 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
252 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
253 -- pragma Depends. Determine whether the type of dependency item Item is
254 -- tagged, unconstrained array, unconstrained record or a record with at
255 -- least one unconstrained component.
257 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
);
258 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
259 -- of a Test_Case pragma if present (possibly Empty). We treat these as
260 -- spec expressions (i.e. similar to a default expression).
262 procedure Record_Possible_Body_Reference
263 (State_Id
: Entity_Id
;
265 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
266 -- Global. Given an abstract state denoted by State_Id and a reference Ref
267 -- to it, determine whether the reference appears in a package body that
268 -- will eventually refine the state. If this is the case, record the
269 -- reference for future checks (see Analyze_Refined_State_In_Decls).
271 procedure Resolve_State
(N
: Node_Id
);
272 -- Handle the overloading of state names by functions. When N denotes a
273 -- function, this routine finds the corresponding state and sets the entity
274 -- of N to that of the state.
276 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
277 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
278 -- then it is rewritten as an identifier with the corresponding special
279 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
280 -- Check, Check_Policy.
282 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
283 -- Place semantic information on the argument of an Elaborate/Elaborate_All
284 -- pragma. Entity name for unit and its parents is taken from item in
285 -- previous with_clause that mentions the unit.
287 Dummy
: Integer := 0;
288 pragma Volatile
(Dummy
);
289 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
292 pragma No_Inline
(ip
);
293 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
294 -- is just to help debugging the front end. If a pragma Inspection_Point
295 -- is added to a source program, then breaking on ip will get you to that
296 -- point in the program.
299 pragma No_Inline
(rv
);
300 -- This is a dummy function called by the processing for pragma Reviewable.
301 -- It is there for assisting front end debugging. By placing a Reviewable
302 -- pragma in the source program, a breakpoint on rv catches this place in
303 -- the source, allowing convenient stepping to the point of interest.
309 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
311 Append_New_Elmt
(Item
, To
=> To_List
);
314 -------------------------------
315 -- Adjust_External_Name_Case --
316 -------------------------------
318 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
322 -- Adjust case of literal if required
324 if Opt
.External_Name_Exp_Casing
= As_Is
then
328 -- Copy existing string
334 for J
in 1 .. String_Length
(Strval
(N
)) loop
335 CC
:= Get_String_Char
(Strval
(N
), J
);
337 if Opt
.External_Name_Exp_Casing
= Uppercase
338 and then CC
>= Get_Char_Code
('a')
339 and then CC
<= Get_Char_Code
('z')
341 Store_String_Char
(CC
- 32);
343 elsif Opt
.External_Name_Exp_Casing
= Lowercase
344 and then CC
>= Get_Char_Code
('A')
345 and then CC
<= Get_Char_Code
('Z')
347 Store_String_Char
(CC
+ 32);
350 Store_String_Char
(CC
);
355 Make_String_Literal
(Sloc
(N
),
356 Strval
=> End_String
);
358 end Adjust_External_Name_Case
;
360 -----------------------------------------
361 -- Analyze_Contract_Cases_In_Decl_Part --
362 -----------------------------------------
364 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
365 Others_Seen
: Boolean := False;
367 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
368 -- Verify the legality of a single contract case
370 ---------------------------
371 -- Analyze_Contract_Case --
372 ---------------------------
374 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
375 Case_Guard
: Node_Id
;
377 Extra_Guard
: Node_Id
;
380 if Nkind
(CCase
) = N_Component_Association
then
381 Case_Guard
:= First
(Choices
(CCase
));
382 Conseq
:= Expression
(CCase
);
384 -- Each contract case must have exactly one case guard
386 Extra_Guard
:= Next
(Case_Guard
);
388 if Present
(Extra_Guard
) then
390 ("contract case must have exactly one case guard",
394 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
396 if Nkind
(Case_Guard
) = N_Others_Choice
then
399 ("only one others choice allowed in contract cases",
405 elsif Others_Seen
then
407 ("others must be the last choice in contract cases", N
);
410 -- Preanalyze the case guard and consequence
412 if Nkind
(Case_Guard
) /= N_Others_Choice
then
413 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
416 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
418 -- The contract case is malformed
421 Error_Msg_N
("wrong syntax in contract case", CCase
);
423 end Analyze_Contract_Case
;
432 Restore_Scope
: Boolean := False;
433 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
435 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
440 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
441 Subp_Id
:= Defining_Entity
(Subp_Decl
);
442 All_Cases
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
444 -- Single and multiple contract cases must appear in aggregate form. If
445 -- this is not the case, then either the parser of the analysis of the
446 -- pragma failed to produce an aggregate.
448 pragma Assert
(Nkind
(All_Cases
) = N_Aggregate
);
450 if No
(Component_Associations
(All_Cases
)) then
451 Error_Msg_N
("wrong syntax for constract cases", N
);
453 -- Individual contract cases appear as component associations
456 -- Ensure that the formal parameters are visible when analyzing all
457 -- clauses. This falls out of the general rule of aspects pertaining
458 -- to subprogram declarations. Skip the installation for subprogram
459 -- bodies because the formals are already visible.
461 if not In_Open_Scopes
(Subp_Id
) then
462 Restore_Scope
:= True;
463 Push_Scope
(Subp_Id
);
464 Install_Formals
(Subp_Id
);
467 CCase
:= First
(Component_Associations
(All_Cases
));
468 while Present
(CCase
) loop
469 Analyze_Contract_Case
(CCase
);
473 if Restore_Scope
then
477 end Analyze_Contract_Cases_In_Decl_Part
;
479 ----------------------------------
480 -- Analyze_Depends_In_Decl_Part --
481 ----------------------------------
483 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
484 Loc
: constant Source_Ptr
:= Sloc
(N
);
486 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
487 -- A list containing the entities of all the inputs processed so far.
488 -- The list is populated with unique entities because the same input
489 -- may appear in multiple input lists.
491 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
492 -- A list containing the entities of all the outputs processed so far.
493 -- The list is populated with unique entities because output items are
494 -- unique in a dependence relation.
496 Constits_Seen
: Elist_Id
:= No_Elist
;
497 -- A list containing the entities of all constituents processed so far.
498 -- It aids in detecting illegal usage of a state and a corresponding
499 -- constituent in pragma [Refinde_]Depends.
501 Global_Seen
: Boolean := False;
502 -- A flag set when pragma Global has been processed
504 Null_Output_Seen
: Boolean := False;
505 -- A flag used to track the legality of a null output
507 Result_Seen
: Boolean := False;
508 -- A flag set when Subp_Id'Result is processed
511 -- The entity of the subprogram subject to pragma [Refined_]Depends
513 States_Seen
: Elist_Id
:= No_Elist
;
514 -- A list containing the entities of all states processed so far. It
515 -- helps in detecting illegal usage of a state and a corresponding
516 -- constituent in pragma [Refined_]Depends.
519 -- The entity of the subprogram [body or stub] subject to pragma
520 -- [Refined_]Depends.
522 Subp_Inputs
: Elist_Id
:= No_Elist
;
523 Subp_Outputs
: Elist_Id
:= No_Elist
;
524 -- Two lists containing the full set of inputs and output of the related
525 -- subprograms. Note that these lists contain both nodes and entities.
527 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
528 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
529 -- to the name buffer. The individual kinds are as follows:
530 -- E_Abstract_State - "state"
531 -- E_In_Parameter - "parameter"
532 -- E_In_Out_Parameter - "parameter"
533 -- E_Out_Parameter - "parameter"
534 -- E_Variable - "global"
536 procedure Analyze_Dependency_Clause
539 -- Verify the legality of a single dependency clause. Flag Is_Last
540 -- denotes whether Clause is the last clause in the relation.
542 procedure Check_Function_Return
;
543 -- Verify that Funtion'Result appears as one of the outputs
544 -- (SPARK RM 6.1.5(10)).
551 -- Ensure that an item fulfils its designated input and/or output role
552 -- as specified by pragma Global (if any) or the enclosing context. If
553 -- this is not the case, emit an error. Item and Item_Id denote the
554 -- attributes of an item. Flag Is_Input should be set when item comes
555 -- from an input list. Flag Self_Ref should be set when the item is an
556 -- output and the dependency clause has operator "+".
558 procedure Check_Usage
559 (Subp_Items
: Elist_Id
;
560 Used_Items
: Elist_Id
;
562 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
563 -- error if this is not the case.
565 procedure Normalize_Clause
(Clause
: Node_Id
);
566 -- Remove a self-dependency "+" from the input list of a clause
568 -----------------------------
569 -- Add_Item_To_Name_Buffer --
570 -----------------------------
572 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
574 if Ekind
(Item_Id
) = E_Abstract_State
then
575 Add_Str_To_Name_Buffer
("state");
577 elsif Is_Formal
(Item_Id
) then
578 Add_Str_To_Name_Buffer
("parameter");
580 elsif Ekind
(Item_Id
) = E_Variable
then
581 Add_Str_To_Name_Buffer
("global");
583 -- The routine should not be called with non-SPARK items
588 end Add_Item_To_Name_Buffer
;
590 -------------------------------
591 -- Analyze_Dependency_Clause --
592 -------------------------------
594 procedure Analyze_Dependency_Clause
598 procedure Analyze_Input_List
(Inputs
: Node_Id
);
599 -- Verify the legality of a single input list
601 procedure Analyze_Input_Output
606 Seen
: in out Elist_Id
;
607 Null_Seen
: in out Boolean;
608 Non_Null_Seen
: in out Boolean);
609 -- Verify the legality of a single input or output item. Flag
610 -- Is_Input should be set whenever Item is an input, False when it
611 -- denotes an output. Flag Self_Ref should be set when the item is an
612 -- output and the dependency clause has a "+". Flag Top_Level should
613 -- be set whenever Item appears immediately within an input or output
614 -- list. Seen is a collection of all abstract states, variables and
615 -- formals processed so far. Flag Null_Seen denotes whether a null
616 -- input or output has been encountered. Flag Non_Null_Seen denotes
617 -- whether a non-null input or output has been encountered.
619 ------------------------
620 -- Analyze_Input_List --
621 ------------------------
623 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
624 Inputs_Seen
: Elist_Id
:= No_Elist
;
625 -- A list containing the entities of all inputs that appear in the
626 -- current input list.
628 Non_Null_Input_Seen
: Boolean := False;
629 Null_Input_Seen
: Boolean := False;
630 -- Flags used to check the legality of an input list
635 -- Multiple inputs appear as an aggregate
637 if Nkind
(Inputs
) = N_Aggregate
then
638 if Present
(Component_Associations
(Inputs
)) then
640 ("nested dependency relations not allowed", Inputs
);
642 elsif Present
(Expressions
(Inputs
)) then
643 Input
:= First
(Expressions
(Inputs
));
644 while Present
(Input
) loop
651 Null_Seen
=> Null_Input_Seen
,
652 Non_Null_Seen
=> Non_Null_Input_Seen
);
657 -- Syntax error, always report
660 Error_Msg_N
("malformed input dependency list", Inputs
);
663 -- Process a solitary input
672 Null_Seen
=> Null_Input_Seen
,
673 Non_Null_Seen
=> Non_Null_Input_Seen
);
676 -- Detect an illegal dependency clause of the form
680 if Null_Output_Seen
and then Null_Input_Seen
then
682 ("null dependency clause cannot have a null input list",
685 end Analyze_Input_List
;
687 --------------------------
688 -- Analyze_Input_Output --
689 --------------------------
691 procedure Analyze_Input_Output
696 Seen
: in out Elist_Id
;
697 Null_Seen
: in out Boolean;
698 Non_Null_Seen
: in out Boolean)
700 Is_Output
: constant Boolean := not Is_Input
;
705 -- Multiple input or output items appear as an aggregate
707 if Nkind
(Item
) = N_Aggregate
then
708 if not Top_Level
then
709 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
711 elsif Present
(Component_Associations
(Item
)) then
713 ("nested dependency relations not allowed", Item
);
715 -- Recursively analyze the grouped items
717 elsif Present
(Expressions
(Item
)) then
718 Grouped
:= First
(Expressions
(Item
));
719 while Present
(Grouped
) loop
722 Is_Input
=> Is_Input
,
723 Self_Ref
=> Self_Ref
,
726 Null_Seen
=> Null_Seen
,
727 Non_Null_Seen
=> Non_Null_Seen
);
732 -- Syntax error, always report
735 Error_Msg_N
("malformed dependency list", Item
);
738 -- Process Function'Result in the context of a dependency clause
740 elsif Is_Attribute_Result
(Item
) then
741 Non_Null_Seen
:= True;
743 -- It is sufficent to analyze the prefix of 'Result in order to
744 -- establish legality of the attribute.
746 Analyze
(Prefix
(Item
));
748 -- The prefix of 'Result must denote the function for which
749 -- pragma Depends applies (SPARK RM 6.1.5(11)).
751 if not Is_Entity_Name
(Prefix
(Item
))
752 or else Ekind
(Spec_Id
) /= E_Function
753 or else Entity
(Prefix
(Item
)) /= Spec_Id
755 Error_Msg_Name_1
:= Name_Result
;
757 ("prefix of attribute % must denote the enclosing "
760 -- Function'Result is allowed to appear on the output side of a
761 -- dependency clause (SPARK RM 6.1.5(6)).
764 SPARK_Msg_N
("function result cannot act as input", Item
);
768 ("cannot mix null and non-null dependency items", Item
);
774 -- Detect multiple uses of null in a single dependency list or
775 -- throughout the whole relation. Verify the placement of a null
776 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
778 elsif Nkind
(Item
) = N_Null
then
781 ("multiple null dependency relations not allowed", Item
);
783 elsif Non_Null_Seen
then
785 ("cannot mix null and non-null dependency items", Item
);
793 ("null output list must be the last clause in a "
794 & "dependency relation", Item
);
796 -- Catch a useless dependence of the form:
801 ("useless dependence, null depends on itself", Item
);
809 Non_Null_Seen
:= True;
812 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
816 Resolve_State
(Item
);
818 -- Find the entity of the item. If this is a renaming, climb
819 -- the renaming chain to reach the root object. Renamings of
820 -- non-entire objects do not yield an entity (Empty).
822 Item_Id
:= Entity_Of
(Item
);
824 if Present
(Item_Id
) then
825 if Ekind_In
(Item_Id
, E_Abstract_State
,
831 -- Ensure that the item fulfils its role as input and/or
832 -- output as specified by pragma Global or the enclosing
835 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
837 -- Detect multiple uses of the same state, variable or
838 -- formal parameter. If this is not the case, add the
839 -- item to the list of processed relations.
841 if Contains
(Seen
, Item_Id
) then
843 ("duplicate use of item &", Item
, Item_Id
);
845 Add_Item
(Item_Id
, Seen
);
848 -- Detect illegal use of an input related to a null
849 -- output. Such input items cannot appear in other
850 -- input lists (SPARK RM 6.1.5(13)).
853 and then Null_Output_Seen
854 and then Contains
(All_Inputs_Seen
, Item_Id
)
857 ("input of a null output list cannot appear in "
858 & "multiple input lists", Item
);
861 -- Add an input or a self-referential output to the list
862 -- of all processed inputs.
864 if Is_Input
or else Self_Ref
then
865 Add_Item
(Item_Id
, All_Inputs_Seen
);
868 -- State related checks (SPARK RM 6.1.5(3))
870 if Ekind
(Item_Id
) = E_Abstract_State
then
871 if Has_Visible_Refinement
(Item_Id
) then
873 ("cannot mention state & in global refinement",
876 ("\use its constituents instead", Item
);
879 -- If the reference to the abstract state appears in
880 -- an enclosing package body that will eventually
881 -- refine the state, record the reference for future
885 Record_Possible_Body_Reference
886 (State_Id
=> Item_Id
,
891 -- When the item renames an entire object, replace the
892 -- item with a reference to the object.
894 if Present
(Renamed_Object
(Entity
(Item
))) then
896 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
900 -- Add the entity of the current item to the list of
903 if Ekind
(Item_Id
) = E_Abstract_State
then
904 Add_Item
(Item_Id
, States_Seen
);
907 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
908 and then Present
(Encapsulating_State
(Item_Id
))
910 Add_Item
(Item_Id
, Constits_Seen
);
913 -- All other input/output items are illegal
914 -- (SPARK RM 6.1.5(1)).
918 ("item must denote parameter, variable, or state",
922 -- All other input/output items are illegal
923 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
927 ("item must denote parameter, variable, or state", Item
);
930 end Analyze_Input_Output
;
938 Non_Null_Output_Seen
: Boolean := False;
939 -- Flag used to check the legality of an output list
941 -- Start of processing for Analyze_Dependency_Clause
944 Inputs
:= Expression
(Clause
);
947 -- An input list with a self-dependency appears as operator "+" where
948 -- the actuals inputs are the right operand.
950 if Nkind
(Inputs
) = N_Op_Plus
then
951 Inputs
:= Right_Opnd
(Inputs
);
955 -- Process the output_list of a dependency_clause
957 Output
:= First
(Choices
(Clause
));
958 while Present
(Output
) loop
962 Self_Ref
=> Self_Ref
,
964 Seen
=> All_Outputs_Seen
,
965 Null_Seen
=> Null_Output_Seen
,
966 Non_Null_Seen
=> Non_Null_Output_Seen
);
971 -- Process the input_list of a dependency_clause
973 Analyze_Input_List
(Inputs
);
974 end Analyze_Dependency_Clause
;
976 ---------------------------
977 -- Check_Function_Return --
978 ---------------------------
980 procedure Check_Function_Return
is
982 if Ekind
(Spec_Id
) = E_Function
and then not Result_Seen
then
984 ("result of & must appear in exactly one output list",
987 end Check_Function_Return
;
1000 (Item_Is_Input
: out Boolean;
1001 Item_Is_Output
: out Boolean);
1002 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1003 -- Item_Is_Output are set depending on the role.
1005 procedure Role_Error
1006 (Item_Is_Input
: Boolean;
1007 Item_Is_Output
: Boolean);
1008 -- Emit an error message concerning the incorrect use of Item in
1009 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1010 -- denote whether the item is an input and/or an output.
1017 (Item_Is_Input
: out Boolean;
1018 Item_Is_Output
: out Boolean)
1021 Item_Is_Input
:= False;
1022 Item_Is_Output
:= False;
1024 -- Abstract state cases
1026 if Ekind
(Item_Id
) = E_Abstract_State
then
1028 -- When pragma Global is present, the mode of the state may be
1029 -- further constrained by setting a more restrictive mode.
1032 if Appears_In
(Subp_Inputs
, Item_Id
) then
1033 Item_Is_Input
:= True;
1036 if Appears_In
(Subp_Outputs
, Item_Id
) then
1037 Item_Is_Output
:= True;
1040 -- Otherwise the state has a default IN OUT mode
1043 Item_Is_Input
:= True;
1044 Item_Is_Output
:= True;
1049 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1050 Item_Is_Input
:= True;
1052 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1053 Item_Is_Input
:= True;
1054 Item_Is_Output
:= True;
1056 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1057 if Scope
(Item_Id
) = Spec_Id
then
1059 -- An OUT parameter of the related subprogram has mode IN
1060 -- if its type is unconstrained or tagged because array
1061 -- bounds, discriminants or tags can be read.
1063 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1064 Item_Is_Input
:= True;
1067 Item_Is_Output
:= True;
1069 -- An OUT parameter of an enclosing subprogram behaves as a
1070 -- read-write variable in which case the mode is IN OUT.
1073 Item_Is_Input
:= True;
1074 Item_Is_Output
:= True;
1079 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1081 -- When pragma Global is present, the mode of the variable may
1082 -- be further constrained by setting a more restrictive mode.
1086 -- A variable has mode IN when its type is unconstrained or
1087 -- tagged because array bounds, discriminants or tags can be
1090 if Appears_In
(Subp_Inputs
, Item_Id
)
1091 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1093 Item_Is_Input
:= True;
1096 if Appears_In
(Subp_Outputs
, Item_Id
) then
1097 Item_Is_Output
:= True;
1100 -- Otherwise the variable has a default IN OUT mode
1103 Item_Is_Input
:= True;
1104 Item_Is_Output
:= True;
1113 procedure Role_Error
1114 (Item_Is_Input
: Boolean;
1115 Item_Is_Output
: Boolean)
1117 Error_Msg
: Name_Id
;
1122 -- When the item is not part of the input and the output set of
1123 -- the related subprogram, then it appears as extra in pragma
1124 -- [Refined_]Depends.
1126 if not Item_Is_Input
and then not Item_Is_Output
then
1127 Add_Item_To_Name_Buffer
(Item_Id
);
1128 Add_Str_To_Name_Buffer
1129 (" & cannot appear in dependence relation");
1131 Error_Msg
:= Name_Find
;
1132 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1134 Error_Msg_Name_1
:= Chars
(Subp_Id
);
1136 ("\& is not part of the input or output set of subprogram %",
1139 -- The mode of the item and its role in pragma [Refined_]Depends
1140 -- are in conflict. Construct a detailed message explaining the
1141 -- illegality (SPARK RM 6.1.5(5-6)).
1144 if Item_Is_Input
then
1145 Add_Str_To_Name_Buffer
("read-only");
1147 Add_Str_To_Name_Buffer
("write-only");
1150 Add_Char_To_Name_Buffer
(' ');
1151 Add_Item_To_Name_Buffer
(Item_Id
);
1152 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1154 if Item_Is_Input
then
1155 Add_Str_To_Name_Buffer
("output");
1157 Add_Str_To_Name_Buffer
("input");
1160 Add_Str_To_Name_Buffer
(" in dependence relation");
1161 Error_Msg
:= Name_Find
;
1162 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1168 Item_Is_Input
: Boolean;
1169 Item_Is_Output
: Boolean;
1171 -- Start of processing for Check_Role
1174 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1179 if not Item_Is_Input
then
1180 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1183 -- Self-referential item
1186 if not Item_Is_Input
or else not Item_Is_Output
then
1187 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1192 elsif not Item_Is_Output
then
1193 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1201 procedure Check_Usage
1202 (Subp_Items
: Elist_Id
;
1203 Used_Items
: Elist_Id
;
1206 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
1207 -- Emit an error concerning the illegal usage of an item
1213 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
1214 Error_Msg
: Name_Id
;
1221 -- Unconstrained and tagged items are not part of the explicit
1222 -- input set of the related subprogram, they do not have to be
1223 -- present in a dependence relation and should not be flagged
1224 -- (SPARK RM 6.1.5(8)).
1226 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1229 Add_Item_To_Name_Buffer
(Item_Id
);
1230 Add_Str_To_Name_Buffer
1231 (" & must appear in at least one input dependence list");
1233 Error_Msg
:= Name_Find
;
1234 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1237 -- Output case (SPARK RM 6.1.5(10))
1242 Add_Item_To_Name_Buffer
(Item_Id
);
1243 Add_Str_To_Name_Buffer
1244 (" & must appear in exactly one output dependence list");
1246 Error_Msg
:= Name_Find
;
1247 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1255 Item_Id
: Entity_Id
;
1257 -- Start of processing for Check_Usage
1260 if No
(Subp_Items
) then
1264 -- Each input or output of the subprogram must appear in a dependency
1267 Elmt
:= First_Elmt
(Subp_Items
);
1268 while Present
(Elmt
) loop
1269 Item
:= Node
(Elmt
);
1271 if Nkind
(Item
) = N_Defining_Identifier
then
1274 Item_Id
:= Entity_Of
(Item
);
1277 -- The item does not appear in a dependency
1279 if Present
(Item_Id
)
1280 and then not Contains
(Used_Items
, Item_Id
)
1282 if Is_Formal
(Item_Id
) then
1283 Usage_Error
(Item
, Item_Id
);
1285 -- States and global variables are not used properly only when
1286 -- the subprogram is subject to pragma Global.
1288 elsif Global_Seen
then
1289 Usage_Error
(Item
, Item_Id
);
1297 ----------------------
1298 -- Normalize_Clause --
1299 ----------------------
1301 procedure Normalize_Clause
(Clause
: Node_Id
) is
1302 procedure Create_Or_Modify_Clause
1308 Multiple
: Boolean);
1309 -- Create a brand new clause to represent the self-reference or
1310 -- modify the input and/or output lists of an existing clause. Output
1311 -- denotes a self-referencial output. Outputs is the output list of a
1312 -- clause. Inputs is the input list of a clause. After denotes the
1313 -- clause after which the new clause is to be inserted. Flag In_Place
1314 -- should be set when normalizing the last output of an output list.
1315 -- Flag Multiple should be set when Output comes from a list with
1318 -----------------------------
1319 -- Create_Or_Modify_Clause --
1320 -----------------------------
1322 procedure Create_Or_Modify_Clause
1330 procedure Propagate_Output
1333 -- Handle the various cases of output propagation to the input
1334 -- list. Output denotes a self-referencial output item. Inputs is
1335 -- the input list of a clause.
1337 ----------------------
1338 -- Propagate_Output --
1339 ----------------------
1341 procedure Propagate_Output
1345 function In_Input_List
1347 Inputs
: List_Id
) return Boolean;
1348 -- Determine whether a particulat item appears in the input
1349 -- list of a clause.
1355 function In_Input_List
1357 Inputs
: List_Id
) return Boolean
1362 Elmt
:= First
(Inputs
);
1363 while Present
(Elmt
) loop
1364 if Entity_Of
(Elmt
) = Item
then
1376 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1379 -- Start of processing for Propagate_Output
1382 -- The clause is of the form:
1384 -- (Output =>+ null)
1386 -- Remove null input and replace it with a copy of the output:
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 aggregate
1463 -- 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). Note that
3113 -- the call analyzes its argument, so this cannot be used for the case
3114 -- where an identifier might not be declared.
3116 procedure Pragma_Misplaced
;
3117 pragma No_Return
(Pragma_Misplaced
);
3118 -- Issue fatal error message for misplaced pragma
3120 procedure Process_Atomic_Independent_Shared_Volatile
;
3121 -- Common processing for pragmas Atomic, Independent, Shared, Volatile.
3122 -- Note that Shared is an obsolete Ada 83 pragma and treated as being
3123 -- identical in effect to pragma Atomic.
3125 procedure Process_Compile_Time_Warning_Or_Error
;
3126 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3128 procedure Process_Convention
3129 (C
: out Convention_Id
;
3130 Ent
: out Entity_Id
);
3131 -- Common processing for Convention, Interface, Import and Export.
3132 -- Checks first two arguments of pragma, and sets the appropriate
3133 -- convention value in the specified entity or entities. On return
3134 -- C is the convention, Ent is the referenced entity.
3136 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3137 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3138 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3140 procedure Process_Extended_Import_Export_Object_Pragma
3141 (Arg_Internal
: Node_Id
;
3142 Arg_External
: Node_Id
;
3143 Arg_Size
: Node_Id
);
3144 -- Common processing for the pragmas Import/Export_Object. The three
3145 -- arguments correspond to the three named parameters of the pragmas. An
3146 -- argument is empty if the corresponding parameter is not present in
3149 procedure Process_Extended_Import_Export_Internal_Arg
3150 (Arg_Internal
: Node_Id
:= Empty
);
3151 -- Common processing for all extended Import and Export pragmas. The
3152 -- argument is the pragma parameter for the Internal argument. If
3153 -- Arg_Internal is empty or inappropriate, an error message is posted.
3154 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3155 -- set to identify the referenced entity.
3157 procedure Process_Extended_Import_Export_Subprogram_Pragma
3158 (Arg_Internal
: Node_Id
;
3159 Arg_External
: Node_Id
;
3160 Arg_Parameter_Types
: Node_Id
;
3161 Arg_Result_Type
: Node_Id
:= Empty
;
3162 Arg_Mechanism
: Node_Id
;
3163 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3164 -- Common processing for all extended Import and Export pragmas applying
3165 -- to subprograms. The caller omits any arguments that do not apply to
3166 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3167 -- only in the Import_Function and Export_Function cases). The argument
3168 -- names correspond to the allowed pragma association identifiers.
3170 procedure Process_Generic_List
;
3171 -- Common processing for Share_Generic and Inline_Generic
3173 procedure Process_Import_Or_Interface
;
3174 -- Common processing for Import or Interface
3176 procedure Process_Import_Predefined_Type
;
3177 -- Processing for completing a type with pragma Import. This is used
3178 -- to declare types that match predefined C types, especially for cases
3179 -- without corresponding Ada predefined type.
3181 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3182 -- Inline status of a subprogram, indicated as follows:
3183 -- Suppressed: inlining is suppressed for the subprogram
3184 -- Disabled: no inlining is requested for the subprogram
3185 -- Enabled: inlining is requested/required for the subprogram
3187 procedure Process_Inline
(Status
: Inline_Status
);
3188 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3189 -- indicates the inline status specified by the pragma.
3191 procedure Process_Interface_Name
3192 (Subprogram_Def
: Entity_Id
;
3194 Link_Arg
: Node_Id
);
3195 -- Given the last two arguments of pragma Import, pragma Export, or
3196 -- pragma Interface_Name, performs validity checks and sets the
3197 -- Interface_Name field of the given subprogram entity to the
3198 -- appropriate external or link name, depending on the arguments given.
3199 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3200 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3201 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3202 -- nor Link_Arg is present, the interface name is set to the default
3203 -- from the subprogram name.
3205 procedure Process_Interrupt_Or_Attach_Handler
;
3206 -- Common processing for Interrupt and Attach_Handler pragmas
3208 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3209 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3210 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3211 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3212 -- is not set in the Restrictions case.
3214 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3215 -- Common processing for Suppress and Unsuppress. The boolean parameter
3216 -- Suppress_Case is True for the Suppress case, and False for the
3219 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3220 -- This procedure sets the Is_Exported flag for the given entity,
3221 -- checking that the entity was not previously imported. Arg is
3222 -- the argument that specified the entity. A check is also made
3223 -- for exporting inappropriate entities.
3225 procedure Set_Extended_Import_Export_External_Name
3226 (Internal_Ent
: Entity_Id
;
3227 Arg_External
: Node_Id
);
3228 -- Common processing for all extended import export pragmas. The first
3229 -- argument, Internal_Ent, is the internal entity, which has already
3230 -- been checked for validity by the caller. Arg_External is from the
3231 -- Import or Export pragma, and may be null if no External parameter
3232 -- was present. If Arg_External is present and is a non-null string
3233 -- (a null string is treated as the default), then the Interface_Name
3234 -- field of Internal_Ent is set appropriately.
3236 procedure Set_Imported
(E
: Entity_Id
);
3237 -- This procedure sets the Is_Imported flag for the given entity,
3238 -- checking that it is not previously exported or imported.
3240 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3241 -- Mech is a parameter passing mechanism (see Import_Function syntax
3242 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3243 -- has the right form, and if not issues an error message. If the
3244 -- argument has the right form then the Mechanism field of Ent is
3245 -- set appropriately.
3247 procedure Set_Rational_Profile
;
3248 -- Activate the set of configuration pragmas and permissions that make
3249 -- up the Rational profile.
3251 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3252 -- Activate the set of configuration pragmas and restrictions that make
3253 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3254 -- is used for error messages on any constructs violating the profile.
3256 ----------------------------------
3257 -- Acquire_Warning_Match_String --
3258 ----------------------------------
3260 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3262 String_To_Name_Buffer
3263 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3265 -- Add asterisk at start if not already there
3267 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3268 Name_Buffer
(2 .. Name_Len
+ 1) :=
3269 Name_Buffer
(1 .. Name_Len
);
3270 Name_Buffer
(1) := '*';
3271 Name_Len
:= Name_Len
+ 1;
3274 -- Add asterisk at end if not already there
3276 if Name_Buffer
(Name_Len
) /= '*' then
3277 Name_Len
:= Name_Len
+ 1;
3278 Name_Buffer
(Name_Len
) := '*';
3280 end Acquire_Warning_Match_String
;
3282 ---------------------
3283 -- Ada_2005_Pragma --
3284 ---------------------
3286 procedure Ada_2005_Pragma
is
3288 if Ada_Version
<= Ada_95
then
3289 Check_Restriction
(No_Implementation_Pragmas
, N
);
3291 end Ada_2005_Pragma
;
3293 ---------------------
3294 -- Ada_2012_Pragma --
3295 ---------------------
3297 procedure Ada_2012_Pragma
is
3299 if Ada_Version
<= Ada_2005
then
3300 Check_Restriction
(No_Implementation_Pragmas
, N
);
3302 end Ada_2012_Pragma
;
3304 ---------------------
3305 -- Analyze_Part_Of --
3306 ---------------------
3308 procedure Analyze_Part_Of
3309 (Item_Id
: Entity_Id
;
3312 Legal
: out Boolean)
3314 Pack_Id
: Entity_Id
;
3315 Placement
: State_Space_Kind
;
3316 Parent_Unit
: Entity_Id
;
3317 State_Id
: Entity_Id
;
3320 -- Assume that the pragma/option is illegal
3324 if Nkind_In
(State
, N_Expanded_Name
,
3326 N_Selected_Component
)
3329 Resolve_State
(State
);
3331 if Is_Entity_Name
(State
)
3332 and then Ekind
(Entity
(State
)) = E_Abstract_State
3334 State_Id
:= Entity
(State
);
3338 ("indicator Part_Of must denote an abstract state", State
);
3342 -- This is a syntax error, always report
3346 ("indicator Part_Of must denote an abstract state", State
);
3350 -- Determine where the state, variable or the package instantiation
3351 -- lives with respect to the enclosing packages or package bodies (if
3352 -- any). This placement dictates the legality of the encapsulating
3355 Find_Placement_In_State_Space
3356 (Item_Id
=> Item_Id
,
3357 Placement
=> Placement
,
3358 Pack_Id
=> Pack_Id
);
3360 -- The item appears in a non-package construct with a declarative
3361 -- part (subprogram, block, etc). As such, the item is not allowed
3362 -- to be a part of an encapsulating state because the item is not
3365 if Placement
= Not_In_Package
then
3367 ("indicator Part_Of cannot appear in this context "
3368 & "(SPARK RM 7.2.6(5))", Indic
);
3369 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3371 ("\& is not part of the hidden state of package %",
3374 -- The item appears in the visible state space of some package. In
3375 -- general this scenario does not warrant Part_Of except when the
3376 -- package is a private child unit and the encapsulating state is
3377 -- declared in a parent unit or a public descendant of that parent
3380 elsif Placement
= Visible_State_Space
then
3381 if Is_Child_Unit
(Pack_Id
)
3382 and then Is_Private_Descendant
(Pack_Id
)
3384 -- A variable or state abstraction which is part of the
3385 -- visible state of a private child unit (or one of its public
3386 -- descendants) must have its Part_Of indicator specified. The
3387 -- Part_Of indicator must denote a state abstraction declared
3388 -- by either the parent unit of the private unit or by a public
3389 -- descendant of that parent unit.
3391 -- Find nearest private ancestor (which can be the current unit
3394 Parent_Unit
:= Pack_Id
;
3395 while Present
(Parent_Unit
) loop
3396 exit when Private_Present
3397 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3398 Parent_Unit
:= Scope
(Parent_Unit
);
3401 Parent_Unit
:= Scope
(Parent_Unit
);
3403 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3405 ("indicator Part_Of must denote an abstract state of& "
3406 & "or public descendant (SPARK RM 7.2.6(3))",
3407 Indic
, Parent_Unit
);
3409 elsif Scope
(State_Id
) = Parent_Unit
3410 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3412 not Is_Private_Descendant
(Scope
(State_Id
)))
3418 ("indicator Part_Of must denote an abstract state of& "
3419 & "or public descendant (SPARK RM 7.2.6(3))",
3420 Indic
, Parent_Unit
);
3423 -- Indicator Part_Of is not needed when the related package is not
3424 -- a private child unit or a public descendant thereof.
3428 ("indicator Part_Of cannot appear in this context "
3429 & "(SPARK RM 7.2.6(5))", Indic
);
3430 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3432 ("\& is declared in the visible part of package %",
3436 -- When the item appears in the private state space of a package, the
3437 -- encapsulating state must be declared in the same package.
3439 elsif Placement
= Private_State_Space
then
3440 if Scope
(State_Id
) /= Pack_Id
then
3442 ("indicator Part_Of must designate an abstract state of "
3443 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3444 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3446 ("\& is declared in the private part of package %",
3450 -- Items declared in the body state space of a package do not need
3451 -- Part_Of indicators as the refinement has already been seen.
3455 ("indicator Part_Of cannot appear in this context "
3456 & "(SPARK RM 7.2.6(5))", Indic
);
3458 if Scope
(State_Id
) = Pack_Id
then
3459 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3461 ("\& is declared in the body of package %", Indic
, Item_Id
);
3466 end Analyze_Part_Of
;
3468 ----------------------------
3469 -- Analyze_Refined_Pragma --
3470 ----------------------------
3472 procedure Analyze_Refined_Pragma
3473 (Spec_Id
: out Entity_Id
;
3474 Body_Id
: out Entity_Id
;
3475 Legal
: out Boolean)
3477 Body_Decl
: Node_Id
;
3478 Spec_Decl
: Node_Id
;
3481 -- Assume that the pragma is illegal
3488 Check_Arg_Count
(1);
3489 Check_No_Identifiers
;
3491 if Nam_In
(Pname
, Name_Refined_Depends
,
3492 Name_Refined_Global
,
3495 Ensure_Aggregate_Form
(Arg1
);
3498 -- Verify the placement of the pragma and check for duplicates. The
3499 -- pragma must apply to a subprogram body [stub].
3501 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3503 -- Extract the entities of the spec and body
3505 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3506 Body_Id
:= Defining_Entity
(Body_Decl
);
3507 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3509 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3510 Body_Id
:= Defining_Entity
(Body_Decl
);
3511 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3518 -- The pragma must apply to the second declaration of a subprogram.
3519 -- In other words, the body [stub] cannot acts as a spec.
3521 if No
(Spec_Id
) then
3522 Error_Pragma
("pragma % cannot apply to a stand alone body");
3525 -- Catch the case where the subprogram body is a subunit and acts as
3526 -- the third declaration of the subprogram.
3528 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3529 Error_Pragma
("pragma % cannot apply to a subunit");
3533 -- The pragma can only apply to the body [stub] of a subprogram
3534 -- declared in the visible part of a package. Retrieve the context of
3535 -- the subprogram declaration.
3537 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3539 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3541 ("pragma % must apply to the body of a subprogram declared in a "
3542 & "package specification");
3546 -- If we get here, then the pragma is legal
3549 end Analyze_Refined_Pragma
;
3551 --------------------------
3552 -- Check_Ada_83_Warning --
3553 --------------------------
3555 procedure Check_Ada_83_Warning
is
3557 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3558 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3560 end Check_Ada_83_Warning
;
3562 ---------------------
3563 -- Check_Arg_Count --
3564 ---------------------
3566 procedure Check_Arg_Count
(Required
: Nat
) is
3568 if Arg_Count
/= Required
then
3569 Error_Pragma
("wrong number of arguments for pragma%");
3571 end Check_Arg_Count
;
3573 --------------------------------
3574 -- Check_Arg_Is_External_Name --
3575 --------------------------------
3577 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3578 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3581 if Nkind
(Argx
) = N_Identifier
then
3585 Analyze_And_Resolve
(Argx
, Standard_String
);
3587 if Is_OK_Static_Expression
(Argx
) then
3590 elsif Etype
(Argx
) = Any_Type
then
3593 -- An interesting special case, if we have a string literal and
3594 -- we are in Ada 83 mode, then we allow it even though it will
3595 -- not be flagged as static. This allows expected Ada 83 mode
3596 -- use of external names which are string literals, even though
3597 -- technically these are not static in Ada 83.
3599 elsif Ada_Version
= Ada_83
3600 and then Nkind
(Argx
) = N_String_Literal
3604 -- Static expression that raises Constraint_Error. This has
3605 -- already been flagged, so just exit from pragma processing.
3607 elsif Is_OK_Static_Expression
(Argx
) then
3610 -- Here we have a real error (non-static expression)
3613 Error_Msg_Name_1
:= Pname
;
3616 Msg
: constant String :=
3617 "argument for pragma% must be a identifier or "
3618 & "static string expression!";
3620 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3625 end Check_Arg_Is_External_Name
;
3627 -----------------------------
3628 -- Check_Arg_Is_Identifier --
3629 -----------------------------
3631 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3632 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3634 if Nkind
(Argx
) /= N_Identifier
then
3636 ("argument for pragma% must be identifier", Argx
);
3638 end Check_Arg_Is_Identifier
;
3640 ----------------------------------
3641 -- Check_Arg_Is_Integer_Literal --
3642 ----------------------------------
3644 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3645 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3647 if Nkind
(Argx
) /= N_Integer_Literal
then
3649 ("argument for pragma% must be integer literal", Argx
);
3651 end Check_Arg_Is_Integer_Literal
;
3653 -------------------------------------------
3654 -- Check_Arg_Is_Library_Level_Local_Name --
3655 -------------------------------------------
3659 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3660 -- | library_unit_NAME
3662 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3664 Check_Arg_Is_Local_Name
(Arg
);
3666 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3667 and then Comes_From_Source
(N
)
3670 ("argument for pragma% must be library level entity", Arg
);
3672 end Check_Arg_Is_Library_Level_Local_Name
;
3674 -----------------------------
3675 -- Check_Arg_Is_Local_Name --
3676 -----------------------------
3680 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3681 -- | library_unit_NAME
3683 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3684 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3689 if Nkind
(Argx
) not in N_Direct_Name
3690 and then (Nkind
(Argx
) /= N_Attribute_Reference
3691 or else Present
(Expressions
(Argx
))
3692 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3693 and then (not Is_Entity_Name
(Argx
)
3694 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3696 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3699 -- No further check required if not an entity name
3701 if not Is_Entity_Name
(Argx
) then
3707 Ent
: constant Entity_Id
:= Entity
(Argx
);
3708 Scop
: constant Entity_Id
:= Scope
(Ent
);
3711 -- Case of a pragma applied to a compilation unit: pragma must
3712 -- occur immediately after the program unit in the compilation.
3714 if Is_Compilation_Unit
(Ent
) then
3716 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3719 -- Case of pragma placed immediately after spec
3721 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3724 -- Case of pragma placed immediately after body
3726 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3727 and then Present
(Corresponding_Body
(Decl
))
3731 (Parent
(Unit_Declaration_Node
3732 (Corresponding_Body
(Decl
))));
3734 -- All other cases are illegal
3741 -- Special restricted placement rule from 10.2.1(11.8/2)
3743 elsif Is_Generic_Formal
(Ent
)
3744 and then Prag_Id
= Pragma_Preelaborable_Initialization
3746 OK
:= List_Containing
(N
) =
3747 Generic_Formal_Declarations
3748 (Unit_Declaration_Node
(Scop
));
3750 -- If this is an aspect applied to a subprogram body, the
3751 -- pragma is inserted in its declarative part.
3753 elsif From_Aspect_Specification
(N
)
3754 and then Ent
= Current_Scope
3756 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3760 -- If the aspect is a predicate (possibly others ???) and the
3761 -- context is a record type, this is a discriminant expression
3762 -- within a type declaration, that freezes the predicated
3765 elsif From_Aspect_Specification
(N
)
3766 and then Prag_Id
= Pragma_Predicate
3767 and then Ekind
(Current_Scope
) = E_Record_Type
3768 and then Scop
= Scope
(Current_Scope
)
3772 -- Default case, just check that the pragma occurs in the scope
3773 -- of the entity denoted by the name.
3776 OK
:= Current_Scope
= Scop
;
3781 ("pragma% argument must be in same declarative part", Arg
);
3785 end Check_Arg_Is_Local_Name
;
3787 ---------------------------------
3788 -- Check_Arg_Is_Locking_Policy --
3789 ---------------------------------
3791 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3792 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3795 Check_Arg_Is_Identifier
(Argx
);
3797 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3798 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3800 end Check_Arg_Is_Locking_Policy
;
3802 -----------------------------------------------
3803 -- Check_Arg_Is_Partition_Elaboration_Policy --
3804 -----------------------------------------------
3806 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3807 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3810 Check_Arg_Is_Identifier
(Argx
);
3812 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3814 ("& is not a valid partition elaboration policy name", Argx
);
3816 end Check_Arg_Is_Partition_Elaboration_Policy
;
3818 -------------------------
3819 -- Check_Arg_Is_One_Of --
3820 -------------------------
3822 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3823 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3826 Check_Arg_Is_Identifier
(Argx
);
3828 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3829 Error_Msg_Name_2
:= N1
;
3830 Error_Msg_Name_3
:= N2
;
3831 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3833 end Check_Arg_Is_One_Of
;
3835 procedure Check_Arg_Is_One_Of
3837 N1
, N2
, N3
: Name_Id
)
3839 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3842 Check_Arg_Is_Identifier
(Argx
);
3844 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3845 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3847 end Check_Arg_Is_One_Of
;
3849 procedure Check_Arg_Is_One_Of
3851 N1
, N2
, N3
, N4
: Name_Id
)
3853 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3856 Check_Arg_Is_Identifier
(Argx
);
3858 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3859 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3861 end Check_Arg_Is_One_Of
;
3863 procedure Check_Arg_Is_One_Of
3865 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3867 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3870 Check_Arg_Is_Identifier
(Argx
);
3872 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3873 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3875 end Check_Arg_Is_One_Of
;
3877 ---------------------------------
3878 -- Check_Arg_Is_Queuing_Policy --
3879 ---------------------------------
3881 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3882 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3885 Check_Arg_Is_Identifier
(Argx
);
3887 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3888 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3890 end Check_Arg_Is_Queuing_Policy
;
3892 ---------------------------------------
3893 -- Check_Arg_Is_OK_Static_Expression --
3894 ---------------------------------------
3896 procedure Check_Arg_Is_OK_Static_Expression
3898 Typ
: Entity_Id
:= Empty
)
3901 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
3902 end Check_Arg_Is_OK_Static_Expression
;
3904 ------------------------------------------
3905 -- Check_Arg_Is_Task_Dispatching_Policy --
3906 ------------------------------------------
3908 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
3909 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3912 Check_Arg_Is_Identifier
(Argx
);
3914 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
3916 ("& is not an allowed task dispatching policy name", Argx
);
3918 end Check_Arg_Is_Task_Dispatching_Policy
;
3920 ---------------------
3921 -- Check_Arg_Order --
3922 ---------------------
3924 procedure Check_Arg_Order
(Names
: Name_List
) is
3927 Highest_So_Far
: Natural := 0;
3928 -- Highest index in Names seen do far
3932 for J
in 1 .. Arg_Count
loop
3933 if Chars
(Arg
) /= No_Name
then
3934 for K
in Names
'Range loop
3935 if Chars
(Arg
) = Names
(K
) then
3936 if K
< Highest_So_Far
then
3937 Error_Msg_Name_1
:= Pname
;
3939 ("parameters out of order for pragma%", Arg
);
3940 Error_Msg_Name_1
:= Names
(K
);
3941 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
3942 Error_Msg_N
("\% must appear before %", Arg
);
3946 Highest_So_Far
:= K
;
3954 end Check_Arg_Order
;
3956 --------------------------------
3957 -- Check_At_Least_N_Arguments --
3958 --------------------------------
3960 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
3962 if Arg_Count
< N
then
3963 Error_Pragma
("too few arguments for pragma%");
3965 end Check_At_Least_N_Arguments
;
3967 -------------------------------
3968 -- Check_At_Most_N_Arguments --
3969 -------------------------------
3971 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
3974 if Arg_Count
> N
then
3976 for J
in 1 .. N
loop
3978 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
3981 end Check_At_Most_N_Arguments
;
3983 ---------------------
3984 -- Check_Component --
3985 ---------------------
3987 procedure Check_Component
3990 In_Variant_Part
: Boolean := False)
3992 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
3993 Sindic
: constant Node_Id
:=
3994 Subtype_Indication
(Component_Definition
(Comp
));
3995 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
3998 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
3999 -- object constraint, then the component type shall be an Unchecked_
4002 if Nkind
(Sindic
) = N_Subtype_Indication
4003 and then Has_Per_Object_Constraint
(Comp_Id
)
4004 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4007 ("component subtype subject to per-object constraint "
4008 & "must be an Unchecked_Union", Comp
);
4010 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4011 -- the body of a generic unit, or within the body of any of its
4012 -- descendant library units, no part of the type of a component
4013 -- declared in a variant_part of the unchecked union type shall be of
4014 -- a formal private type or formal private extension declared within
4015 -- the formal part of the generic unit.
4017 elsif Ada_Version
>= Ada_2012
4018 and then In_Generic_Body
(UU_Typ
)
4019 and then In_Variant_Part
4020 and then Is_Private_Type
(Typ
)
4021 and then Is_Generic_Type
(Typ
)
4024 ("component of unchecked union cannot be of generic type", Comp
);
4026 elsif Needs_Finalization
(Typ
) then
4028 ("component of unchecked union cannot be controlled", Comp
);
4030 elsif Has_Task
(Typ
) then
4032 ("component of unchecked union cannot have tasks", Comp
);
4034 end Check_Component
;
4036 -----------------------------
4037 -- Check_Declaration_Order --
4038 -----------------------------
4040 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4041 procedure Check_Aspect_Specification_Order
;
4042 -- Inspect the aspect specifications of the context to determine the
4045 --------------------------------------
4046 -- Check_Aspect_Specification_Order --
4047 --------------------------------------
4049 procedure Check_Aspect_Specification_Order
is
4050 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4051 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4055 -- Both aspects must be part of the same aspect specification list
4058 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4060 -- Try to reach Second starting from First in a left to right
4061 -- traversal of the aspect specifications.
4063 Asp
:= Next
(Asp_First
);
4064 while Present
(Asp
) loop
4066 -- The order is ok, First is followed by Second
4068 if Asp
= Asp_Second
then
4075 -- If we get here, then the aspects are out of order
4077 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4078 end Check_Aspect_Specification_Order
;
4084 -- Start of processing for Check_Declaration_Order
4087 -- Cannot check the order if one of the pragmas is missing
4089 if No
(First
) or else No
(Second
) then
4093 -- Set up the error names in case the order is incorrect
4095 Error_Msg_Name_1
:= Pragma_Name
(First
);
4096 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4098 if From_Aspect_Specification
(First
) then
4100 -- Both pragmas are actually aspects, check their declaration
4101 -- order in the associated aspect specification list. Otherwise
4102 -- First is an aspect and Second a source pragma.
4104 if From_Aspect_Specification
(Second
) then
4105 Check_Aspect_Specification_Order
;
4108 -- Abstract_States is a source pragma
4111 if From_Aspect_Specification
(Second
) then
4112 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4114 -- Both pragmas are source constructs. Try to reach First from
4115 -- Second by traversing the declarations backwards.
4118 Stmt
:= Prev
(Second
);
4119 while Present
(Stmt
) loop
4121 -- The order is ok, First is followed by Second
4123 if Stmt
= First
then
4130 -- If we get here, then the pragmas are out of order
4132 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4135 end Check_Declaration_Order
;
4137 ----------------------------
4138 -- Check_Duplicate_Pragma --
4139 ----------------------------
4141 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4142 Id
: Entity_Id
:= E
;
4146 -- Nothing to do if this pragma comes from an aspect specification,
4147 -- since we could not be duplicating a pragma, and we dealt with the
4148 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4150 if From_Aspect_Specification
(N
) then
4154 -- Otherwise current pragma may duplicate previous pragma or a
4155 -- previously given aspect specification or attribute definition
4156 -- clause for the same pragma.
4158 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4162 -- If the entity is a type, then we have to make sure that the
4163 -- ostensible duplicate is not for a parent type from which this
4167 if Nkind
(P
) = N_Pragma
then
4169 Args
: constant List_Id
:=
4170 Pragma_Argument_Associations
(P
);
4173 and then Is_Entity_Name
(Expression
(First
(Args
)))
4174 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4175 and then Entity
(Expression
(First
(Args
))) /= E
4181 elsif Nkind
(P
) = N_Aspect_Specification
4182 and then Is_Type
(Entity
(P
))
4183 and then Entity
(P
) /= E
4189 -- Here we have a definite duplicate
4191 Error_Msg_Name_1
:= Pragma_Name
(N
);
4192 Error_Msg_Sloc
:= Sloc
(P
);
4194 -- For a single protected or a single task object, the error is
4195 -- issued on the original entity.
4197 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4198 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4201 if Nkind
(P
) = N_Aspect_Specification
4202 or else From_Aspect_Specification
(P
)
4204 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4206 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4211 end Check_Duplicate_Pragma
;
4213 ----------------------------------
4214 -- Check_Duplicated_Export_Name --
4215 ----------------------------------
4217 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4218 String_Val
: constant String_Id
:= Strval
(Nam
);
4221 -- We are only interested in the export case, and in the case of
4222 -- generics, it is the instance, not the template, that is the
4223 -- problem (the template will generate a warning in any case).
4225 if not Inside_A_Generic
4226 and then (Prag_Id
= Pragma_Export
4228 Prag_Id
= Pragma_Export_Procedure
4230 Prag_Id
= Pragma_Export_Valued_Procedure
4232 Prag_Id
= Pragma_Export_Function
)
4234 for J
in Externals
.First
.. Externals
.Last
loop
4235 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4236 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4237 Error_Msg_N
("external name duplicates name given#", Nam
);
4242 Externals
.Append
(Nam
);
4244 end Check_Duplicated_Export_Name
;
4246 ----------------------------------------
4247 -- Check_Expr_Is_OK_Static_Expression --
4248 ----------------------------------------
4250 procedure Check_Expr_Is_OK_Static_Expression
4252 Typ
: Entity_Id
:= Empty
)
4255 if Present
(Typ
) then
4256 Analyze_And_Resolve
(Expr
, Typ
);
4258 Analyze_And_Resolve
(Expr
);
4261 if Is_OK_Static_Expression
(Expr
) then
4264 elsif Etype
(Expr
) = Any_Type
then
4267 -- An interesting special case, if we have a string literal and we
4268 -- are in Ada 83 mode, then we allow it even though it will not be
4269 -- flagged as static. This allows the use of Ada 95 pragmas like
4270 -- Import in Ada 83 mode. They will of course be flagged with
4271 -- warnings as usual, but will not cause errors.
4273 elsif Ada_Version
= Ada_83
4274 and then Nkind
(Expr
) = N_String_Literal
4278 -- Static expression that raises Constraint_Error. This has already
4279 -- been flagged, so just exit from pragma processing.
4281 elsif Is_OK_Static_Expression
(Expr
) then
4284 -- Finally, we have a real error
4287 Error_Msg_Name_1
:= Pname
;
4288 Flag_Non_Static_Expr
4289 (Fix_Error
("argument for pragma% must be a static expression!"),
4293 end Check_Expr_Is_OK_Static_Expression
;
4295 -------------------------
4296 -- Check_First_Subtype --
4297 -------------------------
4299 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4300 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4301 Ent
: constant Entity_Id
:= Entity
(Argx
);
4304 if Is_First_Subtype
(Ent
) then
4307 elsif Is_Type
(Ent
) then
4309 ("pragma% cannot apply to subtype", Argx
);
4311 elsif Is_Object
(Ent
) then
4313 ("pragma% cannot apply to object, requires a type", Argx
);
4317 ("pragma% cannot apply to&, requires a type", Argx
);
4319 end Check_First_Subtype
;
4321 ----------------------
4322 -- Check_Identifier --
4323 ----------------------
4325 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4328 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4330 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4331 Error_Msg_Name_1
:= Pname
;
4332 Error_Msg_Name_2
:= Id
;
4333 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4337 end Check_Identifier
;
4339 --------------------------------
4340 -- Check_Identifier_Is_One_Of --
4341 --------------------------------
4343 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4346 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4348 if Chars
(Arg
) = No_Name
then
4349 Error_Msg_Name_1
:= Pname
;
4350 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4353 elsif Chars
(Arg
) /= N1
4354 and then Chars
(Arg
) /= N2
4356 Error_Msg_Name_1
:= Pname
;
4357 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4361 end Check_Identifier_Is_One_Of
;
4363 ---------------------------
4364 -- Check_In_Main_Program --
4365 ---------------------------
4367 procedure Check_In_Main_Program
is
4368 P
: constant Node_Id
:= Parent
(N
);
4371 -- Must be at in subprogram body
4373 if Nkind
(P
) /= N_Subprogram_Body
then
4374 Error_Pragma
("% pragma allowed only in subprogram");
4376 -- Otherwise warn if obviously not main program
4378 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4379 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4381 Error_Msg_Name_1
:= Pname
;
4383 ("??pragma% is only effective in main program", N
);
4385 end Check_In_Main_Program
;
4387 ---------------------------------------
4388 -- Check_Interrupt_Or_Attach_Handler --
4389 ---------------------------------------
4391 procedure Check_Interrupt_Or_Attach_Handler
is
4392 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4393 Handler_Proc
, Proc_Scope
: Entity_Id
;
4398 if Prag_Id
= Pragma_Interrupt_Handler
then
4399 Check_Restriction
(No_Dynamic_Attachment
, N
);
4402 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4403 Proc_Scope
:= Scope
(Handler_Proc
);
4405 -- On AAMP only, a pragma Interrupt_Handler is supported for
4406 -- nonprotected parameterless procedures.
4408 if not AAMP_On_Target
4409 or else Prag_Id
= Pragma_Attach_Handler
4411 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4413 ("argument of pragma% must be protected procedure", Arg1
);
4416 -- For pragma case (as opposed to access case), check placement.
4417 -- We don't need to do that for aspects, because we have the
4418 -- check that they aspect applies an appropriate procedure.
4420 if not From_Aspect_Specification
(N
)
4421 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4423 Error_Pragma
("pragma% must be in protected definition");
4427 if not Is_Library_Level_Entity
(Proc_Scope
)
4428 or else (AAMP_On_Target
4429 and then not Is_Library_Level_Entity
(Handler_Proc
))
4432 ("argument for pragma% must be library level entity", Arg1
);
4435 -- AI05-0033: A pragma cannot appear within a generic body, because
4436 -- instance can be in a nested scope. The check that protected type
4437 -- is itself a library-level declaration is done elsewhere.
4439 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4440 -- handle code prior to AI-0033. Analysis tools typically are not
4441 -- interested in this pragma in any case, so no need to worry too
4442 -- much about its placement.
4444 if Inside_A_Generic
then
4445 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4446 and then In_Package_Body
(Scope
(Current_Scope
))
4447 and then not Relaxed_RM_Semantics
4449 Error_Pragma
("pragma% cannot be used inside a generic");
4452 end Check_Interrupt_Or_Attach_Handler
;
4454 ---------------------------------
4455 -- Check_Loop_Pragma_Placement --
4456 ---------------------------------
4458 procedure Check_Loop_Pragma_Placement
is
4459 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4460 -- Verify whether the current pragma is properly grouped with other
4461 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4462 -- related loop where the pragma appears.
4464 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4465 -- Determine whether an arbitrary statement Stmt denotes pragma
4466 -- Loop_Invariant or Loop_Variant.
4468 procedure Placement_Error
(Constr
: Node_Id
);
4469 pragma No_Return
(Placement_Error
);
4470 -- Node Constr denotes the last loop restricted construct before we
4471 -- encountered an illegal relation between enclosing constructs. Emit
4472 -- an error depending on what Constr was.
4474 --------------------------------
4475 -- Check_Loop_Pragma_Grouping --
4476 --------------------------------
4478 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4479 Stop_Search
: exception;
4480 -- This exception is used to terminate the recursive descent of
4481 -- routine Check_Grouping.
4483 procedure Check_Grouping
(L
: List_Id
);
4484 -- Find the first group of pragmas in list L and if successful,
4485 -- ensure that the current pragma is part of that group. The
4486 -- routine raises Stop_Search once such a check is performed to
4487 -- halt the recursive descent.
4489 procedure Grouping_Error
(Prag
: Node_Id
);
4490 pragma No_Return
(Grouping_Error
);
4491 -- Emit an error concerning the current pragma indicating that it
4492 -- should be placed after pragma Prag.
4494 --------------------
4495 -- Check_Grouping --
4496 --------------------
4498 procedure Check_Grouping
(L
: List_Id
) is
4504 -- Inspect the list of declarations or statements looking for
4505 -- the first grouping of pragmas:
4508 -- pragma Loop_Invariant ...;
4509 -- pragma Loop_Variant ...;
4511 -- pragma Loop_Variant ...; -- current pragma
4513 -- If the current pragma is not in the grouping, then it must
4514 -- either appear in a different declarative or statement list
4515 -- or the construct at (1) is separating the pragma from the
4519 while Present
(Stmt
) loop
4521 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4522 -- inside a loop or a block housed inside a loop. Inspect
4523 -- the declarations and statements of the block as they may
4524 -- contain the first grouping.
4526 if Nkind
(Stmt
) = N_Block_Statement
then
4527 HSS
:= Handled_Statement_Sequence
(Stmt
);
4529 Check_Grouping
(Declarations
(Stmt
));
4531 if Present
(HSS
) then
4532 Check_Grouping
(Statements
(HSS
));
4535 -- First pragma of the first topmost grouping has been found
4537 elsif Is_Loop_Pragma
(Stmt
) then
4539 -- The group and the current pragma are not in the same
4540 -- declarative or statement list.
4542 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4543 Grouping_Error
(Stmt
);
4545 -- Try to reach the current pragma from the first pragma
4546 -- of the grouping while skipping other members:
4548 -- pragma Loop_Invariant ...; -- first pragma
4549 -- pragma Loop_Variant ...; -- member
4551 -- pragma Loop_Variant ...; -- current pragma
4554 while Present
(Stmt
) loop
4556 -- The current pragma is either the first pragma
4557 -- of the group or is a member of the group. Stop
4558 -- the search as the placement is legal.
4563 -- Skip group members, but keep track of the last
4564 -- pragma in the group.
4566 elsif Is_Loop_Pragma
(Stmt
) then
4569 -- A non-pragma is separating the group from the
4570 -- current pragma, the placement is illegal.
4573 Grouping_Error
(Prag
);
4579 -- If the traversal did not reach the current pragma,
4580 -- then the list must be malformed.
4582 raise Program_Error
;
4590 --------------------
4591 -- Grouping_Error --
4592 --------------------
4594 procedure Grouping_Error
(Prag
: Node_Id
) is
4596 Error_Msg_Sloc
:= Sloc
(Prag
);
4597 Error_Pragma
("pragma% must appear next to pragma#");
4600 -- Start of processing for Check_Loop_Pragma_Grouping
4603 -- Inspect the statements of the loop or nested blocks housed
4604 -- within to determine whether the current pragma is part of the
4605 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4607 Check_Grouping
(Statements
(Loop_Stmt
));
4610 when Stop_Search
=> null;
4611 end Check_Loop_Pragma_Grouping
;
4613 --------------------
4614 -- Is_Loop_Pragma --
4615 --------------------
4617 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4619 -- Inspect the original node as Loop_Invariant and Loop_Variant
4620 -- pragmas are rewritten to null when assertions are disabled.
4622 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4624 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4625 Name_Loop_Invariant
,
4632 ---------------------
4633 -- Placement_Error --
4634 ---------------------
4636 procedure Placement_Error
(Constr
: Node_Id
) is
4637 LA
: constant String := " with Loop_Entry";
4640 if Prag_Id
= Pragma_Assert
then
4641 Error_Msg_String
(1 .. LA
'Length) := LA
;
4642 Error_Msg_Strlen
:= LA
'Length;
4644 Error_Msg_Strlen
:= 0;
4647 if Nkind
(Constr
) = N_Pragma
then
4649 ("pragma %~ must appear immediately within the statements "
4653 ("block containing pragma %~ must appear immediately within "
4654 & "the statements of a loop", Constr
);
4656 end Placement_Error
;
4658 -- Local declarations
4663 -- Start of processing for Check_Loop_Pragma_Placement
4666 -- Check that pragma appears immediately within a loop statement,
4667 -- ignoring intervening block statements.
4671 while Present
(Stmt
) loop
4673 -- The pragma or previous block must appear immediately within the
4674 -- current block's declarative or statement part.
4676 if Nkind
(Stmt
) = N_Block_Statement
then
4677 if (No
(Declarations
(Stmt
))
4678 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4680 List_Containing
(Prev
) /=
4681 Statements
(Handled_Statement_Sequence
(Stmt
))
4683 Placement_Error
(Prev
);
4686 -- Keep inspecting the parents because we are now within a
4687 -- chain of nested blocks.
4691 Stmt
:= Parent
(Stmt
);
4694 -- The pragma or previous block must appear immediately within the
4695 -- statements of the loop.
4697 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4698 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4699 Placement_Error
(Prev
);
4702 -- Stop the traversal because we reached the innermost loop
4703 -- regardless of whether we encountered an error or not.
4707 -- Ignore a handled statement sequence. Note that this node may
4708 -- be related to a subprogram body in which case we will emit an
4709 -- error on the next iteration of the search.
4711 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4712 Stmt
:= Parent
(Stmt
);
4714 -- Any other statement breaks the chain from the pragma to the
4718 Placement_Error
(Prev
);
4723 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4724 -- grouped together with other such pragmas.
4726 if Is_Loop_Pragma
(N
) then
4728 -- The previous check should have located the related loop
4730 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4731 Check_Loop_Pragma_Grouping
(Stmt
);
4733 end Check_Loop_Pragma_Placement
;
4735 -------------------------------------------
4736 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4737 -------------------------------------------
4739 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4748 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4751 elsif Nkind_In
(P
, N_Package_Specification
,
4756 -- Note: the following tests seem a little peculiar, because
4757 -- they test for bodies, but if we were in the statement part
4758 -- of the body, we would already have hit the handled statement
4759 -- sequence, so the only way we get here is by being in the
4760 -- declarative part of the body.
4762 elsif Nkind_In
(P
, N_Subprogram_Body
,
4773 Error_Pragma
("pragma% is not in declarative part or package spec");
4774 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4776 -------------------------
4777 -- Check_No_Identifier --
4778 -------------------------
4780 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4782 if Nkind
(Arg
) = N_Pragma_Argument_Association
4783 and then Chars
(Arg
) /= No_Name
4785 Error_Pragma_Arg_Ident
4786 ("pragma% does not permit identifier& here", Arg
);
4788 end Check_No_Identifier
;
4790 --------------------------
4791 -- Check_No_Identifiers --
4792 --------------------------
4794 procedure Check_No_Identifiers
is
4798 for J
in 1 .. Arg_Count
loop
4799 Check_No_Identifier
(Arg_Node
);
4802 end Check_No_Identifiers
;
4804 ------------------------
4805 -- Check_No_Link_Name --
4806 ------------------------
4808 procedure Check_No_Link_Name
is
4810 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4814 if Present
(Arg4
) then
4816 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4818 end Check_No_Link_Name
;
4820 -------------------------------
4821 -- Check_Optional_Identifier --
4822 -------------------------------
4824 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4827 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4828 and then Chars
(Arg
) /= No_Name
4830 if Chars
(Arg
) /= Id
then
4831 Error_Msg_Name_1
:= Pname
;
4832 Error_Msg_Name_2
:= Id
;
4833 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4837 end Check_Optional_Identifier
;
4839 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4841 Name_Buffer
(1 .. Id
'Length) := Id
;
4842 Name_Len
:= Id
'Length;
4843 Check_Optional_Identifier
(Arg
, Name_Find
);
4844 end Check_Optional_Identifier
;
4846 --------------------
4847 -- Check_Pre_Post --
4848 --------------------
4850 procedure Check_Pre_Post
is
4855 if not Is_List_Member
(N
) then
4859 -- If we are within an inlined body, the legality of the pragma
4860 -- has been checked already.
4862 if In_Inlined_Body
then
4866 -- Search prior declarations
4869 while Present
(Prev
(P
)) loop
4872 -- If the previous node is a generic subprogram, do not go to to
4873 -- the original node, which is the unanalyzed tree: we need to
4874 -- attach the pre/postconditions to the analyzed version at this
4875 -- point. They get propagated to the original tree when analyzing
4876 -- the corresponding body.
4878 if Nkind
(P
) not in N_Generic_Declaration
then
4879 PO
:= Original_Node
(P
);
4884 -- Skip past prior pragma
4886 if Nkind
(PO
) = N_Pragma
then
4889 -- Skip stuff not coming from source
4891 elsif not Comes_From_Source
(PO
) then
4893 -- The condition may apply to a subprogram instantiation
4895 if Nkind
(PO
) = N_Subprogram_Declaration
4896 and then Present
(Generic_Parent
(Specification
(PO
)))
4900 elsif Nkind
(PO
) = N_Subprogram_Declaration
4901 and then In_Instance
4905 -- For all other cases of non source code, do nothing
4911 -- Only remaining possibility is subprogram declaration
4918 -- If we fall through loop, pragma is at start of list, so see if it
4919 -- is at the start of declarations of a subprogram body.
4923 if Nkind
(PO
) = N_Subprogram_Body
4924 and then List_Containing
(N
) = Declarations
(PO
)
4926 -- This is only allowed if there is no separate specification
4928 if Present
(Corresponding_Spec
(PO
)) then
4930 ("pragma% must apply to subprogram specification");
4937 --------------------------------------
4938 -- Check_Precondition_Postcondition --
4939 --------------------------------------
4941 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
4945 procedure Chain_PPC
(PO
: Node_Id
);
4946 -- If PO is an entry or a [generic] subprogram declaration node, then
4947 -- the precondition/postcondition applies to this subprogram and the
4948 -- processing for the pragma is completed. Otherwise the pragma is
4955 procedure Chain_PPC
(PO
: Node_Id
) is
4959 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
4960 if not From_Aspect_Specification
(N
) then
4962 ("pragma% cannot be applied to abstract subprogram");
4964 elsif Class_Present
(N
) then
4969 ("aspect % requires ''Class for abstract subprogram");
4972 -- AI05-0230: The same restriction applies to null procedures. For
4973 -- compatibility with earlier uses of the Ada pragma, apply this
4974 -- rule only to aspect specifications.
4976 -- The above discrepency needs documentation. Robert is dubious
4977 -- about whether it is a good idea ???
4979 elsif Nkind
(PO
) = N_Subprogram_Declaration
4980 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
4981 and then Null_Present
(Specification
(PO
))
4982 and then From_Aspect_Specification
(N
)
4983 and then not Class_Present
(N
)
4986 ("aspect % requires ''Class for null procedure");
4988 -- Pre/postconditions are legal on a subprogram body if it is not
4989 -- a completion of a declaration. They are also legal on a stub
4990 -- with no previous declarations (this is checked when processing
4991 -- the corresponding aspects).
4993 elsif Nkind
(PO
) = N_Subprogram_Body
4994 and then Acts_As_Spec
(PO
)
4998 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
5001 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5002 N_Expression_Function
,
5003 N_Generic_Subprogram_Declaration
,
5004 N_Entry_Declaration
)
5009 -- Here if we have [generic] subprogram or entry declaration
5011 if Nkind
(PO
) = N_Entry_Declaration
then
5012 S
:= Defining_Entity
(PO
);
5014 S
:= Defining_Unit_Name
(Specification
(PO
));
5016 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5017 S
:= Defining_Identifier
(S
);
5021 -- Note: we do not analyze the pragma at this point. Instead we
5022 -- delay this analysis until the end of the declarative part in
5023 -- which the pragma appears. This implements the required delay
5024 -- in this analysis, allowing forward references. The analysis
5025 -- happens at the end of Analyze_Declarations.
5027 -- Chain spec PPC pragma to list for subprogram
5029 Add_Contract_Item
(N
, S
);
5031 -- Return indicating spec case
5037 -- Start of processing for Check_Precondition_Postcondition
5040 if not Is_List_Member
(N
) then
5044 -- Preanalyze message argument if present. Visibility in this
5045 -- argument is established at the point of pragma occurrence.
5047 if Arg_Count
= 2 then
5048 Check_Optional_Identifier
(Arg2
, Name_Message
);
5049 Preanalyze_Spec_Expression
5050 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5053 -- For a pragma PPC in the extended main source unit, record enabled
5056 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5057 Set_SCO_Pragma_Enabled
(Loc
);
5060 -- If we are within an inlined body, the legality of the pragma
5061 -- has been checked already.
5063 if In_Inlined_Body
then
5068 -- Search prior declarations
5071 while Present
(Prev
(P
)) loop
5074 -- If the previous node is a generic subprogram, do not go to to
5075 -- the original node, which is the unanalyzed tree: we need to
5076 -- attach the pre/postconditions to the analyzed version at this
5077 -- point. They get propagated to the original tree when analyzing
5078 -- the corresponding body.
5080 if Nkind
(P
) not in N_Generic_Declaration
then
5081 PO
:= Original_Node
(P
);
5086 -- Skip past prior pragma
5088 if Nkind
(PO
) = N_Pragma
then
5091 -- Skip stuff not coming from source
5093 elsif not Comes_From_Source
(PO
) then
5095 -- The condition may apply to a subprogram instantiation
5097 if Nkind
(PO
) = N_Subprogram_Declaration
5098 and then Present
(Generic_Parent
(Specification
(PO
)))
5103 elsif Nkind
(PO
) = N_Subprogram_Declaration
5104 and then In_Instance
5109 -- For all other cases of non source code, do nothing
5115 -- Only remaining possibility is subprogram declaration
5123 -- If we fall through loop, pragma is at start of list, so see if it
5124 -- is at the start of declarations of a subprogram body.
5128 if Nkind
(PO
) = N_Subprogram_Body
5129 and then List_Containing
(N
) = Declarations
(PO
)
5131 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5133 -- Analyze pragma expression for correctness and for ASIS use
5135 Preanalyze_Assert_Expression
5136 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5138 -- In ASIS mode, for a pragma generated from a source aspect,
5139 -- also analyze the original aspect expression.
5141 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5142 Preanalyze_Assert_Expression
5143 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5147 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5148 -- The copy is needed because the pragma is expanded into other
5149 -- constructs which are not acceptable in the N_Contract node.
5151 if Acts_As_Spec
(PO
) and then GNATprove_Mode
then
5153 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5156 -- Preanalyze the pragma
5158 Preanalyze_Assert_Expression
5160 (First
(Pragma_Argument_Associations
(Prag
))),
5163 -- Preanalyze the corresponding aspect (if any)
5165 if Present
(Corresponding_Aspect
(Prag
)) then
5166 Preanalyze_Assert_Expression
5167 (Expression
(Corresponding_Aspect
(Prag
)),
5171 -- Chain the copy on the contract of the body
5174 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5181 -- See if it is in the pragmas after a library level subprogram
5183 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5185 -- In GNATprove mode, analyze pragma expression for correctness,
5186 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5187 -- no later point at which the aspect will be analyzed.
5189 if GNATprove_Mode
or ASIS_Mode
then
5190 Analyze_Pre_Post_Condition_In_Decl_Part
5191 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5194 Chain_PPC
(Unit
(Parent
(PO
)));
5198 -- If we fall through, pragma was misplaced
5201 end Check_Precondition_Postcondition
;
5203 -----------------------------
5204 -- Check_Static_Constraint --
5205 -----------------------------
5207 -- Note: for convenience in writing this procedure, in addition to
5208 -- the officially (i.e. by spec) allowed argument which is always a
5209 -- constraint, it also allows ranges and discriminant associations.
5210 -- Above is not clear ???
5212 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5214 procedure Require_Static
(E
: Node_Id
);
5215 -- Require given expression to be static expression
5217 --------------------
5218 -- Require_Static --
5219 --------------------
5221 procedure Require_Static
(E
: Node_Id
) is
5223 if not Is_OK_Static_Expression
(E
) then
5224 Flag_Non_Static_Expr
5225 ("non-static constraint not allowed in Unchecked_Union!", E
);
5230 -- Start of processing for Check_Static_Constraint
5233 case Nkind
(Constr
) is
5234 when N_Discriminant_Association
=>
5235 Require_Static
(Expression
(Constr
));
5238 Require_Static
(Low_Bound
(Constr
));
5239 Require_Static
(High_Bound
(Constr
));
5241 when N_Attribute_Reference
=>
5242 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5243 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5245 when N_Range_Constraint
=>
5246 Check_Static_Constraint
(Range_Expression
(Constr
));
5248 when N_Index_Or_Discriminant_Constraint
=>
5252 IDC
:= First
(Constraints
(Constr
));
5253 while Present
(IDC
) loop
5254 Check_Static_Constraint
(IDC
);
5262 end Check_Static_Constraint
;
5264 ---------------------
5265 -- Check_Test_Case --
5266 ---------------------
5268 procedure Check_Test_Case
is
5272 procedure Chain_CTC
(PO
: Node_Id
);
5273 -- If PO is a [generic] subprogram declaration node, then the
5274 -- test-case applies to this subprogram and the processing for
5275 -- the pragma is completed. Otherwise the pragma is misplaced.
5281 procedure Chain_CTC
(PO
: Node_Id
) is
5282 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5287 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5289 ("pragma% cannot be applied to abstract subprogram");
5291 elsif Nkind
(PO
) = N_Entry_Declaration
then
5292 Error_Pragma
("pragma% cannot be applied to entry");
5294 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5295 N_Generic_Subprogram_Declaration
)
5300 -- Here if we have [generic] subprogram declaration
5302 S
:= Defining_Unit_Name
(Specification
(PO
));
5304 -- Note: we do not analyze the pragma at this point. Instead we
5305 -- delay this analysis until the end of the declarative part in
5306 -- which the pragma appears. This implements the required delay
5307 -- in this analysis, allowing forward references. The analysis
5308 -- happens at the end of Analyze_Declarations.
5310 -- There should not be another test-case with the same name
5311 -- associated to this subprogram.
5313 CTC
:= Contract_Test_Cases
(Contract
(S
));
5314 while Present
(CTC
) loop
5316 -- Omit pragma Contract_Cases because it does not introduce
5317 -- a unique case name and it does not follow the syntax of
5320 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5323 elsif String_Equal
(Name
, Get_Name_From_CTC_Pragma
(CTC
)) then
5324 Error_Msg_Sloc
:= Sloc
(CTC
);
5325 Error_Pragma
("name for pragma% is already used#");
5328 CTC
:= Next_Pragma
(CTC
);
5331 -- Chain spec CTC pragma to list for subprogram
5333 Add_Contract_Item
(N
, S
);
5336 -- Start of processing for Check_Test_Case
5339 -- First check pragma arguments
5341 Check_At_Least_N_Arguments
(2);
5342 Check_At_Most_N_Arguments
(4);
5344 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5346 Check_Optional_Identifier
(Arg1
, Name_Name
);
5347 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
5349 -- In ASIS mode, for a pragma generated from a source aspect, also
5350 -- analyze the original aspect expression.
5352 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5353 Check_Expr_Is_OK_Static_Expression
5354 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5357 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5358 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5360 if Arg_Count
= 4 then
5361 Check_Identifier
(Arg3
, Name_Requires
);
5362 Check_Identifier
(Arg4
, Name_Ensures
);
5364 elsif Arg_Count
= 3 then
5365 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5368 -- Check pragma placement
5370 if not Is_List_Member
(N
) then
5374 -- Test-case should only appear in package spec unit
5376 if Get_Source_Unit
(N
) = No_Unit
5377 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Current_Sem_Unit
)),
5378 N_Package_Declaration
,
5379 N_Generic_Package_Declaration
)
5384 -- Search prior declarations
5387 while Present
(Prev
(P
)) loop
5390 -- If the previous node is a generic subprogram, do not go to to
5391 -- the original node, which is the unanalyzed tree: we need to
5392 -- attach the test-case to the analyzed version at this point.
5393 -- They get propagated to the original tree when analyzing the
5394 -- corresponding body.
5396 if Nkind
(P
) not in N_Generic_Declaration
then
5397 PO
:= Original_Node
(P
);
5402 -- Skip past prior pragma
5404 if Nkind
(PO
) = N_Pragma
then
5407 -- Skip stuff not coming from source
5409 elsif not Comes_From_Source
(PO
) then
5412 -- Only remaining possibility is subprogram declaration. First
5413 -- check that it is declared directly in a package declaration.
5414 -- This may be either the package declaration for the current unit
5415 -- being defined or a local package declaration.
5417 elsif not Present
(Parent
(Parent
(PO
)))
5418 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5419 or else not Nkind_In
(Parent
(Parent
(PO
)),
5420 N_Package_Declaration
,
5421 N_Generic_Package_Declaration
)
5431 -- If we fall through, pragma was misplaced
5434 end Check_Test_Case
;
5436 --------------------------------------
5437 -- Check_Valid_Configuration_Pragma --
5438 --------------------------------------
5440 -- A configuration pragma must appear in the context clause of a
5441 -- compilation unit, and only other pragmas may precede it. Note that
5442 -- the test also allows use in a configuration pragma file.
5444 procedure Check_Valid_Configuration_Pragma
is
5446 if not Is_Configuration_Pragma
then
5447 Error_Pragma
("incorrect placement for configuration pragma%");
5449 end Check_Valid_Configuration_Pragma
;
5451 -------------------------------------
5452 -- Check_Valid_Library_Unit_Pragma --
5453 -------------------------------------
5455 procedure Check_Valid_Library_Unit_Pragma
is
5457 Parent_Node
: Node_Id
;
5458 Unit_Name
: Entity_Id
;
5459 Unit_Kind
: Node_Kind
;
5460 Unit_Node
: Node_Id
;
5461 Sindex
: Source_File_Index
;
5464 if not Is_List_Member
(N
) then
5468 Plist
:= List_Containing
(N
);
5469 Parent_Node
:= Parent
(Plist
);
5471 if Parent_Node
= Empty
then
5474 -- Case of pragma appearing after a compilation unit. In this case
5475 -- it must have an argument with the corresponding name and must
5476 -- be part of the following pragmas of its parent.
5478 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5479 if Plist
/= Pragmas_After
(Parent_Node
) then
5482 elsif Arg_Count
= 0 then
5484 ("argument required if outside compilation unit");
5487 Check_No_Identifiers
;
5488 Check_Arg_Count
(1);
5489 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5490 Unit_Kind
:= Nkind
(Unit_Node
);
5492 Analyze
(Get_Pragma_Arg
(Arg1
));
5494 if Unit_Kind
= N_Generic_Subprogram_Declaration
5495 or else Unit_Kind
= N_Subprogram_Declaration
5497 Unit_Name
:= Defining_Entity
(Unit_Node
);
5499 elsif Unit_Kind
in N_Generic_Instantiation
then
5500 Unit_Name
:= Defining_Entity
(Unit_Node
);
5503 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5506 if Chars
(Unit_Name
) /=
5507 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5510 ("pragma% argument is not current unit name", Arg1
);
5513 if Ekind
(Unit_Name
) = E_Package
5514 and then Present
(Renamed_Entity
(Unit_Name
))
5516 Error_Pragma
("pragma% not allowed for renamed package");
5520 -- Pragma appears other than after a compilation unit
5523 -- Here we check for the generic instantiation case and also
5524 -- for the case of processing a generic formal package. We
5525 -- detect these cases by noting that the Sloc on the node
5526 -- does not belong to the current compilation unit.
5528 Sindex
:= Source_Index
(Current_Sem_Unit
);
5530 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5531 Rewrite
(N
, Make_Null_Statement
(Loc
));
5534 -- If before first declaration, the pragma applies to the
5535 -- enclosing unit, and the name if present must be this name.
5537 elsif Is_Before_First_Decl
(N
, Plist
) then
5538 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5539 Unit_Kind
:= Nkind
(Unit_Node
);
5541 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5544 elsif Unit_Kind
= N_Subprogram_Body
5545 and then not Acts_As_Spec
(Unit_Node
)
5549 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5552 elsif Nkind
(Parent_Node
) = N_Package_Specification
5553 and then Plist
= Private_Declarations
(Parent_Node
)
5557 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5558 or else Nkind
(Parent_Node
) =
5559 N_Generic_Subprogram_Declaration
)
5560 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5564 elsif Arg_Count
> 0 then
5565 Analyze
(Get_Pragma_Arg
(Arg1
));
5567 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5569 ("name in pragma% must be enclosing unit", Arg1
);
5572 -- It is legal to have no argument in this context
5578 -- Error if not before first declaration. This is because a
5579 -- library unit pragma argument must be the name of a library
5580 -- unit (RM 10.1.5(7)), but the only names permitted in this
5581 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5582 -- generic subprogram declarations or generic instantiations.
5586 ("pragma% misplaced, must be before first declaration");
5590 end Check_Valid_Library_Unit_Pragma
;
5596 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5597 Clist
: constant Node_Id
:= Component_List
(Variant
);
5601 Comp
:= First
(Component_Items
(Clist
));
5602 while Present
(Comp
) loop
5603 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5608 ---------------------------
5609 -- Ensure_Aggregate_Form --
5610 ---------------------------
5612 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5613 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5614 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5615 Nam
: constant Name_Id
:= Chars
(Arg
);
5616 Comps
: List_Id
:= No_List
;
5617 Exprs
: List_Id
:= No_List
;
5619 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5620 -- Used to restore Comes_From_Source_Default
5623 -- The argument is already in aggregate form, but the presence of a
5624 -- name causes this to be interpreted as a named association which in
5625 -- turn must be converted into an aggregate.
5627 -- pragma Global (In_Out => (A, B, C))
5631 -- pragma Global ((In_Out => (A, B, C)))
5633 -- aggregate aggregate
5635 if Nkind
(Expr
) = N_Aggregate
then
5636 if Nam
= No_Name
then
5640 -- Do not transform a null argument into an aggregate as N_Null has
5641 -- special meaning in formal verification pragmas.
5643 elsif Nkind
(Expr
) = N_Null
then
5647 -- Everything comes from source if the original comes from source
5649 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5651 -- Positional argument is transformed into an aggregate with an
5652 -- Expressions list.
5654 if Nam
= No_Name
then
5655 Exprs
:= New_List
(Relocate_Node
(Expr
));
5657 -- An associative argument is transformed into an aggregate with
5658 -- Component_Associations.
5662 Make_Component_Association
(Loc
,
5663 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5664 Expression
=> Relocate_Node
(Expr
)));
5667 -- Remove the pragma argument name as this information has been
5668 -- captured in the aggregate.
5670 Set_Chars
(Arg
, No_Name
);
5672 Set_Expression
(Arg
,
5673 Make_Aggregate
(Loc
,
5674 Component_Associations
=> Comps
,
5675 Expressions
=> Exprs
));
5677 -- Restore Comes_From_Source default
5679 Set_Comes_From_Source_Default
(CFSD
);
5680 end Ensure_Aggregate_Form
;
5686 procedure Error_Pragma
(Msg
: String) is
5688 Error_Msg_Name_1
:= Pname
;
5689 Error_Msg_N
(Fix_Error
(Msg
), N
);
5693 ----------------------
5694 -- Error_Pragma_Arg --
5695 ----------------------
5697 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5699 Error_Msg_Name_1
:= Pname
;
5700 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5702 end Error_Pragma_Arg
;
5704 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5706 Error_Msg_Name_1
:= Pname
;
5707 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5708 Error_Pragma_Arg
(Msg2
, Arg
);
5709 end Error_Pragma_Arg
;
5711 ----------------------------
5712 -- Error_Pragma_Arg_Ident --
5713 ----------------------------
5715 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5717 Error_Msg_Name_1
:= Pname
;
5718 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5720 end Error_Pragma_Arg_Ident
;
5722 ----------------------
5723 -- Error_Pragma_Ref --
5724 ----------------------
5726 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5728 Error_Msg_Name_1
:= Pname
;
5729 Error_Msg_Sloc
:= Sloc
(Ref
);
5730 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5732 end Error_Pragma_Ref
;
5734 ------------------------
5735 -- Find_Lib_Unit_Name --
5736 ------------------------
5738 function Find_Lib_Unit_Name
return Entity_Id
is
5740 -- Return inner compilation unit entity, for case of nested
5741 -- categorization pragmas. This happens in generic unit.
5743 if Nkind
(Parent
(N
)) = N_Package_Specification
5744 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5746 return Defining_Entity
(Parent
(N
));
5748 return Current_Scope
;
5750 end Find_Lib_Unit_Name
;
5752 ----------------------------
5753 -- Find_Program_Unit_Name --
5754 ----------------------------
5756 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5757 Unit_Name
: Entity_Id
;
5758 Unit_Kind
: Node_Kind
;
5759 P
: constant Node_Id
:= Parent
(N
);
5762 if Nkind
(P
) = N_Compilation_Unit
then
5763 Unit_Kind
:= Nkind
(Unit
(P
));
5765 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5766 N_Package_Declaration
)
5767 or else Unit_Kind
in N_Generic_Declaration
5769 Unit_Name
:= Defining_Entity
(Unit
(P
));
5771 if Chars
(Id
) = Chars
(Unit_Name
) then
5772 Set_Entity
(Id
, Unit_Name
);
5773 Set_Etype
(Id
, Etype
(Unit_Name
));
5775 Set_Etype
(Id
, Any_Type
);
5777 ("cannot find program unit referenced by pragma%");
5781 Set_Etype
(Id
, Any_Type
);
5782 Error_Pragma
("pragma% inapplicable to this unit");
5788 end Find_Program_Unit_Name
;
5790 -----------------------------------------
5791 -- Find_Unique_Parameterless_Procedure --
5792 -----------------------------------------
5794 function Find_Unique_Parameterless_Procedure
5796 Arg
: Node_Id
) return Entity_Id
5798 Proc
: Entity_Id
:= Empty
;
5801 -- The body of this procedure needs some comments ???
5803 if not Is_Entity_Name
(Name
) then
5805 ("argument of pragma% must be entity name", Arg
);
5807 elsif not Is_Overloaded
(Name
) then
5808 Proc
:= Entity
(Name
);
5810 if Ekind
(Proc
) /= E_Procedure
5811 or else Present
(First_Formal
(Proc
))
5814 ("argument of pragma% must be parameterless procedure", Arg
);
5819 Found
: Boolean := False;
5821 Index
: Interp_Index
;
5824 Get_First_Interp
(Name
, Index
, It
);
5825 while Present
(It
.Nam
) loop
5828 if Ekind
(Proc
) = E_Procedure
5829 and then No
(First_Formal
(Proc
))
5833 Set_Entity
(Name
, Proc
);
5834 Set_Is_Overloaded
(Name
, False);
5837 ("ambiguous handler name for pragma% ", Arg
);
5841 Get_Next_Interp
(Index
, It
);
5846 ("argument of pragma% must be parameterless procedure",
5849 Proc
:= Entity
(Name
);
5855 end Find_Unique_Parameterless_Procedure
;
5861 function Fix_Error
(Msg
: String) return String is
5862 Res
: String (Msg
'Range) := Msg
;
5863 Res_Last
: Natural := Msg
'Last;
5867 -- If we have a rewriting of another pragma, go to that pragma
5869 if Is_Rewrite_Substitution
(N
)
5870 and then Nkind
(Original_Node
(N
)) = N_Pragma
5872 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5875 -- Case where pragma comes from an aspect specification
5877 if From_Aspect_Specification
(N
) then
5879 -- Change appearence of "pragma" in message to "aspect"
5882 while J
<= Res_Last
- 5 loop
5883 if Res
(J
.. J
+ 5) = "pragma" then
5884 Res
(J
.. J
+ 5) := "aspect";
5892 -- Change "argument of" at start of message to "entity for"
5895 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5897 Res
(Res
'First .. Res
'First + 9) := "entity for";
5898 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5899 Res
(Res
'First + 11 .. Res_Last
);
5900 Res_Last
:= Res_Last
- 1;
5903 -- Change "argument" at start of message to "entity"
5906 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5908 Res
(Res
'First .. Res
'First + 5) := "entity";
5909 Res
(Res
'First + 6 .. Res_Last
- 2) :=
5910 Res
(Res
'First + 8 .. Res_Last
);
5911 Res_Last
:= Res_Last
- 2;
5914 -- Get name from corresponding aspect
5916 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
5919 -- Return possibly modified message
5921 return Res
(Res
'First .. Res_Last
);
5924 -------------------------
5925 -- Gather_Associations --
5926 -------------------------
5928 procedure Gather_Associations
5930 Args
: out Args_List
)
5935 -- Initialize all parameters to Empty
5937 for J
in Args
'Range loop
5941 -- That's all we have to do if there are no argument associations
5943 if No
(Pragma_Argument_Associations
(N
)) then
5947 -- Otherwise first deal with any positional parameters present
5949 Arg
:= First
(Pragma_Argument_Associations
(N
));
5950 for Index
in Args
'Range loop
5951 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
5952 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5956 -- Positional parameters all processed, if any left, then we
5957 -- have too many positional parameters.
5959 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
5961 ("too many positional associations for pragma%", Arg
);
5964 -- Process named parameters if any are present
5966 while Present
(Arg
) loop
5967 if Chars
(Arg
) = No_Name
then
5969 ("positional association cannot follow named association",
5973 for Index
in Names
'Range loop
5974 if Names
(Index
) = Chars
(Arg
) then
5975 if Present
(Args
(Index
)) then
5977 ("duplicate argument association for pragma%", Arg
);
5979 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5984 if Index
= Names
'Last then
5985 Error_Msg_Name_1
:= Pname
;
5986 Error_Msg_N
("pragma% does not allow & argument", Arg
);
5988 -- Check for possible misspelling
5990 for Index1
in Names
'Range loop
5991 if Is_Bad_Spelling_Of
5992 (Chars
(Arg
), Names
(Index1
))
5994 Error_Msg_Name_1
:= Names
(Index1
);
5995 Error_Msg_N
-- CODEFIX
5996 ("\possible misspelling of%", Arg
);
6008 end Gather_Associations
;
6014 procedure GNAT_Pragma
is
6016 -- We need to check the No_Implementation_Pragmas restriction for
6017 -- the case of a pragma from source. Note that the case of aspects
6018 -- generating corresponding pragmas marks these pragmas as not being
6019 -- from source, so this test also catches that case.
6021 if Comes_From_Source
(N
) then
6022 Check_Restriction
(No_Implementation_Pragmas
, N
);
6026 --------------------------
6027 -- Is_Before_First_Decl --
6028 --------------------------
6030 function Is_Before_First_Decl
6031 (Pragma_Node
: Node_Id
;
6032 Decls
: List_Id
) return Boolean
6034 Item
: Node_Id
:= First
(Decls
);
6037 -- Only other pragmas can come before this pragma
6040 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6043 elsif Item
= Pragma_Node
then
6049 end Is_Before_First_Decl
;
6051 -----------------------------
6052 -- Is_Configuration_Pragma --
6053 -----------------------------
6055 -- A configuration pragma must appear in the context clause of a
6056 -- compilation unit, and only other pragmas may precede it. Note that
6057 -- the test below also permits use in a configuration pragma file.
6059 function Is_Configuration_Pragma
return Boolean is
6060 Lis
: constant List_Id
:= List_Containing
(N
);
6061 Par
: constant Node_Id
:= Parent
(N
);
6065 -- If no parent, then we are in the configuration pragma file,
6066 -- so the placement is definitely appropriate.
6071 -- Otherwise we must be in the context clause of a compilation unit
6072 -- and the only thing allowed before us in the context list is more
6073 -- configuration pragmas.
6075 elsif Nkind
(Par
) = N_Compilation_Unit
6076 and then Context_Items
(Par
) = Lis
6083 elsif Nkind
(Prg
) /= N_Pragma
then
6093 end Is_Configuration_Pragma
;
6095 --------------------------
6096 -- Is_In_Context_Clause --
6097 --------------------------
6099 function Is_In_Context_Clause
return Boolean is
6101 Parent_Node
: Node_Id
;
6104 if not Is_List_Member
(N
) then
6108 Plist
:= List_Containing
(N
);
6109 Parent_Node
:= Parent
(Plist
);
6111 if Parent_Node
= Empty
6112 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6113 or else Context_Items
(Parent_Node
) /= Plist
6120 end Is_In_Context_Clause
;
6122 ---------------------------------
6123 -- Is_Static_String_Expression --
6124 ---------------------------------
6126 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6127 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6128 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6131 Analyze_And_Resolve
(Argx
);
6133 -- Special case Ada 83, where the expression will never be static,
6134 -- but we will return true if we had a string literal to start with.
6136 if Ada_Version
= Ada_83
then
6139 -- Normal case, true only if we end up with a string literal that
6140 -- is marked as being the result of evaluating a static expression.
6143 return Is_OK_Static_Expression
(Argx
)
6144 and then Nkind
(Argx
) = N_String_Literal
;
6147 end Is_Static_String_Expression
;
6149 ----------------------
6150 -- Pragma_Misplaced --
6151 ----------------------
6153 procedure Pragma_Misplaced
is
6155 Error_Pragma
("incorrect placement of pragma%");
6156 end Pragma_Misplaced
;
6158 ------------------------------------------------
6159 -- Process_Atomic_Independent_Shared_Volatile --
6160 ------------------------------------------------
6162 procedure Process_Atomic_Independent_Shared_Volatile
is
6169 procedure Set_Atomic
(E
: Entity_Id
);
6170 -- Set given type as atomic, and if no explicit alignment was given,
6171 -- set alignment to unknown, since back end knows what the alignment
6172 -- requirements are for atomic arrays. Note: this step is necessary
6173 -- for derived types.
6179 procedure Set_Atomic
(E
: Entity_Id
) is
6183 if not Has_Alignment_Clause
(E
) then
6184 Set_Alignment
(E
, Uint_0
);
6188 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6191 Check_Ada_83_Warning
;
6192 Check_No_Identifiers
;
6193 Check_Arg_Count
(1);
6194 Check_Arg_Is_Local_Name
(Arg1
);
6195 E_Id
:= Get_Pragma_Arg
(Arg1
);
6197 if Etype
(E_Id
) = Any_Type
then
6202 D
:= Declaration_Node
(E
);
6205 -- Check duplicate before we chain ourselves
6207 Check_Duplicate_Pragma
(E
);
6209 -- Now check appropriateness of the entity
6212 if Rep_Item_Too_Early
(E
, N
)
6214 Rep_Item_Too_Late
(E
, N
)
6218 Check_First_Subtype
(Arg1
);
6221 if Prag_Id
= Pragma_Atomic
or else Prag_Id
= Pragma_Shared
then
6223 Set_Atomic
(Underlying_Type
(E
));
6224 Set_Atomic
(Base_Type
(E
));
6227 -- Atomic/Shared imply both Independent and Volatile
6229 if Prag_Id
/= Pragma_Volatile
then
6230 Set_Is_Independent
(E
);
6231 Set_Is_Independent
(Underlying_Type
(E
));
6232 Set_Is_Independent
(Base_Type
(E
));
6234 if Prag_Id
= Pragma_Independent
then
6235 Independence_Checks
.Append
((N
, Base_Type
(E
)));
6239 -- Attribute belongs on the base type. If the view of the type is
6240 -- currently private, it also belongs on the underlying type.
6242 if Prag_Id
/= Pragma_Independent
then
6243 Set_Is_Volatile
(Base_Type
(E
));
6244 Set_Is_Volatile
(Underlying_Type
(E
));
6246 Set_Treat_As_Volatile
(E
);
6247 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6250 elsif K
= N_Object_Declaration
6251 or else (K
= N_Component_Declaration
6252 and then Original_Record_Component
(E
) = E
)
6254 if Rep_Item_Too_Late
(E
, N
) then
6258 if Prag_Id
= Pragma_Atomic
or else Prag_Id
= Pragma_Shared
then
6261 -- If the object declaration has an explicit initialization, a
6262 -- temporary may have to be created to hold the expression, to
6263 -- ensure that access to the object remain atomic.
6265 if Nkind
(Parent
(E
)) = N_Object_Declaration
6266 and then Present
(Expression
(Parent
(E
)))
6268 Set_Has_Delayed_Freeze
(E
);
6271 -- An interesting improvement here. If an object of composite
6272 -- type X is declared atomic, and the type X isn't, that's a
6273 -- pity, since it may not have appropriate alignment etc. We
6274 -- can rescue this in the special case where the object and
6275 -- type are in the same unit by just setting the type as
6276 -- atomic, so that the back end will process it as atomic.
6278 -- Note: we used to do this for elementary types as well,
6279 -- but that turns out to be a bad idea and can have unwanted
6280 -- effects, most notably if the type is elementary, the object
6281 -- a simple component within a record, and both are in a spec:
6282 -- every object of this type in the entire program will be
6283 -- treated as atomic, thus incurring a potentially costly
6284 -- synchronization operation for every access.
6286 -- Of course it would be best if the back end could just adjust
6287 -- the alignment etc for the specific object, but that's not
6288 -- something we are capable of doing at this point.
6290 Utyp
:= Underlying_Type
(Etype
(E
));
6293 and then Is_Composite_Type
(Utyp
)
6294 and then Sloc
(E
) > No_Location
6295 and then Sloc
(Utyp
) > No_Location
6297 Get_Source_File_Index
(Sloc
(E
)) =
6298 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6300 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6304 -- Atomic/Shared imply both Independent and Volatile
6306 if Prag_Id
/= Pragma_Volatile
then
6307 Set_Is_Independent
(E
);
6309 if Prag_Id
= Pragma_Independent
then
6310 Independence_Checks
.Append
((N
, E
));
6314 if Prag_Id
/= Pragma_Independent
then
6315 Set_Is_Volatile
(E
);
6316 Set_Treat_As_Volatile
(E
);
6320 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6323 -- The following check is only relevant when SPARK_Mode is on as
6324 -- this is not a standard Ada legality rule. Pragma Volatile can
6325 -- only apply to a full type declaration or an object declaration
6326 -- (SPARK RM C.6(1)).
6329 and then Prag_Id
= Pragma_Volatile
6330 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6331 N_Object_Declaration
)
6334 ("argument of pragma % must denote a full type or object "
6335 & "declaration", Arg1
);
6337 end Process_Atomic_Independent_Shared_Volatile
;
6339 -------------------------------------------
6340 -- Process_Compile_Time_Warning_Or_Error --
6341 -------------------------------------------
6343 procedure Process_Compile_Time_Warning_Or_Error
is
6344 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6347 Check_Arg_Count
(2);
6348 Check_No_Identifiers
;
6349 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6350 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6352 if Compile_Time_Known_Value
(Arg1x
) then
6353 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6355 Str
: constant String_Id
:=
6356 Strval
(Get_Pragma_Arg
(Arg2
));
6357 Len
: constant Int
:= String_Length
(Str
);
6362 Cent
: constant Entity_Id
:=
6363 Cunit_Entity
(Current_Sem_Unit
);
6365 Force
: constant Boolean :=
6366 Prag_Id
= Pragma_Compile_Time_Warning
6368 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6369 and then (Ekind
(Cent
) /= E_Package
6370 or else not In_Private_Part
(Cent
));
6371 -- Set True if this is the warning case, and we are in the
6372 -- visible part of a package spec, or in a subprogram spec,
6373 -- in which case we want to force the client to see the
6374 -- warning, even though it is not in the main unit.
6377 -- Loop through segments of message separated by line feeds.
6378 -- We output these segments as separate messages with
6379 -- continuation marks for all but the first.
6384 Error_Msg_Strlen
:= 0;
6386 -- Loop to copy characters from argument to error message
6390 exit when Ptr
> Len
;
6391 CC
:= Get_String_Char
(Str
, Ptr
);
6394 -- Ignore wide chars ??? else store character
6396 if In_Character_Range
(CC
) then
6397 C
:= Get_Character
(CC
);
6398 exit when C
= ASCII
.LF
;
6399 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6400 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6404 -- Here with one line ready to go
6406 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6408 -- If this is a warning in a spec, then we want clients
6409 -- to see the warning, so mark the message with the
6410 -- special sequence !! to force the warning. In the case
6411 -- of a package spec, we do not force this if we are in
6412 -- the private part of the spec.
6415 if Cont
= False then
6416 Error_Msg_N
("<<~!!", Arg1
);
6419 Error_Msg_N
("\<<~!!", Arg1
);
6422 -- Error, rather than warning, or in a body, so we do not
6423 -- need to force visibility for client (error will be
6424 -- output in any case, and this is the situation in which
6425 -- we do not want a client to get a warning, since the
6426 -- warning is in the body or the spec private part).
6429 if Cont
= False then
6430 Error_Msg_N
("<<~", Arg1
);
6433 Error_Msg_N
("\<<~", Arg1
);
6437 exit when Ptr
> Len
;
6442 end Process_Compile_Time_Warning_Or_Error
;
6444 ------------------------
6445 -- Process_Convention --
6446 ------------------------
6448 procedure Process_Convention
6449 (C
: out Convention_Id
;
6450 Ent
: out Entity_Id
)
6454 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6455 -- Called if we have more than one Export/Import/Convention pragma.
6456 -- This is generally illegal, but we have a special case of allowing
6457 -- Import and Interface to coexist if they specify the convention in
6458 -- a consistent manner. We are allowed to do this, since Interface is
6459 -- an implementation defined pragma, and we choose to do it since we
6460 -- know Rational allows this combination. S is the entity id of the
6461 -- subprogram in question. This procedure also sets the special flag
6462 -- Import_Interface_Present in both pragmas in the case where we do
6463 -- have matching Import and Interface pragmas.
6465 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6466 -- Set convention in entity E, and also flag that the entity has a
6467 -- convention pragma. If entity is for a private or incomplete type,
6468 -- also set convention and flag on underlying type. This procedure
6469 -- also deals with the special case of C_Pass_By_Copy convention,
6470 -- and error checks for inappropriate convention specification.
6472 -------------------------------
6473 -- Diagnose_Multiple_Pragmas --
6474 -------------------------------
6476 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6477 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6481 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6482 -- Decl is a pragma node. This function returns True if this
6483 -- pragma has a first argument that is an identifier with a
6484 -- Chars field corresponding to the Convention_Id C.
6486 function Same_Name
(Decl
: Node_Id
) return Boolean;
6487 -- Decl is a pragma node. This function returns True if this
6488 -- pragma has a second argument that is an identifier with a
6489 -- Chars field that matches the Chars of the current subprogram.
6491 ---------------------
6492 -- Same_Convention --
6493 ---------------------
6495 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6496 Arg1
: constant Node_Id
:=
6497 First
(Pragma_Argument_Associations
(Decl
));
6500 if Present
(Arg1
) then
6502 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6504 if Nkind
(Arg
) = N_Identifier
6505 and then Is_Convention_Name
(Chars
(Arg
))
6506 and then Get_Convention_Id
(Chars
(Arg
)) = C
6514 end Same_Convention
;
6520 function Same_Name
(Decl
: Node_Id
) return Boolean is
6521 Arg1
: constant Node_Id
:=
6522 First
(Pragma_Argument_Associations
(Decl
));
6530 Arg2
:= Next
(Arg1
);
6537 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6539 if Nkind
(Arg
) = N_Identifier
6540 and then Chars
(Arg
) = Chars
(S
)
6549 -- Start of processing for Diagnose_Multiple_Pragmas
6554 -- Definitely give message if we have Convention/Export here
6556 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6559 -- If we have an Import or Export, scan back from pragma to
6560 -- find any previous pragma applying to the same procedure.
6561 -- The scan will be terminated by the start of the list, or
6562 -- hitting the subprogram declaration. This won't allow one
6563 -- pragma to appear in the public part and one in the private
6564 -- part, but that seems very unlikely in practice.
6568 while Present
(Decl
) and then Decl
/= Pdec
loop
6570 -- Look for pragma with same name as us
6572 if Nkind
(Decl
) = N_Pragma
6573 and then Same_Name
(Decl
)
6575 -- Give error if same as our pragma or Export/Convention
6577 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6583 -- Case of Import/Interface or the other way round
6585 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6588 -- Here we know that we have Import and Interface. It
6589 -- doesn't matter which way round they are. See if
6590 -- they specify the same convention. If so, all OK,
6591 -- and set special flags to stop other messages
6593 if Same_Convention
(Decl
) then
6594 Set_Import_Interface_Present
(N
);
6595 Set_Import_Interface_Present
(Decl
);
6598 -- If different conventions, special message
6601 Error_Msg_Sloc
:= Sloc
(Decl
);
6603 ("convention differs from that given#", Arg1
);
6613 -- Give message if needed if we fall through those tests
6614 -- except on Relaxed_RM_Semantics where we let go: either this
6615 -- is a case accepted/ignored by other Ada compilers (e.g.
6616 -- a mix of Convention and Import), or another error will be
6617 -- generated later (e.g. using both Import and Export).
6619 if Err
and not Relaxed_RM_Semantics
then
6621 ("at most one Convention/Export/Import pragma is allowed",
6624 end Diagnose_Multiple_Pragmas
;
6626 --------------------------------
6627 -- Set_Convention_From_Pragma --
6628 --------------------------------
6630 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6632 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6633 -- for an overridden dispatching operation. Technically this is
6634 -- an amendment and should only be done in Ada 2005 mode. However,
6635 -- this is clearly a mistake, since the problem that is addressed
6636 -- by this AI is that there is a clear gap in the RM.
6638 if Is_Dispatching_Operation
(E
)
6639 and then Present
(Overridden_Operation
(E
))
6640 and then C
/= Convention
(Overridden_Operation
(E
))
6643 ("cannot change convention for overridden dispatching "
6644 & "operation", Arg1
);
6647 -- Special checks for Convention_Stdcall
6649 if C
= Convention_Stdcall
then
6651 -- A dispatching call is not allowed. A dispatching subprogram
6652 -- cannot be used to interface to the Win32 API, so in fact
6653 -- this check does not impose any effective restriction.
6655 if Is_Dispatching_Operation
(E
) then
6656 Error_Msg_Sloc
:= Sloc
(E
);
6658 -- Note: make this unconditional so that if there is more
6659 -- than one call to which the pragma applies, we get a
6660 -- message for each call. Also don't use Error_Pragma,
6661 -- so that we get multiple messages.
6664 ("dispatching subprogram# cannot use Stdcall convention!",
6667 -- Subprograms are not allowed
6669 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6673 and then Ekind
(E
) /= E_Variable
6675 -- An access to subprogram is also allowed
6679 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6681 -- Allow internal call to set convention of subprogram type
6683 and then not (Ekind
(E
) = E_Subprogram_Type
)
6686 ("second argument of pragma% must be subprogram (type)",
6691 -- Set the convention
6693 Set_Convention
(E
, C
);
6694 Set_Has_Convention_Pragma
(E
);
6696 -- For the case of a record base type, also set the convention of
6697 -- any anonymous access types declared in the record which do not
6698 -- currently have a specified convention.
6700 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6705 Comp
:= First_Component
(E
);
6706 while Present
(Comp
) loop
6707 if Present
(Etype
(Comp
))
6708 and then Ekind_In
(Etype
(Comp
),
6709 E_Anonymous_Access_Type
,
6710 E_Anonymous_Access_Subprogram_Type
)
6711 and then not Has_Convention_Pragma
(Comp
)
6713 Set_Convention
(Comp
, C
);
6716 Next_Component
(Comp
);
6721 -- Deal with incomplete/private type case, where underlying type
6722 -- is available, so set convention of that underlying type.
6724 if Is_Incomplete_Or_Private_Type
(E
)
6725 and then Present
(Underlying_Type
(E
))
6727 Set_Convention
(Underlying_Type
(E
), C
);
6728 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6731 -- A class-wide type should inherit the convention of the specific
6732 -- root type (although this isn't specified clearly by the RM).
6734 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6735 Set_Convention
(Class_Wide_Type
(E
), C
);
6738 -- If the entity is a record type, then check for special case of
6739 -- C_Pass_By_Copy, which is treated the same as C except that the
6740 -- special record flag is set. This convention is only permitted
6741 -- on record types (see AI95-00131).
6743 if Cname
= Name_C_Pass_By_Copy
then
6744 if Is_Record_Type
(E
) then
6745 Set_C_Pass_By_Copy
(Base_Type
(E
));
6746 elsif Is_Incomplete_Or_Private_Type
(E
)
6747 and then Is_Record_Type
(Underlying_Type
(E
))
6749 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6752 ("C_Pass_By_Copy convention allowed only for record type",
6757 -- If the entity is a derived boolean type, check for the special
6758 -- case of convention C, C++, or Fortran, where we consider any
6759 -- nonzero value to represent true.
6761 if Is_Discrete_Type
(E
)
6762 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6768 C
= Convention_Fortran
)
6770 Set_Nonzero_Is_True
(Base_Type
(E
));
6772 end Set_Convention_From_Pragma
;
6776 Comp_Unit
: Unit_Number_Type
;
6781 -- Start of processing for Process_Convention
6784 Check_At_Least_N_Arguments
(2);
6785 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6786 Check_Arg_Is_Identifier
(Arg1
);
6787 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6789 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6790 -- tested again below to set the critical flag).
6792 if Cname
= Name_C_Pass_By_Copy
then
6795 -- Otherwise we must have something in the standard convention list
6797 elsif Is_Convention_Name
(Cname
) then
6798 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6800 -- Otherwise warn on unrecognized convention
6803 if Warn_On_Export_Import
then
6805 ("??unrecognized convention name, C assumed",
6806 Get_Pragma_Arg
(Arg1
));
6812 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6813 Check_Arg_Is_Local_Name
(Arg2
);
6815 Id
:= Get_Pragma_Arg
(Arg2
);
6818 if not Is_Entity_Name
(Id
) then
6819 Error_Pragma_Arg
("entity name required", Arg2
);
6824 -- Set entity to return
6828 -- Ada_Pass_By_Copy special checking
6830 if C
= Convention_Ada_Pass_By_Copy
then
6831 if not Is_First_Subtype
(E
) then
6833 ("convention `Ada_Pass_By_Copy` only allowed for types",
6837 if Is_By_Reference_Type
(E
) then
6839 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6843 -- Ada_Pass_By_Reference special checking
6845 elsif C
= Convention_Ada_Pass_By_Reference
then
6846 if not Is_First_Subtype
(E
) then
6848 ("convention `Ada_Pass_By_Reference` only allowed for types",
6852 if Is_By_Copy_Type
(E
) then
6854 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6859 -- Go to renamed subprogram if present, since convention applies to
6860 -- the actual renamed entity, not to the renaming entity. If the
6861 -- subprogram is inherited, go to parent subprogram.
6863 if Is_Subprogram
(E
)
6864 and then Present
(Alias
(E
))
6866 if Nkind
(Parent
(Declaration_Node
(E
))) =
6867 N_Subprogram_Renaming_Declaration
6869 if Scope
(E
) /= Scope
(Alias
(E
)) then
6871 ("cannot apply pragma% to non-local entity&#", E
);
6876 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6877 N_Private_Extension_Declaration
)
6878 and then Scope
(E
) = Scope
(Alias
(E
))
6882 -- Return the parent subprogram the entity was inherited from
6888 -- Check that we are not applying this to a specless body. Relax this
6889 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6891 if Is_Subprogram
(E
)
6892 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6893 and then not Relaxed_RM_Semantics
6896 ("pragma% requires separate spec and must come before body");
6899 -- Check that we are not applying this to a named constant
6901 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6902 Error_Msg_Name_1
:= Pname
;
6904 ("cannot apply pragma% to named constant!",
6905 Get_Pragma_Arg
(Arg2
));
6907 ("\supply appropriate type for&!", Arg2
);
6910 if Ekind
(E
) = E_Enumeration_Literal
then
6911 Error_Pragma
("enumeration literal not allowed for pragma%");
6914 -- Check for rep item appearing too early or too late
6916 if Etype
(E
) = Any_Type
6917 or else Rep_Item_Too_Early
(E
, N
)
6921 elsif Present
(Underlying_Type
(E
)) then
6922 E
:= Underlying_Type
(E
);
6925 if Rep_Item_Too_Late
(E
, N
) then
6929 if Has_Convention_Pragma
(E
) then
6930 Diagnose_Multiple_Pragmas
(E
);
6932 elsif Convention
(E
) = Convention_Protected
6933 or else Ekind
(Scope
(E
)) = E_Protected_Type
6936 ("a protected operation cannot be given a different convention",
6940 -- For Intrinsic, a subprogram is required
6942 if C
= Convention_Intrinsic
6943 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
6946 ("second argument of pragma% must be a subprogram", Arg2
);
6949 -- Deal with non-subprogram cases
6951 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
6952 Set_Convention_From_Pragma
(E
);
6955 Check_First_Subtype
(Arg2
);
6956 Set_Convention_From_Pragma
(Base_Type
(E
));
6958 -- For access subprograms, we must set the convention on the
6959 -- internally generated directly designated type as well.
6961 if Ekind
(E
) = E_Access_Subprogram_Type
then
6962 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
6966 -- For the subprogram case, set proper convention for all homonyms
6967 -- in same scope and the same declarative part, i.e. the same
6968 -- compilation unit.
6971 Comp_Unit
:= Get_Source_Unit
(E
);
6972 Set_Convention_From_Pragma
(E
);
6974 -- Treat a pragma Import as an implicit body, and pragma import
6975 -- as implicit reference (for navigation in GPS).
6977 if Prag_Id
= Pragma_Import
then
6978 Generate_Reference
(E
, Id
, 'b');
6980 -- For exported entities we restrict the generation of references
6981 -- to entities exported to foreign languages since entities
6982 -- exported to Ada do not provide further information to GPS and
6983 -- add undesired references to the output of the gnatxref tool.
6985 elsif Prag_Id
= Pragma_Export
6986 and then Convention
(E
) /= Convention_Ada
6988 Generate_Reference
(E
, Id
, 'i');
6991 -- If the pragma comes from from an aspect, it only applies to the
6992 -- given entity, not its homonyms.
6994 if From_Aspect_Specification
(N
) then
6998 -- Otherwise Loop through the homonyms of the pragma argument's
6999 -- entity, an apply convention to those in the current scope.
7005 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7007 -- Ignore entry for which convention is already set
7009 if Has_Convention_Pragma
(E1
) then
7013 -- Do not set the pragma on inherited operations or on formal
7016 if Comes_From_Source
(E1
)
7017 and then Comp_Unit
= Get_Source_Unit
(E1
)
7018 and then not Is_Formal_Subprogram
(E1
)
7019 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7020 N_Full_Type_Declaration
7022 if Present
(Alias
(E1
))
7023 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7026 ("cannot apply pragma% to non-local entity& declared#",
7030 Set_Convention_From_Pragma
(E1
);
7032 if Prag_Id
= Pragma_Import
then
7033 Generate_Reference
(E1
, Id
, 'b');
7041 end Process_Convention
;
7043 ----------------------------------------
7044 -- Process_Disable_Enable_Atomic_Sync --
7045 ----------------------------------------
7047 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7049 Check_No_Identifiers
;
7050 Check_At_Most_N_Arguments
(1);
7052 -- Modeled internally as
7053 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7057 Pragma_Identifier
=>
7058 Make_Identifier
(Loc
, Nam
),
7059 Pragma_Argument_Associations
=> New_List
(
7060 Make_Pragma_Argument_Association
(Loc
,
7062 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7064 if Present
(Arg1
) then
7065 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7069 end Process_Disable_Enable_Atomic_Sync
;
7071 -------------------------------------------------
7072 -- Process_Extended_Import_Export_Internal_Arg --
7073 -------------------------------------------------
7075 procedure Process_Extended_Import_Export_Internal_Arg
7076 (Arg_Internal
: Node_Id
:= Empty
)
7079 if No
(Arg_Internal
) then
7080 Error_Pragma
("Internal parameter required for pragma%");
7083 if Nkind
(Arg_Internal
) = N_Identifier
then
7086 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7087 and then (Prag_Id
= Pragma_Import_Function
7089 Prag_Id
= Pragma_Export_Function
)
7095 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7098 Check_Arg_Is_Local_Name
(Arg_Internal
);
7099 end Process_Extended_Import_Export_Internal_Arg
;
7101 --------------------------------------------------
7102 -- Process_Extended_Import_Export_Object_Pragma --
7103 --------------------------------------------------
7105 procedure Process_Extended_Import_Export_Object_Pragma
7106 (Arg_Internal
: Node_Id
;
7107 Arg_External
: Node_Id
;
7113 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7114 Def_Id
:= Entity
(Arg_Internal
);
7116 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7118 ("pragma% must designate an object", Arg_Internal
);
7121 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7123 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7126 ("previous Common/Psect_Object applies, pragma % not permitted",
7130 if Rep_Item_Too_Late
(Def_Id
, N
) then
7134 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7136 if Present
(Arg_Size
) then
7137 Check_Arg_Is_External_Name
(Arg_Size
);
7140 -- Export_Object case
7142 if Prag_Id
= Pragma_Export_Object
then
7143 if not Is_Library_Level_Entity
(Def_Id
) then
7145 ("argument for pragma% must be library level entity",
7149 if Ekind
(Current_Scope
) = E_Generic_Package
then
7150 Error_Pragma
("pragma& cannot appear in a generic unit");
7153 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7155 ("exported object must have compile time known size",
7159 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7160 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7162 Set_Exported
(Def_Id
, Arg_Internal
);
7165 -- Import_Object case
7168 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7170 ("cannot use pragma% for task/protected object",
7174 if Ekind
(Def_Id
) = E_Constant
then
7176 ("cannot import a constant", Arg_Internal
);
7179 if Warn_On_Export_Import
7180 and then Has_Discriminants
(Etype
(Def_Id
))
7183 ("imported value must be initialized??", Arg_Internal
);
7186 if Warn_On_Export_Import
7187 and then Is_Access_Type
(Etype
(Def_Id
))
7190 ("cannot import object of an access type??", Arg_Internal
);
7193 if Warn_On_Export_Import
7194 and then Is_Imported
(Def_Id
)
7196 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7198 -- Check for explicit initialization present. Note that an
7199 -- initialization generated by the code generator, e.g. for an
7200 -- access type, does not count here.
7202 elsif Present
(Expression
(Parent
(Def_Id
)))
7205 (Original_Node
(Expression
(Parent
(Def_Id
))))
7207 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7209 ("imported entities cannot be initialized (RM B.1(24))",
7210 "\no initialization allowed for & declared#", Arg1
);
7212 Set_Imported
(Def_Id
);
7213 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7216 end Process_Extended_Import_Export_Object_Pragma
;
7218 ------------------------------------------------------
7219 -- Process_Extended_Import_Export_Subprogram_Pragma --
7220 ------------------------------------------------------
7222 procedure Process_Extended_Import_Export_Subprogram_Pragma
7223 (Arg_Internal
: Node_Id
;
7224 Arg_External
: Node_Id
;
7225 Arg_Parameter_Types
: Node_Id
;
7226 Arg_Result_Type
: Node_Id
:= Empty
;
7227 Arg_Mechanism
: Node_Id
;
7228 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7234 Ambiguous
: Boolean;
7237 function Same_Base_Type
7239 Formal
: Entity_Id
) return Boolean;
7240 -- Determines if Ptype references the type of Formal. Note that only
7241 -- the base types need to match according to the spec. Ptype here is
7242 -- the argument from the pragma, which is either a type name, or an
7243 -- access attribute.
7245 --------------------
7246 -- Same_Base_Type --
7247 --------------------
7249 function Same_Base_Type
7251 Formal
: Entity_Id
) return Boolean
7253 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7257 -- Case where pragma argument is typ'Access
7259 if Nkind
(Ptype
) = N_Attribute_Reference
7260 and then Attribute_Name
(Ptype
) = Name_Access
7262 Pref
:= Prefix
(Ptype
);
7265 if not Is_Entity_Name
(Pref
)
7266 or else Entity
(Pref
) = Any_Type
7271 -- We have a match if the corresponding argument is of an
7272 -- anonymous access type, and its designated type matches the
7273 -- type of the prefix of the access attribute
7275 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7276 and then Base_Type
(Entity
(Pref
)) =
7277 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7279 -- Case where pragma argument is a type name
7284 if not Is_Entity_Name
(Ptype
)
7285 or else Entity
(Ptype
) = Any_Type
7290 -- We have a match if the corresponding argument is of the type
7291 -- given in the pragma (comparing base types)
7293 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7297 -- Start of processing for
7298 -- Process_Extended_Import_Export_Subprogram_Pragma
7301 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7305 -- Loop through homonyms (overloadings) of the entity
7307 Hom_Id
:= Entity
(Arg_Internal
);
7308 while Present
(Hom_Id
) loop
7309 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7311 -- We need a subprogram in the current scope
7313 if not Is_Subprogram
(Def_Id
)
7314 or else Scope
(Def_Id
) /= Current_Scope
7321 -- Pragma cannot apply to subprogram body
7323 if Is_Subprogram
(Def_Id
)
7324 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7328 ("pragma% requires separate spec"
7329 & " and must come before body");
7332 -- Test result type if given, note that the result type
7333 -- parameter can only be present for the function cases.
7335 if Present
(Arg_Result_Type
)
7336 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7340 elsif Etype
(Def_Id
) /= Standard_Void_Type
7342 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7346 -- Test parameter types if given. Note that this parameter
7347 -- has not been analyzed (and must not be, since it is
7348 -- semantic nonsense), so we get it as the parser left it.
7350 elsif Present
(Arg_Parameter_Types
) then
7351 Check_Matching_Types
: declare
7356 Formal
:= First_Formal
(Def_Id
);
7358 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7359 if Present
(Formal
) then
7363 -- A list of one type, e.g. (List) is parsed as
7364 -- a parenthesized expression.
7366 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7367 and then Paren_Count
(Arg_Parameter_Types
) = 1
7370 or else Present
(Next_Formal
(Formal
))
7375 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7378 -- A list of more than one type is parsed as a aggregate
7380 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7381 and then Paren_Count
(Arg_Parameter_Types
) = 0
7383 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7384 while Present
(Ptype
) or else Present
(Formal
) loop
7387 or else not Same_Base_Type
(Ptype
, Formal
)
7392 Next_Formal
(Formal
);
7397 -- Anything else is of the wrong form
7401 ("wrong form for Parameter_Types parameter",
7402 Arg_Parameter_Types
);
7404 end Check_Matching_Types
;
7407 -- Match is now False if the entry we found did not match
7408 -- either a supplied Parameter_Types or Result_Types argument
7414 -- Ambiguous case, the flag Ambiguous shows if we already
7415 -- detected this and output the initial messages.
7418 if not Ambiguous
then
7420 Error_Msg_Name_1
:= Pname
;
7422 ("pragma% does not uniquely identify subprogram!",
7424 Error_Msg_Sloc
:= Sloc
(Ent
);
7425 Error_Msg_N
("matching subprogram #!", N
);
7429 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7430 Error_Msg_N
("matching subprogram #!", N
);
7435 Hom_Id
:= Homonym
(Hom_Id
);
7438 -- See if we found an entry
7441 if not Ambiguous
then
7442 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7444 ("pragma% cannot be given for generic subprogram");
7447 ("pragma% does not identify local subprogram");
7454 -- Import pragmas must be for imported entities
7456 if Prag_Id
= Pragma_Import_Function
7458 Prag_Id
= Pragma_Import_Procedure
7460 Prag_Id
= Pragma_Import_Valued_Procedure
7462 if not Is_Imported
(Ent
) then
7464 ("pragma Import or Interface must precede pragma%");
7467 -- Here we have the Export case which can set the entity as exported
7469 -- But does not do so if the specified external name is null, since
7470 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7471 -- compatible) to request no external name.
7473 elsif Nkind
(Arg_External
) = N_String_Literal
7474 and then String_Length
(Strval
(Arg_External
)) = 0
7478 -- In all other cases, set entity as exported
7481 Set_Exported
(Ent
, Arg_Internal
);
7484 -- Special processing for Valued_Procedure cases
7486 if Prag_Id
= Pragma_Import_Valued_Procedure
7488 Prag_Id
= Pragma_Export_Valued_Procedure
7490 Formal
:= First_Formal
(Ent
);
7493 Error_Pragma
("at least one parameter required for pragma%");
7495 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7496 Error_Pragma
("first parameter must have mode out for pragma%");
7499 Set_Is_Valued_Procedure
(Ent
);
7503 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7505 -- Process Result_Mechanism argument if present. We have already
7506 -- checked that this is only allowed for the function case.
7508 if Present
(Arg_Result_Mechanism
) then
7509 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7512 -- Process Mechanism parameter if present. Note that this parameter
7513 -- is not analyzed, and must not be analyzed since it is semantic
7514 -- nonsense, so we get it in exactly as the parser left it.
7516 if Present
(Arg_Mechanism
) then
7524 -- A single mechanism association without a formal parameter
7525 -- name is parsed as a parenthesized expression. All other
7526 -- cases are parsed as aggregates, so we rewrite the single
7527 -- parameter case as an aggregate for consistency.
7529 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7530 and then Paren_Count
(Arg_Mechanism
) = 1
7532 Rewrite
(Arg_Mechanism
,
7533 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7534 Expressions
=> New_List
(
7535 Relocate_Node
(Arg_Mechanism
))));
7538 -- Case of only mechanism name given, applies to all formals
7540 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7541 Formal
:= First_Formal
(Ent
);
7542 while Present
(Formal
) loop
7543 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7544 Next_Formal
(Formal
);
7547 -- Case of list of mechanism associations given
7550 if Null_Record_Present
(Arg_Mechanism
) then
7552 ("inappropriate form for Mechanism parameter",
7556 -- Deal with positional ones first
7558 Formal
:= First_Formal
(Ent
);
7560 if Present
(Expressions
(Arg_Mechanism
)) then
7561 Mname
:= First
(Expressions
(Arg_Mechanism
));
7562 while Present
(Mname
) loop
7565 ("too many mechanism associations", Mname
);
7568 Set_Mechanism_Value
(Formal
, Mname
);
7569 Next_Formal
(Formal
);
7574 -- Deal with named entries
7576 if Present
(Component_Associations
(Arg_Mechanism
)) then
7577 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7578 while Present
(Massoc
) loop
7579 Choice
:= First
(Choices
(Massoc
));
7581 if Nkind
(Choice
) /= N_Identifier
7582 or else Present
(Next
(Choice
))
7585 ("incorrect form for mechanism association",
7589 Formal
:= First_Formal
(Ent
);
7593 ("parameter name & not present", Choice
);
7596 if Chars
(Choice
) = Chars
(Formal
) then
7598 (Formal
, Expression
(Massoc
));
7600 -- Set entity on identifier (needed by ASIS)
7602 Set_Entity
(Choice
, Formal
);
7607 Next_Formal
(Formal
);
7616 end Process_Extended_Import_Export_Subprogram_Pragma
;
7618 --------------------------
7619 -- Process_Generic_List --
7620 --------------------------
7622 procedure Process_Generic_List
is
7627 Check_No_Identifiers
;
7628 Check_At_Least_N_Arguments
(1);
7630 -- Check all arguments are names of generic units or instances
7633 while Present
(Arg
) loop
7634 Exp
:= Get_Pragma_Arg
(Arg
);
7637 if not Is_Entity_Name
(Exp
)
7639 (not Is_Generic_Instance
(Entity
(Exp
))
7641 not Is_Generic_Unit
(Entity
(Exp
)))
7644 ("pragma% argument must be name of generic unit/instance",
7650 end Process_Generic_List
;
7652 ------------------------------------
7653 -- Process_Import_Predefined_Type --
7654 ------------------------------------
7656 procedure Process_Import_Predefined_Type
is
7657 Loc
: constant Source_Ptr
:= Sloc
(N
);
7659 Ftyp
: Node_Id
:= Empty
;
7665 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7668 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7669 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7673 Ftyp
:= Node
(Elmt
);
7675 if Present
(Ftyp
) then
7677 -- Don't build a derived type declaration, because predefined C
7678 -- types have no declaration anywhere, so cannot really be named.
7679 -- Instead build a full type declaration, starting with an
7680 -- appropriate type definition is built
7682 if Is_Floating_Point_Type
(Ftyp
) then
7683 Def
:= Make_Floating_Point_Definition
(Loc
,
7684 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7685 Make_Real_Range_Specification
(Loc
,
7686 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7687 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7689 -- Should never have a predefined type we cannot handle
7692 raise Program_Error
;
7695 -- Build and insert a Full_Type_Declaration, which will be
7696 -- analyzed as soon as this list entry has been analyzed.
7698 Decl
:= Make_Full_Type_Declaration
(Loc
,
7699 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7700 Type_Definition
=> Def
);
7702 Insert_After
(N
, Decl
);
7703 Mark_Rewrite_Insertion
(Decl
);
7706 Error_Pragma_Arg
("no matching type found for pragma%",
7709 end Process_Import_Predefined_Type
;
7711 ---------------------------------
7712 -- Process_Import_Or_Interface --
7713 ---------------------------------
7715 procedure Process_Import_Or_Interface
is
7721 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7722 -- pragma Import (Entity, "external name");
7724 if Relaxed_RM_Semantics
7725 and then Arg_Count
= 2
7726 and then Prag_Id
= Pragma_Import
7727 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7730 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7733 if not Is_Entity_Name
(Def_Id
) then
7734 Error_Pragma_Arg
("entity name required", Arg1
);
7737 Def_Id
:= Entity
(Def_Id
);
7738 Kill_Size_Check_Code
(Def_Id
);
7739 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7742 Process_Convention
(C
, Def_Id
);
7743 Kill_Size_Check_Code
(Def_Id
);
7744 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7747 -- Various error checks
7749 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7751 -- We do not permit Import to apply to a renaming declaration
7753 if Present
(Renamed_Object
(Def_Id
)) then
7755 ("pragma% not allowed for object renaming", Arg2
);
7757 -- User initialization is not allowed for imported object, but
7758 -- the object declaration may contain a default initialization,
7759 -- that will be discarded. Note that an explicit initialization
7760 -- only counts if it comes from source, otherwise it is simply
7761 -- the code generator making an implicit initialization explicit.
7763 elsif Present
(Expression
(Parent
(Def_Id
)))
7764 and then Comes_From_Source
7765 (Original_Node
(Expression
(Parent
(Def_Id
))))
7767 -- Set imported flag to prevent cascaded errors
7769 Set_Is_Imported
(Def_Id
);
7771 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7773 ("no initialization allowed for declaration of& #",
7774 "\imported entities cannot be initialized (RM B.1(24))",
7778 -- If the pragma comes from an aspect specification the
7779 -- Is_Imported flag has already been set.
7781 if not From_Aspect_Specification
(N
) then
7782 Set_Imported
(Def_Id
);
7785 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7787 -- Note that we do not set Is_Public here. That's because we
7788 -- only want to set it if there is no address clause, and we
7789 -- don't know that yet, so we delay that processing till
7792 -- pragma Import completes deferred constants
7794 if Ekind
(Def_Id
) = E_Constant
then
7795 Set_Has_Completion
(Def_Id
);
7798 -- It is not possible to import a constant of an unconstrained
7799 -- array type (e.g. string) because there is no simple way to
7800 -- write a meaningful subtype for it.
7802 if Is_Array_Type
(Etype
(Def_Id
))
7803 and then not Is_Constrained
(Etype
(Def_Id
))
7806 ("imported constant& must have a constrained subtype",
7811 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7813 -- If the name is overloaded, pragma applies to all of the denoted
7814 -- entities in the same declarative part, unless the pragma comes
7815 -- from an aspect specification or was generated by the compiler
7816 -- (such as for pragma Provide_Shift_Operators).
7819 while Present
(Hom_Id
) loop
7821 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7823 -- Ignore inherited subprograms because the pragma will apply
7824 -- to the parent operation, which is the one called.
7826 if Is_Overloadable
(Def_Id
)
7827 and then Present
(Alias
(Def_Id
))
7831 -- If it is not a subprogram, it must be in an outer scope and
7832 -- pragma does not apply.
7834 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7837 -- The pragma does not apply to primitives of interfaces
7839 elsif Is_Dispatching_Operation
(Def_Id
)
7840 and then Present
(Find_Dispatching_Type
(Def_Id
))
7841 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7845 -- Verify that the homonym is in the same declarative part (not
7846 -- just the same scope). If the pragma comes from an aspect
7847 -- specification we know that it is part of the declaration.
7849 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7850 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7851 and then not From_Aspect_Specification
(N
)
7856 -- If the pragma comes from an aspect specification the
7857 -- Is_Imported flag has already been set.
7859 if not From_Aspect_Specification
(N
) then
7860 Set_Imported
(Def_Id
);
7863 -- Reject an Import applied to an abstract subprogram
7865 if Is_Subprogram
(Def_Id
)
7866 and then Is_Abstract_Subprogram
(Def_Id
)
7868 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7870 ("cannot import abstract subprogram& declared#",
7874 -- Special processing for Convention_Intrinsic
7876 if C
= Convention_Intrinsic
then
7878 -- Link_Name argument not allowed for intrinsic
7882 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7884 -- If no external name is present, then check that this
7885 -- is a valid intrinsic subprogram. If an external name
7886 -- is present, then this is handled by the back end.
7889 Check_Intrinsic_Subprogram
7890 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7894 -- Verify that the subprogram does not have a completion
7895 -- through a renaming declaration. For other completions the
7896 -- pragma appears as a too late representation.
7899 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7903 and then Nkind
(Decl
) = N_Subprogram_Declaration
7904 and then Present
(Corresponding_Body
(Decl
))
7905 and then Nkind
(Unit_Declaration_Node
7906 (Corresponding_Body
(Decl
))) =
7907 N_Subprogram_Renaming_Declaration
7909 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7911 ("cannot import&, renaming already provided for "
7912 & "declaration #", N
, Def_Id
);
7916 -- If the pragma comes from an aspect specification, there
7917 -- must be an Import aspect specified as well. In the rare
7918 -- case where Import is set to False, the suprogram needs to
7919 -- have a local completion.
7922 Imp_Aspect
: constant Node_Id
:=
7923 Find_Aspect
(Def_Id
, Aspect_Import
);
7927 if Present
(Imp_Aspect
)
7928 and then Present
(Expression
(Imp_Aspect
))
7930 Expr
:= Expression
(Imp_Aspect
);
7931 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7933 if Is_Entity_Name
(Expr
)
7934 and then Entity
(Expr
) = Standard_True
7936 Set_Has_Completion
(Def_Id
);
7939 -- If there is no expression, the default is True, as for
7940 -- all boolean aspects. Same for the older pragma.
7943 Set_Has_Completion
(Def_Id
);
7947 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7950 if Is_Compilation_Unit
(Hom_Id
) then
7952 -- Its possible homonyms are not affected by the pragma.
7953 -- Such homonyms might be present in the context of other
7954 -- units being compiled.
7958 elsif From_Aspect_Specification
(N
) then
7961 -- If the pragma was created by the compiler, then we don't
7962 -- want it to apply to other homonyms. This kind of case can
7963 -- occur when using pragma Provide_Shift_Operators, which
7964 -- generates implicit shift and rotate operators with Import
7965 -- pragmas that might apply to earlier explicit or implicit
7966 -- declarations marked with Import (for example, coming from
7967 -- an earlier pragma Provide_Shift_Operators for another type),
7968 -- and we don't generally want other homonyms being treated
7969 -- as imported or the pragma flagged as an illegal duplicate.
7971 elsif not Comes_From_Source
(N
) then
7975 Hom_Id
:= Homonym
(Hom_Id
);
7979 -- When the convention is Java or CIL, we also allow Import to
7980 -- be given for packages, generic packages, exceptions, record
7981 -- components, and access to subprograms.
7983 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
7985 (Is_Package_Or_Generic_Package
(Def_Id
)
7986 or else Ekind
(Def_Id
) = E_Exception
7987 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
7988 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
7990 Set_Imported
(Def_Id
);
7991 Set_Is_Public
(Def_Id
);
7992 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7994 -- Import a CPP class
7996 elsif C
= Convention_CPP
7997 and then (Is_Record_Type
(Def_Id
)
7998 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8000 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8001 if Present
(Full_View
(Def_Id
)) then
8002 Def_Id
:= Full_View
(Def_Id
);
8006 ("cannot import 'C'P'P type before full declaration seen",
8007 Get_Pragma_Arg
(Arg2
));
8009 -- Although we have reported the error we decorate it as
8010 -- CPP_Class to avoid reporting spurious errors
8012 Set_Is_CPP_Class
(Def_Id
);
8017 -- Types treated as CPP classes must be declared limited (note:
8018 -- this used to be a warning but there is no real benefit to it
8019 -- since we did effectively intend to treat the type as limited
8022 if not Is_Limited_Type
(Def_Id
) then
8024 ("imported 'C'P'P type must be limited",
8025 Get_Pragma_Arg
(Arg2
));
8028 if Etype
(Def_Id
) /= Def_Id
8029 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8031 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8034 Set_Is_CPP_Class
(Def_Id
);
8036 -- Imported CPP types must not have discriminants (because C++
8037 -- classes do not have discriminants).
8039 if Has_Discriminants
(Def_Id
) then
8041 ("imported 'C'P'P type cannot have discriminants",
8042 First
(Discriminant_Specifications
8043 (Declaration_Node
(Def_Id
))));
8046 -- Check that components of imported CPP types do not have default
8047 -- expressions. For private types this check is performed when the
8048 -- full view is analyzed (see Process_Full_View).
8050 if not Is_Private_Type
(Def_Id
) then
8051 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8054 -- Import a CPP exception
8056 elsif C
= Convention_CPP
8057 and then Ekind
(Def_Id
) = E_Exception
8061 ("'External_'Name arguments is required for 'Cpp exception",
8064 -- As only a string is allowed, Check_Arg_Is_External_Name
8067 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8070 if Present
(Arg4
) then
8072 ("Link_Name argument not allowed for imported Cpp exception",
8076 -- Do not call Set_Interface_Name as the name of the exception
8077 -- shouldn't be modified (and in particular it shouldn't be
8078 -- the External_Name). For exceptions, the External_Name is the
8079 -- name of the RTTI structure.
8081 -- ??? Emit an error if pragma Import/Export_Exception is present
8083 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8085 Check_Arg_Count
(3);
8086 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8088 Process_Import_Predefined_Type
;
8092 ("second argument of pragma% must be object, subprogram "
8093 & "or incomplete type",
8097 -- If this pragma applies to a compilation unit, then the unit, which
8098 -- is a subprogram, does not require (or allow) a body. We also do
8099 -- not need to elaborate imported procedures.
8101 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8103 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8105 Set_Body_Required
(Cunit
, False);
8108 end Process_Import_Or_Interface
;
8110 --------------------
8111 -- Process_Inline --
8112 --------------------
8114 procedure Process_Inline
(Status
: Inline_Status
) is
8121 procedure Make_Inline
(Subp
: Entity_Id
);
8122 -- Subp is the defining unit name of the subprogram declaration. Set
8123 -- the flag, as well as the flag in the corresponding body, if there
8126 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8127 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8128 -- Has_Pragma_Inline_Always for the Inline_Always case.
8130 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8131 -- Returns True if it can be determined at this stage that inlining
8132 -- is not possible, for example if the body is available and contains
8133 -- exception handlers, we prevent inlining, since otherwise we can
8134 -- get undefined symbols at link time. This function also emits a
8135 -- warning if front-end inlining is enabled and the pragma appears
8138 -- ??? is business with link symbols still valid, or does it relate
8139 -- to front end ZCX which is being phased out ???
8141 ---------------------------
8142 -- Inlining_Not_Possible --
8143 ---------------------------
8145 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8146 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8150 if Nkind
(Decl
) = N_Subprogram_Body
then
8151 Stats
:= Handled_Statement_Sequence
(Decl
);
8152 return Present
(Exception_Handlers
(Stats
))
8153 or else Present
(At_End_Proc
(Stats
));
8155 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8156 and then Present
(Corresponding_Body
(Decl
))
8158 if Front_End_Inlining
8159 and then Analyzed
(Corresponding_Body
(Decl
))
8161 Error_Msg_N
("pragma appears too late, ignored??", N
);
8164 -- If the subprogram is a renaming as body, the body is just a
8165 -- call to the renamed subprogram, and inlining is trivially
8169 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8170 N_Subprogram_Renaming_Declaration
8176 Handled_Statement_Sequence
8177 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8180 Present
(Exception_Handlers
(Stats
))
8181 or else Present
(At_End_Proc
(Stats
));
8185 -- If body is not available, assume the best, the check is
8186 -- performed again when compiling enclosing package bodies.
8190 end Inlining_Not_Possible
;
8196 procedure Make_Inline
(Subp
: Entity_Id
) is
8197 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8198 Inner_Subp
: Entity_Id
:= Subp
;
8201 -- Ignore if bad type, avoid cascaded error
8203 if Etype
(Subp
) = Any_Type
then
8207 -- Ignore if all inlining is suppressed
8209 elsif Suppress_All_Inlining
then
8213 -- If inlining is not possible, for now do not treat as an error
8215 elsif Status
/= Suppressed
8216 and then Inlining_Not_Possible
(Subp
)
8221 -- Here we have a candidate for inlining, but we must exclude
8222 -- derived operations. Otherwise we would end up trying to inline
8223 -- a phantom declaration, and the result would be to drag in a
8224 -- body which has no direct inlining associated with it. That
8225 -- would not only be inefficient but would also result in the
8226 -- backend doing cross-unit inlining in cases where it was
8227 -- definitely inappropriate to do so.
8229 -- However, a simple Comes_From_Source test is insufficient, since
8230 -- we do want to allow inlining of generic instances which also do
8231 -- not come from source. We also need to recognize specs generated
8232 -- by the front-end for bodies that carry the pragma. Finally,
8233 -- predefined operators do not come from source but are not
8234 -- inlineable either.
8236 elsif Is_Generic_Instance
(Subp
)
8237 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8241 elsif not Comes_From_Source
(Subp
)
8242 and then Scope
(Subp
) /= Standard_Standard
8248 -- The referenced entity must either be the enclosing entity, or
8249 -- an entity declared within the current open scope.
8251 if Present
(Scope
(Subp
))
8252 and then Scope
(Subp
) /= Current_Scope
8253 and then Subp
/= Current_Scope
8256 ("argument of% must be entity in current scope", Assoc
);
8260 -- Processing for procedure, operator or function. If subprogram
8261 -- is aliased (as for an instance) indicate that the renamed
8262 -- entity (if declared in the same unit) is inlined.
8264 if Is_Subprogram
(Subp
) then
8265 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8267 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8268 Set_Inline_Flags
(Inner_Subp
);
8270 Decl
:= Parent
(Parent
(Inner_Subp
));
8272 if Nkind
(Decl
) = N_Subprogram_Declaration
8273 and then Present
(Corresponding_Body
(Decl
))
8275 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8277 elsif Is_Generic_Instance
(Subp
) then
8279 -- Indicate that the body needs to be created for
8280 -- inlining subsequent calls. The instantiation node
8281 -- follows the declaration of the wrapper package
8284 if Scope
(Subp
) /= Standard_Standard
8286 Need_Subprogram_Instance_Body
8287 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8293 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8294 -- appear in a formal part to apply to a formal subprogram.
8295 -- Do not apply check within an instance or a formal package
8296 -- the test will have been applied to the original generic.
8298 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8299 and then List_Containing
(Decl
) = List_Containing
(N
)
8300 and then not In_Instance
8303 ("Inline cannot apply to a formal subprogram", N
);
8305 -- If Subp is a renaming, it is the renamed entity that
8306 -- will appear in any call, and be inlined. However, for
8307 -- ASIS uses it is convenient to indicate that the renaming
8308 -- itself is an inlined subprogram, so that some gnatcheck
8309 -- rules can be applied in the absence of expansion.
8311 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8312 Set_Inline_Flags
(Subp
);
8318 -- For a generic subprogram set flag as well, for use at the point
8319 -- of instantiation, to determine whether the body should be
8322 elsif Is_Generic_Subprogram
(Subp
) then
8323 Set_Inline_Flags
(Subp
);
8326 -- Literals are by definition inlined
8328 elsif Kind
= E_Enumeration_Literal
then
8331 -- Anything else is an error
8335 ("expect subprogram name for pragma%", Assoc
);
8339 ----------------------
8340 -- Set_Inline_Flags --
8341 ----------------------
8343 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8345 -- First set the Has_Pragma_XXX flags and issue the appropriate
8346 -- errors and warnings for suspicious combinations.
8348 if Prag_Id
= Pragma_No_Inline
then
8349 if Has_Pragma_Inline_Always
(Subp
) then
8351 ("Inline_Always and No_Inline are mutually exclusive", N
);
8352 elsif Has_Pragma_Inline
(Subp
) then
8354 ("Inline and No_Inline both specified for& ??",
8355 N
, Entity
(Subp_Id
));
8358 Set_Has_Pragma_No_Inline
(Subp
);
8360 if Prag_Id
= Pragma_Inline_Always
then
8361 if Has_Pragma_No_Inline
(Subp
) then
8363 ("Inline_Always and No_Inline are mutually exclusive",
8367 Set_Has_Pragma_Inline_Always
(Subp
);
8369 if Has_Pragma_No_Inline
(Subp
) then
8371 ("Inline and No_Inline both specified for& ??",
8372 N
, Entity
(Subp_Id
));
8376 if not Has_Pragma_Inline
(Subp
) then
8377 Set_Has_Pragma_Inline
(Subp
);
8381 -- Then adjust the Is_Inlined flag. It can never be set if the
8382 -- subprogram is subject to pragma No_Inline.
8386 Set_Is_Inlined
(Subp
, False);
8390 if not Has_Pragma_No_Inline
(Subp
) then
8391 Set_Is_Inlined
(Subp
, True);
8394 end Set_Inline_Flags
;
8396 -- Start of processing for Process_Inline
8399 Check_No_Identifiers
;
8400 Check_At_Least_N_Arguments
(1);
8402 if Status
= Enabled
then
8403 Inline_Processing_Required
:= True;
8407 while Present
(Assoc
) loop
8408 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8412 if Is_Entity_Name
(Subp_Id
) then
8413 Subp
:= Entity
(Subp_Id
);
8415 if Subp
= Any_Id
then
8417 -- If previous error, avoid cascaded errors
8419 Check_Error_Detected
;
8425 -- For the pragma case, climb homonym chain. This is
8426 -- what implements allowing the pragma in the renaming
8427 -- case, with the result applying to the ancestors, and
8428 -- also allows Inline to apply to all previous homonyms.
8430 if not From_Aspect_Specification
(N
) then
8431 while Present
(Homonym
(Subp
))
8432 and then Scope
(Homonym
(Subp
)) = Current_Scope
8434 Make_Inline
(Homonym
(Subp
));
8435 Subp
:= Homonym
(Subp
);
8442 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8449 ----------------------------
8450 -- Process_Interface_Name --
8451 ----------------------------
8453 procedure Process_Interface_Name
8454 (Subprogram_Def
: Entity_Id
;
8460 String_Val
: String_Id
;
8462 procedure Check_Form_Of_Interface_Name
8464 Ext_Name_Case
: Boolean);
8465 -- SN is a string literal node for an interface name. This routine
8466 -- performs some minimal checks that the name is reasonable. In
8467 -- particular that no spaces or other obviously incorrect characters
8468 -- appear. This is only a warning, since any characters are allowed.
8469 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8471 ----------------------------------
8472 -- Check_Form_Of_Interface_Name --
8473 ----------------------------------
8475 procedure Check_Form_Of_Interface_Name
8477 Ext_Name_Case
: Boolean)
8479 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8480 SL
: constant Nat
:= String_Length
(S
);
8485 Error_Msg_N
("interface name cannot be null string", SN
);
8488 for J
in 1 .. SL
loop
8489 C
:= Get_String_Char
(S
, J
);
8491 -- Look for dubious character and issue unconditional warning.
8492 -- Definitely dubious if not in character range.
8494 if not In_Character_Range
(C
)
8496 -- For all cases except CLI target,
8497 -- commas, spaces and slashes are dubious (in CLI, we use
8498 -- commas and backslashes in external names to specify
8499 -- assembly version and public key, while slashes and spaces
8500 -- can be used in names to mark nested classes and
8503 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8504 and then (Get_Character
(C
) = ','
8506 Get_Character
(C
) = '\'))
8507 or else (VM_Target
/= CLI_Target
8508 and then (Get_Character
(C
) = ' '
8510 Get_Character
(C
) = '/'))
8513 ("??interface name contains illegal character",
8514 Sloc
(SN
) + Source_Ptr
(J
));
8517 end Check_Form_Of_Interface_Name
;
8519 -- Start of processing for Process_Interface_Name
8522 if No
(Link_Arg
) then
8523 if No
(Ext_Arg
) then
8524 if VM_Target
= CLI_Target
8525 and then Ekind
(Subprogram_Def
) = E_Package
8526 and then Nkind
(Parent
(Subprogram_Def
)) =
8527 N_Package_Specification
8528 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8533 (Generic_Parent
(Parent
(Subprogram_Def
))));
8538 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8540 Link_Nam
:= Expression
(Ext_Arg
);
8543 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8544 Ext_Nam
:= Expression
(Ext_Arg
);
8549 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8550 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8551 Ext_Nam
:= Expression
(Ext_Arg
);
8552 Link_Nam
:= Expression
(Link_Arg
);
8555 -- Check expressions for external name and link name are static
8557 if Present
(Ext_Nam
) then
8558 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8559 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8561 -- Verify that external name is not the name of a local entity,
8562 -- which would hide the imported one and could lead to run-time
8563 -- surprises. The problem can only arise for entities declared in
8564 -- a package body (otherwise the external name is fully qualified
8565 -- and will not conflict).
8573 if Prag_Id
= Pragma_Import
then
8574 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8576 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8578 if Nam
/= Chars
(Subprogram_Def
)
8579 and then Present
(E
)
8580 and then not Is_Overloadable
(E
)
8581 and then Is_Immediately_Visible
(E
)
8582 and then not Is_Imported
(E
)
8583 and then Ekind
(Scope
(E
)) = E_Package
8586 while Present
(Par
) loop
8587 if Nkind
(Par
) = N_Package_Body
then
8588 Error_Msg_Sloc
:= Sloc
(E
);
8590 ("imported entity is hidden by & declared#",
8595 Par
:= Parent
(Par
);
8602 if Present
(Link_Nam
) then
8603 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8604 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8607 -- If there is no link name, just set the external name
8609 if No
(Link_Nam
) then
8610 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8612 -- For the Link_Name case, the given literal is preceded by an
8613 -- asterisk, which indicates to GCC that the given name should be
8614 -- taken literally, and in particular that no prepending of
8615 -- underlines should occur, even in systems where this is the
8621 if VM_Target
= No_VM
then
8622 Store_String_Char
(Get_Char_Code
('*'));
8625 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8626 Store_String_Chars
(String_Val
);
8628 Make_String_Literal
(Sloc
(Link_Nam
),
8629 Strval
=> End_String
);
8632 -- Set the interface name. If the entity is a generic instance, use
8633 -- its alias, which is the callable entity.
8635 if Is_Generic_Instance
(Subprogram_Def
) then
8636 Set_Encoded_Interface_Name
8637 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8639 Set_Encoded_Interface_Name
8640 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8643 -- We allow duplicated export names in CIL/Java, as they are always
8644 -- enclosed in a namespace that differentiates them, and overloaded
8645 -- entities are supported by the VM.
8647 if Convention
(Subprogram_Def
) /= Convention_CIL
8649 Convention
(Subprogram_Def
) /= Convention_Java
8651 Check_Duplicated_Export_Name
(Link_Nam
);
8653 end Process_Interface_Name
;
8655 -----------------------------------------
8656 -- Process_Interrupt_Or_Attach_Handler --
8657 -----------------------------------------
8659 procedure Process_Interrupt_Or_Attach_Handler
is
8660 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8661 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8662 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8665 Set_Is_Interrupt_Handler
(Handler_Proc
);
8667 -- If the pragma is not associated with a handler procedure within a
8668 -- protected type, then it must be for a nonprotected procedure for
8669 -- the AAMP target, in which case we don't associate a representation
8670 -- item with the procedure's scope.
8672 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8673 if Prag_Id
= Pragma_Interrupt_Handler
8675 Prag_Id
= Pragma_Attach_Handler
8677 Record_Rep_Item
(Proc_Scope
, N
);
8680 end Process_Interrupt_Or_Attach_Handler
;
8682 --------------------------------------------------
8683 -- Process_Restrictions_Or_Restriction_Warnings --
8684 --------------------------------------------------
8686 -- Note: some of the simple identifier cases were handled in par-prag,
8687 -- but it is harmless (and more straightforward) to simply handle all
8688 -- cases here, even if it means we repeat a bit of work in some cases.
8690 procedure Process_Restrictions_Or_Restriction_Warnings
8694 R_Id
: Restriction_Id
;
8700 -- Ignore all Restrictions pragmas in CodePeer mode
8702 if CodePeer_Mode
then
8706 Check_Ada_83_Warning
;
8707 Check_At_Least_N_Arguments
(1);
8708 Check_Valid_Configuration_Pragma
;
8711 while Present
(Arg
) loop
8713 Expr
:= Get_Pragma_Arg
(Arg
);
8715 -- Case of no restriction identifier present
8717 if Id
= No_Name
then
8718 if Nkind
(Expr
) /= N_Identifier
then
8720 ("invalid form for restriction", Arg
);
8725 (Process_Restriction_Synonyms
(Expr
));
8727 if R_Id
not in All_Boolean_Restrictions
then
8728 Error_Msg_Name_1
:= Pname
;
8730 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8732 -- Check for possible misspelling
8734 for J
in Restriction_Id
loop
8736 Rnm
: constant String := Restriction_Id
'Image (J
);
8739 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8740 Name_Len
:= Rnm
'Length;
8741 Set_Casing
(All_Lower_Case
);
8743 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8745 (Identifier_Casing
(Current_Source_File
));
8746 Error_Msg_String
(1 .. Rnm
'Length) :=
8747 Name_Buffer
(1 .. Name_Len
);
8748 Error_Msg_Strlen
:= Rnm
'Length;
8749 Error_Msg_N
-- CODEFIX
8750 ("\possible misspelling of ""~""",
8751 Get_Pragma_Arg
(Arg
));
8760 if Implementation_Restriction
(R_Id
) then
8761 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8764 -- Special processing for No_Elaboration_Code restriction
8766 if R_Id
= No_Elaboration_Code
then
8768 -- Restriction is only recognized within a configuration
8769 -- pragma file, or within a unit of the main extended
8770 -- program. Note: the test for Main_Unit is needed to
8771 -- properly include the case of configuration pragma files.
8773 if not (Current_Sem_Unit
= Main_Unit
8774 or else In_Extended_Main_Source_Unit
(N
))
8778 -- Don't allow in a subunit unless already specified in
8781 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8782 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8783 and then not Restriction_Active
(No_Elaboration_Code
)
8786 ("invalid specification of ""No_Elaboration_Code""",
8789 ("\restriction cannot be specified in a subunit", N
);
8791 ("\unless also specified in body or spec", N
);
8794 -- If we accept a No_Elaboration_Code restriction, then it
8795 -- needs to be added to the configuration restriction set so
8796 -- that we get proper application to other units in the main
8797 -- extended source as required.
8800 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8804 -- If this is a warning, then set the warning unless we already
8805 -- have a real restriction active (we never want a warning to
8806 -- override a real restriction).
8809 if not Restriction_Active
(R_Id
) then
8810 Set_Restriction
(R_Id
, N
);
8811 Restriction_Warnings
(R_Id
) := True;
8814 -- If real restriction case, then set it and make sure that the
8815 -- restriction warning flag is off, since a real restriction
8816 -- always overrides a warning.
8819 Set_Restriction
(R_Id
, N
);
8820 Restriction_Warnings
(R_Id
) := False;
8823 -- Check for obsolescent restrictions in Ada 2005 mode
8826 and then Ada_Version
>= Ada_2005
8827 and then (R_Id
= No_Asynchronous_Control
8829 R_Id
= No_Unchecked_Deallocation
8831 R_Id
= No_Unchecked_Conversion
)
8833 Check_Restriction
(No_Obsolescent_Features
, N
);
8836 -- A very special case that must be processed here: pragma
8837 -- Restrictions (No_Exceptions) turns off all run-time
8838 -- checking. This is a bit dubious in terms of the formal
8839 -- language definition, but it is what is intended by RM
8840 -- H.4(12). Restriction_Warnings never affects generated code
8841 -- so this is done only in the real restriction case.
8843 -- Atomic_Synchronization is not a real check, so it is not
8844 -- affected by this processing).
8846 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8847 -- run-time checks in CodePeer and GNATprove modes: we want to
8848 -- generate checks for analysis purposes, as set respectively
8849 -- by -gnatC and -gnatd.F
8852 and then not (CodePeer_Mode
or GNATprove_Mode
)
8853 and then R_Id
= No_Exceptions
8855 for J
in Scope_Suppress
.Suppress
'Range loop
8856 if J
/= Atomic_Synchronization
then
8857 Scope_Suppress
.Suppress
(J
) := True;
8862 -- Case of No_Dependence => unit-name. Note that the parser
8863 -- already made the necessary entry in the No_Dependence table.
8865 elsif Id
= Name_No_Dependence
then
8866 if not OK_No_Dependence_Unit_Name
(Expr
) then
8870 -- Case of No_Specification_Of_Aspect => aspect-identifier
8872 elsif Id
= Name_No_Specification_Of_Aspect
then
8877 if Nkind
(Expr
) /= N_Identifier
then
8880 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8883 if A_Id
= No_Aspect
then
8884 Error_Pragma_Arg
("invalid restriction name", Arg
);
8886 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8890 -- Case of No_Use_Of_Attribute => attribute-identifier
8892 elsif Id
= Name_No_Use_Of_Attribute
then
8893 if Nkind
(Expr
) /= N_Identifier
8894 or else not Is_Attribute_Name
(Chars
(Expr
))
8896 Error_Msg_N
("unknown attribute name??", Expr
);
8899 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8902 -- Case of No_Use_Of_Entity => fully-qualified-name
8904 elsif Id
= Name_No_Use_Of_Entity
then
8906 -- Restriction is only recognized within a configuration
8907 -- pragma file, or within a unit of the main extended
8908 -- program. Note: the test for Main_Unit is needed to
8909 -- properly include the case of configuration pragma files.
8911 if Current_Sem_Unit
= Main_Unit
8912 or else In_Extended_Main_Source_Unit
(N
)
8914 if not OK_No_Dependence_Unit_Name
(Expr
) then
8915 Error_Msg_N
("wrong form for entity name", Expr
);
8917 Set_Restriction_No_Use_Of_Entity
8918 (Expr
, Warn
, No_Profile
);
8922 -- Case of No_Use_Of_Pragma => pragma-identifier
8924 elsif Id
= Name_No_Use_Of_Pragma
then
8925 if Nkind
(Expr
) /= N_Identifier
8926 or else not Is_Pragma_Name
(Chars
(Expr
))
8928 Error_Msg_N
("unknown pragma name??", Expr
);
8930 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8933 -- All other cases of restriction identifier present
8936 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8937 Analyze_And_Resolve
(Expr
, Any_Integer
);
8939 if R_Id
not in All_Parameter_Restrictions
then
8941 ("invalid restriction parameter identifier", Arg
);
8943 elsif not Is_OK_Static_Expression
(Expr
) then
8944 Flag_Non_Static_Expr
8945 ("value must be static expression!", Expr
);
8948 elsif not Is_Integer_Type
(Etype
(Expr
))
8949 or else Expr_Value
(Expr
) < 0
8952 ("value must be non-negative integer", Arg
);
8955 -- Restriction pragma is active
8957 Val
:= Expr_Value
(Expr
);
8959 if not UI_Is_In_Int_Range
(Val
) then
8961 ("pragma ignored, value too large??", Arg
);
8964 -- Warning case. If the real restriction is active, then we
8965 -- ignore the request, since warning never overrides a real
8966 -- restriction. Otherwise we set the proper warning. Note that
8967 -- this circuit sets the warning again if it is already set,
8968 -- which is what we want, since the constant may have changed.
8971 if not Restriction_Active
(R_Id
) then
8973 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
8974 Restriction_Warnings
(R_Id
) := True;
8977 -- Real restriction case, set restriction and make sure warning
8978 -- flag is off since real restriction always overrides warning.
8981 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
8982 Restriction_Warnings
(R_Id
) := False;
8988 end Process_Restrictions_Or_Restriction_Warnings
;
8990 ---------------------------------
8991 -- Process_Suppress_Unsuppress --
8992 ---------------------------------
8994 -- Note: this procedure makes entries in the check suppress data
8995 -- structures managed by Sem. See spec of package Sem for full
8996 -- details on how we handle recording of check suppression.
8998 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9003 In_Package_Spec
: constant Boolean :=
9004 Is_Package_Or_Generic_Package
(Current_Scope
)
9005 and then not In_Package_Body
(Current_Scope
);
9007 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9008 -- Used to suppress a single check on the given entity
9010 --------------------------------
9011 -- Suppress_Unsuppress_Echeck --
9012 --------------------------------
9014 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9016 -- Check for error of trying to set atomic synchronization for
9017 -- a non-atomic variable.
9019 if C
= Atomic_Synchronization
9020 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9023 ("pragma & requires atomic type or variable",
9024 Pragma_Identifier
(Original_Node
(N
)));
9027 Set_Checks_May_Be_Suppressed
(E
);
9029 if In_Package_Spec
then
9030 Push_Global_Suppress_Stack_Entry
9033 Suppress
=> Suppress_Case
);
9035 Push_Local_Suppress_Stack_Entry
9038 Suppress
=> Suppress_Case
);
9041 -- If this is a first subtype, and the base type is distinct,
9042 -- then also set the suppress flags on the base type.
9044 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9045 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9047 end Suppress_Unsuppress_Echeck
;
9049 -- Start of processing for Process_Suppress_Unsuppress
9052 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9053 -- on user code: we want to generate checks for analysis purposes, as
9054 -- set respectively by -gnatC and -gnatd.F
9056 if (CodePeer_Mode
or GNATprove_Mode
)
9057 and then Comes_From_Source
(N
)
9062 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9063 -- declarative part or a package spec (RM 11.5(5)).
9065 if not Is_Configuration_Pragma
then
9066 Check_Is_In_Decl_Part_Or_Package_Spec
;
9069 Check_At_Least_N_Arguments
(1);
9070 Check_At_Most_N_Arguments
(2);
9071 Check_No_Identifier
(Arg1
);
9072 Check_Arg_Is_Identifier
(Arg1
);
9074 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9076 if C
= No_Check_Id
then
9078 ("argument of pragma% is not valid check name", Arg1
);
9081 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9083 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9085 ("Suppress of Elaboration_Check ignored in SPARK??",
9086 "\elaboration checking rules are statically enforced "
9087 & "(SPARK RM 7.7)", Arg1
);
9090 -- One-argument case
9092 if Arg_Count
= 1 then
9094 -- Make an entry in the local scope suppress table. This is the
9095 -- table that directly shows the current value of the scope
9096 -- suppress check for any check id value.
9098 if C
= All_Checks
then
9100 -- For All_Checks, we set all specific predefined checks with
9101 -- the exception of Elaboration_Check, which is handled
9102 -- specially because of not wanting All_Checks to have the
9103 -- effect of deactivating static elaboration order processing.
9104 -- Atomic_Synchronization is also not affected, since this is
9105 -- not a real check.
9107 for J
in Scope_Suppress
.Suppress
'Range loop
9108 if J
/= Elaboration_Check
9110 J
/= Atomic_Synchronization
9112 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9116 -- If not All_Checks, and predefined check, then set appropriate
9117 -- scope entry. Note that we will set Elaboration_Check if this
9118 -- is explicitly specified. Atomic_Synchronization is allowed
9119 -- only if internally generated and entity is atomic.
9121 elsif C
in Predefined_Check_Id
9122 and then (not Comes_From_Source
(N
)
9123 or else C
/= Atomic_Synchronization
)
9125 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9128 -- Also make an entry in the Local_Entity_Suppress table
9130 Push_Local_Suppress_Stack_Entry
9133 Suppress
=> Suppress_Case
);
9135 -- Case of two arguments present, where the check is suppressed for
9136 -- a specified entity (given as the second argument of the pragma)
9139 -- This is obsolescent in Ada 2005 mode
9141 if Ada_Version
>= Ada_2005
then
9142 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9145 Check_Optional_Identifier
(Arg2
, Name_On
);
9146 E_Id
:= Get_Pragma_Arg
(Arg2
);
9149 if not Is_Entity_Name
(E_Id
) then
9151 ("second argument of pragma% must be entity name", Arg2
);
9160 -- Enforce RM 11.5(7) which requires that for a pragma that
9161 -- appears within a package spec, the named entity must be
9162 -- within the package spec. We allow the package name itself
9163 -- to be mentioned since that makes sense, although it is not
9164 -- strictly allowed by 11.5(7).
9167 and then E
/= Current_Scope
9168 and then Scope
(E
) /= Current_Scope
9171 ("entity in pragma% is not in package spec (RM 11.5(7))",
9175 -- Loop through homonyms. As noted below, in the case of a package
9176 -- spec, only homonyms within the package spec are considered.
9179 Suppress_Unsuppress_Echeck
(E
, C
);
9181 if Is_Generic_Instance
(E
)
9182 and then Is_Subprogram
(E
)
9183 and then Present
(Alias
(E
))
9185 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9188 -- Move to next homonym if not aspect spec case
9190 exit when From_Aspect_Specification
(N
);
9194 -- If we are within a package specification, the pragma only
9195 -- applies to homonyms in the same scope.
9197 exit when In_Package_Spec
9198 and then Scope
(E
) /= Current_Scope
;
9201 end Process_Suppress_Unsuppress
;
9207 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9209 if Is_Imported
(E
) then
9211 ("cannot export entity& that was previously imported", Arg
);
9213 elsif Present
(Address_Clause
(E
))
9214 and then not Relaxed_RM_Semantics
9217 ("cannot export entity& that has an address clause", Arg
);
9220 Set_Is_Exported
(E
);
9222 -- Generate a reference for entity explicitly, because the
9223 -- identifier may be overloaded and name resolution will not
9226 Generate_Reference
(E
, Arg
);
9228 -- Deal with exporting non-library level entity
9230 if not Is_Library_Level_Entity
(E
) then
9232 -- Not allowed at all for subprograms
9234 if Is_Subprogram
(E
) then
9235 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9237 -- Otherwise set public and statically allocated
9241 Set_Is_Statically_Allocated
(E
);
9243 -- Warn if the corresponding W flag is set
9245 if Warn_On_Export_Import
9247 -- Only do this for something that was in the source. Not
9248 -- clear if this can be False now (there used for sure to be
9249 -- cases on some systems where it was False), but anyway the
9250 -- test is harmless if not needed, so it is retained.
9252 and then Comes_From_Source
(Arg
)
9255 ("?x?& has been made static as a result of Export",
9258 ("\?x?this usage is non-standard and non-portable",
9264 if Warn_On_Export_Import
and then Is_Type
(E
) then
9265 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9268 if Warn_On_Export_Import
and Inside_A_Generic
then
9270 ("all instances of& will have the same external name?x?",
9275 ----------------------------------------------
9276 -- Set_Extended_Import_Export_External_Name --
9277 ----------------------------------------------
9279 procedure Set_Extended_Import_Export_External_Name
9280 (Internal_Ent
: Entity_Id
;
9281 Arg_External
: Node_Id
)
9283 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9287 if No
(Arg_External
) then
9291 Check_Arg_Is_External_Name
(Arg_External
);
9293 if Nkind
(Arg_External
) = N_String_Literal
then
9294 if String_Length
(Strval
(Arg_External
)) = 0 then
9297 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9300 elsif Nkind
(Arg_External
) = N_Identifier
then
9301 New_Name
:= Get_Default_External_Name
(Arg_External
);
9303 -- Check_Arg_Is_External_Name should let through only identifiers and
9304 -- string literals or static string expressions (which are folded to
9305 -- string literals).
9308 raise Program_Error
;
9311 -- If we already have an external name set (by a prior normal Import
9312 -- or Export pragma), then the external names must match
9314 if Present
(Interface_Name
(Internal_Ent
)) then
9316 -- Ignore mismatching names in CodePeer mode, to support some
9317 -- old compilers which would export the same procedure under
9318 -- different names, e.g:
9320 -- pragma Export_Procedure (P, "a");
9321 -- pragma Export_Procedure (P, "b");
9323 if CodePeer_Mode
then
9327 Check_Matching_Internal_Names
: declare
9328 S1
: constant String_Id
:= Strval
(Old_Name
);
9329 S2
: constant String_Id
:= Strval
(New_Name
);
9332 pragma No_Return
(Mismatch
);
9333 -- Called if names do not match
9339 procedure Mismatch
is
9341 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9343 ("external name does not match that given #",
9347 -- Start of processing for Check_Matching_Internal_Names
9350 if String_Length
(S1
) /= String_Length
(S2
) then
9354 for J
in 1 .. String_Length
(S1
) loop
9355 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9360 end Check_Matching_Internal_Names
;
9362 -- Otherwise set the given name
9365 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9366 Check_Duplicated_Export_Name
(New_Name
);
9368 end Set_Extended_Import_Export_External_Name
;
9374 procedure Set_Imported
(E
: Entity_Id
) is
9376 -- Error message if already imported or exported
9378 if Is_Exported
(E
) or else Is_Imported
(E
) then
9380 -- Error if being set Exported twice
9382 if Is_Exported
(E
) then
9383 Error_Msg_NE
("entity& was previously exported", N
, E
);
9385 -- Ignore error in CodePeer mode where we treat all imported
9386 -- subprograms as unknown.
9388 elsif CodePeer_Mode
then
9391 -- OK if Import/Interface case
9393 elsif Import_Interface_Present
(N
) then
9396 -- Error if being set Imported twice
9399 Error_Msg_NE
("entity& was previously imported", N
, E
);
9402 Error_Msg_Name_1
:= Pname
;
9404 ("\(pragma% applies to all previous entities)", N
);
9406 Error_Msg_Sloc
:= Sloc
(E
);
9407 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9409 -- Here if not previously imported or exported, OK to import
9412 Set_Is_Imported
(E
);
9414 -- For subprogram, set Import_Pragma field
9416 if Is_Subprogram
(E
) then
9417 Set_Import_Pragma
(E
, N
);
9420 -- If the entity is an object that is not at the library level,
9421 -- then it is statically allocated. We do not worry about objects
9422 -- with address clauses in this context since they are not really
9423 -- imported in the linker sense.
9426 and then not Is_Library_Level_Entity
(E
)
9427 and then No
(Address_Clause
(E
))
9429 Set_Is_Statically_Allocated
(E
);
9436 -------------------------
9437 -- Set_Mechanism_Value --
9438 -------------------------
9440 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9441 -- analyzed, since it is semantic nonsense), so we get it in the exact
9442 -- form created by the parser.
9444 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9445 procedure Bad_Mechanism
;
9446 pragma No_Return
(Bad_Mechanism
);
9447 -- Signal bad mechanism name
9449 -------------------------
9450 -- Bad_Mechanism_Value --
9451 -------------------------
9453 procedure Bad_Mechanism
is
9455 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9458 -- Start of processing for Set_Mechanism_Value
9461 if Mechanism
(Ent
) /= Default_Mechanism
then
9463 ("mechanism for & has already been set", Mech_Name
, Ent
);
9466 -- MECHANISM_NAME ::= value | reference
9468 if Nkind
(Mech_Name
) = N_Identifier
then
9469 if Chars
(Mech_Name
) = Name_Value
then
9470 Set_Mechanism
(Ent
, By_Copy
);
9473 elsif Chars
(Mech_Name
) = Name_Reference
then
9474 Set_Mechanism
(Ent
, By_Reference
);
9477 elsif Chars
(Mech_Name
) = Name_Copy
then
9479 ("bad mechanism name, Value assumed", Mech_Name
);
9488 end Set_Mechanism_Value
;
9490 --------------------------
9491 -- Set_Rational_Profile --
9492 --------------------------
9494 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9495 -- and extension to the semantics of renaming declarations.
9497 procedure Set_Rational_Profile
is
9499 Implicit_Packing
:= True;
9500 Overriding_Renamings
:= True;
9501 Use_VADS_Size
:= True;
9502 end Set_Rational_Profile
;
9504 ---------------------------
9505 -- Set_Ravenscar_Profile --
9506 ---------------------------
9508 -- The tasks to be done here are
9510 -- Set required policies
9512 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9513 -- pragma Locking_Policy (Ceiling_Locking)
9515 -- Set Detect_Blocking mode
9517 -- Set required restrictions (see System.Rident for detailed list)
9519 -- Set the No_Dependence rules
9520 -- No_Dependence => Ada.Asynchronous_Task_Control
9521 -- No_Dependence => Ada.Calendar
9522 -- No_Dependence => Ada.Execution_Time.Group_Budget
9523 -- No_Dependence => Ada.Execution_Time.Timers
9524 -- No_Dependence => Ada.Task_Attributes
9525 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9527 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9528 Prefix_Entity
: Entity_Id
;
9529 Selector_Entity
: Entity_Id
;
9530 Prefix_Node
: Node_Id
;
9534 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9536 if Task_Dispatching_Policy
/= ' '
9537 and then Task_Dispatching_Policy
/= 'F'
9539 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9540 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9542 -- Set the FIFO_Within_Priorities policy, but always preserve
9543 -- System_Location since we like the error message with the run time
9547 Task_Dispatching_Policy
:= 'F';
9549 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9550 Task_Dispatching_Policy_Sloc
:= Loc
;
9554 -- pragma Locking_Policy (Ceiling_Locking)
9556 if Locking_Policy
/= ' '
9557 and then Locking_Policy
/= 'C'
9559 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9560 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9562 -- Set the Ceiling_Locking policy, but preserve System_Location since
9563 -- we like the error message with the run time name.
9566 Locking_Policy
:= 'C';
9568 if Locking_Policy_Sloc
/= System_Location
then
9569 Locking_Policy_Sloc
:= Loc
;
9573 -- pragma Detect_Blocking
9575 Detect_Blocking
:= True;
9577 -- Set the corresponding restrictions
9579 Set_Profile_Restrictions
9580 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9582 -- Set the No_Dependence restrictions
9584 -- The following No_Dependence restrictions:
9585 -- No_Dependence => Ada.Asynchronous_Task_Control
9586 -- No_Dependence => Ada.Calendar
9587 -- No_Dependence => Ada.Task_Attributes
9588 -- are already set by previous call to Set_Profile_Restrictions.
9590 -- Set the following restrictions which were added to Ada 2005:
9591 -- No_Dependence => Ada.Execution_Time.Group_Budget
9592 -- No_Dependence => Ada.Execution_Time.Timers
9594 if Ada_Version
>= Ada_2005
then
9595 Name_Buffer
(1 .. 3) := "ada";
9598 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9600 Name_Buffer
(1 .. 14) := "execution_time";
9603 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9606 Make_Selected_Component
9608 Prefix
=> Prefix_Entity
,
9609 Selector_Name
=> Selector_Entity
);
9611 Name_Buffer
(1 .. 13) := "group_budgets";
9614 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9617 Make_Selected_Component
9619 Prefix
=> Prefix_Node
,
9620 Selector_Name
=> Selector_Entity
);
9622 Set_Restriction_No_Dependence
9624 Warn
=> Treat_Restrictions_As_Warnings
,
9625 Profile
=> Ravenscar
);
9627 Name_Buffer
(1 .. 6) := "timers";
9630 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9633 Make_Selected_Component
9635 Prefix
=> Prefix_Node
,
9636 Selector_Name
=> Selector_Entity
);
9638 Set_Restriction_No_Dependence
9640 Warn
=> Treat_Restrictions_As_Warnings
,
9641 Profile
=> Ravenscar
);
9644 -- Set the following restrictions which was added to Ada 2012 (see
9646 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9648 if Ada_Version
>= Ada_2012
then
9649 Name_Buffer
(1 .. 6) := "system";
9652 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9654 Name_Buffer
(1 .. 15) := "multiprocessors";
9657 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9660 Make_Selected_Component
9662 Prefix
=> Prefix_Entity
,
9663 Selector_Name
=> Selector_Entity
);
9665 Name_Buffer
(1 .. 19) := "dispatching_domains";
9668 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9671 Make_Selected_Component
9673 Prefix
=> Prefix_Node
,
9674 Selector_Name
=> Selector_Entity
);
9676 Set_Restriction_No_Dependence
9678 Warn
=> Treat_Restrictions_As_Warnings
,
9679 Profile
=> Ravenscar
);
9681 end Set_Ravenscar_Profile
;
9683 -- Start of processing for Analyze_Pragma
9686 -- The following code is a defense against recursion. Not clear that
9687 -- this can happen legitimately, but perhaps some error situations
9688 -- can cause it, and we did see this recursion during testing.
9690 if Analyzed
(N
) then
9693 Set_Analyzed
(N
, True);
9696 -- Deal with unrecognized pragma
9698 Pname
:= Pragma_Name
(N
);
9700 if not Is_Pragma_Name
(Pname
) then
9701 if Warn_On_Unrecognized_Pragma
then
9702 Error_Msg_Name_1
:= Pname
;
9703 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9705 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9706 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9707 Error_Msg_Name_1
:= PN
;
9708 Error_Msg_N
-- CODEFIX
9709 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9718 -- Here to start processing for recognized pragma
9720 Prag_Id
:= Get_Pragma_Id
(Pname
);
9721 Pname
:= Original_Aspect_Name
(N
);
9723 -- Capture setting of Opt.Uneval_Old
9725 case Opt
.Uneval_Old
is
9727 Set_Uneval_Old_Accept
(N
);
9731 Set_Uneval_Old_Warn
(N
);
9733 raise Program_Error
;
9736 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9737 -- is already set, indicating that we have already checked the policy
9738 -- at the right point. This happens for example in the case of a pragma
9739 -- that is derived from an Aspect.
9741 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9744 -- For a pragma that is a rewriting of another pragma, copy the
9745 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9747 elsif Is_Rewrite_Substitution
(N
)
9748 and then Nkind
(Original_Node
(N
)) = N_Pragma
9749 and then Original_Node
(N
) /= N
9751 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9752 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9754 -- Otherwise query the applicable policy at this point
9757 Check_Applicable_Policy
(N
);
9759 -- If pragma is disabled, rewrite as NULL and skip analysis
9761 if Is_Disabled
(N
) then
9762 Rewrite
(N
, Make_Null_Statement
(Loc
));
9776 if Present
(Pragma_Argument_Associations
(N
)) then
9777 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9778 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9780 if Present
(Arg1
) then
9781 Arg2
:= Next
(Arg1
);
9783 if Present
(Arg2
) then
9784 Arg3
:= Next
(Arg2
);
9786 if Present
(Arg3
) then
9787 Arg4
:= Next
(Arg3
);
9793 Check_Restriction_No_Use_Of_Pragma
(N
);
9795 -- An enumeration type defines the pragmas that are supported by the
9796 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9797 -- into the corresponding enumeration value for the following case.
9805 -- pragma Abort_Defer;
9807 when Pragma_Abort_Defer
=>
9809 Check_Arg_Count
(0);
9811 -- The only required semantic processing is to check the
9812 -- placement. This pragma must appear at the start of the
9813 -- statement sequence of a handled sequence of statements.
9815 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9816 or else N
/= First
(Statements
(Parent
(N
)))
9821 --------------------
9822 -- Abstract_State --
9823 --------------------
9825 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9827 -- ABSTRACT_STATE_LIST ::=
9829 -- | STATE_NAME_WITH_OPTIONS
9830 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9832 -- STATE_NAME_WITH_OPTIONS ::=
9834 -- | (STATE_NAME with OPTION_LIST)
9836 -- OPTION_LIST ::= OPTION {, OPTION}
9840 -- | NAME_VALUE_OPTION
9842 -- SIMPLE_OPTION ::= Ghost
9844 -- NAME_VALUE_OPTION ::=
9845 -- Part_Of => ABSTRACT_STATE
9846 -- | External [=> EXTERNAL_PROPERTY_LIST]
9848 -- EXTERNAL_PROPERTY_LIST ::=
9849 -- EXTERNAL_PROPERTY
9850 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9852 -- EXTERNAL_PROPERTY ::=
9853 -- Async_Readers [=> boolean_EXPRESSION]
9854 -- | Async_Writers [=> boolean_EXPRESSION]
9855 -- | Effective_Reads [=> boolean_EXPRESSION]
9856 -- | Effective_Writes [=> boolean_EXPRESSION]
9857 -- others => boolean_EXPRESSION
9859 -- STATE_NAME ::= defining_identifier
9861 -- ABSTRACT_STATE ::= name
9863 when Pragma_Abstract_State
=> Abstract_State
: declare
9864 Missing_Parentheses
: Boolean := False;
9865 -- Flag set when a state declaration with options is not properly
9868 -- Flags used to verify the consistency of states
9870 Non_Null_Seen
: Boolean := False;
9871 Null_Seen
: Boolean := False;
9873 procedure Analyze_Abstract_State
9875 Pack_Id
: Entity_Id
);
9876 -- Verify the legality of a single state declaration. Create and
9877 -- decorate a state abstraction entity and introduce it into the
9878 -- visibility chain. Pack_Id denotes the entity or the related
9879 -- package where pragma Abstract_State appears.
9881 ----------------------------
9882 -- Analyze_Abstract_State --
9883 ----------------------------
9885 procedure Analyze_Abstract_State
9887 Pack_Id
: Entity_Id
)
9889 -- Flags used to verify the consistency of options
9891 AR_Seen
: Boolean := False;
9892 AW_Seen
: Boolean := False;
9893 ER_Seen
: Boolean := False;
9894 EW_Seen
: Boolean := False;
9895 External_Seen
: Boolean := False;
9896 Others_Seen
: Boolean := False;
9897 Part_Of_Seen
: Boolean := False;
9899 -- Flags used to store the static value of all external states'
9902 AR_Val
: Boolean := False;
9903 AW_Val
: Boolean := False;
9904 ER_Val
: Boolean := False;
9905 EW_Val
: Boolean := False;
9907 State_Id
: Entity_Id
:= Empty
;
9908 -- The entity to be generated for the current state declaration
9910 procedure Analyze_External_Option
(Opt
: Node_Id
);
9911 -- Verify the legality of option External
9913 procedure Analyze_External_Property
9915 Expr
: Node_Id
:= Empty
);
9916 -- Verify the legailty of a single external property. Prop
9917 -- denotes the external property. Expr is the expression used
9918 -- to set the property.
9920 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9921 -- Verify the legality of option Part_Of
9923 procedure Check_Duplicate_Option
9925 Status
: in out Boolean);
9926 -- Flag Status denotes whether a particular option has been
9927 -- seen while processing a state. This routine verifies that
9928 -- Opt is not a duplicate option and sets the flag Status
9929 -- (SPARK RM 7.1.4(1)).
9931 procedure Check_Duplicate_Property
9933 Status
: in out Boolean);
9934 -- Flag Status denotes whether a particular property has been
9935 -- seen while processing option External. This routine verifies
9936 -- that Prop is not a duplicate property and sets flag Status.
9937 -- Opt is not a duplicate property and sets the flag Status.
9938 -- (SPARK RM 7.1.4(2))
9940 procedure Create_Abstract_State
9945 -- Generate an abstract state entity with name Nam and enter it
9946 -- into visibility. Decl is the "declaration" of the state as
9947 -- it appears in pragma Abstract_State. Loc is the location of
9948 -- the related state "declaration". Flag Is_Null should be set
9949 -- when the associated Abstract_State pragma defines a null
9952 -----------------------------
9953 -- Analyze_External_Option --
9954 -----------------------------
9956 procedure Analyze_External_Option
(Opt
: Node_Id
) is
9957 Errors
: constant Nat
:= Serious_Errors_Detected
;
9959 Props
: Node_Id
:= Empty
;
9962 Check_Duplicate_Option
(Opt
, External_Seen
);
9964 if Nkind
(Opt
) = N_Component_Association
then
9965 Props
:= Expression
(Opt
);
9968 -- External state with properties
9970 if Present
(Props
) then
9972 -- Multiple properties appear as an aggregate
9974 if Nkind
(Props
) = N_Aggregate
then
9976 -- Simple property form
9978 Prop
:= First
(Expressions
(Props
));
9979 while Present
(Prop
) loop
9980 Analyze_External_Property
(Prop
);
9984 -- Property with expression form
9986 Prop
:= First
(Component_Associations
(Props
));
9987 while Present
(Prop
) loop
9988 Analyze_External_Property
9989 (Prop
=> First
(Choices
(Prop
)),
9990 Expr
=> Expression
(Prop
));
9998 Analyze_External_Property
(Props
);
10001 -- An external state defined without any properties defaults
10002 -- all properties to True.
10011 -- Once all external properties have been processed, verify
10012 -- their mutual interaction. Do not perform the check when
10013 -- at least one of the properties is illegal as this will
10014 -- produce a bogus error.
10016 if Errors
= Serious_Errors_Detected
then
10017 Check_External_Properties
10018 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10020 end Analyze_External_Option
;
10022 -------------------------------
10023 -- Analyze_External_Property --
10024 -------------------------------
10026 procedure Analyze_External_Property
10028 Expr
: Node_Id
:= Empty
)
10030 Expr_Val
: Boolean;
10033 -- Check the placement of "others" (if available)
10035 if Nkind
(Prop
) = N_Others_Choice
then
10036 if Others_Seen
then
10038 ("only one others choice allowed in option External",
10041 Others_Seen
:= True;
10044 elsif Others_Seen
then
10046 ("others must be the last property in option External",
10049 -- The only remaining legal options are the four predefined
10050 -- external properties.
10052 elsif Nkind
(Prop
) = N_Identifier
10053 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10054 Name_Async_Writers
,
10055 Name_Effective_Reads
,
10056 Name_Effective_Writes
)
10060 -- Otherwise the construct is not a valid property
10063 SPARK_Msg_N
("invalid external state property", Prop
);
10067 -- Ensure that the expression of the external state property
10068 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10070 if Present
(Expr
) then
10071 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10073 if Is_OK_Static_Expression
(Expr
) then
10074 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10077 ("expression of external state property must be "
10081 -- The lack of expression defaults the property to True
10087 -- Named properties
10089 if Nkind
(Prop
) = N_Identifier
then
10090 if Chars
(Prop
) = Name_Async_Readers
then
10091 Check_Duplicate_Property
(Prop
, AR_Seen
);
10092 AR_Val
:= Expr_Val
;
10094 elsif Chars
(Prop
) = Name_Async_Writers
then
10095 Check_Duplicate_Property
(Prop
, AW_Seen
);
10096 AW_Val
:= Expr_Val
;
10098 elsif Chars
(Prop
) = Name_Effective_Reads
then
10099 Check_Duplicate_Property
(Prop
, ER_Seen
);
10100 ER_Val
:= Expr_Val
;
10103 Check_Duplicate_Property
(Prop
, EW_Seen
);
10104 EW_Val
:= Expr_Val
;
10107 -- The handling of property "others" must take into account
10108 -- all other named properties that have been encountered so
10109 -- far. Only those that have not been seen are affected by
10113 if not AR_Seen
then
10114 AR_Val
:= Expr_Val
;
10117 if not AW_Seen
then
10118 AW_Val
:= Expr_Val
;
10121 if not ER_Seen
then
10122 ER_Val
:= Expr_Val
;
10125 if not EW_Seen
then
10126 EW_Val
:= Expr_Val
;
10129 end Analyze_External_Property
;
10131 ----------------------------
10132 -- Analyze_Part_Of_Option --
10133 ----------------------------
10135 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10136 Encaps
: constant Node_Id
:= Expression
(Opt
);
10137 Encaps_Id
: Entity_Id
;
10141 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10144 (Item_Id
=> State_Id
,
10146 Indic
=> First
(Choices
(Opt
)),
10149 -- The Part_Of indicator turns an abstract state into a
10150 -- constituent of the encapsulating state.
10153 Encaps_Id
:= Entity
(Encaps
);
10155 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10156 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10158 end Analyze_Part_Of_Option
;
10160 ----------------------------
10161 -- Check_Duplicate_Option --
10162 ----------------------------
10164 procedure Check_Duplicate_Option
10166 Status
: in out Boolean)
10170 SPARK_Msg_N
("duplicate state option", Opt
);
10174 end Check_Duplicate_Option
;
10176 ------------------------------
10177 -- Check_Duplicate_Property --
10178 ------------------------------
10180 procedure Check_Duplicate_Property
10182 Status
: in out Boolean)
10186 SPARK_Msg_N
("duplicate external property", Prop
);
10190 end Check_Duplicate_Property
;
10192 ---------------------------
10193 -- Create_Abstract_State --
10194 ---------------------------
10196 procedure Create_Abstract_State
10203 -- The abstract state may be semi-declared when the related
10204 -- package was withed through a limited with clause. In that
10205 -- case reuse the entity to fully declare the state.
10207 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10208 State_Id
:= Entity
(Decl
);
10210 -- Otherwise the elaboration of pragma Abstract_State
10211 -- declares the state.
10214 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10216 if Present
(Decl
) then
10217 Set_Entity
(Decl
, State_Id
);
10221 -- Null states never come from source
10223 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10224 Set_Parent
(State_Id
, State
);
10225 Set_Ekind
(State_Id
, E_Abstract_State
);
10226 Set_Etype
(State_Id
, Standard_Void_Type
);
10227 Set_Encapsulating_State
(State_Id
, Empty
);
10228 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10229 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10231 -- An abstract state declared within a Ghost region becomes
10232 -- Ghost (SPARK RM 6.9(2)).
10234 if Ghost_Mode
> None
then
10235 Set_Is_Ghost_Entity
(State_Id
);
10238 -- Establish a link between the state declaration and the
10239 -- abstract state entity. Note that a null state remains as
10240 -- N_Null and does not carry any linkages.
10242 if not Is_Null
then
10243 if Present
(Decl
) then
10244 Set_Entity
(Decl
, State_Id
);
10245 Set_Etype
(Decl
, Standard_Void_Type
);
10248 -- Every non-null state must be defined, nameable and
10251 Push_Scope
(Pack_Id
);
10252 Generate_Definition
(State_Id
);
10253 Enter_Name
(State_Id
);
10256 end Create_Abstract_State
;
10263 -- Start of processing for Analyze_Abstract_State
10266 -- A package with a null abstract state is not allowed to
10267 -- declare additional states.
10271 ("package & has null abstract state", State
, Pack_Id
);
10273 -- Null states appear as internally generated entities
10275 elsif Nkind
(State
) = N_Null
then
10276 Create_Abstract_State
10277 (Nam
=> New_Internal_Name
('S'),
10279 Loc
=> Sloc
(State
),
10283 -- Catch a case where a null state appears in a list of
10284 -- non-null states.
10286 if Non_Null_Seen
then
10288 ("package & has non-null abstract state",
10292 -- Simple state declaration
10294 elsif Nkind
(State
) = N_Identifier
then
10295 Create_Abstract_State
10296 (Nam
=> Chars
(State
),
10298 Loc
=> Sloc
(State
),
10300 Non_Null_Seen
:= True;
10302 -- State declaration with various options. This construct
10303 -- appears as an extension aggregate in the tree.
10305 elsif Nkind
(State
) = N_Extension_Aggregate
then
10306 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10307 Create_Abstract_State
10308 (Nam
=> Chars
(Ancestor_Part
(State
)),
10309 Decl
=> Ancestor_Part
(State
),
10310 Loc
=> Sloc
(Ancestor_Part
(State
)),
10312 Non_Null_Seen
:= True;
10315 ("state name must be an identifier",
10316 Ancestor_Part
(State
));
10319 -- Options External and Ghost appear as expressions
10321 Opt
:= First
(Expressions
(State
));
10322 while Present
(Opt
) loop
10323 if Nkind
(Opt
) = N_Identifier
then
10324 if Chars
(Opt
) = Name_External
then
10325 Analyze_External_Option
(Opt
);
10327 elsif Chars
(Opt
) = Name_Ghost
then
10328 if Present
(State_Id
) then
10329 Set_Is_Ghost_Entity
(State_Id
);
10332 -- Option Part_Of without an encapsulating state is
10333 -- illegal. (SPARK RM 7.1.4(9)).
10335 elsif Chars
(Opt
) = Name_Part_Of
then
10337 ("indicator Part_Of must denote an abstract "
10340 -- Do not emit an error message when a previous state
10341 -- declaration with options was not parenthesized as
10342 -- the option is actually another state declaration.
10344 -- with Abstract_State
10345 -- (State_1 with ..., -- missing parentheses
10346 -- (State_2 with ...),
10347 -- State_3) -- ok state declaration
10349 elsif Missing_Parentheses
then
10352 -- Otherwise the option is not allowed. Note that it
10353 -- is not possible to distinguish between an option
10354 -- and a state declaration when a previous state with
10355 -- options not properly parentheses.
10357 -- with Abstract_State
10358 -- (State_1 with ..., -- missing parentheses
10359 -- State_2); -- could be an option
10363 ("simple option not allowed in state declaration",
10367 -- Catch a case where missing parentheses around a state
10368 -- declaration with options cause a subsequent state
10369 -- declaration with options to be treated as an option.
10371 -- with Abstract_State
10372 -- (State_1 with ..., -- missing parentheses
10373 -- (State_2 with ...))
10375 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10376 Missing_Parentheses
:= True;
10378 ("state declaration must be parenthesized",
10379 Ancestor_Part
(State
));
10381 -- Otherwise the option is malformed
10384 SPARK_Msg_N
("malformed option", Opt
);
10390 -- Options External and Part_Of appear as component
10393 Opt
:= First
(Component_Associations
(State
));
10394 while Present
(Opt
) loop
10395 Opt_Nam
:= First
(Choices
(Opt
));
10397 if Nkind
(Opt_Nam
) = N_Identifier
then
10398 if Chars
(Opt_Nam
) = Name_External
then
10399 Analyze_External_Option
(Opt
);
10401 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10402 Analyze_Part_Of_Option
(Opt
);
10405 SPARK_Msg_N
("invalid state option", Opt
);
10408 SPARK_Msg_N
("invalid state option", Opt
);
10414 -- Any other attempt to declare a state is illegal. This is a
10415 -- syntax error, always report.
10418 Error_Msg_N
("malformed abstract state declaration", State
);
10422 -- Guard against a junk state. In such cases no entity is
10423 -- generated and the subsequent checks cannot be applied.
10425 if Present
(State_Id
) then
10427 -- Verify whether the state does not introduce an illegal
10428 -- hidden state within a package subject to a null abstract
10431 Check_No_Hidden_State
(State_Id
);
10433 -- Check whether the lack of option Part_Of agrees with the
10434 -- placement of the abstract state with respect to the state
10437 if not Part_Of_Seen
then
10438 Check_Missing_Part_Of
(State_Id
);
10441 -- Associate the state with its related package
10443 if No
(Abstract_States
(Pack_Id
)) then
10444 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10447 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10449 end Analyze_Abstract_State
;
10453 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10454 Pack_Id
: Entity_Id
;
10457 -- Start of processing for Abstract_State
10461 Check_No_Identifiers
;
10462 Check_Arg_Count
(1);
10463 Ensure_Aggregate_Form
(Arg1
);
10465 -- Ensure the proper placement of the pragma. Abstract states must
10466 -- be associated with a package declaration.
10468 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10469 N_Package_Declaration
)
10475 State
:= Expression
(Arg1
);
10476 Pack_Id
:= Defining_Entity
(Context
);
10478 -- Mark the associated package as Ghost if it is subject to aspect
10479 -- or pragma Ghost as this affects the declaration of an abstract
10482 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10483 Set_Is_Ghost_Entity
(Pack_Id
);
10486 -- Multiple non-null abstract states appear as an aggregate
10488 if Nkind
(State
) = N_Aggregate
then
10489 State
:= First
(Expressions
(State
));
10490 while Present
(State
) loop
10491 Analyze_Abstract_State
(State
, Pack_Id
);
10495 -- Various forms of a single abstract state. Note that these may
10496 -- include malformed state declarations.
10499 Analyze_Abstract_State
(State
, Pack_Id
);
10502 -- Save the pragma for retrieval by other tools
10504 Add_Contract_Item
(N
, Pack_Id
);
10506 -- Verify the declaration order of pragmas Abstract_State and
10509 Check_Declaration_Order
10511 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10512 end Abstract_State
;
10520 -- Note: this pragma also has some specific processing in Par.Prag
10521 -- because we want to set the Ada version mode during parsing.
10523 when Pragma_Ada_83
=>
10525 Check_Arg_Count
(0);
10527 -- We really should check unconditionally for proper configuration
10528 -- pragma placement, since we really don't want mixed Ada modes
10529 -- within a single unit, and the GNAT reference manual has always
10530 -- said this was a configuration pragma, but we did not check and
10531 -- are hesitant to add the check now.
10533 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10534 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10535 -- or Ada 2012 mode.
10537 if Ada_Version
>= Ada_2005
then
10538 Check_Valid_Configuration_Pragma
;
10541 -- Now set Ada 83 mode
10543 Ada_Version
:= Ada_83
;
10544 Ada_Version_Explicit
:= Ada_83
;
10545 Ada_Version_Pragma
:= N
;
10553 -- Note: this pragma also has some specific processing in Par.Prag
10554 -- because we want to set the Ada 83 version mode during parsing.
10556 when Pragma_Ada_95
=>
10558 Check_Arg_Count
(0);
10560 -- We really should check unconditionally for proper configuration
10561 -- pragma placement, since we really don't want mixed Ada modes
10562 -- within a single unit, and the GNAT reference manual has always
10563 -- said this was a configuration pragma, but we did not check and
10564 -- are hesitant to add the check now.
10566 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10567 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10569 if Ada_Version
>= Ada_2005
then
10570 Check_Valid_Configuration_Pragma
;
10573 -- Now set Ada 95 mode
10575 Ada_Version
:= Ada_95
;
10576 Ada_Version_Explicit
:= Ada_95
;
10577 Ada_Version_Pragma
:= N
;
10579 ---------------------
10580 -- Ada_05/Ada_2005 --
10581 ---------------------
10584 -- pragma Ada_05 (LOCAL_NAME);
10586 -- pragma Ada_2005;
10587 -- pragma Ada_2005 (LOCAL_NAME):
10589 -- Note: these pragmas also have some specific processing in Par.Prag
10590 -- because we want to set the Ada 2005 version mode during parsing.
10592 -- The one argument form is used for managing the transition from
10593 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10594 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10595 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10596 -- mode, a preference rule is established which does not choose
10597 -- such an entity unless it is unambiguously specified. This avoids
10598 -- extra subprograms marked this way from generating ambiguities in
10599 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10600 -- intended for exclusive use in the GNAT run-time library.
10602 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10608 if Arg_Count
= 1 then
10609 Check_Arg_Is_Local_Name
(Arg1
);
10610 E_Id
:= Get_Pragma_Arg
(Arg1
);
10612 if Etype
(E_Id
) = Any_Type
then
10616 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10617 Record_Rep_Item
(Entity
(E_Id
), N
);
10620 Check_Arg_Count
(0);
10622 -- For Ada_2005 we unconditionally enforce the documented
10623 -- configuration pragma placement, since we do not want to
10624 -- tolerate mixed modes in a unit involving Ada 2005. That
10625 -- would cause real difficulties for those cases where there
10626 -- are incompatibilities between Ada 95 and Ada 2005.
10628 Check_Valid_Configuration_Pragma
;
10630 -- Now set appropriate Ada mode
10632 Ada_Version
:= Ada_2005
;
10633 Ada_Version_Explicit
:= Ada_2005
;
10634 Ada_Version_Pragma
:= N
;
10638 ---------------------
10639 -- Ada_12/Ada_2012 --
10640 ---------------------
10643 -- pragma Ada_12 (LOCAL_NAME);
10645 -- pragma Ada_2012;
10646 -- pragma Ada_2012 (LOCAL_NAME):
10648 -- Note: these pragmas also have some specific processing in Par.Prag
10649 -- because we want to set the Ada 2012 version mode during parsing.
10651 -- The one argument form is used for managing the transition from Ada
10652 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10653 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10654 -- mode will generate a warning. In addition, in any pre-Ada_2012
10655 -- mode, a preference rule is established which does not choose
10656 -- such an entity unless it is unambiguously specified. This avoids
10657 -- extra subprograms marked this way from generating ambiguities in
10658 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10659 -- intended for exclusive use in the GNAT run-time library.
10661 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10667 if Arg_Count
= 1 then
10668 Check_Arg_Is_Local_Name
(Arg1
);
10669 E_Id
:= Get_Pragma_Arg
(Arg1
);
10671 if Etype
(E_Id
) = Any_Type
then
10675 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10676 Record_Rep_Item
(Entity
(E_Id
), N
);
10679 Check_Arg_Count
(0);
10681 -- For Ada_2012 we unconditionally enforce the documented
10682 -- configuration pragma placement, since we do not want to
10683 -- tolerate mixed modes in a unit involving Ada 2012. That
10684 -- would cause real difficulties for those cases where there
10685 -- are incompatibilities between Ada 95 and Ada 2012. We could
10686 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10688 Check_Valid_Configuration_Pragma
;
10690 -- Now set appropriate Ada mode
10692 Ada_Version
:= Ada_2012
;
10693 Ada_Version_Explicit
:= Ada_2012
;
10694 Ada_Version_Pragma
:= N
;
10698 ----------------------
10699 -- All_Calls_Remote --
10700 ----------------------
10702 -- pragma All_Calls_Remote [(library_package_NAME)];
10704 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10705 Lib_Entity
: Entity_Id
;
10708 Check_Ada_83_Warning
;
10709 Check_Valid_Library_Unit_Pragma
;
10711 if Nkind
(N
) = N_Null_Statement
then
10715 Lib_Entity
:= Find_Lib_Unit_Name
;
10717 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10719 if Present
(Lib_Entity
)
10720 and then not Debug_Flag_U
10722 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10723 Error_Pragma
("pragma% only apply to rci unit");
10725 -- Set flag for entity of the library unit
10728 Set_Has_All_Calls_Remote
(Lib_Entity
);
10732 end All_Calls_Remote
;
10734 ---------------------------
10735 -- Allow_Integer_Address --
10736 ---------------------------
10738 -- pragma Allow_Integer_Address;
10740 when Pragma_Allow_Integer_Address
=>
10742 Check_Valid_Configuration_Pragma
;
10743 Check_Arg_Count
(0);
10745 -- If Address is a private type, then set the flag to allow
10746 -- integer address values. If Address is not private, then this
10747 -- pragma has no purpose, so it is simply ignored. Not clear if
10748 -- there are any such targets now.
10750 if Opt
.Address_Is_Private
then
10751 Opt
.Allow_Integer_Address
:= True;
10759 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10760 -- ARG ::= NAME | EXPRESSION
10762 -- The first two arguments are by convention intended to refer to an
10763 -- external tool and a tool-specific function. These arguments are
10766 when Pragma_Annotate
=> Annotate
: declare
10772 Check_At_Least_N_Arguments
(1);
10774 -- See if last argument is Entity => local_Name, and if so process
10775 -- and then remove it for remaining processing.
10778 Last_Arg
: constant Node_Id
:=
10779 Last
(Pragma_Argument_Associations
(N
));
10782 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10783 and then Chars
(Last_Arg
) = Name_Entity
10785 Check_Arg_Is_Local_Name
(Last_Arg
);
10786 Arg_Count
:= Arg_Count
- 1;
10788 -- Not allowed in compiler units (bootstrap issues)
10790 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10794 -- Continue processing with last argument removed for now
10796 Check_Arg_Is_Identifier
(Arg1
);
10797 Check_No_Identifiers
;
10800 -- Second parameter is optional, it is never analyzed
10805 -- Here if we have a second parameter
10808 -- Second parameter must be identifier
10810 Check_Arg_Is_Identifier
(Arg2
);
10812 -- Process remaining parameters if any
10814 Arg
:= Next
(Arg2
);
10815 while Present
(Arg
) loop
10816 Exp
:= Get_Pragma_Arg
(Arg
);
10819 if Is_Entity_Name
(Exp
) then
10822 -- For string literals, we assume Standard_String as the
10823 -- type, unless the string contains wide or wide_wide
10826 elsif Nkind
(Exp
) = N_String_Literal
then
10827 if Has_Wide_Wide_Character
(Exp
) then
10828 Resolve
(Exp
, Standard_Wide_Wide_String
);
10829 elsif Has_Wide_Character
(Exp
) then
10830 Resolve
(Exp
, Standard_Wide_String
);
10832 Resolve
(Exp
, Standard_String
);
10835 elsif Is_Overloaded
(Exp
) then
10837 ("ambiguous argument for pragma%", Exp
);
10848 -------------------------------------------------
10849 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10850 -------------------------------------------------
10853 -- ( [Check => ] Boolean_EXPRESSION
10854 -- [, [Message =>] Static_String_EXPRESSION]);
10856 -- pragma Assert_And_Cut
10857 -- ( [Check => ] Boolean_EXPRESSION
10858 -- [, [Message =>] Static_String_EXPRESSION]);
10861 -- ( [Check => ] Boolean_EXPRESSION
10862 -- [, [Message =>] Static_String_EXPRESSION]);
10864 -- pragma Loop_Invariant
10865 -- ( [Check => ] Boolean_EXPRESSION
10866 -- [, [Message =>] Static_String_EXPRESSION]);
10868 when Pragma_Assert |
10869 Pragma_Assert_And_Cut |
10871 Pragma_Loop_Invariant
=>
10873 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10874 -- Determine whether expression Expr contains a Loop_Entry
10875 -- attribute reference.
10877 -------------------------
10878 -- Contains_Loop_Entry --
10879 -------------------------
10881 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10882 Has_Loop_Entry
: Boolean := False;
10884 function Process
(N
: Node_Id
) return Traverse_Result
;
10885 -- Process function for traversal to look for Loop_Entry
10891 function Process
(N
: Node_Id
) return Traverse_Result
is
10893 if Nkind
(N
) = N_Attribute_Reference
10894 and then Attribute_Name
(N
) = Name_Loop_Entry
10896 Has_Loop_Entry
:= True;
10903 procedure Traverse
is new Traverse_Proc
(Process
);
10905 -- Start of processing for Contains_Loop_Entry
10909 return Has_Loop_Entry
;
10910 end Contains_Loop_Entry
;
10917 -- Start of processing for Assert
10920 -- Assert is an Ada 2005 RM-defined pragma
10922 if Prag_Id
= Pragma_Assert
then
10925 -- The remaining ones are GNAT pragmas
10931 Check_At_Least_N_Arguments
(1);
10932 Check_At_Most_N_Arguments
(2);
10933 Check_Arg_Order
((Name_Check
, Name_Message
));
10934 Check_Optional_Identifier
(Arg1
, Name_Check
);
10935 Expr
:= Get_Pragma_Arg
(Arg1
);
10937 -- Special processing for Loop_Invariant, Loop_Variant or for
10938 -- other cases where a Loop_Entry attribute is present. If the
10939 -- assertion pragma contains attribute Loop_Entry, ensure that
10940 -- the related pragma is within a loop.
10942 if Prag_Id
= Pragma_Loop_Invariant
10943 or else Prag_Id
= Pragma_Loop_Variant
10944 or else Contains_Loop_Entry
(Expr
)
10946 Check_Loop_Pragma_Placement
;
10948 -- Perform preanalysis to deal with embedded Loop_Entry
10951 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10954 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10955 -- a corresponding Check pragma:
10957 -- pragma Check (name, condition [, msg]);
10959 -- Where name is the identifier matching the pragma name. So
10960 -- rewrite pragma in this manner, transfer the message argument
10961 -- if present, and analyze the result
10963 -- Note: When dealing with a semantically analyzed tree, the
10964 -- information that a Check node N corresponds to a source Assert,
10965 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10966 -- pragma kind of Original_Node(N).
10969 Make_Pragma_Argument_Association
(Loc
,
10970 Expression
=> Make_Identifier
(Loc
, Pname
)),
10971 Make_Pragma_Argument_Association
(Sloc
(Expr
),
10972 Expression
=> Expr
));
10974 if Arg_Count
> 1 then
10975 Check_Optional_Identifier
(Arg2
, Name_Message
);
10977 -- Provide semantic annnotations for optional argument, for
10978 -- ASIS use, before rewriting.
10980 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
10981 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
10984 -- Rewrite as Check pragma
10988 Chars
=> Name_Check
,
10989 Pragma_Argument_Associations
=> Newa
));
10993 ----------------------
10994 -- Assertion_Policy --
10995 ----------------------
10997 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10999 -- The following form is Ada 2012 only, but we allow it in all modes
11001 -- Pragma Assertion_Policy (
11002 -- ASSERTION_KIND => POLICY_IDENTIFIER
11003 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11005 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11007 -- RM_ASSERTION_KIND ::= Assert |
11008 -- Static_Predicate |
11009 -- Dynamic_Predicate |
11014 -- Type_Invariant |
11015 -- Type_Invariant'Class
11017 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11019 -- Contract_Cases |
11021 -- Default_Initial_Condition |
11023 -- Initial_Condition |
11024 -- Loop_Invariant |
11030 -- Statement_Assertions
11032 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11033 -- ID_ASSERTION_KIND list contains implementation-defined additions
11034 -- recognized by GNAT. The effect is to control the behavior of
11035 -- identically named aspects and pragmas, depending on the specified
11036 -- policy identifier:
11038 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11040 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11041 -- implementation defined addition that results in totally ignoring
11042 -- the corresponding assertion. If Disable is specified, then the
11043 -- argument of the assertion is not even analyzed. This is useful
11044 -- when the aspect/pragma argument references entities in a with'ed
11045 -- package that is replaced by a dummy package in the final build.
11047 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11048 -- and Type_Invariant'Class were recognized by the parser and
11049 -- transformed into references to the special internal identifiers
11050 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11051 -- processing is required here.
11053 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11062 -- This can always appear as a configuration pragma
11064 if Is_Configuration_Pragma
then
11067 -- It can also appear in a declarative part or package spec in Ada
11068 -- 2012 mode. We allow this in other modes, but in that case we
11069 -- consider that we have an Ada 2012 pragma on our hands.
11072 Check_Is_In_Decl_Part_Or_Package_Spec
;
11076 -- One argument case with no identifier (first form above)
11079 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11080 or else Chars
(Arg1
) = No_Name
)
11082 Check_Arg_Is_One_Of
11083 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11085 -- Treat one argument Assertion_Policy as equivalent to:
11087 -- pragma Check_Policy (Assertion, policy)
11089 -- So rewrite pragma in that manner and link on to the chain
11090 -- of Check_Policy pragmas, marking the pragma as analyzed.
11092 Policy
:= Get_Pragma_Arg
(Arg1
);
11096 Chars
=> Name_Check_Policy
,
11097 Pragma_Argument_Associations
=> New_List
(
11098 Make_Pragma_Argument_Association
(Loc
,
11099 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11101 Make_Pragma_Argument_Association
(Loc
,
11103 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11106 -- Here if we have two or more arguments
11109 Check_At_Least_N_Arguments
(1);
11112 -- Loop through arguments
11115 while Present
(Arg
) loop
11116 LocP
:= Sloc
(Arg
);
11118 -- Kind must be specified
11120 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11121 or else Chars
(Arg
) = No_Name
11124 ("missing assertion kind for pragma%", Arg
);
11127 -- Check Kind and Policy have allowed forms
11129 Kind
:= Chars
(Arg
);
11131 if not Is_Valid_Assertion_Kind
(Kind
) then
11133 ("invalid assertion kind for pragma%", Arg
);
11136 Check_Arg_Is_One_Of
11137 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11139 -- Rewrite the Assertion_Policy pragma as a series of
11140 -- Check_Policy pragmas of the form:
11142 -- Check_Policy (Kind, Policy);
11144 -- Note: the insertion of the pragmas cannot be done with
11145 -- Insert_Action because in the configuration case, there
11146 -- are no scopes on the scope stack and the mechanism will
11149 Insert_Before_And_Analyze
(N
,
11151 Chars
=> Name_Check_Policy
,
11152 Pragma_Argument_Associations
=> New_List
(
11153 Make_Pragma_Argument_Association
(LocP
,
11154 Expression
=> Make_Identifier
(LocP
, Kind
)),
11155 Make_Pragma_Argument_Association
(LocP
,
11156 Expression
=> Get_Pragma_Arg
(Arg
)))));
11161 -- Rewrite the Assertion_Policy pragma as null since we have
11162 -- now inserted all the equivalent Check pragmas.
11164 Rewrite
(N
, Make_Null_Statement
(Loc
));
11167 end Assertion_Policy
;
11169 ------------------------------
11170 -- Assume_No_Invalid_Values --
11171 ------------------------------
11173 -- pragma Assume_No_Invalid_Values (On | Off);
11175 when Pragma_Assume_No_Invalid_Values
=>
11177 Check_Valid_Configuration_Pragma
;
11178 Check_Arg_Count
(1);
11179 Check_No_Identifiers
;
11180 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11182 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11183 Assume_No_Invalid_Values
:= True;
11185 Assume_No_Invalid_Values
:= False;
11188 --------------------------
11189 -- Attribute_Definition --
11190 --------------------------
11192 -- pragma Attribute_Definition
11193 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11194 -- [Entity =>] LOCAL_NAME,
11195 -- [Expression =>] EXPRESSION | NAME);
11197 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11198 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11203 Check_Arg_Count
(3);
11204 Check_Optional_Identifier
(Arg1
, "attribute");
11205 Check_Optional_Identifier
(Arg2
, "entity");
11206 Check_Optional_Identifier
(Arg3
, "expression");
11208 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11209 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11213 Check_Arg_Is_Local_Name
(Arg2
);
11215 -- If the attribute is not recognized, then issue a warning (not
11216 -- an error), and ignore the pragma.
11218 Aname
:= Chars
(Attribute_Designator
);
11220 if not Is_Attribute_Name
(Aname
) then
11221 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11225 -- Otherwise, rewrite the pragma as an attribute definition clause
11228 Make_Attribute_Definition_Clause
(Loc
,
11229 Name
=> Get_Pragma_Arg
(Arg2
),
11231 Expression
=> Get_Pragma_Arg
(Arg3
)));
11233 end Attribute_Definition
;
11235 ------------------------------------------------------------------
11236 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11237 ------------------------------------------------------------------
11239 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11240 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11241 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11242 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11244 -- FLAG ::= boolean_EXPRESSION
11246 when Pragma_Async_Readers |
11247 Pragma_Async_Writers |
11248 Pragma_Effective_Reads |
11249 Pragma_Effective_Writes
=>
11250 Async_Effective
: declare
11254 Obj_Id
: Entity_Id
;
11258 Check_No_Identifiers
;
11259 Check_At_Least_N_Arguments
(1);
11260 Check_At_Most_N_Arguments
(2);
11261 Check_Arg_Is_Local_Name
(Arg1
);
11262 Error_Msg_Name_1
:= Pname
;
11264 Obj
:= Get_Pragma_Arg
(Arg1
);
11265 Expr
:= Get_Pragma_Arg
(Arg2
);
11267 -- Perform minimal verification to ensure that the argument is at
11268 -- least a variable. Subsequent finer grained checks will be done
11269 -- at the end of the declarative region the contains the pragma.
11271 if Is_Entity_Name
(Obj
)
11272 and then Present
(Entity
(Obj
))
11273 and then Ekind
(Entity
(Obj
)) = E_Variable
11275 Obj_Id
:= Entity
(Obj
);
11277 -- Detect a duplicate pragma. Note that it is not efficient to
11278 -- examine preceding statements as Boolean aspects may appear
11279 -- anywhere between the related object declaration and its
11280 -- freeze point. As an alternative, inspect the contents of the
11281 -- variable contract.
11283 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11285 if Present
(Duplic
) then
11286 Error_Msg_Sloc
:= Sloc
(Duplic
);
11287 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11289 -- No duplicate detected
11292 if Present
(Expr
) then
11293 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11296 -- Chain the pragma on the contract for further processing
11298 Add_Contract_Item
(N
, Obj_Id
);
11301 Error_Pragma
("pragma % must apply to a volatile object");
11303 end Async_Effective
;
11309 -- pragma Asynchronous (LOCAL_NAME);
11311 when Pragma_Asynchronous
=> Asynchronous
: declare
11317 Formal
: Entity_Id
;
11319 procedure Process_Async_Pragma
;
11320 -- Common processing for procedure and access-to-procedure case
11322 --------------------------
11323 -- Process_Async_Pragma --
11324 --------------------------
11326 procedure Process_Async_Pragma
is
11329 Set_Is_Asynchronous
(Nm
);
11333 -- The formals should be of mode IN (RM E.4.1(6))
11336 while Present
(S
) loop
11337 Formal
:= Defining_Identifier
(S
);
11339 if Nkind
(Formal
) = N_Defining_Identifier
11340 and then Ekind
(Formal
) /= E_In_Parameter
11343 ("pragma% procedure can only have IN parameter",
11350 Set_Is_Asynchronous
(Nm
);
11351 end Process_Async_Pragma
;
11353 -- Start of processing for pragma Asynchronous
11356 Check_Ada_83_Warning
;
11357 Check_No_Identifiers
;
11358 Check_Arg_Count
(1);
11359 Check_Arg_Is_Local_Name
(Arg1
);
11361 if Debug_Flag_U
then
11365 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11366 Analyze
(Get_Pragma_Arg
(Arg1
));
11367 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11369 if not Is_Remote_Call_Interface
(C_Ent
)
11370 and then not Is_Remote_Types
(C_Ent
)
11372 -- This pragma should only appear in an RCI or Remote Types
11373 -- unit (RM E.4.1(4)).
11376 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11379 if Ekind
(Nm
) = E_Procedure
11380 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11382 if not Is_Remote_Call_Interface
(Nm
) then
11384 ("pragma% cannot be applied on non-remote procedure",
11388 L
:= Parameter_Specifications
(Parent
(Nm
));
11389 Process_Async_Pragma
;
11392 elsif Ekind
(Nm
) = E_Function
then
11394 ("pragma% cannot be applied to function", Arg1
);
11396 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11397 if Is_Record_Type
(Nm
) then
11399 -- A record type that is the Equivalent_Type for a remote
11400 -- access-to-subprogram type.
11402 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11405 -- A non-expanded RAS type (distribution is not enabled)
11407 N
:= Declaration_Node
(Nm
);
11410 if Nkind
(N
) = N_Full_Type_Declaration
11411 and then Nkind
(Type_Definition
(N
)) =
11412 N_Access_Procedure_Definition
11414 L
:= Parameter_Specifications
(Type_Definition
(N
));
11415 Process_Async_Pragma
;
11417 if Is_Asynchronous
(Nm
)
11418 and then Expander_Active
11419 and then Get_PCS_Name
/= Name_No_DSA
11421 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11426 ("pragma% cannot reference access-to-function type",
11430 -- Only other possibility is Access-to-class-wide type
11432 elsif Is_Access_Type
(Nm
)
11433 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11435 Check_First_Subtype
(Arg1
);
11436 Set_Is_Asynchronous
(Nm
);
11437 if Expander_Active
then
11438 RACW_Type_Is_Asynchronous
(Nm
);
11442 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11450 -- pragma Atomic (LOCAL_NAME);
11452 when Pragma_Atomic
=>
11453 Process_Atomic_Independent_Shared_Volatile
;
11455 -----------------------
11456 -- Atomic_Components --
11457 -----------------------
11459 -- pragma Atomic_Components (array_LOCAL_NAME);
11461 -- This processing is shared by Volatile_Components
11463 when Pragma_Atomic_Components |
11464 Pragma_Volatile_Components
=>
11466 Atomic_Components
: declare
11473 Check_Ada_83_Warning
;
11474 Check_No_Identifiers
;
11475 Check_Arg_Count
(1);
11476 Check_Arg_Is_Local_Name
(Arg1
);
11477 E_Id
:= Get_Pragma_Arg
(Arg1
);
11479 if Etype
(E_Id
) = Any_Type
then
11483 E
:= Entity
(E_Id
);
11485 Check_Duplicate_Pragma
(E
);
11487 if Rep_Item_Too_Early
(E
, N
)
11489 Rep_Item_Too_Late
(E
, N
)
11494 D
:= Declaration_Node
(E
);
11497 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11499 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11500 and then Nkind
(D
) = N_Object_Declaration
11501 and then Nkind
(Object_Definition
(D
)) =
11502 N_Constrained_Array_Definition
)
11504 -- The flag is set on the object, or on the base type
11506 if Nkind
(D
) /= N_Object_Declaration
then
11507 E
:= Base_Type
(E
);
11510 -- Atomic implies both Independent and Volatile
11512 if Prag_Id
= Pragma_Atomic_Components
then
11513 Set_Has_Atomic_Components
(E
);
11514 Set_Has_Independent_Components
(E
);
11517 Set_Has_Volatile_Components
(E
);
11520 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11522 end Atomic_Components
;
11524 --------------------
11525 -- Attach_Handler --
11526 --------------------
11528 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11530 when Pragma_Attach_Handler
=>
11531 Check_Ada_83_Warning
;
11532 Check_No_Identifiers
;
11533 Check_Arg_Count
(2);
11535 if No_Run_Time_Mode
then
11536 Error_Msg_CRT
("Attach_Handler pragma", N
);
11538 Check_Interrupt_Or_Attach_Handler
;
11540 -- The expression that designates the attribute may depend on a
11541 -- discriminant, and is therefore a per-object expression, to
11542 -- be expanded in the init proc. If expansion is enabled, then
11543 -- perform semantic checks on a copy only.
11548 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11551 -- In Relaxed_RM_Semantics mode, we allow any static
11552 -- integer value, for compatibility with other compilers.
11554 if Relaxed_RM_Semantics
11555 and then Nkind
(Parg2
) = N_Integer_Literal
11557 Typ
:= Standard_Integer
;
11559 Typ
:= RTE
(RE_Interrupt_ID
);
11562 if Expander_Active
then
11563 Temp
:= New_Copy_Tree
(Parg2
);
11564 Set_Parent
(Temp
, N
);
11565 Preanalyze_And_Resolve
(Temp
, Typ
);
11568 Resolve
(Parg2
, Typ
);
11572 Process_Interrupt_Or_Attach_Handler
;
11575 --------------------
11576 -- C_Pass_By_Copy --
11577 --------------------
11579 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11581 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11587 Check_Valid_Configuration_Pragma
;
11588 Check_Arg_Count
(1);
11589 Check_Optional_Identifier
(Arg1
, "max_size");
11591 Arg
:= Get_Pragma_Arg
(Arg1
);
11592 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11594 Val
:= Expr_Value
(Arg
);
11598 ("maximum size for pragma% must be positive", Arg1
);
11600 elsif UI_Is_In_Int_Range
(Val
) then
11601 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11603 -- If a giant value is given, Int'Last will do well enough.
11604 -- If sometime someone complains that a record larger than
11605 -- two gigabytes is not copied, we will worry about it then.
11608 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11610 end C_Pass_By_Copy
;
11616 -- pragma Check ([Name =>] CHECK_KIND,
11617 -- [Check =>] Boolean_EXPRESSION
11618 -- [,[Message =>] String_EXPRESSION]);
11620 -- CHECK_KIND ::= IDENTIFIER |
11623 -- Invariant'Class |
11624 -- Type_Invariant'Class
11626 -- The identifiers Assertions and Statement_Assertions are not
11627 -- allowed, since they have special meaning for Check_Policy.
11629 when Pragma_Check
=> Check
: declare
11637 Check_At_Least_N_Arguments
(2);
11638 Check_At_Most_N_Arguments
(3);
11639 Check_Optional_Identifier
(Arg1
, Name_Name
);
11640 Check_Optional_Identifier
(Arg2
, Name_Check
);
11642 if Arg_Count
= 3 then
11643 Check_Optional_Identifier
(Arg3
, Name_Message
);
11644 Str
:= Get_Pragma_Arg
(Arg3
);
11647 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11648 Check_Arg_Is_Identifier
(Arg1
);
11649 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11651 -- Check forbidden name Assertions or Statement_Assertions
11654 when Name_Assertions
=>
11656 ("""Assertions"" is not allowed as a check kind "
11657 & "for pragma%", Arg1
);
11659 when Name_Statement_Assertions
=>
11661 ("""Statement_Assertions"" is not allowed as a check kind "
11662 & "for pragma%", Arg1
);
11668 -- Check applicable policy. We skip this if Checked/Ignored status
11669 -- is already set (e.g. in the casse of a pragma from an aspect).
11671 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11674 -- For a non-source pragma that is a rewriting of another pragma,
11675 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11677 elsif Is_Rewrite_Substitution
(N
)
11678 and then Nkind
(Original_Node
(N
)) = N_Pragma
11679 and then Original_Node
(N
) /= N
11681 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11682 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11684 -- Otherwise query the applicable policy at this point
11687 case Check_Kind
(Cname
) is
11688 when Name_Ignore
=>
11689 Set_Is_Ignored
(N
, True);
11690 Set_Is_Checked
(N
, False);
11693 Set_Is_Ignored
(N
, False);
11694 Set_Is_Checked
(N
, True);
11696 -- For disable, rewrite pragma as null statement and skip
11697 -- rest of the analysis of the pragma.
11699 when Name_Disable
=>
11700 Rewrite
(N
, Make_Null_Statement
(Loc
));
11704 -- No other possibilities
11707 raise Program_Error
;
11711 -- If check kind was not Disable, then continue pragma analysis
11713 Expr
:= Get_Pragma_Arg
(Arg2
);
11715 -- Deal with SCO generation
11718 when Name_Predicate |
11721 -- Nothing to do: since checks occur in client units,
11722 -- the SCO for the aspect in the declaration unit is
11723 -- conservatively always enabled.
11729 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11731 -- Mark aspect/pragma SCO as enabled
11733 Set_SCO_Pragma_Enabled
(Loc
);
11737 -- Deal with analyzing the string argument.
11739 if Arg_Count
= 3 then
11741 -- If checks are not on we don't want any expansion (since
11742 -- such expansion would not get properly deleted) but
11743 -- we do want to analyze (to get proper references).
11744 -- The Preanalyze_And_Resolve routine does just what we want
11746 if Is_Ignored
(N
) then
11747 Preanalyze_And_Resolve
(Str
, Standard_String
);
11749 -- Otherwise we need a proper analysis and expansion
11752 Analyze_And_Resolve
(Str
, Standard_String
);
11756 -- Now you might think we could just do the same with the Boolean
11757 -- expression if checks are off (and expansion is on) and then
11758 -- rewrite the check as a null statement. This would work but we
11759 -- would lose the useful warnings about an assertion being bound
11760 -- to fail even if assertions are turned off.
11762 -- So instead we wrap the boolean expression in an if statement
11763 -- that looks like:
11765 -- if False and then condition then
11769 -- The reason we do this rewriting during semantic analysis rather
11770 -- than as part of normal expansion is that we cannot analyze and
11771 -- expand the code for the boolean expression directly, or it may
11772 -- cause insertion of actions that would escape the attempt to
11773 -- suppress the check code.
11775 -- Note that the Sloc for the if statement corresponds to the
11776 -- argument condition, not the pragma itself. The reason for
11777 -- this is that we may generate a warning if the condition is
11778 -- False at compile time, and we do not want to delete this
11779 -- warning when we delete the if statement.
11781 if Expander_Active
and Is_Ignored
(N
) then
11782 Eloc
:= Sloc
(Expr
);
11785 Make_If_Statement
(Eloc
,
11787 Make_And_Then
(Eloc
,
11788 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
11789 Right_Opnd
=> Expr
),
11790 Then_Statements
=> New_List
(
11791 Make_Null_Statement
(Eloc
))));
11793 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11795 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11797 -- Check is active or expansion not active. In these cases we can
11798 -- just go ahead and analyze the boolean with no worries.
11801 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11802 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11803 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11807 --------------------------
11808 -- Check_Float_Overflow --
11809 --------------------------
11811 -- pragma Check_Float_Overflow;
11813 when Pragma_Check_Float_Overflow
=>
11815 Check_Valid_Configuration_Pragma
;
11816 Check_Arg_Count
(0);
11817 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11823 -- pragma Check_Name (check_IDENTIFIER);
11825 when Pragma_Check_Name
=>
11827 Check_No_Identifiers
;
11828 Check_Valid_Configuration_Pragma
;
11829 Check_Arg_Count
(1);
11830 Check_Arg_Is_Identifier
(Arg1
);
11833 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11836 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11837 if Check_Names
.Table
(J
) = Nam
then
11842 Check_Names
.Append
(Nam
);
11849 -- This is the old style syntax, which is still allowed in all modes:
11851 -- pragma Check_Policy ([Name =>] CHECK_KIND
11852 -- [Policy =>] POLICY_IDENTIFIER);
11854 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11856 -- CHECK_KIND ::= IDENTIFIER |
11859 -- Type_Invariant'Class |
11862 -- This is the new style syntax, compatible with Assertion_Policy
11863 -- and also allowed in all modes.
11865 -- Pragma Check_Policy (
11866 -- CHECK_KIND => POLICY_IDENTIFIER
11867 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11869 -- Note: the identifiers Name and Policy are not allowed as
11870 -- Check_Kind values. This avoids ambiguities between the old and
11871 -- new form syntax.
11873 when Pragma_Check_Policy
=> Check_Policy
: declare
11879 Check_At_Least_N_Arguments
(1);
11881 -- A Check_Policy pragma can appear either as a configuration
11882 -- pragma, or in a declarative part or a package spec (see RM
11883 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11884 -- followed for Check_Policy).
11886 if not Is_Configuration_Pragma
then
11887 Check_Is_In_Decl_Part_Or_Package_Spec
;
11890 -- Figure out if we have the old or new syntax. We have the
11891 -- old syntax if the first argument has no identifier, or the
11892 -- identifier is Name.
11894 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11895 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11899 Check_Arg_Count
(2);
11900 Check_Optional_Identifier
(Arg1
, Name_Name
);
11901 Kind
:= Get_Pragma_Arg
(Arg1
);
11902 Rewrite_Assertion_Kind
(Kind
);
11903 Check_Arg_Is_Identifier
(Arg1
);
11905 -- Check forbidden check kind
11907 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11908 Error_Msg_Name_2
:= Chars
(Kind
);
11910 ("pragma% does not allow% as check name", Arg1
);
11915 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11916 Check_Arg_Is_One_Of
11918 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11919 Ident
:= Get_Pragma_Arg
(Arg2
);
11921 if Chars
(Kind
) = Name_Ghost
then
11923 -- Pragma Check_Policy specifying a Ghost policy cannot
11924 -- occur within a ghost subprogram or package.
11926 if Ghost_Mode
> None
then
11928 ("pragma % cannot appear within ghost subprogram or "
11931 -- The policy identifier of pragma Ghost must be either
11932 -- Check or Ignore (SPARK RM 6.9(7)).
11934 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11938 ("argument of pragma % Ghost must be Check or Ignore",
11943 -- And chain pragma on the Check_Policy_List for search
11945 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11946 Opt
.Check_Policy_List
:= N
;
11948 -- For the new syntax, what we do is to convert each argument to
11949 -- an old syntax equivalent. We do that because we want to chain
11950 -- old style Check_Policy pragmas for the search (we don't want
11951 -- to have to deal with multiple arguments in the search).
11961 while Present
(Arg
) loop
11962 LocP
:= Sloc
(Arg
);
11963 Argx
:= Get_Pragma_Arg
(Arg
);
11965 -- Kind must be specified
11967 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11968 or else Chars
(Arg
) = No_Name
11971 ("missing assertion kind for pragma%", Arg
);
11974 -- Construct equivalent old form syntax Check_Policy
11975 -- pragma and insert it to get remaining checks.
11979 Chars
=> Name_Check_Policy
,
11980 Pragma_Argument_Associations
=> New_List
(
11981 Make_Pragma_Argument_Association
(LocP
,
11983 Make_Identifier
(LocP
, Chars
(Arg
))),
11984 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11985 Expression
=> Argx
))));
11990 -- Rewrite original Check_Policy pragma to null, since we
11991 -- have converted it into a series of old syntax pragmas.
11993 Rewrite
(N
, Make_Null_Statement
(Loc
));
11999 ---------------------
12000 -- CIL_Constructor --
12001 ---------------------
12003 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12005 -- Processing for this pragma is shared with Java_Constructor
12011 -- pragma Comment (static_string_EXPRESSION)
12013 -- Processing for pragma Comment shares the circuitry for pragma
12014 -- Ident. The only differences are that Ident enforces a limit of 31
12015 -- characters on its argument, and also enforces limitations on
12016 -- placement for DEC compatibility. Pragma Comment shares neither of
12017 -- these restrictions.
12019 -------------------
12020 -- Common_Object --
12021 -------------------
12023 -- pragma Common_Object (
12024 -- [Internal =>] LOCAL_NAME
12025 -- [, [External =>] EXTERNAL_SYMBOL]
12026 -- [, [Size =>] EXTERNAL_SYMBOL]);
12028 -- Processing for this pragma is shared with Psect_Object
12030 ------------------------
12031 -- Compile_Time_Error --
12032 ------------------------
12034 -- pragma Compile_Time_Error
12035 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12037 when Pragma_Compile_Time_Error
=>
12039 Process_Compile_Time_Warning_Or_Error
;
12041 --------------------------
12042 -- Compile_Time_Warning --
12043 --------------------------
12045 -- pragma Compile_Time_Warning
12046 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12048 when Pragma_Compile_Time_Warning
=>
12050 Process_Compile_Time_Warning_Or_Error
;
12052 ---------------------------
12053 -- Compiler_Unit_Warning --
12054 ---------------------------
12056 -- pragma Compiler_Unit_Warning;
12060 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12061 -- errors not warnings. This means that we had introduced a big extra
12062 -- inertia to compiler changes, since even if we implemented a new
12063 -- feature, and even if all versions to be used for bootstrapping
12064 -- implemented this new feature, we could not use it, since old
12065 -- compilers would give errors for using this feature in units
12066 -- having Compiler_Unit pragmas.
12068 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12069 -- problem. We no longer have any units mentioning Compiler_Unit,
12070 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12071 -- and thus generates a warning which can be ignored. So that deals
12072 -- with the problem of old compilers not implementing the newer form
12075 -- Newer compilers recognize the new pragma, but generate warning
12076 -- messages instead of errors, which again can be ignored in the
12077 -- case of an old compiler which implements a wanted new feature
12078 -- but at the time felt like warning about it for older compilers.
12080 -- We retain Compiler_Unit so that new compilers can be used to build
12081 -- older run-times that use this pragma. That's an unusual case, but
12082 -- it's easy enough to handle, so why not?
12084 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12086 Check_Arg_Count
(0);
12088 -- Only recognized in main unit
12090 if Current_Sem_Unit
= Main_Unit
then
12091 Compiler_Unit
:= True;
12094 -----------------------------
12095 -- Complete_Representation --
12096 -----------------------------
12098 -- pragma Complete_Representation;
12100 when Pragma_Complete_Representation
=>
12102 Check_Arg_Count
(0);
12104 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12106 ("pragma & must appear within record representation clause");
12109 ----------------------------
12110 -- Complex_Representation --
12111 ----------------------------
12113 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12115 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12122 Check_Arg_Count
(1);
12123 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12124 Check_Arg_Is_Local_Name
(Arg1
);
12125 E_Id
:= Get_Pragma_Arg
(Arg1
);
12127 if Etype
(E_Id
) = Any_Type
then
12131 E
:= Entity
(E_Id
);
12133 if not Is_Record_Type
(E
) then
12135 ("argument for pragma% must be record type", Arg1
);
12138 Ent
:= First_Entity
(E
);
12141 or else No
(Next_Entity
(Ent
))
12142 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12143 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12144 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12147 ("record for pragma% must have two fields of the same "
12148 & "floating-point type", Arg1
);
12151 Set_Has_Complex_Representation
(Base_Type
(E
));
12153 -- We need to treat the type has having a non-standard
12154 -- representation, for back-end purposes, even though in
12155 -- general a complex will have the default representation
12156 -- of a record with two real components.
12158 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12160 end Complex_Representation
;
12162 -------------------------
12163 -- Component_Alignment --
12164 -------------------------
12166 -- pragma Component_Alignment (
12167 -- [Form =>] ALIGNMENT_CHOICE
12168 -- [, [Name =>] type_LOCAL_NAME]);
12170 -- ALIGNMENT_CHOICE ::=
12172 -- | Component_Size_4
12176 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12177 Args
: Args_List
(1 .. 2);
12178 Names
: constant Name_List
(1 .. 2) := (
12182 Form
: Node_Id
renames Args
(1);
12183 Name
: Node_Id
renames Args
(2);
12185 Atype
: Component_Alignment_Kind
;
12190 Gather_Associations
(Names
, Args
);
12193 Error_Pragma
("missing Form argument for pragma%");
12196 Check_Arg_Is_Identifier
(Form
);
12198 -- Get proper alignment, note that Default = Component_Size on all
12199 -- machines we have so far, and we want to set this value rather
12200 -- than the default value to indicate that it has been explicitly
12201 -- set (and thus will not get overridden by the default component
12202 -- alignment for the current scope)
12204 if Chars
(Form
) = Name_Component_Size
then
12205 Atype
:= Calign_Component_Size
;
12207 elsif Chars
(Form
) = Name_Component_Size_4
then
12208 Atype
:= Calign_Component_Size_4
;
12210 elsif Chars
(Form
) = Name_Default
then
12211 Atype
:= Calign_Component_Size
;
12213 elsif Chars
(Form
) = Name_Storage_Unit
then
12214 Atype
:= Calign_Storage_Unit
;
12218 ("invalid Form parameter for pragma%", Form
);
12221 -- Case with no name, supplied, affects scope table entry
12225 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12227 -- Case of name supplied
12230 Check_Arg_Is_Local_Name
(Name
);
12232 Typ
:= Entity
(Name
);
12235 or else Rep_Item_Too_Early
(Typ
, N
)
12239 Typ
:= Underlying_Type
(Typ
);
12242 if not Is_Record_Type
(Typ
)
12243 and then not Is_Array_Type
(Typ
)
12246 ("Name parameter of pragma% must identify record or "
12247 & "array type", Name
);
12250 -- An explicit Component_Alignment pragma overrides an
12251 -- implicit pragma Pack, but not an explicit one.
12253 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12254 Set_Is_Packed
(Base_Type
(Typ
), False);
12255 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12258 end Component_AlignmentP
;
12260 --------------------
12261 -- Contract_Cases --
12262 --------------------
12264 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12266 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12268 -- CASE_GUARD ::= boolean_EXPRESSION | others
12270 -- CONSEQUENCE ::= boolean_EXPRESSION
12272 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12273 Subp_Decl
: Node_Id
;
12277 Check_No_Identifiers
;
12278 Check_Arg_Count
(1);
12279 Ensure_Aggregate_Form
(Arg1
);
12281 -- The pragma is analyzed at the end of the declarative part which
12282 -- contains the related subprogram. Reset the analyzed flag.
12284 Set_Analyzed
(N
, False);
12286 -- Ensure the proper placement of the pragma. Contract_Cases must
12287 -- be associated with a subprogram declaration or a body that acts
12291 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12293 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12296 -- Body acts as spec
12298 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12299 and then No
(Corresponding_Spec
(Subp_Decl
))
12303 -- Body stub acts as spec
12305 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12306 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12315 -- When the pragma appears on a subprogram body, perform the full
12318 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12319 Analyze_Contract_Cases_In_Decl_Part
(N
);
12321 -- When Contract_Cases applies to a subprogram compilation unit,
12322 -- the corresponding pragma is placed after the unit's declaration
12323 -- node and needs to be analyzed immediately.
12325 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12326 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12328 Analyze_Contract_Cases_In_Decl_Part
(N
);
12331 -- Chain the pragma on the contract for further processing
12333 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12334 end Contract_Cases
;
12340 -- pragma Controlled (first_subtype_LOCAL_NAME);
12342 when Pragma_Controlled
=> Controlled
: declare
12346 Check_No_Identifiers
;
12347 Check_Arg_Count
(1);
12348 Check_Arg_Is_Local_Name
(Arg1
);
12349 Arg
:= Get_Pragma_Arg
(Arg1
);
12351 if not Is_Entity_Name
(Arg
)
12352 or else not Is_Access_Type
(Entity
(Arg
))
12354 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12356 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12364 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12365 -- [Entity =>] LOCAL_NAME);
12367 when Pragma_Convention
=> Convention
: declare
12370 pragma Warnings
(Off
, C
);
12371 pragma Warnings
(Off
, E
);
12373 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12374 Check_Ada_83_Warning
;
12375 Check_Arg_Count
(2);
12376 Process_Convention
(C
, E
);
12379 ---------------------------
12380 -- Convention_Identifier --
12381 ---------------------------
12383 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12384 -- [Convention =>] convention_IDENTIFIER);
12386 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12392 Check_Arg_Order
((Name_Name
, Name_Convention
));
12393 Check_Arg_Count
(2);
12394 Check_Optional_Identifier
(Arg1
, Name_Name
);
12395 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12396 Check_Arg_Is_Identifier
(Arg1
);
12397 Check_Arg_Is_Identifier
(Arg2
);
12398 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12399 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12401 if Is_Convention_Name
(Cname
) then
12402 Record_Convention_Identifier
12403 (Idnam
, Get_Convention_Id
(Cname
));
12406 ("second arg for % pragma must be convention", Arg2
);
12408 end Convention_Identifier
;
12414 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12416 when Pragma_CPP_Class
=> CPP_Class
: declare
12420 if Warn_On_Obsolescent_Feature
then
12422 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12423 & "effect; replace it by pragma import?j?", N
);
12426 Check_Arg_Count
(1);
12430 Chars
=> Name_Import
,
12431 Pragma_Argument_Associations
=> New_List
(
12432 Make_Pragma_Argument_Association
(Loc
,
12433 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12434 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12438 ---------------------
12439 -- CPP_Constructor --
12440 ---------------------
12442 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12443 -- [, [External_Name =>] static_string_EXPRESSION ]
12444 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12446 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12449 Def_Id
: Entity_Id
;
12450 Tag_Typ
: Entity_Id
;
12454 Check_At_Least_N_Arguments
(1);
12455 Check_At_Most_N_Arguments
(3);
12456 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12457 Check_Arg_Is_Local_Name
(Arg1
);
12459 Id
:= Get_Pragma_Arg
(Arg1
);
12460 Find_Program_Unit_Name
(Id
);
12462 -- If we did not find the name, we are done
12464 if Etype
(Id
) = Any_Type
then
12468 Def_Id
:= Entity
(Id
);
12470 -- Check if already defined as constructor
12472 if Is_Constructor
(Def_Id
) then
12474 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12478 if Ekind
(Def_Id
) = E_Function
12479 and then (Is_CPP_Class
(Etype
(Def_Id
))
12480 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12482 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12484 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12486 ("'C'P'P constructor must be defined in the scope of "
12487 & "its returned type", Arg1
);
12490 if Arg_Count
>= 2 then
12491 Set_Imported
(Def_Id
);
12492 Set_Is_Public
(Def_Id
);
12493 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12496 Set_Has_Completion
(Def_Id
);
12497 Set_Is_Constructor
(Def_Id
);
12498 Set_Convention
(Def_Id
, Convention_CPP
);
12500 -- Imported C++ constructors are not dispatching primitives
12501 -- because in C++ they don't have a dispatch table slot.
12502 -- However, in Ada the constructor has the profile of a
12503 -- function that returns a tagged type and therefore it has
12504 -- been treated as a primitive operation during semantic
12505 -- analysis. We now remove it from the list of primitive
12506 -- operations of the type.
12508 if Is_Tagged_Type
(Etype
(Def_Id
))
12509 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12510 and then Is_Dispatching_Operation
(Def_Id
)
12512 Tag_Typ
:= Etype
(Def_Id
);
12514 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12515 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12519 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12520 Set_Is_Dispatching_Operation
(Def_Id
, False);
12523 -- For backward compatibility, if the constructor returns a
12524 -- class wide type, and we internally change the return type to
12525 -- the corresponding root type.
12527 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12528 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12532 ("pragma% requires function returning a 'C'P'P_Class type",
12535 end CPP_Constructor
;
12541 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12545 if Warn_On_Obsolescent_Feature
then
12547 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12556 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12560 if Warn_On_Obsolescent_Feature
then
12562 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12571 -- pragma CPU (EXPRESSION);
12573 when Pragma_CPU
=> CPU
: declare
12574 P
: constant Node_Id
:= Parent
(N
);
12580 Check_No_Identifiers
;
12581 Check_Arg_Count
(1);
12585 if Nkind
(P
) = N_Subprogram_Body
then
12586 Check_In_Main_Program
;
12588 Arg
:= Get_Pragma_Arg
(Arg1
);
12589 Analyze_And_Resolve
(Arg
, Any_Integer
);
12591 Ent
:= Defining_Unit_Name
(Specification
(P
));
12593 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12594 Ent
:= Defining_Identifier
(Ent
);
12599 if not Is_OK_Static_Expression
(Arg
) then
12600 Flag_Non_Static_Expr
12601 ("main subprogram affinity is not static!", Arg
);
12604 -- If constraint error, then we already signalled an error
12606 elsif Raises_Constraint_Error
(Arg
) then
12609 -- Otherwise check in range
12613 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12614 -- This is the entity System.Multiprocessors.CPU_Range;
12616 Val
: constant Uint
:= Expr_Value
(Arg
);
12619 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12621 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12624 ("main subprogram CPU is out of range", Arg1
);
12630 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12634 elsif Nkind
(P
) = N_Task_Definition
then
12635 Arg
:= Get_Pragma_Arg
(Arg1
);
12636 Ent
:= Defining_Identifier
(Parent
(P
));
12638 -- The expression must be analyzed in the special manner
12639 -- described in "Handling of Default and Per-Object
12640 -- Expressions" in sem.ads.
12642 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12644 -- Anything else is incorrect
12650 -- Check duplicate pragma before we chain the pragma in the Rep
12651 -- Item chain of Ent.
12653 Check_Duplicate_Pragma
(Ent
);
12654 Record_Rep_Item
(Ent
, N
);
12661 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12663 when Pragma_Debug
=> Debug
: declare
12670 -- The condition for executing the call is that the expander
12671 -- is active and that we are not ignoring this debug pragma.
12676 (Expander_Active
and then not Is_Ignored
(N
)),
12679 if not Is_Ignored
(N
) then
12680 Set_SCO_Pragma_Enabled
(Loc
);
12683 if Arg_Count
= 2 then
12685 Make_And_Then
(Loc
,
12686 Left_Opnd
=> Relocate_Node
(Cond
),
12687 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12688 Call
:= Get_Pragma_Arg
(Arg2
);
12690 Call
:= Get_Pragma_Arg
(Arg1
);
12694 N_Indexed_Component
,
12698 N_Selected_Component
)
12700 -- If this pragma Debug comes from source, its argument was
12701 -- parsed as a name form (which is syntactically identical).
12702 -- In a generic context a parameterless call will be left as
12703 -- an expanded name (if global) or selected_component if local.
12704 -- Change it to a procedure call statement now.
12706 Change_Name_To_Procedure_Call_Statement
(Call
);
12708 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12710 -- Already in the form of a procedure call statement: nothing
12711 -- to do (could happen in case of an internally generated
12717 -- All other cases: diagnose error
12720 ("argument of pragma ""Debug"" is not procedure call",
12725 -- Rewrite into a conditional with an appropriate condition. We
12726 -- wrap the procedure call in a block so that overhead from e.g.
12727 -- use of the secondary stack does not generate execution overhead
12728 -- for suppressed conditions.
12730 -- Normally the analysis that follows will freeze the subprogram
12731 -- being called. However, if the call is to a null procedure,
12732 -- we want to freeze it before creating the block, because the
12733 -- analysis that follows may be done with expansion disabled, in
12734 -- which case the body will not be generated, leading to spurious
12737 if Nkind
(Call
) = N_Procedure_Call_Statement
12738 and then Is_Entity_Name
(Name
(Call
))
12740 Analyze
(Name
(Call
));
12741 Freeze_Before
(N
, Entity
(Name
(Call
)));
12745 Make_Implicit_If_Statement
(N
,
12747 Then_Statements
=> New_List
(
12748 Make_Block_Statement
(Loc
,
12749 Handled_Statement_Sequence
=>
12750 Make_Handled_Sequence_Of_Statements
(Loc
,
12751 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12754 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12755 -- after analysis of the normally rewritten node, to capture all
12756 -- references to entities, which avoids issuing wrong warnings
12757 -- about unused entities.
12759 if GNATprove_Mode
then
12760 Rewrite
(N
, Make_Null_Statement
(Loc
));
12768 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12770 when Pragma_Debug_Policy
=>
12772 Check_Arg_Count
(1);
12773 Check_No_Identifiers
;
12774 Check_Arg_Is_Identifier
(Arg1
);
12776 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12777 -- rewrite it that way, and let the rest of the checking come
12778 -- from analyzing the rewritten pragma.
12782 Chars
=> Name_Check_Policy
,
12783 Pragma_Argument_Associations
=> New_List
(
12784 Make_Pragma_Argument_Association
(Loc
,
12785 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12787 Make_Pragma_Argument_Association
(Loc
,
12788 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12791 -------------------------------
12792 -- Default_Initial_Condition --
12793 -------------------------------
12795 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12797 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12804 Check_No_Identifiers
;
12805 Check_At_Most_N_Arguments
(1);
12808 while Present
(Stmt
) loop
12810 -- Skip prior pragmas, but check for duplicates
12812 if Nkind
(Stmt
) = N_Pragma
then
12813 if Pragma_Name
(Stmt
) = Pname
then
12814 Error_Msg_Name_1
:= Pname
;
12815 Error_Msg_Sloc
:= Sloc
(Stmt
);
12816 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12819 -- Skip internally generated code
12821 elsif not Comes_From_Source
(Stmt
) then
12824 -- The associated private type [extension] has been found, stop
12827 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12828 N_Private_Type_Declaration
)
12830 Typ
:= Defining_Entity
(Stmt
);
12833 -- The pragma does not apply to a legal construct, issue an
12834 -- error and stop the analysis.
12841 Stmt
:= Prev
(Stmt
);
12844 Set_Has_Default_Init_Cond
(Typ
);
12845 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12847 -- Chain the pragma on the rep item chain for further processing
12849 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12850 end Default_Init_Cond
;
12852 ----------------------------------
12853 -- Default_Scalar_Storage_Order --
12854 ----------------------------------
12856 -- pragma Default_Scalar_Storage_Order
12857 -- (High_Order_First | Low_Order_First);
12859 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12860 Default
: Character;
12864 Check_Arg_Count
(1);
12866 -- Default_Scalar_Storage_Order can appear as a configuration
12867 -- pragma, or in a declarative part of a package spec.
12869 if not Is_Configuration_Pragma
then
12870 Check_Is_In_Decl_Part_Or_Package_Spec
;
12873 Check_No_Identifiers
;
12874 Check_Arg_Is_One_Of
12875 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12876 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12877 Default
:= Fold_Upper
(Name_Buffer
(1));
12879 if not Support_Nondefault_SSO_On_Target
12880 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12882 if Warn_On_Unrecognized_Pragma
then
12884 ("non-default Scalar_Storage_Order not supported "
12885 & "on target?g?", N
);
12887 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12890 -- Here set the specified default
12893 Opt
.Default_SSO
:= Default
;
12897 --------------------------
12898 -- Default_Storage_Pool --
12899 --------------------------
12901 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12903 when Pragma_Default_Storage_Pool
=>
12905 Check_Arg_Count
(1);
12907 -- Default_Storage_Pool can appear as a configuration pragma, or
12908 -- in a declarative part of a package spec.
12910 if not Is_Configuration_Pragma
then
12911 Check_Is_In_Decl_Part_Or_Package_Spec
;
12914 -- Case of Default_Storage_Pool (null);
12916 if Nkind
(Expression
(Arg1
)) = N_Null
then
12917 Analyze
(Expression
(Arg1
));
12919 -- This is an odd case, this is not really an expression, so
12920 -- we don't have a type for it. So just set the type to Empty.
12922 Set_Etype
(Expression
(Arg1
), Empty
);
12924 -- Case of Default_Storage_Pool (storage_pool_NAME);
12927 -- If it's a configuration pragma, then the only allowed
12928 -- argument is "null".
12930 if Is_Configuration_Pragma
then
12931 Error_Pragma_Arg
("NULL expected", Arg1
);
12934 -- The expected type for a non-"null" argument is
12935 -- Root_Storage_Pool'Class, and the pool must be a variable.
12937 Analyze_And_Resolve
12938 (Get_Pragma_Arg
(Arg1
),
12939 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12941 if not Is_Variable
(Expression
(Arg1
)) then
12943 ("default storage pool must be a variable", Arg1
);
12947 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12948 -- for an access type will use this information to set the
12949 -- appropriate attributes of the access type.
12951 Default_Pool
:= Expression
(Arg1
);
12957 -- pragma Depends (DEPENDENCY_RELATION);
12959 -- DEPENDENCY_RELATION ::=
12961 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12963 -- DEPENDENCY_CLAUSE ::=
12964 -- OUTPUT_LIST =>[+] INPUT_LIST
12965 -- | NULL_DEPENDENCY_CLAUSE
12967 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12969 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12971 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12973 -- OUTPUT ::= NAME | FUNCTION_RESULT
12976 -- where FUNCTION_RESULT is a function Result attribute_reference
12978 when Pragma_Depends
=> Depends
: declare
12979 Subp_Decl
: Node_Id
;
12983 Check_Arg_Count
(1);
12984 Ensure_Aggregate_Form
(Arg1
);
12986 -- Ensure the proper placement of the pragma. Depends must be
12987 -- associated with a subprogram declaration or a body that acts
12991 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12993 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12996 -- Body acts as spec
12998 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12999 and then No
(Corresponding_Spec
(Subp_Decl
))
13003 -- Body stub acts as spec
13005 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13006 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13015 -- When the pragma appears on a subprogram body, perform the full
13018 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
13019 Analyze_Depends_In_Decl_Part
(N
);
13021 -- When Depends applies to a subprogram compilation unit, the
13022 -- corresponding pragma is placed after the unit's declaration
13023 -- node and needs to be analyzed immediately.
13025 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13026 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
13028 Analyze_Depends_In_Decl_Part
(N
);
13031 -- Chain the pragma on the contract for further processing
13033 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13036 ---------------------
13037 -- Detect_Blocking --
13038 ---------------------
13040 -- pragma Detect_Blocking;
13042 when Pragma_Detect_Blocking
=>
13044 Check_Arg_Count
(0);
13045 Check_Valid_Configuration_Pragma
;
13046 Detect_Blocking
:= True;
13048 ------------------------------------
13049 -- Disable_Atomic_Synchronization --
13050 ------------------------------------
13052 -- pragma Disable_Atomic_Synchronization [(Entity)];
13054 when Pragma_Disable_Atomic_Synchronization
=>
13056 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13058 -------------------
13059 -- Discard_Names --
13060 -------------------
13062 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13064 when Pragma_Discard_Names
=> Discard_Names
: declare
13069 Check_Ada_83_Warning
;
13071 -- Deal with configuration pragma case
13073 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13074 Global_Discard_Names
:= True;
13077 -- Otherwise, check correct appropriate context
13080 Check_Is_In_Decl_Part_Or_Package_Spec
;
13082 if Arg_Count
= 0 then
13084 -- If there is no parameter, then from now on this pragma
13085 -- applies to any enumeration, exception or tagged type
13086 -- defined in the current declarative part, and recursively
13087 -- to any nested scope.
13089 Set_Discard_Names
(Current_Scope
);
13093 Check_Arg_Count
(1);
13094 Check_Optional_Identifier
(Arg1
, Name_On
);
13095 Check_Arg_Is_Local_Name
(Arg1
);
13097 E_Id
:= Get_Pragma_Arg
(Arg1
);
13099 if Etype
(E_Id
) = Any_Type
then
13102 E
:= Entity
(E_Id
);
13105 if (Is_First_Subtype
(E
)
13107 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13108 or else Ekind
(E
) = E_Exception
13110 Set_Discard_Names
(E
);
13111 Record_Rep_Item
(E
, N
);
13115 ("inappropriate entity for pragma%", Arg1
);
13122 ------------------------
13123 -- Dispatching_Domain --
13124 ------------------------
13126 -- pragma Dispatching_Domain (EXPRESSION);
13128 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13129 P
: constant Node_Id
:= Parent
(N
);
13135 Check_No_Identifiers
;
13136 Check_Arg_Count
(1);
13138 -- This pragma is born obsolete, but not the aspect
13140 if not From_Aspect_Specification
(N
) then
13142 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13145 if Nkind
(P
) = N_Task_Definition
then
13146 Arg
:= Get_Pragma_Arg
(Arg1
);
13147 Ent
:= Defining_Identifier
(Parent
(P
));
13149 -- The expression must be analyzed in the special manner
13150 -- described in "Handling of Default and Per-Object
13151 -- Expressions" in sem.ads.
13153 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13155 -- Check duplicate pragma before we chain the pragma in the Rep
13156 -- Item chain of Ent.
13158 Check_Duplicate_Pragma
(Ent
);
13159 Record_Rep_Item
(Ent
, N
);
13161 -- Anything else is incorrect
13166 end Dispatching_Domain
;
13172 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13174 when Pragma_Elaborate
=> Elaborate
: declare
13179 -- Pragma must be in context items list of a compilation unit
13181 if not Is_In_Context_Clause
then
13185 -- Must be at least one argument
13187 if Arg_Count
= 0 then
13188 Error_Pragma
("pragma% requires at least one argument");
13191 -- In Ada 83 mode, there can be no items following it in the
13192 -- context list except other pragmas and implicit with clauses
13193 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13194 -- placement rule does not apply.
13196 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13198 while Present
(Citem
) loop
13199 if Nkind
(Citem
) = N_Pragma
13200 or else (Nkind
(Citem
) = N_With_Clause
13201 and then Implicit_With
(Citem
))
13206 ("(Ada 83) pragma% must be at end of context clause");
13213 -- Finally, the arguments must all be units mentioned in a with
13214 -- clause in the same context clause. Note we already checked (in
13215 -- Par.Prag) that the arguments are all identifiers or selected
13219 Outer
: while Present
(Arg
) loop
13220 Citem
:= First
(List_Containing
(N
));
13221 Inner
: while Citem
/= N
loop
13222 if Nkind
(Citem
) = N_With_Clause
13223 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13225 Set_Elaborate_Present
(Citem
, True);
13226 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13228 -- With the pragma present, elaboration calls on
13229 -- subprograms from the named unit need no further
13230 -- checks, as long as the pragma appears in the current
13231 -- compilation unit. If the pragma appears in some unit
13232 -- in the context, there might still be a need for an
13233 -- Elaborate_All_Desirable from the current compilation
13234 -- to the named unit, so we keep the check enabled.
13236 if In_Extended_Main_Source_Unit
(N
) then
13238 -- This does not apply in SPARK mode, where we allow
13239 -- pragma Elaborate, but we don't trust it to be right
13240 -- so we will still insist on the Elaborate_All.
13242 if SPARK_Mode
/= On
then
13243 Set_Suppress_Elaboration_Warnings
13244 (Entity
(Name
(Citem
)));
13256 ("argument of pragma% is not withed unit", Arg
);
13262 -- Give a warning if operating in static mode with one of the
13263 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13266 and not Dynamic_Elaboration_Checks
13268 -- pragma Elaborate not allowed in SPARK mode anyway. We
13269 -- already complained about it, no point in generating any
13270 -- further complaint.
13272 and SPARK_Mode
/= On
13275 ("?l?use of pragma Elaborate may not be safe", N
);
13277 ("?l?use pragma Elaborate_All instead if possible", N
);
13281 -------------------
13282 -- Elaborate_All --
13283 -------------------
13285 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13287 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13292 Check_Ada_83_Warning
;
13294 -- Pragma must be in context items list of a compilation unit
13296 if not Is_In_Context_Clause
then
13300 -- Must be at least one argument
13302 if Arg_Count
= 0 then
13303 Error_Pragma
("pragma% requires at least one argument");
13306 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13307 -- have to appear at the end of the context clause, but may
13308 -- appear mixed in with other items, even in Ada 83 mode.
13310 -- Final check: the arguments must all be units mentioned in
13311 -- a with clause in the same context clause. Note that we
13312 -- already checked (in Par.Prag) that all the arguments are
13313 -- either identifiers or selected components.
13316 Outr
: while Present
(Arg
) loop
13317 Citem
:= First
(List_Containing
(N
));
13318 Innr
: while Citem
/= N
loop
13319 if Nkind
(Citem
) = N_With_Clause
13320 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13322 Set_Elaborate_All_Present
(Citem
, True);
13323 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13325 -- Suppress warnings and elaboration checks on the named
13326 -- unit if the pragma is in the current compilation, as
13327 -- for pragma Elaborate.
13329 if In_Extended_Main_Source_Unit
(N
) then
13330 Set_Suppress_Elaboration_Warnings
13331 (Entity
(Name
(Citem
)));
13340 Set_Error_Posted
(N
);
13342 ("argument of pragma% is not withed unit", Arg
);
13349 --------------------
13350 -- Elaborate_Body --
13351 --------------------
13353 -- pragma Elaborate_Body [( library_unit_NAME )];
13355 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13356 Cunit_Node
: Node_Id
;
13357 Cunit_Ent
: Entity_Id
;
13360 Check_Ada_83_Warning
;
13361 Check_Valid_Library_Unit_Pragma
;
13363 if Nkind
(N
) = N_Null_Statement
then
13367 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13368 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13370 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13373 Error_Pragma
("pragma% must refer to a spec, not a body");
13375 Set_Body_Required
(Cunit_Node
, True);
13376 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13378 -- If we are in dynamic elaboration mode, then we suppress
13379 -- elaboration warnings for the unit, since it is definitely
13380 -- fine NOT to do dynamic checks at the first level (and such
13381 -- checks will be suppressed because no elaboration boolean
13382 -- is created for Elaborate_Body packages).
13384 -- But in the static model of elaboration, Elaborate_Body is
13385 -- definitely NOT good enough to ensure elaboration safety on
13386 -- its own, since the body may WITH other units that are not
13387 -- safe from an elaboration point of view, so a client must
13388 -- still do an Elaborate_All on such units.
13390 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13391 -- Elaborate_Body always suppressed elab warnings.
13393 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13394 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13397 end Elaborate_Body
;
13399 ------------------------
13400 -- Elaboration_Checks --
13401 ------------------------
13403 -- pragma Elaboration_Checks (Static | Dynamic);
13405 when Pragma_Elaboration_Checks
=>
13407 Check_Arg_Count
(1);
13408 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13410 -- Set flag accordingly (ignore attempt at dynamic elaboration
13411 -- checks in SPARK mode).
13413 Dynamic_Elaboration_Checks
:=
13414 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13415 and then SPARK_Mode
/= On
;
13421 -- pragma Eliminate (
13422 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13423 -- [,[Entity =>] IDENTIFIER |
13424 -- SELECTED_COMPONENT |
13426 -- [, OVERLOADING_RESOLUTION]);
13428 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13431 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13432 -- FUNCTION_PROFILE
13434 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13436 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13437 -- Result_Type => result_SUBTYPE_NAME]
13439 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13440 -- SUBTYPE_NAME ::= STRING_LITERAL
13442 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13443 -- SOURCE_TRACE ::= STRING_LITERAL
13445 when Pragma_Eliminate
=> Eliminate
: declare
13446 Args
: Args_List
(1 .. 5);
13447 Names
: constant Name_List
(1 .. 5) := (
13450 Name_Parameter_Types
,
13452 Name_Source_Location
);
13454 Unit_Name
: Node_Id
renames Args
(1);
13455 Entity
: Node_Id
renames Args
(2);
13456 Parameter_Types
: Node_Id
renames Args
(3);
13457 Result_Type
: Node_Id
renames Args
(4);
13458 Source_Location
: Node_Id
renames Args
(5);
13462 Check_Valid_Configuration_Pragma
;
13463 Gather_Associations
(Names
, Args
);
13465 if No
(Unit_Name
) then
13466 Error_Pragma
("missing Unit_Name argument for pragma%");
13470 and then (Present
(Parameter_Types
)
13472 Present
(Result_Type
)
13474 Present
(Source_Location
))
13476 Error_Pragma
("missing Entity argument for pragma%");
13479 if (Present
(Parameter_Types
)
13481 Present
(Result_Type
))
13483 Present
(Source_Location
)
13486 ("parameter profile and source location cannot be used "
13487 & "together in pragma%");
13490 Process_Eliminate_Pragma
13499 -----------------------------------
13500 -- Enable_Atomic_Synchronization --
13501 -----------------------------------
13503 -- pragma Enable_Atomic_Synchronization [(Entity)];
13505 when Pragma_Enable_Atomic_Synchronization
=>
13507 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13514 -- [ Convention =>] convention_IDENTIFIER,
13515 -- [ Entity =>] LOCAL_NAME
13516 -- [, [External_Name =>] static_string_EXPRESSION ]
13517 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13519 when Pragma_Export
=> Export
: declare
13521 Def_Id
: Entity_Id
;
13523 pragma Warnings
(Off
, C
);
13526 Check_Ada_83_Warning
;
13530 Name_External_Name
,
13533 Check_At_Least_N_Arguments
(2);
13534 Check_At_Most_N_Arguments
(4);
13536 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13537 -- pragma Export (Entity, "external name");
13539 if Relaxed_RM_Semantics
13540 and then Arg_Count
= 2
13541 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13544 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13547 if not Is_Entity_Name
(Def_Id
) then
13548 Error_Pragma_Arg
("entity name required", Arg1
);
13551 Def_Id
:= Entity
(Def_Id
);
13552 Set_Exported
(Def_Id
, Arg1
);
13555 Process_Convention
(C
, Def_Id
);
13557 if Ekind
(Def_Id
) /= E_Constant
then
13558 Note_Possible_Modification
13559 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13562 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13563 Set_Exported
(Def_Id
, Arg2
);
13566 -- If the entity is a deferred constant, propagate the information
13567 -- to the full view, because gigi elaborates the full view only.
13569 if Ekind
(Def_Id
) = E_Constant
13570 and then Present
(Full_View
(Def_Id
))
13573 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13575 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13576 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13577 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13582 ---------------------
13583 -- Export_Function --
13584 ---------------------
13586 -- pragma Export_Function (
13587 -- [Internal =>] LOCAL_NAME
13588 -- [, [External =>] EXTERNAL_SYMBOL]
13589 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13590 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13591 -- [, [Mechanism =>] MECHANISM]
13592 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13594 -- EXTERNAL_SYMBOL ::=
13596 -- | static_string_EXPRESSION
13598 -- PARAMETER_TYPES ::=
13600 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13602 -- TYPE_DESIGNATOR ::=
13604 -- | subtype_Name ' Access
13608 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13610 -- MECHANISM_ASSOCIATION ::=
13611 -- [formal_parameter_NAME =>] MECHANISM_NAME
13613 -- MECHANISM_NAME ::=
13617 when Pragma_Export_Function
=> Export_Function
: declare
13618 Args
: Args_List
(1 .. 6);
13619 Names
: constant Name_List
(1 .. 6) := (
13622 Name_Parameter_Types
,
13625 Name_Result_Mechanism
);
13627 Internal
: Node_Id
renames Args
(1);
13628 External
: Node_Id
renames Args
(2);
13629 Parameter_Types
: Node_Id
renames Args
(3);
13630 Result_Type
: Node_Id
renames Args
(4);
13631 Mechanism
: Node_Id
renames Args
(5);
13632 Result_Mechanism
: Node_Id
renames Args
(6);
13636 Gather_Associations
(Names
, Args
);
13637 Process_Extended_Import_Export_Subprogram_Pragma
(
13638 Arg_Internal
=> Internal
,
13639 Arg_External
=> External
,
13640 Arg_Parameter_Types
=> Parameter_Types
,
13641 Arg_Result_Type
=> Result_Type
,
13642 Arg_Mechanism
=> Mechanism
,
13643 Arg_Result_Mechanism
=> Result_Mechanism
);
13644 end Export_Function
;
13646 -------------------
13647 -- Export_Object --
13648 -------------------
13650 -- pragma Export_Object (
13651 -- [Internal =>] LOCAL_NAME
13652 -- [, [External =>] EXTERNAL_SYMBOL]
13653 -- [, [Size =>] EXTERNAL_SYMBOL]);
13655 -- EXTERNAL_SYMBOL ::=
13657 -- | static_string_EXPRESSION
13659 -- PARAMETER_TYPES ::=
13661 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13663 -- TYPE_DESIGNATOR ::=
13665 -- | subtype_Name ' Access
13669 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13671 -- MECHANISM_ASSOCIATION ::=
13672 -- [formal_parameter_NAME =>] MECHANISM_NAME
13674 -- MECHANISM_NAME ::=
13678 when Pragma_Export_Object
=> Export_Object
: declare
13679 Args
: Args_List
(1 .. 3);
13680 Names
: constant Name_List
(1 .. 3) := (
13685 Internal
: Node_Id
renames Args
(1);
13686 External
: Node_Id
renames Args
(2);
13687 Size
: Node_Id
renames Args
(3);
13691 Gather_Associations
(Names
, Args
);
13692 Process_Extended_Import_Export_Object_Pragma
(
13693 Arg_Internal
=> Internal
,
13694 Arg_External
=> External
,
13698 ----------------------
13699 -- Export_Procedure --
13700 ----------------------
13702 -- pragma Export_Procedure (
13703 -- [Internal =>] LOCAL_NAME
13704 -- [, [External =>] EXTERNAL_SYMBOL]
13705 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13706 -- [, [Mechanism =>] MECHANISM]);
13708 -- EXTERNAL_SYMBOL ::=
13710 -- | static_string_EXPRESSION
13712 -- PARAMETER_TYPES ::=
13714 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13716 -- TYPE_DESIGNATOR ::=
13718 -- | subtype_Name ' Access
13722 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13724 -- MECHANISM_ASSOCIATION ::=
13725 -- [formal_parameter_NAME =>] MECHANISM_NAME
13727 -- MECHANISM_NAME ::=
13731 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13732 Args
: Args_List
(1 .. 4);
13733 Names
: constant Name_List
(1 .. 4) := (
13736 Name_Parameter_Types
,
13739 Internal
: Node_Id
renames Args
(1);
13740 External
: Node_Id
renames Args
(2);
13741 Parameter_Types
: Node_Id
renames Args
(3);
13742 Mechanism
: Node_Id
renames Args
(4);
13746 Gather_Associations
(Names
, Args
);
13747 Process_Extended_Import_Export_Subprogram_Pragma
(
13748 Arg_Internal
=> Internal
,
13749 Arg_External
=> External
,
13750 Arg_Parameter_Types
=> Parameter_Types
,
13751 Arg_Mechanism
=> Mechanism
);
13752 end Export_Procedure
;
13758 -- pragma Export_Value (
13759 -- [Value =>] static_integer_EXPRESSION,
13760 -- [Link_Name =>] static_string_EXPRESSION);
13762 when Pragma_Export_Value
=>
13764 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13765 Check_Arg_Count
(2);
13767 Check_Optional_Identifier
(Arg1
, Name_Value
);
13768 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13770 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13771 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13773 -----------------------------
13774 -- Export_Valued_Procedure --
13775 -----------------------------
13777 -- pragma Export_Valued_Procedure (
13778 -- [Internal =>] LOCAL_NAME
13779 -- [, [External =>] EXTERNAL_SYMBOL,]
13780 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13781 -- [, [Mechanism =>] MECHANISM]);
13783 -- EXTERNAL_SYMBOL ::=
13785 -- | static_string_EXPRESSION
13787 -- PARAMETER_TYPES ::=
13789 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13791 -- TYPE_DESIGNATOR ::=
13793 -- | subtype_Name ' Access
13797 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13799 -- MECHANISM_ASSOCIATION ::=
13800 -- [formal_parameter_NAME =>] MECHANISM_NAME
13802 -- MECHANISM_NAME ::=
13806 when Pragma_Export_Valued_Procedure
=>
13807 Export_Valued_Procedure
: declare
13808 Args
: Args_List
(1 .. 4);
13809 Names
: constant Name_List
(1 .. 4) := (
13812 Name_Parameter_Types
,
13815 Internal
: Node_Id
renames Args
(1);
13816 External
: Node_Id
renames Args
(2);
13817 Parameter_Types
: Node_Id
renames Args
(3);
13818 Mechanism
: Node_Id
renames Args
(4);
13822 Gather_Associations
(Names
, Args
);
13823 Process_Extended_Import_Export_Subprogram_Pragma
(
13824 Arg_Internal
=> Internal
,
13825 Arg_External
=> External
,
13826 Arg_Parameter_Types
=> Parameter_Types
,
13827 Arg_Mechanism
=> Mechanism
);
13828 end Export_Valued_Procedure
;
13830 -------------------
13831 -- Extend_System --
13832 -------------------
13834 -- pragma Extend_System ([Name =>] Identifier);
13836 when Pragma_Extend_System
=> Extend_System
: declare
13839 Check_Valid_Configuration_Pragma
;
13840 Check_Arg_Count
(1);
13841 Check_Optional_Identifier
(Arg1
, Name_Name
);
13842 Check_Arg_Is_Identifier
(Arg1
);
13844 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13847 and then Name_Buffer
(1 .. 4) = "aux_"
13849 if Present
(System_Extend_Pragma_Arg
) then
13850 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13851 Chars
(Expression
(System_Extend_Pragma_Arg
))
13855 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13856 Error_Pragma
("pragma% conflicts with that #");
13860 System_Extend_Pragma_Arg
:= Arg1
;
13862 if not GNAT_Mode
then
13863 System_Extend_Unit
:= Arg1
;
13867 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13871 ------------------------
13872 -- Extensions_Allowed --
13873 ------------------------
13875 -- pragma Extensions_Allowed (ON | OFF);
13877 when Pragma_Extensions_Allowed
=>
13879 Check_Arg_Count
(1);
13880 Check_No_Identifiers
;
13881 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13883 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13884 Extensions_Allowed
:= True;
13885 Ada_Version
:= Ada_Version_Type
'Last;
13888 Extensions_Allowed
:= False;
13889 Ada_Version
:= Ada_Version_Explicit
;
13890 Ada_Version_Pragma
:= Empty
;
13893 ------------------------
13894 -- Extensions_Visible --
13895 ------------------------
13897 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13899 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13900 Context
: constant Node_Id
:= Parent
(N
);
13902 Formal
: Entity_Id
;
13903 Orig_Stmt
: Node_Id
;
13907 Has_OK_Formal
: Boolean := False;
13911 Check_No_Identifiers
;
13912 Check_At_Most_N_Arguments
(1);
13916 while Present
(Stmt
) loop
13918 -- Skip prior pragmas, but check for duplicates
13920 if Nkind
(Stmt
) = N_Pragma
then
13921 if Pragma_Name
(Stmt
) = Pname
then
13922 Error_Msg_Name_1
:= Pname
;
13923 Error_Msg_Sloc
:= Sloc
(Stmt
);
13924 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13927 -- Skip internally generated code
13929 elsif not Comes_From_Source
(Stmt
) then
13930 Orig_Stmt
:= Original_Node
(Stmt
);
13932 -- When pragma Ghost applies to an expression function, the
13933 -- expression function is transformed into a subprogram.
13935 if Nkind
(Stmt
) = N_Subprogram_Declaration
13936 and then Comes_From_Source
(Orig_Stmt
)
13937 and then Nkind
(Orig_Stmt
) = N_Expression_Function
13939 Subp
:= Defining_Entity
(Stmt
);
13943 -- The associated [generic] subprogram declaration has been
13944 -- found, stop the search.
13946 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
13947 N_Subprogram_Declaration
)
13949 Subp
:= Defining_Entity
(Stmt
);
13952 -- The pragma does not apply to a legal construct, issue an
13953 -- error and stop the analysis.
13956 Error_Pragma
("pragma % must apply to a subprogram");
13960 Stmt
:= Prev
(Stmt
);
13963 -- When the pragma applies to a stand alone subprogram body, it
13964 -- appears within the declarations of the body. In that case the
13965 -- enclosing construct is the proper context. This check is done
13966 -- after the traversal above to allow for duplicate detection.
13969 and then Nkind
(Context
) = N_Subprogram_Body
13970 and then No
(Corresponding_Spec
(Context
))
13972 Subp
:= Defining_Entity
(Context
);
13976 Error_Pragma
("pragma % must apply to a subprogram");
13980 -- Examine the formals of the related subprogram
13982 Formal
:= First_Formal
(Subp
);
13983 while Present
(Formal
) loop
13985 -- At least one of the formals is of a specific tagged type,
13986 -- the pragma is legal.
13988 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13989 Has_OK_Formal
:= True;
13992 -- A generic subprogram with at least one formal of a private
13993 -- type ensures the legality of the pragma because the actual
13994 -- may be specifically tagged. Note that this is verified by
13995 -- the check above at instantiation time.
13997 elsif Is_Private_Type
(Etype
(Formal
))
13998 and then Is_Generic_Type
(Etype
(Formal
))
14000 Has_OK_Formal
:= True;
14004 Next_Formal
(Formal
);
14007 if not Has_OK_Formal
then
14008 Error_Msg_Name_1
:= Pname
;
14009 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
14011 ("\subprogram & lacks parameter of specific tagged or "
14012 & "generic private type", N
, Subp
);
14016 -- Analyze the Boolean expression (if any)
14018 if Present
(Arg1
) then
14019 Expr
:= Get_Pragma_Arg
(Arg1
);
14021 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14023 if not Is_OK_Static_Expression
(Expr
) then
14025 ("expression of pragma % must be static", Expr
);
14030 -- Chain the pragma on the contract for further processing
14032 Add_Contract_Item
(N
, Subp
);
14033 end Extensions_Visible
;
14039 -- pragma External (
14040 -- [ Convention =>] convention_IDENTIFIER,
14041 -- [ Entity =>] LOCAL_NAME
14042 -- [, [External_Name =>] static_string_EXPRESSION ]
14043 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14045 when Pragma_External
=> External
: declare
14046 Def_Id
: Entity_Id
;
14049 pragma Warnings
(Off
, C
);
14056 Name_External_Name
,
14058 Check_At_Least_N_Arguments
(2);
14059 Check_At_Most_N_Arguments
(4);
14060 Process_Convention
(C
, Def_Id
);
14061 Note_Possible_Modification
14062 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14063 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14064 Set_Exported
(Def_Id
, Arg2
);
14067 --------------------------
14068 -- External_Name_Casing --
14069 --------------------------
14071 -- pragma External_Name_Casing (
14072 -- UPPERCASE | LOWERCASE
14073 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14075 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14078 Check_No_Identifiers
;
14080 if Arg_Count
= 2 then
14081 Check_Arg_Is_One_Of
14082 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14084 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14086 Opt
.External_Name_Exp_Casing
:= As_Is
;
14088 when Name_Uppercase
=>
14089 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14091 when Name_Lowercase
=>
14092 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14099 Check_Arg_Count
(1);
14102 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14104 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14105 when Name_Uppercase
=>
14106 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14108 when Name_Lowercase
=>
14109 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14114 end External_Name_Casing
;
14120 -- pragma Fast_Math;
14122 when Pragma_Fast_Math
=>
14124 Check_No_Identifiers
;
14125 Check_Valid_Configuration_Pragma
;
14128 --------------------------
14129 -- Favor_Top_Level --
14130 --------------------------
14132 -- pragma Favor_Top_Level (type_NAME);
14134 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14135 Named_Entity
: Entity_Id
;
14139 Check_No_Identifiers
;
14140 Check_Arg_Count
(1);
14141 Check_Arg_Is_Local_Name
(Arg1
);
14142 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14144 -- If it's an access-to-subprogram type (in particular, not a
14145 -- subtype), set the flag on that type.
14147 if Is_Access_Subprogram_Type
(Named_Entity
) then
14148 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14150 -- Otherwise it's an error (name denotes the wrong sort of entity)
14154 ("access-to-subprogram type expected",
14155 Get_Pragma_Arg
(Arg1
));
14157 end Favor_Top_Level
;
14159 ---------------------------
14160 -- Finalize_Storage_Only --
14161 ---------------------------
14163 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14165 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14166 Assoc
: constant Node_Id
:= Arg1
;
14167 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14172 Check_No_Identifiers
;
14173 Check_Arg_Count
(1);
14174 Check_Arg_Is_Local_Name
(Arg1
);
14176 Find_Type
(Type_Id
);
14177 Typ
:= Entity
(Type_Id
);
14180 or else Rep_Item_Too_Early
(Typ
, N
)
14184 Typ
:= Underlying_Type
(Typ
);
14187 if not Is_Controlled
(Typ
) then
14188 Error_Pragma
("pragma% must specify controlled type");
14191 Check_First_Subtype
(Arg1
);
14193 if Finalize_Storage_Only
(Typ
) then
14194 Error_Pragma
("duplicate pragma%, only one allowed");
14196 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14197 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14199 end Finalize_Storage
;
14205 -- pragma Ghost [ (boolean_EXPRESSION) ];
14207 when Pragma_Ghost
=> Ghost
: declare
14211 Orig_Stmt
: Node_Id
;
14212 Prev_Id
: Entity_Id
;
14217 Check_No_Identifiers
;
14218 Check_At_Most_N_Arguments
(1);
14220 Context
:= Parent
(N
);
14222 -- Handle compilation units
14224 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14225 Context
:= Unit
(Parent
(Context
));
14230 while Present
(Stmt
) loop
14232 -- Skip prior pragmas, but check for duplicates
14234 if Nkind
(Stmt
) = N_Pragma
then
14235 if Pragma_Name
(Stmt
) = Pname
then
14236 Error_Msg_Name_1
:= Pname
;
14237 Error_Msg_Sloc
:= Sloc
(Stmt
);
14238 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14241 -- Protected and task types cannot be subject to pragma Ghost
14243 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
14244 Error_Pragma
("pragma % cannot apply to a protected type");
14247 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
14248 Error_Pragma
("pragma % cannot apply to a task type");
14251 -- Skip internally generated code
14253 elsif not Comes_From_Source
(Stmt
) then
14254 Orig_Stmt
:= Original_Node
(Stmt
);
14256 -- When pragma Ghost applies to an untagged derivation, the
14257 -- derivation is transformed into a [sub]type declaration.
14259 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14260 N_Subtype_Declaration
)
14261 and then Comes_From_Source
(Orig_Stmt
)
14262 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14263 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14264 N_Derived_Type_Definition
14266 Id
:= Defining_Entity
(Stmt
);
14269 -- When pragma Ghost applies to an expression function, the
14270 -- expression function is transformed into a subprogram.
14272 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14273 and then Comes_From_Source
(Orig_Stmt
)
14274 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14276 Id
:= Defining_Entity
(Stmt
);
14280 -- The pragma applies to a legal construct, stop the traversal
14282 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14283 N_Full_Type_Declaration
,
14284 N_Generic_Subprogram_Declaration
,
14285 N_Object_Declaration
,
14286 N_Private_Extension_Declaration
,
14287 N_Private_Type_Declaration
,
14288 N_Subprogram_Declaration
,
14289 N_Subtype_Declaration
)
14291 Id
:= Defining_Entity
(Stmt
);
14294 -- The pragma does not apply to a legal construct, issue an
14295 -- error and stop the analysis.
14299 ("pragma % must apply to an object, package, subprogram "
14304 Stmt
:= Prev
(Stmt
);
14309 -- When pragma Ghost is associated with a [generic] package, it
14310 -- appears in the visible declarations.
14312 if Nkind
(Context
) = N_Package_Specification
14313 and then Present
(Visible_Declarations
(Context
))
14314 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14316 Id
:= Defining_Entity
(Context
);
14318 -- Pragma Ghost applies to a stand alone subprogram body
14320 elsif Nkind
(Context
) = N_Subprogram_Body
14321 and then No
(Corresponding_Spec
(Context
))
14323 Id
:= Defining_Entity
(Context
);
14329 ("pragma % must apply to an object, package, subprogram or "
14334 -- A derived type or type extension cannot be subject to pragma
14335 -- Ghost if either the parent type or one of the progenitor types
14336 -- is not Ghost (SPARK RM 6.9(9)).
14338 if Is_Derived_Type
(Id
) then
14339 Check_Ghost_Derivation
(Id
);
14342 -- Handle completions of types and constants that are subject to
14345 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14346 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14348 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14349 Error_Msg_Name_1
:= Pname
;
14351 -- The full declaration of a deferred constant cannot be
14352 -- subject to pragma Ghost unless the deferred declaration
14353 -- is also Ghost (SPARK RM 6.9(10)).
14355 if Ekind
(Prev_Id
) = E_Constant
then
14356 Error_Msg_Name_1
:= Pname
;
14357 Error_Msg_NE
(Fix_Error
14358 ("pragma % must apply to declaration of deferred "
14359 & "constant &"), N
, Id
);
14362 -- Pragma Ghost may appear on the full view of an incomplete
14363 -- type because the incomplete declaration lacks aspects and
14364 -- cannot be subject to pragma Ghost.
14366 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14369 -- The full declaration of a type cannot be subject to
14370 -- pragma Ghost unless the partial view is also Ghost
14371 -- (SPARK RM 6.9(10)).
14374 Error_Msg_NE
(Fix_Error
14375 ("pragma % must apply to partial view of type &"),
14382 -- Analyze the Boolean expression (if any)
14384 if Present
(Arg1
) then
14385 Expr
:= Get_Pragma_Arg
(Arg1
);
14387 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14389 if Is_OK_Static_Expression
(Expr
) then
14391 -- "Ghostness" cannot be turned off once enabled within a
14392 -- region (SPARK RM 6.9(7)).
14394 if Is_False
(Expr_Value
(Expr
))
14395 and then Ghost_Mode
> None
14398 ("pragma % with value False cannot appear in enabled "
14403 -- Otherwie the expression is not static
14407 ("expression of pragma % must be static", Expr
);
14412 Set_Is_Ghost_Entity
(Id
);
14419 -- pragma Global (GLOBAL_SPECIFICATION);
14421 -- GLOBAL_SPECIFICATION ::=
14424 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14426 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14428 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14429 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14430 -- GLOBAL_ITEM ::= NAME
14432 when Pragma_Global
=> Global
: declare
14433 Subp_Decl
: Node_Id
;
14437 Check_Arg_Count
(1);
14438 Ensure_Aggregate_Form
(Arg1
);
14440 -- Ensure the proper placement of the pragma. Global must be
14441 -- associated with a subprogram declaration or a body that acts
14445 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14447 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14450 -- Body acts as spec
14452 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14453 and then No
(Corresponding_Spec
(Subp_Decl
))
14457 -- Body stub acts as spec
14459 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14460 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14469 -- When the pragma appears on a subprogram body, perform the full
14472 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14473 Analyze_Global_In_Decl_Part
(N
);
14475 -- When Global applies to a subprogram compilation unit, the
14476 -- corresponding pragma is placed after the unit's declaration
14477 -- node and needs to be analyzed immediately.
14479 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14480 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14482 Analyze_Global_In_Decl_Part
(N
);
14485 -- Chain the pragma on the contract for further processing
14487 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14494 -- pragma Ident (static_string_EXPRESSION)
14496 -- Note: pragma Comment shares this processing. Pragma Ident is
14497 -- identical in effect to pragma Commment.
14499 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14504 Check_Arg_Count
(1);
14505 Check_No_Identifiers
;
14506 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14509 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14516 GP
:= Parent
(Parent
(N
));
14518 if Nkind_In
(GP
, N_Package_Declaration
,
14519 N_Generic_Package_Declaration
)
14524 -- If we have a compilation unit, then record the ident value,
14525 -- checking for improper duplication.
14527 if Nkind
(GP
) = N_Compilation_Unit
then
14528 CS
:= Ident_String
(Current_Sem_Unit
);
14530 if Present
(CS
) then
14532 -- If we have multiple instances, concatenate them, but
14533 -- not in ASIS, where we want the original tree.
14535 if not ASIS_Mode
then
14536 Start_String
(Strval
(CS
));
14537 Store_String_Char
(' ');
14538 Store_String_Chars
(Strval
(Str
));
14539 Set_Strval
(CS
, End_String
);
14543 Set_Ident_String
(Current_Sem_Unit
, Str
);
14546 -- For subunits, we just ignore the Ident, since in GNAT these
14547 -- are not separate object files, and hence not separate units
14548 -- in the unit table.
14550 elsif Nkind
(GP
) = N_Subunit
then
14556 ----------------------------
14557 -- Implementation_Defined --
14558 ----------------------------
14560 -- pragma Implementation_Defined (LOCAL_NAME);
14562 -- Marks previously declared entity as implementation defined. For
14563 -- an overloaded entity, applies to the most recent homonym.
14565 -- pragma Implementation_Defined;
14567 -- The form with no arguments appears anywhere within a scope, most
14568 -- typically a package spec, and indicates that all entities that are
14569 -- defined within the package spec are Implementation_Defined.
14571 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14576 Check_No_Identifiers
;
14578 -- Form with no arguments
14580 if Arg_Count
= 0 then
14581 Set_Is_Implementation_Defined
(Current_Scope
);
14583 -- Form with one argument
14586 Check_Arg_Count
(1);
14587 Check_Arg_Is_Local_Name
(Arg1
);
14588 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14589 Set_Is_Implementation_Defined
(Ent
);
14591 end Implementation_Defined
;
14597 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14599 -- IMPLEMENTATION_KIND ::=
14600 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14602 -- "By_Any" and "Optional" are treated as synonyms in order to
14603 -- support Ada 2012 aspect Synchronization.
14605 when Pragma_Implemented
=> Implemented
: declare
14606 Proc_Id
: Entity_Id
;
14611 Check_Arg_Count
(2);
14612 Check_No_Identifiers
;
14613 Check_Arg_Is_Identifier
(Arg1
);
14614 Check_Arg_Is_Local_Name
(Arg1
);
14615 Check_Arg_Is_One_Of
(Arg2
,
14618 Name_By_Protected_Procedure
,
14621 -- Extract the name of the local procedure
14623 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14625 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14626 -- primitive procedure of a synchronized tagged type.
14628 if Ekind
(Proc_Id
) = E_Procedure
14629 and then Is_Primitive
(Proc_Id
)
14630 and then Present
(First_Formal
(Proc_Id
))
14632 Typ
:= Etype
(First_Formal
(Proc_Id
));
14634 if Is_Tagged_Type
(Typ
)
14637 -- Check for a protected, a synchronized or a task interface
14639 ((Is_Interface
(Typ
)
14640 and then Is_Synchronized_Interface
(Typ
))
14642 -- Check for a protected type or a task type that implements
14646 (Is_Concurrent_Record_Type
(Typ
)
14647 and then Present
(Interfaces
(Typ
)))
14649 -- In analysis-only mode, examine original protected type
14652 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
14653 and then Present
(Interface_List
(Parent
(Typ
))))
14655 -- Check for a private record extension with keyword
14659 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14660 E_Record_Subtype_With_Private
)
14661 and then Synchronized_Present
(Parent
(Typ
))))
14666 ("controlling formal must be of synchronized tagged type",
14671 -- Procedures declared inside a protected type must be accepted
14673 elsif Ekind
(Proc_Id
) = E_Procedure
14674 and then Is_Protected_Type
(Scope
(Proc_Id
))
14678 -- The first argument is not a primitive procedure
14682 ("pragma % must be applied to a primitive procedure", Arg1
);
14686 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14687 -- By_Protected_Procedure to the primitive procedure of a task
14690 if Chars
(Arg2
) = Name_By_Protected_Procedure
14691 and then Is_Interface
(Typ
)
14692 and then Is_Task_Interface
(Typ
)
14695 ("implementation kind By_Protected_Procedure cannot be "
14696 & "applied to a task interface primitive", Arg2
);
14700 Record_Rep_Item
(Proc_Id
, N
);
14703 ----------------------
14704 -- Implicit_Packing --
14705 ----------------------
14707 -- pragma Implicit_Packing;
14709 when Pragma_Implicit_Packing
=>
14711 Check_Arg_Count
(0);
14712 Implicit_Packing
:= True;
14719 -- [Convention =>] convention_IDENTIFIER,
14720 -- [Entity =>] LOCAL_NAME
14721 -- [, [External_Name =>] static_string_EXPRESSION ]
14722 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14724 when Pragma_Import
=>
14725 Check_Ada_83_Warning
;
14729 Name_External_Name
,
14732 Check_At_Least_N_Arguments
(2);
14733 Check_At_Most_N_Arguments
(4);
14734 Process_Import_Or_Interface
;
14736 ---------------------
14737 -- Import_Function --
14738 ---------------------
14740 -- pragma Import_Function (
14741 -- [Internal =>] LOCAL_NAME,
14742 -- [, [External =>] EXTERNAL_SYMBOL]
14743 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14744 -- [, [Result_Type =>] SUBTYPE_MARK]
14745 -- [, [Mechanism =>] MECHANISM]
14746 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14748 -- EXTERNAL_SYMBOL ::=
14750 -- | static_string_EXPRESSION
14752 -- PARAMETER_TYPES ::=
14754 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14756 -- TYPE_DESIGNATOR ::=
14758 -- | subtype_Name ' Access
14762 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14764 -- MECHANISM_ASSOCIATION ::=
14765 -- [formal_parameter_NAME =>] MECHANISM_NAME
14767 -- MECHANISM_NAME ::=
14771 when Pragma_Import_Function
=> Import_Function
: declare
14772 Args
: Args_List
(1 .. 6);
14773 Names
: constant Name_List
(1 .. 6) := (
14776 Name_Parameter_Types
,
14779 Name_Result_Mechanism
);
14781 Internal
: Node_Id
renames Args
(1);
14782 External
: Node_Id
renames Args
(2);
14783 Parameter_Types
: Node_Id
renames Args
(3);
14784 Result_Type
: Node_Id
renames Args
(4);
14785 Mechanism
: Node_Id
renames Args
(5);
14786 Result_Mechanism
: Node_Id
renames Args
(6);
14790 Gather_Associations
(Names
, Args
);
14791 Process_Extended_Import_Export_Subprogram_Pragma
(
14792 Arg_Internal
=> Internal
,
14793 Arg_External
=> External
,
14794 Arg_Parameter_Types
=> Parameter_Types
,
14795 Arg_Result_Type
=> Result_Type
,
14796 Arg_Mechanism
=> Mechanism
,
14797 Arg_Result_Mechanism
=> Result_Mechanism
);
14798 end Import_Function
;
14800 -------------------
14801 -- Import_Object --
14802 -------------------
14804 -- pragma Import_Object (
14805 -- [Internal =>] LOCAL_NAME
14806 -- [, [External =>] EXTERNAL_SYMBOL]
14807 -- [, [Size =>] EXTERNAL_SYMBOL]);
14809 -- EXTERNAL_SYMBOL ::=
14811 -- | static_string_EXPRESSION
14813 when Pragma_Import_Object
=> Import_Object
: declare
14814 Args
: Args_List
(1 .. 3);
14815 Names
: constant Name_List
(1 .. 3) := (
14820 Internal
: Node_Id
renames Args
(1);
14821 External
: Node_Id
renames Args
(2);
14822 Size
: Node_Id
renames Args
(3);
14826 Gather_Associations
(Names
, Args
);
14827 Process_Extended_Import_Export_Object_Pragma
(
14828 Arg_Internal
=> Internal
,
14829 Arg_External
=> External
,
14833 ----------------------
14834 -- Import_Procedure --
14835 ----------------------
14837 -- pragma Import_Procedure (
14838 -- [Internal =>] LOCAL_NAME
14839 -- [, [External =>] EXTERNAL_SYMBOL]
14840 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14841 -- [, [Mechanism =>] MECHANISM]);
14843 -- EXTERNAL_SYMBOL ::=
14845 -- | static_string_EXPRESSION
14847 -- PARAMETER_TYPES ::=
14849 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14851 -- TYPE_DESIGNATOR ::=
14853 -- | subtype_Name ' Access
14857 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14859 -- MECHANISM_ASSOCIATION ::=
14860 -- [formal_parameter_NAME =>] MECHANISM_NAME
14862 -- MECHANISM_NAME ::=
14866 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14867 Args
: Args_List
(1 .. 4);
14868 Names
: constant Name_List
(1 .. 4) := (
14871 Name_Parameter_Types
,
14874 Internal
: Node_Id
renames Args
(1);
14875 External
: Node_Id
renames Args
(2);
14876 Parameter_Types
: Node_Id
renames Args
(3);
14877 Mechanism
: Node_Id
renames Args
(4);
14881 Gather_Associations
(Names
, Args
);
14882 Process_Extended_Import_Export_Subprogram_Pragma
(
14883 Arg_Internal
=> Internal
,
14884 Arg_External
=> External
,
14885 Arg_Parameter_Types
=> Parameter_Types
,
14886 Arg_Mechanism
=> Mechanism
);
14887 end Import_Procedure
;
14889 -----------------------------
14890 -- Import_Valued_Procedure --
14891 -----------------------------
14893 -- pragma Import_Valued_Procedure (
14894 -- [Internal =>] LOCAL_NAME
14895 -- [, [External =>] EXTERNAL_SYMBOL]
14896 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14897 -- [, [Mechanism =>] MECHANISM]);
14899 -- EXTERNAL_SYMBOL ::=
14901 -- | static_string_EXPRESSION
14903 -- PARAMETER_TYPES ::=
14905 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14907 -- TYPE_DESIGNATOR ::=
14909 -- | subtype_Name ' Access
14913 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14915 -- MECHANISM_ASSOCIATION ::=
14916 -- [formal_parameter_NAME =>] MECHANISM_NAME
14918 -- MECHANISM_NAME ::=
14922 when Pragma_Import_Valued_Procedure
=>
14923 Import_Valued_Procedure
: declare
14924 Args
: Args_List
(1 .. 4);
14925 Names
: constant Name_List
(1 .. 4) := (
14928 Name_Parameter_Types
,
14931 Internal
: Node_Id
renames Args
(1);
14932 External
: Node_Id
renames Args
(2);
14933 Parameter_Types
: Node_Id
renames Args
(3);
14934 Mechanism
: Node_Id
renames Args
(4);
14938 Gather_Associations
(Names
, Args
);
14939 Process_Extended_Import_Export_Subprogram_Pragma
(
14940 Arg_Internal
=> Internal
,
14941 Arg_External
=> External
,
14942 Arg_Parameter_Types
=> Parameter_Types
,
14943 Arg_Mechanism
=> Mechanism
);
14944 end Import_Valued_Procedure
;
14950 -- pragma Independent (LOCAL_NAME);
14952 when Pragma_Independent
=>
14953 Process_Atomic_Independent_Shared_Volatile
;
14955 ----------------------------
14956 -- Independent_Components --
14957 ----------------------------
14959 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
14961 when Pragma_Independent_Components
=> Independent_Components
: declare
14969 Check_Ada_83_Warning
;
14971 Check_No_Identifiers
;
14972 Check_Arg_Count
(1);
14973 Check_Arg_Is_Local_Name
(Arg1
);
14974 E_Id
:= Get_Pragma_Arg
(Arg1
);
14976 if Etype
(E_Id
) = Any_Type
then
14980 E
:= Entity
(E_Id
);
14982 -- Check duplicate before we chain ourselves
14984 Check_Duplicate_Pragma
(E
);
14986 -- Check appropriate entity
14988 if Rep_Item_Too_Early
(E
, N
)
14990 Rep_Item_Too_Late
(E
, N
)
14995 D
:= Declaration_Node
(E
);
14998 -- The flag is set on the base type, or on the object
15000 if K
= N_Full_Type_Declaration
15001 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15003 Set_Has_Independent_Components
(Base_Type
(E
));
15004 Independence_Checks
.Append
((N
, Base_Type
(E
)));
15006 -- For record type, set all components independent
15008 if Is_Record_Type
(E
) then
15009 C
:= First_Component
(E
);
15010 while Present
(C
) loop
15011 Set_Is_Independent
(C
);
15012 Next_Component
(C
);
15016 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15017 and then Nkind
(D
) = N_Object_Declaration
15018 and then Nkind
(Object_Definition
(D
)) =
15019 N_Constrained_Array_Definition
15021 Set_Has_Independent_Components
(E
);
15022 Independence_Checks
.Append
((N
, E
));
15025 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15027 end Independent_Components
;
15029 -----------------------
15030 -- Initial_Condition --
15031 -----------------------
15033 -- pragma Initial_Condition (boolean_EXPRESSION);
15035 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15036 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15037 Pack_Id
: Entity_Id
;
15042 Check_No_Identifiers
;
15043 Check_Arg_Count
(1);
15045 -- Ensure the proper placement of the pragma. Initial_Condition
15046 -- must be associated with a package declaration.
15048 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15049 N_Package_Declaration
)
15056 while Present
(Stmt
) loop
15058 -- Skip prior pragmas, but check for duplicates
15060 if Nkind
(Stmt
) = N_Pragma
then
15061 if Pragma_Name
(Stmt
) = Pname
then
15062 Error_Msg_Name_1
:= Pname
;
15063 Error_Msg_Sloc
:= Sloc
(Stmt
);
15064 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15067 -- Skip internally generated code
15069 elsif not Comes_From_Source
(Stmt
) then
15072 -- The pragma does not apply to a legal construct, issue an
15073 -- error and stop the analysis.
15080 Stmt
:= Prev
(Stmt
);
15083 -- The pragma must be analyzed at the end of the visible
15084 -- declarations of the related package. Save the pragma for later
15085 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15086 -- the contract of the package.
15088 Pack_Id
:= Defining_Entity
(Context
);
15089 Add_Contract_Item
(N
, Pack_Id
);
15091 -- Verify the declaration order of pragma Initial_Condition with
15092 -- respect to pragmas Abstract_State and Initializes when SPARK
15093 -- checks are enabled.
15095 if SPARK_Mode
/= Off
then
15096 Check_Declaration_Order
15097 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15100 Check_Declaration_Order
15101 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
15104 end Initial_Condition
;
15106 ------------------------
15107 -- Initialize_Scalars --
15108 ------------------------
15110 -- pragma Initialize_Scalars;
15112 when Pragma_Initialize_Scalars
=>
15114 Check_Arg_Count
(0);
15115 Check_Valid_Configuration_Pragma
;
15116 Check_Restriction
(No_Initialize_Scalars
, N
);
15118 -- Initialize_Scalars creates false positives in CodePeer, and
15119 -- incorrect negative results in GNATprove mode, so ignore this
15120 -- pragma in these modes.
15122 if not Restriction_Active
(No_Initialize_Scalars
)
15123 and then not (CodePeer_Mode
or GNATprove_Mode
)
15125 Init_Or_Norm_Scalars
:= True;
15126 Initialize_Scalars
:= True;
15133 -- pragma Initializes (INITIALIZATION_SPEC);
15135 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15137 -- INITIALIZATION_LIST ::=
15138 -- INITIALIZATION_ITEM
15139 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15141 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15146 -- | (INPUT {, INPUT})
15150 when Pragma_Initializes
=> Initializes
: declare
15151 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15152 Pack_Id
: Entity_Id
;
15157 Check_No_Identifiers
;
15158 Check_Arg_Count
(1);
15159 Ensure_Aggregate_Form
(Arg1
);
15161 -- Ensure the proper placement of the pragma. Initializes must be
15162 -- associated with a package declaration.
15164 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15165 N_Package_Declaration
)
15172 while Present
(Stmt
) loop
15174 -- Skip prior pragmas, but check for duplicates
15176 if Nkind
(Stmt
) = N_Pragma
then
15177 if Pragma_Name
(Stmt
) = Pname
then
15178 Error_Msg_Name_1
:= Pname
;
15179 Error_Msg_Sloc
:= Sloc
(Stmt
);
15180 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15183 -- Skip internally generated code
15185 elsif not Comes_From_Source
(Stmt
) then
15188 -- The pragma does not apply to a legal construct, issue an
15189 -- error and stop the analysis.
15196 Stmt
:= Prev
(Stmt
);
15199 -- The pragma must be analyzed at the end of the visible
15200 -- declarations of the related package. Save the pragma for later
15201 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15202 -- contract of the package.
15204 Pack_Id
:= Defining_Entity
(Context
);
15205 Add_Contract_Item
(N
, Pack_Id
);
15207 -- Verify the declaration order of pragmas Abstract_State and
15208 -- Initializes when SPARK checks are enabled.
15210 if SPARK_Mode
/= Off
then
15211 Check_Declaration_Order
15212 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15221 -- pragma Inline ( NAME {, NAME} );
15223 when Pragma_Inline
=>
15225 -- Pragma always active unless in GNATprove mode. It is disabled
15226 -- in GNATprove mode because frontend inlining is applied
15227 -- independently of pragmas Inline and Inline_Always for
15228 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15231 if not GNATprove_Mode
then
15233 -- Inline status is Enabled if inlining option is active
15235 if Inline_Active
then
15236 Process_Inline
(Enabled
);
15238 Process_Inline
(Disabled
);
15242 -------------------
15243 -- Inline_Always --
15244 -------------------
15246 -- pragma Inline_Always ( NAME {, NAME} );
15248 when Pragma_Inline_Always
=>
15251 -- Pragma always active unless in CodePeer mode or GNATprove
15252 -- mode. It is disabled in CodePeer mode because inlining is
15253 -- not helpful, and enabling it caused walk order issues. It
15254 -- is disabled in GNATprove mode because frontend inlining is
15255 -- applied independently of pragmas Inline and Inline_Always for
15256 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15259 if not CodePeer_Mode
and not GNATprove_Mode
then
15260 Process_Inline
(Enabled
);
15263 --------------------
15264 -- Inline_Generic --
15265 --------------------
15267 -- pragma Inline_Generic (NAME {, NAME});
15269 when Pragma_Inline_Generic
=>
15271 Process_Generic_List
;
15273 ----------------------
15274 -- Inspection_Point --
15275 ----------------------
15277 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15279 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15286 if Arg_Count
> 0 then
15289 Exp
:= Get_Pragma_Arg
(Arg
);
15292 if not Is_Entity_Name
(Exp
)
15293 or else not Is_Object
(Entity
(Exp
))
15295 Error_Pragma_Arg
("object name required", Arg
);
15299 exit when No
(Arg
);
15302 end Inspection_Point
;
15308 -- pragma Interface (
15309 -- [ Convention =>] convention_IDENTIFIER,
15310 -- [ Entity =>] LOCAL_NAME
15311 -- [, [External_Name =>] static_string_EXPRESSION ]
15312 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15314 when Pragma_Interface
=>
15319 Name_External_Name
,
15321 Check_At_Least_N_Arguments
(2);
15322 Check_At_Most_N_Arguments
(4);
15323 Process_Import_Or_Interface
;
15325 -- In Ada 2005, the permission to use Interface (a reserved word)
15326 -- as a pragma name is considered an obsolescent feature, and this
15327 -- pragma was already obsolescent in Ada 95.
15329 if Ada_Version
>= Ada_95
then
15331 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15333 if Warn_On_Obsolescent_Feature
then
15335 ("pragma Interface is an obsolescent feature?j?", N
);
15337 ("|use pragma Import instead?j?", N
);
15341 --------------------
15342 -- Interface_Name --
15343 --------------------
15345 -- pragma Interface_Name (
15346 -- [ Entity =>] LOCAL_NAME
15347 -- [,[External_Name =>] static_string_EXPRESSION ]
15348 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15350 when Pragma_Interface_Name
=> Interface_Name
: declare
15352 Def_Id
: Entity_Id
;
15353 Hom_Id
: Entity_Id
;
15359 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15360 Check_At_Least_N_Arguments
(2);
15361 Check_At_Most_N_Arguments
(3);
15362 Id
:= Get_Pragma_Arg
(Arg1
);
15365 -- This is obsolete from Ada 95 on, but it is an implementation
15366 -- defined pragma, so we do not consider that it violates the
15367 -- restriction (No_Obsolescent_Features).
15369 if Ada_Version
>= Ada_95
then
15370 if Warn_On_Obsolescent_Feature
then
15372 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15374 ("|use pragma Import instead?j?", N
);
15378 if not Is_Entity_Name
(Id
) then
15380 ("first argument for pragma% must be entity name", Arg1
);
15381 elsif Etype
(Id
) = Any_Type
then
15384 Def_Id
:= Entity
(Id
);
15387 -- Special DEC-compatible processing for the object case, forces
15388 -- object to be imported.
15390 if Ekind
(Def_Id
) = E_Variable
then
15391 Kill_Size_Check_Code
(Def_Id
);
15392 Note_Possible_Modification
(Id
, Sure
=> False);
15394 -- Initialization is not allowed for imported variable
15396 if Present
(Expression
(Parent
(Def_Id
)))
15397 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15399 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15401 ("no initialization allowed for declaration of& #",
15405 -- For compatibility, support VADS usage of providing both
15406 -- pragmas Interface and Interface_Name to obtain the effect
15407 -- of a single Import pragma.
15409 if Is_Imported
(Def_Id
)
15410 and then Present
(First_Rep_Item
(Def_Id
))
15411 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15413 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15417 Set_Imported
(Def_Id
);
15420 Set_Is_Public
(Def_Id
);
15421 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15424 -- Otherwise must be subprogram
15426 elsif not Is_Subprogram
(Def_Id
) then
15428 ("argument of pragma% is not subprogram", Arg1
);
15431 Check_At_Most_N_Arguments
(3);
15435 -- Loop through homonyms
15438 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15440 if Is_Imported
(Def_Id
) then
15441 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15445 exit when From_Aspect_Specification
(N
);
15446 Hom_Id
:= Homonym
(Hom_Id
);
15448 exit when No
(Hom_Id
)
15449 or else Scope
(Hom_Id
) /= Current_Scope
;
15454 ("argument of pragma% is not imported subprogram",
15458 end Interface_Name
;
15460 -----------------------
15461 -- Interrupt_Handler --
15462 -----------------------
15464 -- pragma Interrupt_Handler (handler_NAME);
15466 when Pragma_Interrupt_Handler
=>
15467 Check_Ada_83_Warning
;
15468 Check_Arg_Count
(1);
15469 Check_No_Identifiers
;
15471 if No_Run_Time_Mode
then
15472 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15474 Check_Interrupt_Or_Attach_Handler
;
15475 Process_Interrupt_Or_Attach_Handler
;
15478 ------------------------
15479 -- Interrupt_Priority --
15480 ------------------------
15482 -- pragma Interrupt_Priority [(EXPRESSION)];
15484 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15485 P
: constant Node_Id
:= Parent
(N
);
15490 Check_Ada_83_Warning
;
15492 if Arg_Count
/= 0 then
15493 Arg
:= Get_Pragma_Arg
(Arg1
);
15494 Check_Arg_Count
(1);
15495 Check_No_Identifiers
;
15497 -- The expression must be analyzed in the special manner
15498 -- described in "Handling of Default and Per-Object
15499 -- Expressions" in sem.ads.
15501 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15504 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15509 Ent
:= Defining_Identifier
(Parent
(P
));
15511 -- Check duplicate pragma before we chain the pragma in the Rep
15512 -- Item chain of Ent.
15514 Check_Duplicate_Pragma
(Ent
);
15515 Record_Rep_Item
(Ent
, N
);
15517 end Interrupt_Priority
;
15519 ---------------------
15520 -- Interrupt_State --
15521 ---------------------
15523 -- pragma Interrupt_State (
15524 -- [Name =>] INTERRUPT_ID,
15525 -- [State =>] INTERRUPT_STATE);
15527 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15528 -- INTERRUPT_STATE => System | Runtime | User
15530 -- Note: if the interrupt id is given as an identifier, then it must
15531 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15532 -- given as a static integer expression which must be in the range of
15533 -- Ada.Interrupts.Interrupt_ID.
15535 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15536 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15537 -- This is the entity Ada.Interrupts.Interrupt_ID;
15539 State_Type
: Character;
15540 -- Set to 's'/'r'/'u' for System/Runtime/User
15543 -- Index to entry in Interrupt_States table
15546 -- Value of interrupt
15548 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15549 -- The first argument to the pragma
15551 Int_Ent
: Entity_Id
;
15552 -- Interrupt entity in Ada.Interrupts.Names
15556 Check_Arg_Order
((Name_Name
, Name_State
));
15557 Check_Arg_Count
(2);
15559 Check_Optional_Identifier
(Arg1
, Name_Name
);
15560 Check_Optional_Identifier
(Arg2
, Name_State
);
15561 Check_Arg_Is_Identifier
(Arg2
);
15563 -- First argument is identifier
15565 if Nkind
(Arg1X
) = N_Identifier
then
15567 -- Search list of names in Ada.Interrupts.Names
15569 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15571 if No
(Int_Ent
) then
15572 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15574 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15575 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15579 Next_Entity
(Int_Ent
);
15582 -- First argument is not an identifier, so it must be a static
15583 -- expression of type Ada.Interrupts.Interrupt_ID.
15586 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15587 Int_Val
:= Expr_Value
(Arg1X
);
15589 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15591 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15594 ("value not in range of type "
15595 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15601 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15602 when Name_Runtime
=> State_Type
:= 'r';
15603 when Name_System
=> State_Type
:= 's';
15604 when Name_User
=> State_Type
:= 'u';
15607 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15610 -- Check if entry is already stored
15612 IST_Num
:= Interrupt_States
.First
;
15614 -- If entry not found, add it
15616 if IST_Num
> Interrupt_States
.Last
then
15617 Interrupt_States
.Append
15618 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15619 Interrupt_State
=> State_Type
,
15620 Pragma_Loc
=> Loc
));
15623 -- Case of entry for the same entry
15625 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15628 -- If state matches, done, no need to make redundant entry
15631 State_Type
= Interrupt_States
.Table
(IST_Num
).
15634 -- Otherwise if state does not match, error
15637 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15639 ("state conflicts with that given #", Arg2
);
15643 IST_Num
:= IST_Num
+ 1;
15645 end Interrupt_State
;
15651 -- pragma Invariant
15652 -- ([Entity =>] type_LOCAL_NAME,
15653 -- [Check =>] EXPRESSION
15654 -- [,[Message =>] String_Expression]);
15656 when Pragma_Invariant
=> Invariant
: declare
15663 Check_At_Least_N_Arguments
(2);
15664 Check_At_Most_N_Arguments
(3);
15665 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15666 Check_Optional_Identifier
(Arg2
, Name_Check
);
15668 if Arg_Count
= 3 then
15669 Check_Optional_Identifier
(Arg3
, Name_Message
);
15670 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15673 Check_Arg_Is_Local_Name
(Arg1
);
15675 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15676 Find_Type
(Type_Id
);
15677 Typ
:= Entity
(Type_Id
);
15679 if Typ
= Any_Type
then
15682 -- An invariant must apply to a private type, or appear in the
15683 -- private part of a package spec and apply to a completion.
15684 -- a class-wide invariant can only appear on a private declaration
15685 -- or private extension, not a completion.
15687 elsif Ekind_In
(Typ
, E_Private_Type
,
15688 E_Record_Type_With_Private
,
15689 E_Limited_Private_Type
)
15693 elsif In_Private_Part
(Current_Scope
)
15694 and then Has_Private_Declaration
(Typ
)
15695 and then not Class_Present
(N
)
15699 elsif In_Private_Part
(Current_Scope
) then
15701 ("pragma% only allowed for private type declared in "
15702 & "visible part", Arg1
);
15706 ("pragma% only allowed for private type", Arg1
);
15709 -- Not allowed for abstract type
15711 if Is_Abstract_Type
(Typ
) then
15713 ("pragma% not allowed for abstract type", Arg1
);
15716 -- Note that the type has at least one invariant, and also that
15717 -- it has inheritable invariants if we have Invariant'Class
15718 -- or Type_Invariant'Class. Build the corresponding invariant
15719 -- procedure declaration, so that calls to it can be generated
15720 -- before the body is built (e.g. within an expression function).
15722 Insert_After_And_Analyze
15723 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15725 if Class_Present
(N
) then
15726 Set_Has_Inheritable_Invariants
(Typ
);
15729 -- The remaining processing is simply to link the pragma on to
15730 -- the rep item chain, for processing when the type is frozen.
15731 -- This is accomplished by a call to Rep_Item_Too_Late.
15733 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15736 ----------------------
15737 -- Java_Constructor --
15738 ----------------------
15740 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15742 -- Also handles pragma CIL_Constructor
15744 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15745 Java_Constructor
: declare
15746 Convention
: Convention_Id
;
15747 Def_Id
: Entity_Id
;
15748 Hom_Id
: Entity_Id
;
15750 This_Formal
: Entity_Id
;
15754 Check_Arg_Count
(1);
15755 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15756 Check_Arg_Is_Local_Name
(Arg1
);
15758 Id
:= Get_Pragma_Arg
(Arg1
);
15759 Find_Program_Unit_Name
(Id
);
15761 -- If we did not find the name, we are done
15763 if Etype
(Id
) = Any_Type
then
15767 -- Check wrong use of pragma in wrong VM target
15769 if VM_Target
= No_VM
then
15772 elsif VM_Target
= CLI_Target
15773 and then Prag_Id
= Pragma_Java_Constructor
15775 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15777 elsif VM_Target
= JVM_Target
15778 and then Prag_Id
= Pragma_CIL_Constructor
15780 Error_Pragma
("must use pragma 'Java_'Constructor");
15784 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15785 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15786 when others => null;
15789 Hom_Id
:= Entity
(Id
);
15791 -- Loop through homonyms
15794 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15796 -- The constructor is required to be a function
15798 if Ekind
(Def_Id
) /= E_Function
then
15799 if VM_Target
= JVM_Target
then
15801 ("pragma% requires function returning a 'Java access "
15805 ("pragma% requires function returning a 'C'I'L access "
15810 -- Check arguments: For tagged type the first formal must be
15811 -- named "this" and its type must be a named access type
15812 -- designating a class-wide tagged type that has convention
15813 -- CIL/Java. The first formal must also have a null default
15814 -- value. For example:
15816 -- type Typ is tagged ...
15817 -- type Ref is access all Typ;
15818 -- pragma Convention (CIL, Typ);
15820 -- function New_Typ (This : Ref) return Ref;
15821 -- function New_Typ (This : Ref; I : Integer) return Ref;
15822 -- pragma Cil_Constructor (New_Typ);
15824 -- Reason: The first formal must NOT be a primitive of the
15827 -- This rule also applies to constructors of delegates used
15828 -- to interface with standard target libraries. For example:
15830 -- type Delegate is access procedure ...
15831 -- pragma Import (CIL, Delegate, ...);
15833 -- function new_Delegate
15834 -- (This : Delegate := null; ... ) return Delegate;
15836 -- For value-types this rule does not apply.
15838 if not Is_Value_Type
(Etype
(Def_Id
)) then
15839 if No
(First_Formal
(Def_Id
)) then
15840 Error_Msg_Name_1
:= Pname
;
15841 Error_Msg_N
("% function must have parameters", Def_Id
);
15845 -- In the JRE library we have several occurrences in which
15846 -- the "this" parameter is not the first formal.
15848 This_Formal
:= First_Formal
(Def_Id
);
15850 -- In the JRE library we have several occurrences in which
15851 -- the "this" parameter is not the first formal. Search for
15854 if VM_Target
= JVM_Target
then
15855 while Present
(This_Formal
)
15856 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15858 Next_Formal
(This_Formal
);
15861 if No
(This_Formal
) then
15862 This_Formal
:= First_Formal
(Def_Id
);
15866 -- Warning: The first parameter should be named "this".
15867 -- We temporarily allow it because we have the following
15868 -- case in the Java runtime (file s-osinte.ads) ???
15870 -- function new_Thread
15871 -- (Self_Id : System.Address) return Thread_Id;
15872 -- pragma Java_Constructor (new_Thread);
15874 if VM_Target
= JVM_Target
15875 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15877 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15881 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15882 Error_Msg_Name_1
:= Pname
;
15884 ("first formal of % function must be named `this`",
15885 Parent
(This_Formal
));
15887 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15888 Error_Msg_Name_1
:= Pname
;
15890 ("first formal of % function must be an access type",
15891 Parameter_Type
(Parent
(This_Formal
)));
15893 -- For delegates the type of the first formal must be a
15894 -- named access-to-subprogram type (see previous example)
15896 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15897 and then Ekind
(Etype
(This_Formal
))
15898 /= E_Access_Subprogram_Type
15900 Error_Msg_Name_1
:= Pname
;
15902 ("first formal of % function must be a named access "
15903 & "to subprogram type",
15904 Parameter_Type
(Parent
(This_Formal
)));
15906 -- Warning: We should reject anonymous access types because
15907 -- the constructor must not be handled as a primitive of the
15908 -- tagged type. We temporarily allow it because this profile
15909 -- is currently generated by cil2ada???
15911 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15912 and then not Ekind_In
(Etype
(This_Formal
),
15914 E_General_Access_Type
,
15915 E_Anonymous_Access_Type
)
15917 Error_Msg_Name_1
:= Pname
;
15919 ("first formal of % function must be a named access "
15920 & "type", Parameter_Type
(Parent
(This_Formal
)));
15922 elsif Atree
.Convention
15923 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15925 Error_Msg_Name_1
:= Pname
;
15927 if Convention
= Convention_Java
then
15929 ("pragma% requires convention 'Cil in designated "
15930 & "type", Parameter_Type
(Parent
(This_Formal
)));
15933 ("pragma% requires convention 'Java in designated "
15934 & "type", Parameter_Type
(Parent
(This_Formal
)));
15937 elsif No
(Expression
(Parent
(This_Formal
)))
15938 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15940 Error_Msg_Name_1
:= Pname
;
15942 ("pragma% requires first formal with default `null`",
15943 Parameter_Type
(Parent
(This_Formal
)));
15947 -- Check result type: the constructor must be a function
15949 -- * a value type (only allowed in the CIL compiler)
15950 -- * an access-to-subprogram type with convention Java/CIL
15951 -- * an access-type designating a type that has convention
15954 if Is_Value_Type
(Etype
(Def_Id
)) then
15957 -- Access-to-subprogram type with convention Java/CIL
15959 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15960 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15961 if Convention
= Convention_Java
then
15963 ("pragma% requires function returning a 'Java "
15964 & "access type", Arg1
);
15966 pragma Assert
(Convention
= Convention_CIL
);
15968 ("pragma% requires function returning a 'C'I'L "
15969 & "access type", Arg1
);
15973 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15974 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15975 E_General_Access_Type
)
15978 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15980 Error_Msg_Name_1
:= Pname
;
15982 if Convention
= Convention_Java
then
15984 ("pragma% requires function returning a named "
15985 & "'Java access type", Arg1
);
15988 ("pragma% requires function returning a named "
15989 & "'C'I'L access type", Arg1
);
15994 Set_Is_Constructor
(Def_Id
);
15995 Set_Convention
(Def_Id
, Convention
);
15996 Set_Is_Imported
(Def_Id
);
15998 exit when From_Aspect_Specification
(N
);
15999 Hom_Id
:= Homonym
(Hom_Id
);
16001 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
16003 end Java_Constructor
;
16005 ----------------------
16006 -- Java_Interface --
16007 ----------------------
16009 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16011 when Pragma_Java_Interface
=> Java_Interface
: declare
16017 Check_Arg_Count
(1);
16018 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16019 Check_Arg_Is_Local_Name
(Arg1
);
16021 Arg
:= Get_Pragma_Arg
(Arg1
);
16024 if Etype
(Arg
) = Any_Type
then
16028 if not Is_Entity_Name
(Arg
)
16029 or else not Is_Type
(Entity
(Arg
))
16031 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
16034 Typ
:= Underlying_Type
(Entity
(Arg
));
16036 -- For now simply check some of the semantic constraints on the
16037 -- type. This currently leaves out some restrictions on interface
16038 -- types, namely that the parent type must be java.lang.Object.Typ
16039 -- and that all primitives of the type should be declared
16042 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
16044 ("pragma% requires an abstract tagged type", Arg1
);
16046 elsif not Has_Discriminants
(Typ
)
16047 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
16048 /= E_Anonymous_Access_Type
16050 not Is_Class_Wide_Type
16051 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
16054 ("type must have a class-wide access discriminant", Arg1
);
16056 end Java_Interface
;
16062 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16064 when Pragma_Keep_Names
=> Keep_Names
: declare
16069 Check_Arg_Count
(1);
16070 Check_Optional_Identifier
(Arg1
, Name_On
);
16071 Check_Arg_Is_Local_Name
(Arg1
);
16073 Arg
:= Get_Pragma_Arg
(Arg1
);
16076 if Etype
(Arg
) = Any_Type
then
16080 if not Is_Entity_Name
(Arg
)
16081 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16084 ("pragma% requires a local enumeration type", Arg1
);
16087 Set_Discard_Names
(Entity
(Arg
), False);
16094 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16096 when Pragma_License
=>
16099 -- Do not analyze pragma any further in CodePeer mode, to avoid
16100 -- extraneous errors in this implementation-dependent pragma,
16101 -- which has a different profile on other compilers.
16103 if CodePeer_Mode
then
16107 Check_Arg_Count
(1);
16108 Check_No_Identifiers
;
16109 Check_Valid_Configuration_Pragma
;
16110 Check_Arg_Is_Identifier
(Arg1
);
16113 Sind
: constant Source_File_Index
:=
16114 Source_Index
(Current_Sem_Unit
);
16117 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16119 Set_License
(Sind
, GPL
);
16121 when Name_Modified_GPL
=>
16122 Set_License
(Sind
, Modified_GPL
);
16124 when Name_Restricted
=>
16125 Set_License
(Sind
, Restricted
);
16127 when Name_Unrestricted
=>
16128 Set_License
(Sind
, Unrestricted
);
16131 Error_Pragma_Arg
("invalid license name", Arg1
);
16139 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16141 when Pragma_Link_With
=> Link_With
: declare
16147 if Operating_Mode
= Generate_Code
16148 and then In_Extended_Main_Source_Unit
(N
)
16150 Check_At_Least_N_Arguments
(1);
16151 Check_No_Identifiers
;
16152 Check_Is_In_Decl_Part_Or_Package_Spec
;
16153 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16157 while Present
(Arg
) loop
16158 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16160 -- Store argument, converting sequences of spaces to a
16161 -- single null character (this is one of the differences
16162 -- in processing between Link_With and Linker_Options).
16164 Arg_Store
: declare
16165 C
: constant Char_Code
:= Get_Char_Code
(' ');
16166 S
: constant String_Id
:=
16167 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16168 L
: constant Nat
:= String_Length
(S
);
16171 procedure Skip_Spaces
;
16172 -- Advance F past any spaces
16178 procedure Skip_Spaces
is
16180 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16185 -- Start of processing for Arg_Store
16188 Skip_Spaces
; -- skip leading spaces
16190 -- Loop through characters, changing any embedded
16191 -- sequence of spaces to a single null character (this
16192 -- is how Link_With/Linker_Options differ)
16195 if Get_String_Char
(S
, F
) = C
then
16198 Store_String_Char
(ASCII
.NUL
);
16201 Store_String_Char
(Get_String_Char
(S
, F
));
16209 if Present
(Arg
) then
16210 Store_String_Char
(ASCII
.NUL
);
16214 Store_Linker_Option_String
(End_String
);
16222 -- pragma Linker_Alias (
16223 -- [Entity =>] LOCAL_NAME
16224 -- [Target =>] static_string_EXPRESSION);
16226 when Pragma_Linker_Alias
=>
16228 Check_Arg_Order
((Name_Entity
, Name_Target
));
16229 Check_Arg_Count
(2);
16230 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16231 Check_Optional_Identifier
(Arg2
, Name_Target
);
16232 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16233 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16235 -- The only processing required is to link this item on to the
16236 -- list of rep items for the given entity. This is accomplished
16237 -- by the call to Rep_Item_Too_Late (when no error is detected
16238 -- and False is returned).
16240 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16243 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16246 ------------------------
16247 -- Linker_Constructor --
16248 ------------------------
16250 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16252 -- Code is shared with Linker_Destructor
16254 -----------------------
16255 -- Linker_Destructor --
16256 -----------------------
16258 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16260 when Pragma_Linker_Constructor |
16261 Pragma_Linker_Destructor
=>
16262 Linker_Constructor
: declare
16268 Check_Arg_Count
(1);
16269 Check_No_Identifiers
;
16270 Check_Arg_Is_Local_Name
(Arg1
);
16271 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16273 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16275 if not Is_Library_Level_Entity
(Proc
) then
16277 ("argument for pragma% must be library level entity", Arg1
);
16280 -- The only processing required is to link this item on to the
16281 -- list of rep items for the given entity. This is accomplished
16282 -- by the call to Rep_Item_Too_Late (when no error is detected
16283 -- and False is returned).
16285 if Rep_Item_Too_Late
(Proc
, N
) then
16288 Set_Has_Gigi_Rep_Item
(Proc
);
16290 end Linker_Constructor
;
16292 --------------------
16293 -- Linker_Options --
16294 --------------------
16296 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16298 when Pragma_Linker_Options
=> Linker_Options
: declare
16302 Check_Ada_83_Warning
;
16303 Check_No_Identifiers
;
16304 Check_Arg_Count
(1);
16305 Check_Is_In_Decl_Part_Or_Package_Spec
;
16306 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16307 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16310 while Present
(Arg
) loop
16311 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16312 Store_String_Char
(ASCII
.NUL
);
16314 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16318 if Operating_Mode
= Generate_Code
16319 and then In_Extended_Main_Source_Unit
(N
)
16321 Store_Linker_Option_String
(End_String
);
16323 end Linker_Options
;
16325 --------------------
16326 -- Linker_Section --
16327 --------------------
16329 -- pragma Linker_Section (
16330 -- [Entity =>] LOCAL_NAME
16331 -- [Section =>] static_string_EXPRESSION);
16333 when Pragma_Linker_Section
=> Linker_Section
: declare
16340 Check_Arg_Order
((Name_Entity
, Name_Section
));
16341 Check_Arg_Count
(2);
16342 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16343 Check_Optional_Identifier
(Arg2
, Name_Section
);
16344 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16345 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16347 -- Check kind of entity
16349 Arg
:= Get_Pragma_Arg
(Arg1
);
16350 Ent
:= Entity
(Arg
);
16352 case Ekind
(Ent
) is
16354 -- Objects (constants and variables) and types. For these cases
16355 -- all we need to do is to set the Linker_Section_pragma field,
16356 -- checking that we do not have a duplicate.
16358 when E_Constant | E_Variable | Type_Kind
=>
16359 LPE
:= Linker_Section_Pragma
(Ent
);
16361 if Present
(LPE
) then
16362 Error_Msg_Sloc
:= Sloc
(LPE
);
16364 ("Linker_Section already specified for &#", Arg1
, Ent
);
16367 Set_Linker_Section_Pragma
(Ent
, N
);
16371 when Subprogram_Kind
=>
16373 -- Aspect case, entity already set
16375 if From_Aspect_Specification
(N
) then
16376 Set_Linker_Section_Pragma
16377 (Entity
(Corresponding_Aspect
(N
)), N
);
16379 -- Pragma case, we must climb the homonym chain, but skip
16380 -- any for which the linker section is already set.
16384 if No
(Linker_Section_Pragma
(Ent
)) then
16385 Set_Linker_Section_Pragma
(Ent
, N
);
16388 Ent
:= Homonym
(Ent
);
16390 or else Scope
(Ent
) /= Current_Scope
;
16394 -- All other cases are illegal
16398 ("pragma% applies only to objects, subprograms, and types",
16401 end Linker_Section
;
16407 -- pragma List (On | Off)
16409 -- There is nothing to do here, since we did all the processing for
16410 -- this pragma in Par.Prag (so that it works properly even in syntax
16413 when Pragma_List
=>
16420 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16422 when Pragma_Lock_Free
=> Lock_Free
: declare
16423 P
: constant Node_Id
:= Parent
(N
);
16429 Check_No_Identifiers
;
16430 Check_At_Most_N_Arguments
(1);
16432 -- Protected definition case
16434 if Nkind
(P
) = N_Protected_Definition
then
16435 Ent
:= Defining_Identifier
(Parent
(P
));
16439 if Arg_Count
= 1 then
16440 Arg
:= Get_Pragma_Arg
(Arg1
);
16441 Val
:= Is_True
(Static_Boolean
(Arg
));
16443 -- No arguments (expression is considered to be True)
16449 -- Check duplicate pragma before we chain the pragma in the Rep
16450 -- Item chain of Ent.
16452 Check_Duplicate_Pragma
(Ent
);
16453 Record_Rep_Item
(Ent
, N
);
16454 Set_Uses_Lock_Free
(Ent
, Val
);
16456 -- Anything else is incorrect placement
16463 --------------------
16464 -- Locking_Policy --
16465 --------------------
16467 -- pragma Locking_Policy (policy_IDENTIFIER);
16469 when Pragma_Locking_Policy
=> declare
16470 subtype LP_Range
is Name_Id
16471 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16476 Check_Ada_83_Warning
;
16477 Check_Arg_Count
(1);
16478 Check_No_Identifiers
;
16479 Check_Arg_Is_Locking_Policy
(Arg1
);
16480 Check_Valid_Configuration_Pragma
;
16481 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16484 when Name_Ceiling_Locking
=>
16486 when Name_Inheritance_Locking
=>
16488 when Name_Concurrent_Readers_Locking
=>
16492 if Locking_Policy
/= ' '
16493 and then Locking_Policy
/= LP
16495 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16496 Error_Pragma
("locking policy incompatible with policy#");
16498 -- Set new policy, but always preserve System_Location since we
16499 -- like the error message with the run time name.
16502 Locking_Policy
:= LP
;
16504 if Locking_Policy_Sloc
/= System_Location
then
16505 Locking_Policy_Sloc
:= Loc
;
16510 -------------------
16511 -- Loop_Optimize --
16512 -------------------
16514 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16516 -- OPTIMIZATION_HINT ::=
16517 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16519 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16524 Check_At_Least_N_Arguments
(1);
16525 Check_No_Identifiers
;
16527 Hint
:= First
(Pragma_Argument_Associations
(N
));
16528 while Present
(Hint
) loop
16529 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16537 Check_Loop_Pragma_Placement
;
16544 -- pragma Loop_Variant
16545 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16547 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16549 -- CHANGE_DIRECTION ::= Increases | Decreases
16551 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16556 Check_At_Least_N_Arguments
(1);
16557 Check_Loop_Pragma_Placement
;
16559 -- Process all increasing / decreasing expressions
16561 Variant
:= First
(Pragma_Argument_Associations
(N
));
16562 while Present
(Variant
) loop
16563 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16566 Error_Pragma_Arg
("wrong change modifier", Variant
);
16569 Preanalyze_Assert_Expression
16570 (Expression
(Variant
), Any_Discrete
);
16576 -----------------------
16577 -- Machine_Attribute --
16578 -----------------------
16580 -- pragma Machine_Attribute (
16581 -- [Entity =>] LOCAL_NAME,
16582 -- [Attribute_Name =>] static_string_EXPRESSION
16583 -- [, [Info =>] static_EXPRESSION] );
16585 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16586 Def_Id
: Entity_Id
;
16590 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16592 if Arg_Count
= 3 then
16593 Check_Optional_Identifier
(Arg3
, Name_Info
);
16594 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16596 Check_Arg_Count
(2);
16599 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16600 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16601 Check_Arg_Is_Local_Name
(Arg1
);
16602 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16603 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16605 if Is_Access_Type
(Def_Id
) then
16606 Def_Id
:= Designated_Type
(Def_Id
);
16609 if Rep_Item_Too_Early
(Def_Id
, N
) then
16613 Def_Id
:= Underlying_Type
(Def_Id
);
16615 -- The only processing required is to link this item on to the
16616 -- list of rep items for the given entity. This is accomplished
16617 -- by the call to Rep_Item_Too_Late (when no error is detected
16618 -- and False is returned).
16620 if Rep_Item_Too_Late
(Def_Id
, N
) then
16623 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16625 end Machine_Attribute
;
16632 -- (MAIN_OPTION [, MAIN_OPTION]);
16635 -- [STACK_SIZE =>] static_integer_EXPRESSION
16636 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16637 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16639 when Pragma_Main
=> Main
: declare
16640 Args
: Args_List
(1 .. 3);
16641 Names
: constant Name_List
(1 .. 3) := (
16643 Name_Task_Stack_Size_Default
,
16644 Name_Time_Slicing_Enabled
);
16650 Gather_Associations
(Names
, Args
);
16652 for J
in 1 .. 2 loop
16653 if Present
(Args
(J
)) then
16654 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16658 if Present
(Args
(3)) then
16659 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16663 while Present
(Nod
) loop
16664 if Nkind
(Nod
) = N_Pragma
16665 and then Pragma_Name
(Nod
) = Name_Main
16667 Error_Msg_Name_1
:= Pname
;
16668 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16679 -- pragma Main_Storage
16680 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16682 -- MAIN_STORAGE_OPTION ::=
16683 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16684 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16686 when Pragma_Main_Storage
=> Main_Storage
: declare
16687 Args
: Args_List
(1 .. 2);
16688 Names
: constant Name_List
(1 .. 2) := (
16689 Name_Working_Storage
,
16696 Gather_Associations
(Names
, Args
);
16698 for J
in 1 .. 2 loop
16699 if Present
(Args
(J
)) then
16700 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16704 Check_In_Main_Program
;
16707 while Present
(Nod
) loop
16708 if Nkind
(Nod
) = N_Pragma
16709 and then Pragma_Name
(Nod
) = Name_Main_Storage
16711 Error_Msg_Name_1
:= Pname
;
16712 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16723 -- pragma Memory_Size (NUMERIC_LITERAL)
16725 when Pragma_Memory_Size
=>
16728 -- Memory size is simply ignored
16730 Check_No_Identifiers
;
16731 Check_Arg_Count
(1);
16732 Check_Arg_Is_Integer_Literal
(Arg1
);
16740 -- The only correct use of this pragma is on its own in a file, in
16741 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16742 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16743 -- check for a file containing nothing but a No_Body pragma). If we
16744 -- attempt to process it during normal semantics processing, it means
16745 -- it was misplaced.
16747 when Pragma_No_Body
=>
16751 -----------------------------
16752 -- No_Elaboration_Code_All --
16753 -----------------------------
16755 -- pragma No_Elaboration_Code_All;
16757 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16760 Check_Valid_Library_Unit_Pragma
;
16762 if Nkind
(N
) = N_Null_Statement
then
16766 -- Must appear for a spec or generic spec
16768 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16769 N_Generic_Package_Declaration
,
16770 N_Generic_Subprogram_Declaration
,
16771 N_Package_Declaration
,
16772 N_Subprogram_Declaration
)
16776 ("pragma% can only occur for package "
16777 & "or subprogram spec"));
16780 -- Set flag in unit table
16782 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16784 -- Set restriction No_Elaboration_Code if this is the main unit
16786 if Current_Sem_Unit
= Main_Unit
then
16787 Set_Restriction
(No_Elaboration_Code
, N
);
16790 -- If we are in the main unit or in an extended main source unit,
16791 -- then we also add it to the configuration restrictions so that
16792 -- it will apply to all units in the extended main source.
16794 if Current_Sem_Unit
= Main_Unit
16795 or else In_Extended_Main_Source_Unit
(N
)
16797 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16800 -- If in main extended unit, activate transitive with test
16802 if In_Extended_Main_Source_Unit
(N
) then
16803 Opt
.No_Elab_Code_All_Pragma
:= N
;
16811 -- pragma No_Inline ( NAME {, NAME} );
16813 when Pragma_No_Inline
=>
16815 Process_Inline
(Suppressed
);
16821 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16823 when Pragma_No_Return
=> No_Return
: declare
16831 Check_At_Least_N_Arguments
(1);
16833 -- Loop through arguments of pragma
16836 while Present
(Arg
) loop
16837 Check_Arg_Is_Local_Name
(Arg
);
16838 Id
:= Get_Pragma_Arg
(Arg
);
16841 if not Is_Entity_Name
(Id
) then
16842 Error_Pragma_Arg
("entity name required", Arg
);
16845 if Etype
(Id
) = Any_Type
then
16849 -- Loop to find matching procedures
16854 and then Scope
(E
) = Current_Scope
16856 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16859 -- Set flag on any alias as well
16861 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16862 Set_No_Return
(Alias
(E
));
16868 exit when From_Aspect_Specification
(N
);
16872 -- If entity in not in current scope it may be the enclosing
16873 -- suprogram body to which the aspect applies.
16876 if Entity
(Id
) = Current_Scope
16877 and then From_Aspect_Specification
(N
)
16879 Set_No_Return
(Entity
(Id
));
16881 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16893 -- pragma No_Run_Time;
16895 -- Note: this pragma is retained for backwards compatibility. See
16896 -- body of Rtsfind for full details on its handling.
16898 when Pragma_No_Run_Time
=>
16900 Check_Valid_Configuration_Pragma
;
16901 Check_Arg_Count
(0);
16903 No_Run_Time_Mode
:= True;
16904 Configurable_Run_Time_Mode
:= True;
16906 -- Set Duration to 32 bits if word size is 32
16908 if Ttypes
.System_Word_Size
= 32 then
16909 Duration_32_Bits_On_Target
:= True;
16912 -- Set appropriate restrictions
16914 Set_Restriction
(No_Finalization
, N
);
16915 Set_Restriction
(No_Exception_Handlers
, N
);
16916 Set_Restriction
(Max_Tasks
, N
, 0);
16917 Set_Restriction
(No_Tasking
, N
);
16919 -----------------------
16920 -- No_Tagged_Streams --
16921 -----------------------
16923 -- pragma No_Tagged_Streams;
16924 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16926 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16932 Check_At_Most_N_Arguments
(1);
16934 -- One argument case
16936 if Arg_Count
= 1 then
16937 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16938 Check_Arg_Is_Local_Name
(Arg1
);
16939 E_Id
:= Get_Pragma_Arg
(Arg1
);
16941 if Etype
(E_Id
) = Any_Type
then
16945 E
:= Entity
(E_Id
);
16947 Check_Duplicate_Pragma
(E
);
16949 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16951 ("argument for pragma% must be root tagged type", Arg1
);
16954 if Rep_Item_Too_Early
(E
, N
)
16956 Rep_Item_Too_Late
(E
, N
)
16960 Set_No_Tagged_Streams_Pragma
(E
, N
);
16963 -- Zero argument case
16966 Check_Is_In_Decl_Part_Or_Package_Spec
;
16967 No_Tagged_Streams
:= N
;
16969 end No_Tagged_Strms
;
16971 ------------------------
16972 -- No_Strict_Aliasing --
16973 ------------------------
16975 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16977 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16982 Check_At_Most_N_Arguments
(1);
16984 if Arg_Count
= 0 then
16985 Check_Valid_Configuration_Pragma
;
16986 Opt
.No_Strict_Aliasing
:= True;
16989 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16990 Check_Arg_Is_Local_Name
(Arg1
);
16991 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16993 if E_Id
= Any_Type
then
16995 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16996 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16999 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
17001 end No_Strict_Aliasing
;
17003 -----------------------
17004 -- Normalize_Scalars --
17005 -----------------------
17007 -- pragma Normalize_Scalars;
17009 when Pragma_Normalize_Scalars
=>
17010 Check_Ada_83_Warning
;
17011 Check_Arg_Count
(0);
17012 Check_Valid_Configuration_Pragma
;
17014 -- Normalize_Scalars creates false positives in CodePeer, and
17015 -- incorrect negative results in GNATprove mode, so ignore this
17016 -- pragma in these modes.
17018 if not (CodePeer_Mode
or GNATprove_Mode
) then
17019 Normalize_Scalars
:= True;
17020 Init_Or_Norm_Scalars
:= True;
17027 -- pragma Obsolescent;
17029 -- pragma Obsolescent (
17030 -- [Message =>] static_string_EXPRESSION
17031 -- [,[Version =>] Ada_05]]);
17033 -- pragma Obsolescent (
17034 -- [Entity =>] NAME
17035 -- [,[Message =>] static_string_EXPRESSION
17036 -- [,[Version =>] Ada_05]] );
17038 when Pragma_Obsolescent
=> Obsolescent
: declare
17042 procedure Set_Obsolescent
(E
: Entity_Id
);
17043 -- Given an entity Ent, mark it as obsolescent if appropriate
17045 ---------------------
17046 -- Set_Obsolescent --
17047 ---------------------
17049 procedure Set_Obsolescent
(E
: Entity_Id
) is
17058 -- Entity name was given
17060 if Present
(Ename
) then
17062 -- If entity name matches, we are fine. Save entity in
17063 -- pragma argument, for ASIS use.
17065 if Chars
(Ename
) = Chars
(Ent
) then
17066 Set_Entity
(Ename
, Ent
);
17067 Generate_Reference
(Ent
, Ename
);
17069 -- If entity name does not match, only possibility is an
17070 -- enumeration literal from an enumeration type declaration.
17072 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17074 ("pragma % entity name does not match declaration");
17077 Ent
:= First_Literal
(E
);
17081 ("pragma % entity name does not match any "
17082 & "enumeration literal");
17084 elsif Chars
(Ent
) = Chars
(Ename
) then
17085 Set_Entity
(Ename
, Ent
);
17086 Generate_Reference
(Ent
, Ename
);
17090 Ent
:= Next_Literal
(Ent
);
17096 -- Ent points to entity to be marked
17098 if Arg_Count
>= 1 then
17100 -- Deal with static string argument
17102 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17103 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17105 for J
in 1 .. String_Length
(S
) loop
17106 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17108 ("pragma% argument does not allow wide characters",
17113 Obsolescent_Warnings
.Append
17114 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17116 -- Check for Ada_05 parameter
17118 if Arg_Count
/= 1 then
17119 Check_Arg_Count
(2);
17122 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17125 Check_Arg_Is_Identifier
(Argx
);
17127 if Chars
(Argx
) /= Name_Ada_05
then
17128 Error_Msg_Name_2
:= Name_Ada_05
;
17130 ("only allowed argument for pragma% is %", Argx
);
17133 if Ada_Version_Explicit
< Ada_2005
17134 or else not Warn_On_Ada_2005_Compatibility
17142 -- Set flag if pragma active
17145 Set_Is_Obsolescent
(Ent
);
17149 end Set_Obsolescent
;
17151 -- Start of processing for pragma Obsolescent
17156 Check_At_Most_N_Arguments
(3);
17158 -- See if first argument specifies an entity name
17162 (Chars
(Arg1
) = Name_Entity
17164 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17166 N_Operator_Symbol
))
17168 Ename
:= Get_Pragma_Arg
(Arg1
);
17170 -- Eliminate first argument, so we can share processing
17174 Arg_Count
:= Arg_Count
- 1;
17176 -- No Entity name argument given
17182 if Arg_Count
>= 1 then
17183 Check_Optional_Identifier
(Arg1
, Name_Message
);
17185 if Arg_Count
= 2 then
17186 Check_Optional_Identifier
(Arg2
, Name_Version
);
17190 -- Get immediately preceding declaration
17193 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17197 -- Cases where we do not follow anything other than another pragma
17201 -- First case: library level compilation unit declaration with
17202 -- the pragma immediately following the declaration.
17204 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17206 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17209 -- Case 2: library unit placement for package
17213 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17215 if Is_Package_Or_Generic_Package
(Ent
) then
17216 Set_Obsolescent
(Ent
);
17222 -- Cases where we must follow a declaration
17225 if Nkind
(Decl
) not in N_Declaration
17226 and then Nkind
(Decl
) not in N_Later_Decl_Item
17227 and then Nkind
(Decl
) not in N_Generic_Declaration
17228 and then Nkind
(Decl
) not in N_Renaming_Declaration
17231 ("pragma% misplaced, "
17232 & "must immediately follow a declaration");
17235 Set_Obsolescent
(Defining_Entity
(Decl
));
17245 -- pragma Optimize (Time | Space | Off);
17247 -- The actual check for optimize is done in Gigi. Note that this
17248 -- pragma does not actually change the optimization setting, it
17249 -- simply checks that it is consistent with the pragma.
17251 when Pragma_Optimize
=>
17252 Check_No_Identifiers
;
17253 Check_Arg_Count
(1);
17254 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17256 ------------------------
17257 -- Optimize_Alignment --
17258 ------------------------
17260 -- pragma Optimize_Alignment (Time | Space | Off);
17262 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17264 Check_No_Identifiers
;
17265 Check_Arg_Count
(1);
17266 Check_Valid_Configuration_Pragma
;
17269 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17273 Opt
.Optimize_Alignment
:= 'T';
17275 Opt
.Optimize_Alignment
:= 'S';
17277 Opt
.Optimize_Alignment
:= 'O';
17279 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17283 -- Set indication that mode is set locally. If we are in fact in a
17284 -- configuration pragma file, this setting is harmless since the
17285 -- switch will get reset anyway at the start of each unit.
17287 Optimize_Alignment_Local
:= True;
17288 end Optimize_Alignment
;
17294 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17296 when Pragma_Ordered
=> Ordered
: declare
17297 Assoc
: constant Node_Id
:= Arg1
;
17303 Check_No_Identifiers
;
17304 Check_Arg_Count
(1);
17305 Check_Arg_Is_Local_Name
(Arg1
);
17307 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17308 Find_Type
(Type_Id
);
17309 Typ
:= Entity
(Type_Id
);
17311 if Typ
= Any_Type
then
17314 Typ
:= Underlying_Type
(Typ
);
17317 if not Is_Enumeration_Type
(Typ
) then
17318 Error_Pragma
("pragma% must specify enumeration type");
17321 Check_First_Subtype
(Arg1
);
17322 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17325 -------------------
17326 -- Overflow_Mode --
17327 -------------------
17329 -- pragma Overflow_Mode
17330 -- ([General => ] MODE [, [Assertions => ] MODE]);
17332 -- MODE := STRICT | MINIMIZED | ELIMINATED
17334 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17335 -- since System.Bignums makes this assumption. This is true of nearly
17336 -- all (all?) targets.
17338 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17339 function Get_Overflow_Mode
17341 Arg
: Node_Id
) return Overflow_Mode_Type
;
17342 -- Function to process one pragma argument, Arg. If an identifier
17343 -- is present, it must be Name. Mode type is returned if a valid
17344 -- argument exists, otherwise an error is signalled.
17346 -----------------------
17347 -- Get_Overflow_Mode --
17348 -----------------------
17350 function Get_Overflow_Mode
17352 Arg
: Node_Id
) return Overflow_Mode_Type
17354 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17357 Check_Optional_Identifier
(Arg
, Name
);
17358 Check_Arg_Is_Identifier
(Argx
);
17360 if Chars
(Argx
) = Name_Strict
then
17363 elsif Chars
(Argx
) = Name_Minimized
then
17366 elsif Chars
(Argx
) = Name_Eliminated
then
17367 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17369 ("Eliminated not implemented on this target", Argx
);
17375 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17377 end Get_Overflow_Mode
;
17379 -- Start of processing for Overflow_Mode
17383 Check_At_Least_N_Arguments
(1);
17384 Check_At_Most_N_Arguments
(2);
17386 -- Process first argument
17388 Scope_Suppress
.Overflow_Mode_General
:=
17389 Get_Overflow_Mode
(Name_General
, Arg1
);
17391 -- Case of only one argument
17393 if Arg_Count
= 1 then
17394 Scope_Suppress
.Overflow_Mode_Assertions
:=
17395 Scope_Suppress
.Overflow_Mode_General
;
17397 -- Case of two arguments present
17400 Scope_Suppress
.Overflow_Mode_Assertions
:=
17401 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17405 --------------------------
17406 -- Overriding Renamings --
17407 --------------------------
17409 -- pragma Overriding_Renamings;
17411 when Pragma_Overriding_Renamings
=>
17413 Check_Arg_Count
(0);
17414 Check_Valid_Configuration_Pragma
;
17415 Overriding_Renamings
:= True;
17421 -- pragma Pack (first_subtype_LOCAL_NAME);
17423 when Pragma_Pack
=> Pack
: declare
17424 Assoc
: constant Node_Id
:= Arg1
;
17428 Ignore
: Boolean := False;
17431 Check_No_Identifiers
;
17432 Check_Arg_Count
(1);
17433 Check_Arg_Is_Local_Name
(Arg1
);
17434 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17436 if not Is_Entity_Name
(Type_Id
)
17437 or else not Is_Type
(Entity
(Type_Id
))
17440 ("argument for pragma% must be type or subtype", Arg1
);
17443 Find_Type
(Type_Id
);
17444 Typ
:= Entity
(Type_Id
);
17447 or else Rep_Item_Too_Early
(Typ
, N
)
17451 Typ
:= Underlying_Type
(Typ
);
17454 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17455 Error_Pragma
("pragma% must specify array or record type");
17458 Check_First_Subtype
(Arg1
);
17459 Check_Duplicate_Pragma
(Typ
);
17463 if Is_Array_Type
(Typ
) then
17464 Ctyp
:= Component_Type
(Typ
);
17466 -- Ignore pack that does nothing
17468 if Known_Static_Esize
(Ctyp
)
17469 and then Known_Static_RM_Size
(Ctyp
)
17470 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17471 and then Addressable
(Esize
(Ctyp
))
17476 -- Process OK pragma Pack. Note that if there is a separate
17477 -- component clause present, the Pack will be cancelled. This
17478 -- processing is in Freeze.
17480 if not Rep_Item_Too_Late
(Typ
, N
) then
17482 -- In CodePeer mode, we do not need complex front-end
17483 -- expansions related to pragma Pack, so disable handling
17486 if CodePeer_Mode
then
17489 -- Don't attempt any packing for VM targets. We possibly
17490 -- could deal with some cases of array bit-packing, but we
17491 -- don't bother, since this is not a typical kind of
17492 -- representation in the VM context anyway (and would not
17493 -- for example work nicely with the debugger).
17495 elsif VM_Target
/= No_VM
then
17496 if not GNAT_Mode
then
17498 ("??pragma% ignored in this configuration");
17501 -- Normal case where we do the pack action
17505 Set_Is_Packed
(Base_Type
(Typ
));
17506 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17509 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17513 -- For record types, the pack is always effective
17515 else pragma Assert
(Is_Record_Type
(Typ
));
17516 if not Rep_Item_Too_Late
(Typ
, N
) then
17518 -- Ignore pack request with warning in VM mode (skip warning
17519 -- if we are compiling GNAT run time library).
17521 if VM_Target
/= No_VM
then
17522 if not GNAT_Mode
then
17524 ("??pragma% ignored in this configuration");
17527 -- Normal case of pack request active
17530 Set_Is_Packed
(Base_Type
(Typ
));
17531 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17532 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17544 -- There is nothing to do here, since we did all the processing for
17545 -- this pragma in Par.Prag (so that it works properly even in syntax
17548 when Pragma_Page
=>
17555 -- pragma Part_Of (ABSTRACT_STATE);
17557 -- ABSTRACT_STATE ::= NAME
17559 when Pragma_Part_Of
=> Part_Of
: declare
17560 procedure Propagate_Part_Of
17561 (Pack_Id
: Entity_Id
;
17562 State_Id
: Entity_Id
;
17563 Instance
: Node_Id
);
17564 -- Propagate the Part_Of indicator to all abstract states and
17565 -- variables declared in the visible state space of a package
17566 -- denoted by Pack_Id. State_Id is the encapsulating state.
17567 -- Instance is the package instantiation node.
17569 -----------------------
17570 -- Propagate_Part_Of --
17571 -----------------------
17573 procedure Propagate_Part_Of
17574 (Pack_Id
: Entity_Id
;
17575 State_Id
: Entity_Id
;
17576 Instance
: Node_Id
)
17578 Has_Item
: Boolean := False;
17579 -- Flag set when the visible state space contains at least one
17580 -- abstract state or variable.
17582 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17583 -- Propagate the Part_Of indicator to all abstract states and
17584 -- variables declared in the visible state space of a package
17585 -- denoted by Pack_Id.
17587 -----------------------
17588 -- Propagate_Part_Of --
17589 -----------------------
17591 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17592 Item_Id
: Entity_Id
;
17595 -- Traverse the entity chain of the package and set relevant
17596 -- attributes of abstract states and variables declared in
17597 -- the visible state space of the package.
17599 Item_Id
:= First_Entity
(Pack_Id
);
17600 while Present
(Item_Id
)
17601 and then not In_Private_Part
(Item_Id
)
17603 -- Do not consider internally generated items
17605 if not Comes_From_Source
(Item_Id
) then
17608 -- The Part_Of indicator turns an abstract state or
17609 -- variable into a constituent of the encapsulating
17612 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17617 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17618 Set_Encapsulating_State
(Item_Id
, State_Id
);
17620 -- Recursively handle nested packages and instantiations
17622 elsif Ekind
(Item_Id
) = E_Package
then
17623 Propagate_Part_Of
(Item_Id
);
17626 Next_Entity
(Item_Id
);
17628 end Propagate_Part_Of
;
17630 -- Start of processing for Propagate_Part_Of
17633 Propagate_Part_Of
(Pack_Id
);
17635 -- Detect a package instantiation that is subject to a Part_Of
17636 -- indicator, but has no visible state.
17638 if not Has_Item
then
17640 ("package instantiation & has Part_Of indicator but "
17641 & "lacks visible state", Instance
, Pack_Id
);
17643 end Propagate_Part_Of
;
17647 Item_Id
: Entity_Id
;
17650 State_Id
: Entity_Id
;
17653 -- Start of processing for Part_Of
17657 Check_No_Identifiers
;
17658 Check_Arg_Count
(1);
17660 -- Ensure the proper placement of the pragma. Part_Of must appear
17661 -- on a variable declaration or a package instantiation.
17664 while Present
(Stmt
) loop
17666 -- Skip prior pragmas, but check for duplicates
17668 if Nkind
(Stmt
) = N_Pragma
then
17669 if Pragma_Name
(Stmt
) = Pname
then
17670 Error_Msg_Name_1
:= Pname
;
17671 Error_Msg_Sloc
:= Sloc
(Stmt
);
17672 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17675 -- Skip internally generated code
17677 elsif not Comes_From_Source
(Stmt
) then
17680 -- The pragma applies to an object declaration (possibly a
17681 -- variable) or a package instantiation. Stop the traversal
17682 -- and continue the analysis.
17684 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17685 N_Package_Instantiation
)
17689 -- The pragma does not apply to a legal construct, issue an
17690 -- error and stop the analysis.
17697 Stmt
:= Prev
(Stmt
);
17700 -- When the context is an object declaration, ensure that we are
17701 -- dealing with a variable.
17703 if Nkind
(Stmt
) = N_Object_Declaration
17704 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17706 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17710 -- Extract the entity of the related object declaration or package
17711 -- instantiation. In the case of the instantiation, use the entity
17712 -- of the instance spec.
17714 if Nkind
(Stmt
) = N_Package_Instantiation
then
17715 Stmt
:= Instance_Spec
(Stmt
);
17718 Item_Id
:= Defining_Entity
(Stmt
);
17719 State
:= Get_Pragma_Arg
(Arg1
);
17721 -- Detect any discrepancies between the placement of the object
17722 -- or package instantiation with respect to state space and the
17723 -- encapsulating state.
17726 (Item_Id
=> Item_Id
,
17732 State_Id
:= Entity
(State
);
17734 -- Add the pragma to the contract of the item. This aids with
17735 -- the detection of a missing but required Part_Of indicator.
17737 Add_Contract_Item
(N
, Item_Id
);
17739 -- The Part_Of indicator turns a variable into a constituent
17740 -- of the encapsulating state.
17742 if Ekind
(Item_Id
) = E_Variable
then
17743 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17744 Set_Encapsulating_State
(Item_Id
, State_Id
);
17746 -- Propagate the Part_Of indicator to the visible state space
17747 -- of the package instantiation.
17751 (Pack_Id
=> Item_Id
,
17752 State_Id
=> State_Id
,
17758 ----------------------------------
17759 -- Partition_Elaboration_Policy --
17760 ----------------------------------
17762 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17764 when Pragma_Partition_Elaboration_Policy
=> declare
17765 subtype PEP_Range
is Name_Id
17766 range First_Partition_Elaboration_Policy_Name
17767 .. Last_Partition_Elaboration_Policy_Name
;
17768 PEP_Val
: PEP_Range
;
17773 Check_Arg_Count
(1);
17774 Check_No_Identifiers
;
17775 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17776 Check_Valid_Configuration_Pragma
;
17777 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17780 when Name_Concurrent
=>
17782 when Name_Sequential
=>
17786 if Partition_Elaboration_Policy
/= ' '
17787 and then Partition_Elaboration_Policy
/= PEP
17789 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17791 ("partition elaboration policy incompatible with policy#");
17793 -- Set new policy, but always preserve System_Location since we
17794 -- like the error message with the run time name.
17797 Partition_Elaboration_Policy
:= PEP
;
17799 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17800 Partition_Elaboration_Policy_Sloc
:= Loc
;
17809 -- pragma Passive [(PASSIVE_FORM)];
17811 -- PASSIVE_FORM ::= Semaphore | No
17813 when Pragma_Passive
=>
17816 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17817 Error_Pragma
("pragma% must be within task definition");
17820 if Arg_Count
/= 0 then
17821 Check_Arg_Count
(1);
17822 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17825 ----------------------------------
17826 -- Preelaborable_Initialization --
17827 ----------------------------------
17829 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17831 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17836 Check_Arg_Count
(1);
17837 Check_No_Identifiers
;
17838 Check_Arg_Is_Identifier
(Arg1
);
17839 Check_Arg_Is_Local_Name
(Arg1
);
17840 Check_First_Subtype
(Arg1
);
17841 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17843 -- The pragma may come from an aspect on a private declaration,
17844 -- even if the freeze point at which this is analyzed in the
17845 -- private part after the full view.
17847 if Has_Private_Declaration
(Ent
)
17848 and then From_Aspect_Specification
(N
)
17852 -- Check appropriate type argument
17854 elsif Is_Private_Type
(Ent
)
17855 or else Is_Protected_Type
(Ent
)
17856 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17858 -- AI05-0028: The pragma applies to all composite types. Note
17859 -- that we apply this binding interpretation to earlier versions
17860 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
17861 -- choice since there are other compilers that do the same.
17863 or else Is_Composite_Type
(Ent
)
17869 ("pragma % can only be applied to private, formal derived, "
17870 & "protected, or composite type", Arg1
);
17873 -- Give an error if the pragma is applied to a protected type that
17874 -- does not qualify (due to having entries, or due to components
17875 -- that do not qualify).
17877 if Is_Protected_Type
(Ent
)
17878 and then not Has_Preelaborable_Initialization
(Ent
)
17881 ("protected type & does not have preelaborable "
17882 & "initialization", Ent
);
17884 -- Otherwise mark the type as definitely having preelaborable
17888 Set_Known_To_Have_Preelab_Init
(Ent
);
17891 if Has_Pragma_Preelab_Init
(Ent
)
17892 and then Warn_On_Redundant_Constructs
17894 Error_Pragma
("?r?duplicate pragma%!");
17896 Set_Has_Pragma_Preelab_Init
(Ent
);
17900 --------------------
17901 -- Persistent_BSS --
17902 --------------------
17904 -- pragma Persistent_BSS [(object_NAME)];
17906 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17913 Check_At_Most_N_Arguments
(1);
17915 -- Case of application to specific object (one argument)
17917 if Arg_Count
= 1 then
17918 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17920 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17922 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17925 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17928 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17929 Decl
:= Parent
(Ent
);
17931 -- Check for duplication before inserting in list of
17932 -- representation items.
17934 Check_Duplicate_Pragma
(Ent
);
17936 if Rep_Item_Too_Late
(Ent
, N
) then
17940 if Present
(Expression
(Decl
)) then
17942 ("object for pragma% cannot have initialization", Arg1
);
17945 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17947 ("object type for pragma% is not potentially persistent",
17952 Make_Linker_Section_Pragma
17953 (Ent
, Sloc
(N
), ".persistent.bss");
17954 Insert_After
(N
, Prag
);
17957 -- Case of use as configuration pragma with no arguments
17960 Check_Valid_Configuration_Pragma
;
17961 Persistent_BSS_Mode
:= True;
17963 end Persistent_BSS
;
17969 -- pragma Polling (ON | OFF);
17971 when Pragma_Polling
=>
17973 Check_Arg_Count
(1);
17974 Check_No_Identifiers
;
17975 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17976 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17982 -- pragma Post (Boolean_EXPRESSION);
17983 -- pragma Post_Class (Boolean_EXPRESSION);
17985 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
17986 PC_Pragma
: Node_Id
;
17990 Check_Arg_Count
(1);
17991 Check_No_Identifiers
;
17994 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
17995 -- flag Class_Present to True for the Post_Class case.
17997 Set_Class_Present
(N
, Prag_Id
= Pragma_Post_Class
);
17998 PC_Pragma
:= New_Copy
(N
);
17999 Set_Pragma_Identifier
18000 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
18001 Rewrite
(N
, PC_Pragma
);
18002 Set_Analyzed
(N
, False);
18006 -------------------
18007 -- Postcondition --
18008 -------------------
18010 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18011 -- [,[Message =>] String_EXPRESSION]);
18013 when Pragma_Postcondition
=> Postcondition
: declare
18018 Check_At_Least_N_Arguments
(1);
18019 Check_At_Most_N_Arguments
(2);
18020 Check_Optional_Identifier
(Arg1
, Name_Check
);
18022 -- Verify the proper placement of the pragma. The remainder of the
18023 -- processing is found in Sem_Ch6/Sem_Ch7.
18025 Check_Precondition_Postcondition
(In_Body
);
18027 -- When the pragma is a source construct appearing inside a body,
18028 -- preanalyze the boolean_expression to detect illegal forward
18032 -- pragma Postcondition (X'Old ...);
18035 if Comes_From_Source
(N
) and then In_Body
then
18036 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
18044 -- pragma Pre (Boolean_EXPRESSION);
18045 -- pragma Pre_Class (Boolean_EXPRESSION);
18047 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
18048 PC_Pragma
: Node_Id
;
18052 Check_Arg_Count
(1);
18053 Check_No_Identifiers
;
18056 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
18057 -- flag Class_Present to True for the Pre_Class case.
18059 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
18060 PC_Pragma
:= New_Copy
(N
);
18061 Set_Pragma_Identifier
18062 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
18063 Rewrite
(N
, PC_Pragma
);
18064 Set_Analyzed
(N
, False);
18072 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18073 -- [,[Message =>] String_EXPRESSION]);
18075 when Pragma_Precondition
=> Precondition
: declare
18080 Check_At_Least_N_Arguments
(1);
18081 Check_At_Most_N_Arguments
(2);
18082 Check_Optional_Identifier
(Arg1
, Name_Check
);
18083 Check_Precondition_Postcondition
(In_Body
);
18085 -- If in spec, nothing more to do. If in body, then we convert
18086 -- the pragma to an equivalent pragma Check. That works fine since
18087 -- pragma Check will analyze the condition in the proper context.
18089 -- The form of the pragma Check is either:
18091 -- pragma Check (Precondition, cond [, msg])
18093 -- pragma Check (Pre, cond [, msg])
18095 -- We use the Pre form if this pragma derived from a Pre aspect.
18096 -- This is needed to make sure that the right set of Policy
18097 -- pragmas are checked.
18101 -- Rewrite as Check pragma
18105 Chars
=> Name_Check
,
18106 Pragma_Argument_Associations
=> New_List
(
18107 Make_Pragma_Argument_Association
(Loc
,
18108 Expression
=> Make_Identifier
(Loc
, Pname
)),
18110 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
18112 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
18114 if Arg_Count
= 2 then
18115 Append_To
(Pragma_Argument_Associations
(N
),
18116 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
18118 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
18129 -- pragma Predicate
18130 -- ([Entity =>] type_LOCAL_NAME,
18131 -- [Check =>] boolean_EXPRESSION);
18133 when Pragma_Predicate
=> Predicate
: declare
18140 Check_Arg_Count
(2);
18141 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18142 Check_Optional_Identifier
(Arg2
, Name_Check
);
18144 Check_Arg_Is_Local_Name
(Arg1
);
18146 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18147 Find_Type
(Type_Id
);
18148 Typ
:= Entity
(Type_Id
);
18150 if Typ
= Any_Type
then
18154 -- The remaining processing is simply to link the pragma on to
18155 -- the rep item chain, for processing when the type is frozen.
18156 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18157 -- mark the type as having predicates.
18159 Set_Has_Predicates
(Typ
);
18160 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18167 -- pragma Preelaborate [(library_unit_NAME)];
18169 -- Set the flag Is_Preelaborated of program unit name entity
18171 when Pragma_Preelaborate
=> Preelaborate
: declare
18172 Pa
: constant Node_Id
:= Parent
(N
);
18173 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18177 Check_Ada_83_Warning
;
18178 Check_Valid_Library_Unit_Pragma
;
18180 if Nkind
(N
) = N_Null_Statement
then
18184 Ent
:= Find_Lib_Unit_Name
;
18185 Check_Duplicate_Pragma
(Ent
);
18187 -- This filters out pragmas inside generic parents that show up
18188 -- inside instantiations. Pragmas that come from aspects in the
18189 -- unit are not ignored.
18191 if Present
(Ent
) then
18192 if Pk
= N_Package_Specification
18193 and then Present
(Generic_Parent
(Pa
))
18194 and then not From_Aspect_Specification
(N
)
18199 if not Debug_Flag_U
then
18200 Set_Is_Preelaborated
(Ent
);
18201 Set_Suppress_Elaboration_Warnings
(Ent
);
18207 -------------------------------
18208 -- Prefix_Exception_Messages --
18209 -------------------------------
18211 -- pragma Prefix_Exception_Messages;
18213 when Pragma_Prefix_Exception_Messages
=>
18215 Check_Valid_Configuration_Pragma
;
18216 Check_Arg_Count
(0);
18217 Prefix_Exception_Messages
:= True;
18223 -- pragma Priority (EXPRESSION);
18225 when Pragma_Priority
=> Priority
: declare
18226 P
: constant Node_Id
:= Parent
(N
);
18231 Check_No_Identifiers
;
18232 Check_Arg_Count
(1);
18236 if Nkind
(P
) = N_Subprogram_Body
then
18237 Check_In_Main_Program
;
18239 Ent
:= Defining_Unit_Name
(Specification
(P
));
18241 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18242 Ent
:= Defining_Identifier
(Ent
);
18245 Arg
:= Get_Pragma_Arg
(Arg1
);
18246 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18250 if not Is_OK_Static_Expression
(Arg
) then
18251 Flag_Non_Static_Expr
18252 ("main subprogram priority is not static!", Arg
);
18255 -- If constraint error, then we already signalled an error
18257 elsif Raises_Constraint_Error
(Arg
) then
18260 -- Otherwise check in range except if Relaxed_RM_Semantics
18261 -- where we ignore the value if out of range.
18265 Val
: constant Uint
:= Expr_Value
(Arg
);
18267 if not Relaxed_RM_Semantics
18270 or else Val
> Expr_Value
(Expression
18271 (Parent
(RTE
(RE_Max_Priority
)))))
18274 ("main subprogram priority is out of range", Arg1
);
18277 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18282 -- Load an arbitrary entity from System.Tasking.Stages or
18283 -- System.Tasking.Restricted.Stages (depending on the
18284 -- supported profile) to make sure that one of these packages
18285 -- is implicitly with'ed, since we need to have the tasking
18286 -- run time active for the pragma Priority to have any effect.
18287 -- Previously we with'ed the package System.Tasking, but this
18288 -- package does not trigger the required initialization of the
18289 -- run-time library.
18292 Discard
: Entity_Id
;
18293 pragma Warnings
(Off
, Discard
);
18295 if Restricted_Profile
then
18296 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18298 Discard
:= RTE
(RE_Activate_Tasks
);
18302 -- Task or Protected, must be of type Integer
18304 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18305 Arg
:= Get_Pragma_Arg
(Arg1
);
18306 Ent
:= Defining_Identifier
(Parent
(P
));
18308 -- The expression must be analyzed in the special manner
18309 -- described in "Handling of Default and Per-Object
18310 -- Expressions" in sem.ads.
18312 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18314 if not Is_OK_Static_Expression
(Arg
) then
18315 Check_Restriction
(Static_Priorities
, Arg
);
18318 -- Anything else is incorrect
18324 -- Check duplicate pragma before we chain the pragma in the Rep
18325 -- Item chain of Ent.
18327 Check_Duplicate_Pragma
(Ent
);
18328 Record_Rep_Item
(Ent
, N
);
18331 -----------------------------------
18332 -- Priority_Specific_Dispatching --
18333 -----------------------------------
18335 -- pragma Priority_Specific_Dispatching (
18336 -- policy_IDENTIFIER,
18337 -- first_priority_EXPRESSION,
18338 -- last_priority_EXPRESSION);
18340 when Pragma_Priority_Specific_Dispatching
=>
18341 Priority_Specific_Dispatching
: declare
18342 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18343 -- This is the entity System.Any_Priority;
18346 Lower_Bound
: Node_Id
;
18347 Upper_Bound
: Node_Id
;
18353 Check_Arg_Count
(3);
18354 Check_No_Identifiers
;
18355 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18356 Check_Valid_Configuration_Pragma
;
18357 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18358 DP
:= Fold_Upper
(Name_Buffer
(1));
18360 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18361 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18362 Lower_Val
:= Expr_Value
(Lower_Bound
);
18364 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18365 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18366 Upper_Val
:= Expr_Value
(Upper_Bound
);
18368 -- It is not allowed to use Task_Dispatching_Policy and
18369 -- Priority_Specific_Dispatching in the same partition.
18371 if Task_Dispatching_Policy
/= ' ' then
18372 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18374 ("pragma% incompatible with Task_Dispatching_Policy#");
18376 -- Check lower bound in range
18378 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18380 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18383 ("first_priority is out of range", Arg2
);
18385 -- Check upper bound in range
18387 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18389 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18392 ("last_priority is out of range", Arg3
);
18394 -- Check that the priority range is valid
18396 elsif Lower_Val
> Upper_Val
then
18398 ("last_priority_expression must be greater than or equal to "
18399 & "first_priority_expression");
18401 -- Store the new policy, but always preserve System_Location since
18402 -- we like the error message with the run-time name.
18405 -- Check overlapping in the priority ranges specified in other
18406 -- Priority_Specific_Dispatching pragmas within the same
18407 -- partition. We can only check those we know about.
18410 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18412 if Specific_Dispatching
.Table
(J
).First_Priority
in
18413 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18414 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18415 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18418 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18420 ("priority range overlaps with "
18421 & "Priority_Specific_Dispatching#");
18425 -- The use of Priority_Specific_Dispatching is incompatible
18426 -- with Task_Dispatching_Policy.
18428 if Task_Dispatching_Policy
/= ' ' then
18429 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18431 ("Priority_Specific_Dispatching incompatible "
18432 & "with Task_Dispatching_Policy#");
18435 -- The use of Priority_Specific_Dispatching forces ceiling
18438 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18439 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18441 ("Priority_Specific_Dispatching incompatible "
18442 & "with Locking_Policy#");
18444 -- Set the Ceiling_Locking policy, but preserve System_Location
18445 -- since we like the error message with the run time name.
18448 Locking_Policy
:= 'C';
18450 if Locking_Policy_Sloc
/= System_Location
then
18451 Locking_Policy_Sloc
:= Loc
;
18455 -- Add entry in the table
18457 Specific_Dispatching
.Append
18458 ((Dispatching_Policy
=> DP
,
18459 First_Priority
=> UI_To_Int
(Lower_Val
),
18460 Last_Priority
=> UI_To_Int
(Upper_Val
),
18461 Pragma_Loc
=> Loc
));
18463 end Priority_Specific_Dispatching
;
18469 -- pragma Profile (profile_IDENTIFIER);
18471 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18473 when Pragma_Profile
=>
18475 Check_Arg_Count
(1);
18476 Check_Valid_Configuration_Pragma
;
18477 Check_No_Identifiers
;
18480 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18483 if Chars
(Argx
) = Name_Ravenscar
then
18484 Set_Ravenscar_Profile
(N
);
18486 elsif Chars
(Argx
) = Name_Restricted
then
18487 Set_Profile_Restrictions
18489 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18491 elsif Chars
(Argx
) = Name_Rational
then
18492 Set_Rational_Profile
;
18494 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18495 Set_Profile_Restrictions
18496 (No_Implementation_Extensions
,
18497 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18500 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18504 ----------------------
18505 -- Profile_Warnings --
18506 ----------------------
18508 -- pragma Profile_Warnings (profile_IDENTIFIER);
18510 -- profile_IDENTIFIER => Restricted | Ravenscar
18512 when Pragma_Profile_Warnings
=>
18514 Check_Arg_Count
(1);
18515 Check_Valid_Configuration_Pragma
;
18516 Check_No_Identifiers
;
18519 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18522 if Chars
(Argx
) = Name_Ravenscar
then
18523 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18525 elsif Chars
(Argx
) = Name_Restricted
then
18526 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18528 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18529 Set_Profile_Restrictions
18530 (No_Implementation_Extensions
, N
, Warn
=> True);
18533 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18537 --------------------------
18538 -- Propagate_Exceptions --
18539 --------------------------
18541 -- pragma Propagate_Exceptions;
18543 -- Note: this pragma is obsolete and has no effect
18545 when Pragma_Propagate_Exceptions
=>
18547 Check_Arg_Count
(0);
18549 if Warn_On_Obsolescent_Feature
then
18551 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18552 "and has no effect?j?", N
);
18555 -----------------------------
18556 -- Provide_Shift_Operators --
18557 -----------------------------
18559 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18561 when Pragma_Provide_Shift_Operators
=>
18562 Provide_Shift_Operators
: declare
18565 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18566 -- Insert declaration and pragma Instrinsic for named shift op
18568 ----------------------------
18569 -- Declare_Shift_Operator --
18570 ----------------------------
18572 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18578 Make_Subprogram_Declaration
(Loc
,
18579 Make_Function_Specification
(Loc
,
18580 Defining_Unit_Name
=>
18581 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18583 Result_Definition
=>
18584 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18586 Parameter_Specifications
=> New_List
(
18587 Make_Parameter_Specification
(Loc
,
18588 Defining_Identifier
=>
18589 Make_Defining_Identifier
(Loc
, Name_Value
),
18591 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18593 Make_Parameter_Specification
(Loc
,
18594 Defining_Identifier
=>
18595 Make_Defining_Identifier
(Loc
, Name_Amount
),
18597 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18601 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18602 Pragma_Argument_Associations
=> New_List
(
18603 Make_Pragma_Argument_Association
(Loc
,
18604 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18605 Make_Pragma_Argument_Association
(Loc
,
18606 Expression
=> Make_Identifier
(Loc
, Nam
))));
18608 Insert_After
(N
, Import
);
18609 Insert_After
(N
, Func
);
18610 end Declare_Shift_Operator
;
18612 -- Start of processing for Provide_Shift_Operators
18616 Check_Arg_Count
(1);
18617 Check_Arg_Is_Local_Name
(Arg1
);
18619 Arg1
:= Get_Pragma_Arg
(Arg1
);
18621 -- We must have an entity name
18623 if not Is_Entity_Name
(Arg1
) then
18625 ("pragma % must apply to integer first subtype", Arg1
);
18628 -- If no Entity, means there was a prior error so ignore
18630 if Present
(Entity
(Arg1
)) then
18631 Ent
:= Entity
(Arg1
);
18633 -- Apply error checks
18635 if not Is_First_Subtype
(Ent
) then
18637 ("cannot apply pragma %",
18638 "\& is not a first subtype",
18641 elsif not Is_Integer_Type
(Ent
) then
18643 ("cannot apply pragma %",
18644 "\& is not an integer type",
18647 elsif Has_Shift_Operator
(Ent
) then
18649 ("cannot apply pragma %",
18650 "\& already has declared shift operators",
18653 elsif Is_Frozen
(Ent
) then
18655 ("pragma % appears too late",
18656 "\& is already frozen",
18660 -- Now declare the operators. We do this during analysis rather
18661 -- than expansion, since we want the operators available if we
18662 -- are operating in -gnatc or ASIS mode.
18664 Declare_Shift_Operator
(Name_Rotate_Left
);
18665 Declare_Shift_Operator
(Name_Rotate_Right
);
18666 Declare_Shift_Operator
(Name_Shift_Left
);
18667 Declare_Shift_Operator
(Name_Shift_Right
);
18668 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18670 end Provide_Shift_Operators
;
18676 -- pragma Psect_Object (
18677 -- [Internal =>] LOCAL_NAME,
18678 -- [, [External =>] EXTERNAL_SYMBOL]
18679 -- [, [Size =>] EXTERNAL_SYMBOL]);
18681 when Pragma_Psect_Object | Pragma_Common_Object
=>
18682 Psect_Object
: declare
18683 Args
: Args_List
(1 .. 3);
18684 Names
: constant Name_List
(1 .. 3) := (
18689 Internal
: Node_Id
renames Args
(1);
18690 External
: Node_Id
renames Args
(2);
18691 Size
: Node_Id
renames Args
(3);
18693 Def_Id
: Entity_Id
;
18695 procedure Check_Arg
(Arg
: Node_Id
);
18696 -- Checks that argument is either a string literal or an
18697 -- identifier, and posts error message if not.
18703 procedure Check_Arg
(Arg
: Node_Id
) is
18705 if not Nkind_In
(Original_Node
(Arg
),
18710 ("inappropriate argument for pragma %", Arg
);
18714 -- Start of processing for Common_Object/Psect_Object
18718 Gather_Associations
(Names
, Args
);
18719 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18721 Def_Id
:= Entity
(Internal
);
18723 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18725 ("pragma% must designate an object", Internal
);
18728 Check_Arg
(Internal
);
18730 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18732 ("cannot use pragma% for imported/exported object",
18736 if Is_Concurrent_Type
(Etype
(Internal
)) then
18738 ("cannot specify pragma % for task/protected object",
18742 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18744 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18746 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18749 if Ekind
(Def_Id
) = E_Constant
then
18751 ("cannot specify pragma % for a constant", Internal
);
18754 if Is_Record_Type
(Etype
(Internal
)) then
18760 Ent
:= First_Entity
(Etype
(Internal
));
18761 while Present
(Ent
) loop
18762 Decl
:= Declaration_Node
(Ent
);
18764 if Ekind
(Ent
) = E_Component
18765 and then Nkind
(Decl
) = N_Component_Declaration
18766 and then Present
(Expression
(Decl
))
18767 and then Warn_On_Export_Import
18770 ("?x?object for pragma % has defaults", Internal
);
18780 if Present
(Size
) then
18784 if Present
(External
) then
18785 Check_Arg_Is_External_Name
(External
);
18788 -- If all error tests pass, link pragma on to the rep item chain
18790 Record_Rep_Item
(Def_Id
, N
);
18797 -- pragma Pure [(library_unit_NAME)];
18799 when Pragma_Pure
=> Pure
: declare
18803 Check_Ada_83_Warning
;
18804 Check_Valid_Library_Unit_Pragma
;
18806 if Nkind
(N
) = N_Null_Statement
then
18810 Ent
:= Find_Lib_Unit_Name
;
18812 Set_Has_Pragma_Pure
(Ent
);
18813 Set_Suppress_Elaboration_Warnings
(Ent
);
18816 -------------------
18817 -- Pure_Function --
18818 -------------------
18820 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18822 when Pragma_Pure_Function
=> Pure_Function
: declare
18825 Def_Id
: Entity_Id
;
18826 Effective
: Boolean := False;
18830 Check_Arg_Count
(1);
18831 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18832 Check_Arg_Is_Local_Name
(Arg1
);
18833 E_Id
:= Get_Pragma_Arg
(Arg1
);
18835 if Error_Posted
(E_Id
) then
18839 -- Loop through homonyms (overloadings) of referenced entity
18841 E
:= Entity
(E_Id
);
18843 if Present
(E
) then
18845 Def_Id
:= Get_Base_Subprogram
(E
);
18847 if not Ekind_In
(Def_Id
, E_Function
,
18848 E_Generic_Function
,
18852 ("pragma% requires a function name", Arg1
);
18855 Set_Is_Pure
(Def_Id
);
18857 if not Has_Pragma_Pure_Function
(Def_Id
) then
18858 Set_Has_Pragma_Pure_Function
(Def_Id
);
18862 exit when From_Aspect_Specification
(N
);
18864 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18868 and then Warn_On_Redundant_Constructs
18871 ("pragma Pure_Function on& is redundant?r?",
18877 --------------------
18878 -- Queuing_Policy --
18879 --------------------
18881 -- pragma Queuing_Policy (policy_IDENTIFIER);
18883 when Pragma_Queuing_Policy
=> declare
18887 Check_Ada_83_Warning
;
18888 Check_Arg_Count
(1);
18889 Check_No_Identifiers
;
18890 Check_Arg_Is_Queuing_Policy
(Arg1
);
18891 Check_Valid_Configuration_Pragma
;
18892 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18893 QP
:= Fold_Upper
(Name_Buffer
(1));
18895 if Queuing_Policy
/= ' '
18896 and then Queuing_Policy
/= QP
18898 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18899 Error_Pragma
("queuing policy incompatible with policy#");
18901 -- Set new policy, but always preserve System_Location since we
18902 -- like the error message with the run time name.
18905 Queuing_Policy
:= QP
;
18907 if Queuing_Policy_Sloc
/= System_Location
then
18908 Queuing_Policy_Sloc
:= Loc
;
18917 -- pragma Rational, for compatibility with foreign compiler
18919 when Pragma_Rational
=>
18920 Set_Rational_Profile
;
18922 ------------------------------------
18923 -- Refined_Depends/Refined_Global --
18924 ------------------------------------
18926 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18928 -- DEPENDENCY_RELATION ::=
18930 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18932 -- DEPENDENCY_CLAUSE ::=
18933 -- OUTPUT_LIST =>[+] INPUT_LIST
18934 -- | NULL_DEPENDENCY_CLAUSE
18936 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18938 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18940 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18942 -- OUTPUT ::= NAME | FUNCTION_RESULT
18945 -- where FUNCTION_RESULT is a function Result attribute_reference
18947 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18949 -- GLOBAL_SPECIFICATION ::=
18952 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18954 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18956 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18957 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18958 -- GLOBAL_ITEM ::= NAME
18960 when Pragma_Refined_Depends |
18961 Pragma_Refined_Global
=> Refined_Depends_Global
:
18963 Body_Id
: Entity_Id
;
18965 Spec_Id
: Entity_Id
;
18968 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18970 -- Save the pragma in the contract of the subprogram body. The
18971 -- remaining analysis is performed at the end of the enclosing
18975 Add_Contract_Item
(N
, Body_Id
);
18977 end Refined_Depends_Global
;
18983 -- pragma Refined_Post (boolean_EXPRESSION);
18985 when Pragma_Refined_Post
=> Refined_Post
: declare
18986 Body_Id
: Entity_Id
;
18988 Result_Seen
: Boolean := False;
18989 Spec_Id
: Entity_Id
;
18992 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18994 -- Analyze the boolean expression as a "spec expression"
18997 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
18999 -- Verify that the refined postcondition mentions attribute
19000 -- 'Result and its expression introduces a post-state.
19002 if Warn_On_Suspicious_Contract
19003 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
19005 Check_Result_And_Post_State
(N
, Result_Seen
);
19007 if not Result_Seen
then
19009 ("pragma % does not mention function result?T?");
19013 -- Chain the pragma on the contract for easy retrieval
19015 Add_Contract_Item
(N
, Body_Id
);
19019 -------------------
19020 -- Refined_State --
19021 -------------------
19023 -- pragma Refined_State (REFINEMENT_LIST);
19025 -- REFINEMENT_LIST ::=
19026 -- REFINEMENT_CLAUSE
19027 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19029 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19031 -- CONSTITUENT_LIST ::=
19034 -- | (CONSTITUENT {, CONSTITUENT})
19036 -- CONSTITUENT ::= object_NAME | state_NAME
19038 when Pragma_Refined_State
=> Refined_State
: declare
19039 Context
: constant Node_Id
:= Parent
(N
);
19040 Spec_Id
: Entity_Id
;
19045 Check_No_Identifiers
;
19046 Check_Arg_Count
(1);
19048 -- Ensure the proper placement of the pragma. Refined states must
19049 -- be associated with a package body.
19051 if Nkind
(Context
) /= N_Package_Body
then
19057 while Present
(Stmt
) loop
19059 -- Skip prior pragmas, but check for duplicates
19061 if Nkind
(Stmt
) = N_Pragma
then
19062 if Pragma_Name
(Stmt
) = Pname
then
19063 Error_Msg_Name_1
:= Pname
;
19064 Error_Msg_Sloc
:= Sloc
(Stmt
);
19065 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
19068 -- Skip internally generated code
19070 elsif not Comes_From_Source
(Stmt
) then
19073 -- The pragma does not apply to a legal construct, issue an
19074 -- error and stop the analysis.
19081 Stmt
:= Prev
(Stmt
);
19084 Spec_Id
:= Corresponding_Spec
(Context
);
19086 -- State refinement is allowed only when the corresponding package
19087 -- declaration has non-null pragma Abstract_State. Refinement not
19088 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19090 if SPARK_Mode
/= Off
19092 (No
(Abstract_States
(Spec_Id
))
19093 or else Has_Null_Abstract_State
(Spec_Id
))
19096 ("useless refinement, package & does not define abstract "
19097 & "states", N
, Spec_Id
);
19101 -- The pragma must be analyzed at the end of the declarations as
19102 -- it has visibility over the whole declarative region. Save the
19103 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19104 -- adding it to the contract of the package body.
19106 Add_Contract_Item
(N
, Defining_Entity
(Context
));
19109 -----------------------
19110 -- Relative_Deadline --
19111 -----------------------
19113 -- pragma Relative_Deadline (time_span_EXPRESSION);
19115 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19116 P
: constant Node_Id
:= Parent
(N
);
19121 Check_No_Identifiers
;
19122 Check_Arg_Count
(1);
19124 Arg
:= Get_Pragma_Arg
(Arg1
);
19126 -- The expression must be analyzed in the special manner described
19127 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19129 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19133 if Nkind
(P
) = N_Subprogram_Body
then
19134 Check_In_Main_Program
;
19136 -- Only Task and subprogram cases allowed
19138 elsif Nkind
(P
) /= N_Task_Definition
then
19142 -- Check duplicate pragma before we set the corresponding flag
19144 if Has_Relative_Deadline_Pragma
(P
) then
19145 Error_Pragma
("duplicate pragma% not allowed");
19148 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19149 -- Relative_Deadline pragma node cannot be inserted in the Rep
19150 -- Item chain of Ent since it is rewritten by the expander as a
19151 -- procedure call statement that will break the chain.
19153 Set_Has_Relative_Deadline_Pragma
(P
, True);
19154 end Relative_Deadline
;
19156 ------------------------
19157 -- Remote_Access_Type --
19158 ------------------------
19160 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19162 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19167 Check_Arg_Count
(1);
19168 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19169 Check_Arg_Is_Local_Name
(Arg1
);
19171 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19173 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19174 and then Ekind
(E
) = E_General_Access_Type
19175 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19176 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19178 and then Is_Valid_Remote_Object_Type
19179 (Root_Type
(Directly_Designated_Type
(E
)))
19181 Set_Is_Remote_Types
(E
);
19185 ("pragma% applies only to formal access to classwide types",
19188 end Remote_Access_Type
;
19190 ---------------------------
19191 -- Remote_Call_Interface --
19192 ---------------------------
19194 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19196 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19197 Cunit_Node
: Node_Id
;
19198 Cunit_Ent
: Entity_Id
;
19202 Check_Ada_83_Warning
;
19203 Check_Valid_Library_Unit_Pragma
;
19205 if Nkind
(N
) = N_Null_Statement
then
19209 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19210 K
:= Nkind
(Unit
(Cunit_Node
));
19211 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19213 if K
= N_Package_Declaration
19214 or else K
= N_Generic_Package_Declaration
19215 or else K
= N_Subprogram_Declaration
19216 or else K
= N_Generic_Subprogram_Declaration
19217 or else (K
= N_Subprogram_Body
19218 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19223 "pragma% must apply to package or subprogram declaration");
19226 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19227 end Remote_Call_Interface
;
19233 -- pragma Remote_Types [(library_unit_NAME)];
19235 when Pragma_Remote_Types
=> Remote_Types
: declare
19236 Cunit_Node
: Node_Id
;
19237 Cunit_Ent
: Entity_Id
;
19240 Check_Ada_83_Warning
;
19241 Check_Valid_Library_Unit_Pragma
;
19243 if Nkind
(N
) = N_Null_Statement
then
19247 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19248 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19250 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19251 N_Generic_Package_Declaration
)
19254 ("pragma% can only apply to a package declaration");
19257 Set_Is_Remote_Types
(Cunit_Ent
);
19264 -- pragma Ravenscar;
19266 when Pragma_Ravenscar
=>
19268 Check_Arg_Count
(0);
19269 Check_Valid_Configuration_Pragma
;
19270 Set_Ravenscar_Profile
(N
);
19272 if Warn_On_Obsolescent_Feature
then
19274 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19276 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19279 -------------------------
19280 -- Restricted_Run_Time --
19281 -------------------------
19283 -- pragma Restricted_Run_Time;
19285 when Pragma_Restricted_Run_Time
=>
19287 Check_Arg_Count
(0);
19288 Check_Valid_Configuration_Pragma
;
19289 Set_Profile_Restrictions
19290 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19292 if Warn_On_Obsolescent_Feature
then
19294 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19297 ("|use pragma Profile (Restricted) instead?j?", N
);
19304 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19307 -- restriction_IDENTIFIER
19308 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19310 when Pragma_Restrictions
=>
19311 Process_Restrictions_Or_Restriction_Warnings
19312 (Warn
=> Treat_Restrictions_As_Warnings
);
19314 --------------------------
19315 -- Restriction_Warnings --
19316 --------------------------
19318 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19321 -- restriction_IDENTIFIER
19322 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19324 when Pragma_Restriction_Warnings
=>
19326 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19332 -- pragma Reviewable;
19334 when Pragma_Reviewable
=>
19335 Check_Ada_83_Warning
;
19336 Check_Arg_Count
(0);
19338 -- Call dummy debugging function rv. This is done to assist front
19339 -- end debugging. By placing a Reviewable pragma in the source
19340 -- program, a breakpoint on rv catches this place in the source,
19341 -- allowing convenient stepping to the point of interest.
19345 --------------------------
19346 -- Short_Circuit_And_Or --
19347 --------------------------
19349 -- pragma Short_Circuit_And_Or;
19351 when Pragma_Short_Circuit_And_Or
=>
19353 Check_Arg_Count
(0);
19354 Check_Valid_Configuration_Pragma
;
19355 Short_Circuit_And_Or
:= True;
19357 -------------------
19358 -- Share_Generic --
19359 -------------------
19361 -- pragma Share_Generic (GNAME {, GNAME});
19363 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19365 when Pragma_Share_Generic
=>
19367 Process_Generic_List
;
19373 -- pragma Shared (LOCAL_NAME);
19375 when Pragma_Shared
=>
19377 Process_Atomic_Independent_Shared_Volatile
;
19379 --------------------
19380 -- Shared_Passive --
19381 --------------------
19383 -- pragma Shared_Passive [(library_unit_NAME)];
19385 -- Set the flag Is_Shared_Passive of program unit name entity
19387 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19388 Cunit_Node
: Node_Id
;
19389 Cunit_Ent
: Entity_Id
;
19392 Check_Ada_83_Warning
;
19393 Check_Valid_Library_Unit_Pragma
;
19395 if Nkind
(N
) = N_Null_Statement
then
19399 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19400 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19402 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19403 N_Generic_Package_Declaration
)
19406 ("pragma% can only apply to a package declaration");
19409 Set_Is_Shared_Passive
(Cunit_Ent
);
19410 end Shared_Passive
;
19412 -----------------------
19413 -- Short_Descriptors --
19414 -----------------------
19416 -- pragma Short_Descriptors;
19418 -- Recognize and validate, but otherwise ignore
19420 when Pragma_Short_Descriptors
=>
19422 Check_Arg_Count
(0);
19423 Check_Valid_Configuration_Pragma
;
19425 ------------------------------
19426 -- Simple_Storage_Pool_Type --
19427 ------------------------------
19429 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19431 when Pragma_Simple_Storage_Pool_Type
=>
19432 Simple_Storage_Pool_Type
: declare
19438 Check_Arg_Count
(1);
19439 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19441 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19442 Find_Type
(Type_Id
);
19443 Typ
:= Entity
(Type_Id
);
19445 if Typ
= Any_Type
then
19449 -- We require the pragma to apply to a type declared in a package
19450 -- declaration, but not (immediately) within a package body.
19452 if Ekind
(Current_Scope
) /= E_Package
19453 or else In_Package_Body
(Current_Scope
)
19456 ("pragma% can only apply to type declared immediately "
19457 & "within a package declaration");
19460 -- A simple storage pool type must be an immutably limited record
19461 -- or private type. If the pragma is given for a private type,
19462 -- the full type is similarly restricted (which is checked later
19463 -- in Freeze_Entity).
19465 if Is_Record_Type
(Typ
)
19466 and then not Is_Limited_View
(Typ
)
19469 ("pragma% can only apply to explicitly limited record type");
19471 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19473 ("pragma% can only apply to a private type that is limited");
19475 elsif not Is_Record_Type
(Typ
)
19476 and then not Is_Private_Type
(Typ
)
19479 ("pragma% can only apply to limited record or private type");
19482 Record_Rep_Item
(Typ
, N
);
19483 end Simple_Storage_Pool_Type
;
19485 ----------------------
19486 -- Source_File_Name --
19487 ----------------------
19489 -- There are five forms for this pragma:
19491 -- pragma Source_File_Name (
19492 -- [UNIT_NAME =>] unit_NAME,
19493 -- BODY_FILE_NAME => STRING_LITERAL
19494 -- [, [INDEX =>] INTEGER_LITERAL]);
19496 -- pragma Source_File_Name (
19497 -- [UNIT_NAME =>] unit_NAME,
19498 -- SPEC_FILE_NAME => STRING_LITERAL
19499 -- [, [INDEX =>] INTEGER_LITERAL]);
19501 -- pragma Source_File_Name (
19502 -- BODY_FILE_NAME => STRING_LITERAL
19503 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19504 -- [, CASING => CASING_SPEC]);
19506 -- pragma Source_File_Name (
19507 -- SPEC_FILE_NAME => STRING_LITERAL
19508 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19509 -- [, CASING => CASING_SPEC]);
19511 -- pragma Source_File_Name (
19512 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19513 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19514 -- [, CASING => CASING_SPEC]);
19516 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19518 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19519 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19520 -- only be used when no project file is used, while SFNP can only be
19521 -- used when a project file is used.
19523 -- No processing here. Processing was completed during parsing, since
19524 -- we need to have file names set as early as possible. Units are
19525 -- loaded well before semantic processing starts.
19527 -- The only processing we defer to this point is the check for
19528 -- correct placement.
19530 when Pragma_Source_File_Name
=>
19532 Check_Valid_Configuration_Pragma
;
19534 ------------------------------
19535 -- Source_File_Name_Project --
19536 ------------------------------
19538 -- See Source_File_Name for syntax
19540 -- No processing here. Processing was completed during parsing, since
19541 -- we need to have file names set as early as possible. Units are
19542 -- loaded well before semantic processing starts.
19544 -- The only processing we defer to this point is the check for
19545 -- correct placement.
19547 when Pragma_Source_File_Name_Project
=>
19549 Check_Valid_Configuration_Pragma
;
19551 -- Check that a pragma Source_File_Name_Project is used only in a
19552 -- configuration pragmas file.
19554 -- Pragmas Source_File_Name_Project should only be generated by
19555 -- the Project Manager in configuration pragmas files.
19557 -- This is really an ugly test. It seems to depend on some
19558 -- accidental and undocumented property. At the very least it
19559 -- needs to be documented, but it would be better to have a
19560 -- clean way of testing if we are in a configuration file???
19562 if Present
(Parent
(N
)) then
19564 ("pragma% can only appear in a configuration pragmas file");
19567 ----------------------
19568 -- Source_Reference --
19569 ----------------------
19571 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19573 -- Nothing to do, all processing completed in Par.Prag, since we need
19574 -- the information for possible parser messages that are output.
19576 when Pragma_Source_Reference
=>
19583 -- pragma SPARK_Mode [(On | Off)];
19585 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19586 Mode_Id
: SPARK_Mode_Type
;
19588 procedure Check_Pragma_Conformance
19589 (Context_Pragma
: Node_Id
;
19590 Entity_Pragma
: Node_Id
;
19591 Entity
: Entity_Id
);
19592 -- If Context_Pragma is not Empty, verify that the new pragma N
19593 -- is compatible with the pragma Context_Pragma that was inherited
19594 -- from the context:
19595 -- . if Context_Pragma is ON, then the new mode can be anything
19596 -- . if Context_Pragma is OFF, then the only allowed new mode is
19599 -- If Entity is not Empty, verify that the new pragma N is
19600 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19601 -- for Entity (which may be Empty):
19602 -- . if Entity_Pragma is ON, then the new mode can be anything
19603 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19605 -- . if Entity_Pragma is Empty, we always issue an error, as this
19606 -- corresponds to a case where a previous section of Entity
19607 -- had no SPARK_Mode set.
19609 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19610 -- Verify that pragma is applied to library-level entity E
19612 procedure Set_SPARK_Flags
;
19613 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19614 -- and ensures that Dynamic_Elaboration_Checks are off if the
19615 -- call sets SPARK_Mode On.
19617 ------------------------------
19618 -- Check_Pragma_Conformance --
19619 ------------------------------
19621 procedure Check_Pragma_Conformance
19622 (Context_Pragma
: Node_Id
;
19623 Entity_Pragma
: Node_Id
;
19624 Entity
: Entity_Id
)
19626 Arg
: Node_Id
:= Arg1
;
19629 -- The current pragma may appear without an argument. If this
19630 -- is the case, associate all error messages with the pragma
19637 -- The mode of the current pragma is compared against that of
19638 -- an enclosing context.
19640 if Present
(Context_Pragma
) then
19641 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19643 -- Issue an error if the new mode is less restrictive than
19644 -- that of the context.
19646 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19647 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19650 ("cannot change SPARK_Mode from Off to On", Arg
);
19651 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19652 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg
);
19657 -- The mode of the current pragma is compared against that of
19658 -- an initial package/subprogram declaration.
19660 if Present
(Entity
) then
19662 -- Both the initial declaration and the completion carry
19663 -- SPARK_Mode pragmas.
19665 if Present
(Entity_Pragma
) then
19666 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
19668 -- Issue an error if the new mode is less restrictive
19669 -- than that of the initial declaration.
19671 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19672 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19674 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19675 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19677 ("\value Off was set for SPARK_Mode on&#",
19682 -- Otherwise the initial declaration lacks a SPARK_Mode
19683 -- pragma in which case the current pragma is illegal as
19684 -- it cannot "complete".
19687 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19688 Error_Msg_Sloc
:= Sloc
(Entity
);
19690 ("\no value was set for SPARK_Mode on&#",
19695 end Check_Pragma_Conformance
;
19697 --------------------------------
19698 -- Check_Library_Level_Entity --
19699 --------------------------------
19701 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19702 MsgF
: constant String := "incorrect placement of pragma%";
19705 if not Is_Library_Level_Entity
(E
) then
19706 Error_Msg_Name_1
:= Pname
;
19707 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19709 if Ekind_In
(E
, E_Generic_Package
,
19714 ("\& is not a library-level package", N
, E
);
19717 ("\& is not a library-level subprogram", N
, E
);
19722 end Check_Library_Level_Entity
;
19724 ---------------------
19725 -- Set_SPARK_Flags --
19726 ---------------------
19728 procedure Set_SPARK_Flags
is
19730 SPARK_Mode
:= Mode_Id
;
19731 SPARK_Mode_Pragma
:= N
;
19733 if SPARK_Mode
= On
then
19734 Dynamic_Elaboration_Checks
:= False;
19736 end Set_SPARK_Flags
;
19740 Body_Id
: Entity_Id
;
19743 Spec_Id
: Entity_Id
;
19746 -- Start of processing for Do_SPARK_Mode
19749 -- When a SPARK_Mode pragma appears inside an instantiation whose
19750 -- enclosing context has SPARK_Mode set to "off", the pragma has
19751 -- no semantic effect.
19753 if Ignore_Pragma_SPARK_Mode
then
19754 Rewrite
(N
, Make_Null_Statement
(Loc
));
19760 Check_No_Identifiers
;
19761 Check_At_Most_N_Arguments
(1);
19763 -- Check the legality of the mode (no argument = ON)
19765 if Arg_Count
= 1 then
19766 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19767 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19772 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19773 Context
:= Parent
(N
);
19775 -- The pragma appears in a configuration pragmas file
19777 if No
(Context
) then
19778 Check_Valid_Configuration_Pragma
;
19780 if Present
(SPARK_Mode_Pragma
) then
19781 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19782 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19788 -- The pragma acts as a configuration pragma in a compilation unit
19790 -- pragma SPARK_Mode ...;
19791 -- package Pack is ...;
19793 elsif Nkind
(Context
) = N_Compilation_Unit
19794 and then List_Containing
(N
) = Context_Items
(Context
)
19796 Check_Valid_Configuration_Pragma
;
19799 -- Otherwise the placement of the pragma within the tree dictates
19800 -- its associated construct. Inspect the declarative list where
19801 -- the pragma resides to find a potential construct.
19805 while Present
(Stmt
) loop
19807 -- Skip prior pragmas, but check for duplicates
19809 if Nkind
(Stmt
) = N_Pragma
then
19810 if Pragma_Name
(Stmt
) = Pname
then
19811 Error_Msg_Name_1
:= Pname
;
19812 Error_Msg_Sloc
:= Sloc
(Stmt
);
19813 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19817 -- The pragma applies to a [generic] subprogram declaration.
19818 -- Note that this case covers an internally generated spec
19819 -- for a stand alone body.
19822 -- procedure Proc ...;
19823 -- pragma SPARK_Mode ..;
19825 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19826 N_Subprogram_Declaration
)
19828 Spec_Id
:= Defining_Entity
(Stmt
);
19829 Check_Library_Level_Entity
(Spec_Id
);
19830 Check_Pragma_Conformance
19831 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19832 Entity_Pragma
=> Empty
,
19835 Set_SPARK_Pragma
(Spec_Id
, N
);
19836 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19839 -- Skip internally generated code
19841 elsif not Comes_From_Source
(Stmt
) then
19844 -- Otherwise the pragma does not apply to a legal construct
19845 -- or it does not appear at the top of a declarative or a
19846 -- statement list. Issue an error and stop the analysis.
19856 -- The pragma applies to a package or a subprogram that acts as
19857 -- a compilation unit.
19859 -- procedure Proc ...;
19860 -- pragma SPARK_Mode ...;
19862 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19863 Context
:= Unit
(Parent
(Context
));
19866 -- The pragma appears within package declarations
19868 if Nkind
(Context
) = N_Package_Specification
then
19869 Spec_Id
:= Defining_Entity
(Context
);
19870 Check_Library_Level_Entity
(Spec_Id
);
19872 -- The pragma is at the top of the visible declarations
19875 -- pragma SPARK_Mode ...;
19877 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19878 Check_Pragma_Conformance
19879 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19880 Entity_Pragma
=> Empty
,
19884 Set_SPARK_Pragma
(Spec_Id
, N
);
19885 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19886 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19887 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19889 -- The pragma is at the top of the private declarations
19893 -- pragma SPARK_Mode ...;
19896 Check_Pragma_Conformance
19897 (Context_Pragma
=> Empty
,
19898 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19899 Entity
=> Spec_Id
);
19902 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19903 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19906 -- The pragma appears at the top of package body declarations
19908 -- package body Pack is
19909 -- pragma SPARK_Mode ...;
19911 elsif Nkind
(Context
) = N_Package_Body
then
19912 Spec_Id
:= Corresponding_Spec
(Context
);
19913 Body_Id
:= Defining_Entity
(Context
);
19914 Check_Library_Level_Entity
(Body_Id
);
19915 Check_Pragma_Conformance
19916 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19917 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19918 Entity
=> Spec_Id
);
19921 Set_SPARK_Pragma
(Body_Id
, N
);
19922 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19923 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19924 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19926 -- The pragma appears at the top of package body statements
19928 -- package body Pack is
19930 -- pragma SPARK_Mode;
19932 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19933 and then Nkind
(Parent
(Context
)) = N_Package_Body
19935 Context
:= Parent
(Context
);
19936 Spec_Id
:= Corresponding_Spec
(Context
);
19937 Body_Id
:= Defining_Entity
(Context
);
19938 Check_Library_Level_Entity
(Body_Id
);
19939 Check_Pragma_Conformance
19940 (Context_Pragma
=> Empty
,
19941 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19942 Entity
=> Body_Id
);
19945 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19946 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19948 -- The pragma appeared as an aspect of a [generic] subprogram
19949 -- declaration that acts as a compilation unit.
19952 -- procedure Proc ...;
19953 -- pragma SPARK_Mode ...;
19955 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19956 N_Subprogram_Declaration
)
19958 Spec_Id
:= Defining_Entity
(Context
);
19959 Check_Library_Level_Entity
(Spec_Id
);
19960 Check_Pragma_Conformance
19961 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19962 Entity_Pragma
=> Empty
,
19965 Set_SPARK_Pragma
(Spec_Id
, N
);
19966 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19968 -- The pragma appears at the top of subprogram body
19971 -- procedure Proc ... is
19972 -- pragma SPARK_Mode;
19974 elsif Nkind
(Context
) = N_Subprogram_Body
then
19975 Spec_Id
:= Corresponding_Spec
(Context
);
19976 Context
:= Specification
(Context
);
19977 Body_Id
:= Defining_Entity
(Context
);
19979 -- Ignore pragma when applied to the special body created
19980 -- for inlining, recognized by its internal name _Parent.
19982 if Chars
(Body_Id
) = Name_uParent
then
19986 Check_Library_Level_Entity
(Body_Id
);
19988 -- The body is a completion of a previous declaration
19990 if Present
(Spec_Id
) then
19991 Check_Pragma_Conformance
19992 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19993 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19994 Entity
=> Spec_Id
);
19996 -- The body acts as spec
19999 Check_Pragma_Conformance
20000 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20001 Entity_Pragma
=> Empty
,
20007 Set_SPARK_Pragma
(Body_Id
, N
);
20008 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20010 -- The pragma does not apply to a legal construct, issue error
20018 --------------------------------
20019 -- Static_Elaboration_Desired --
20020 --------------------------------
20022 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20024 when Pragma_Static_Elaboration_Desired
=>
20026 Check_At_Most_N_Arguments
(1);
20028 if Is_Compilation_Unit
(Current_Scope
)
20029 and then Ekind
(Current_Scope
) = E_Package
20031 Set_Static_Elaboration_Desired
(Current_Scope
, True);
20033 Error_Pragma
("pragma% must apply to a library-level package");
20040 -- pragma Storage_Size (EXPRESSION);
20042 when Pragma_Storage_Size
=> Storage_Size
: declare
20043 P
: constant Node_Id
:= Parent
(N
);
20047 Check_No_Identifiers
;
20048 Check_Arg_Count
(1);
20050 -- The expression must be analyzed in the special manner described
20051 -- in "Handling of Default Expressions" in sem.ads.
20053 Arg
:= Get_Pragma_Arg
(Arg1
);
20054 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20056 if not Is_OK_Static_Expression
(Arg
) then
20057 Check_Restriction
(Static_Storage_Size
, Arg
);
20060 if Nkind
(P
) /= N_Task_Definition
then
20065 if Has_Storage_Size_Pragma
(P
) then
20066 Error_Pragma
("duplicate pragma% not allowed");
20068 Set_Has_Storage_Size_Pragma
(P
, True);
20071 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20079 -- pragma Storage_Unit (NUMERIC_LITERAL);
20081 -- Only permitted argument is System'Storage_Unit value
20083 when Pragma_Storage_Unit
=>
20084 Check_No_Identifiers
;
20085 Check_Arg_Count
(1);
20086 Check_Arg_Is_Integer_Literal
(Arg1
);
20088 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20089 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20091 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20093 ("the only allowed argument for pragma% is ^", Arg1
);
20096 --------------------
20097 -- Stream_Convert --
20098 --------------------
20100 -- pragma Stream_Convert (
20101 -- [Entity =>] type_LOCAL_NAME,
20102 -- [Read =>] function_NAME,
20103 -- [Write =>] function NAME);
20105 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20107 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20108 -- Check that the given argument is the name of a local function
20109 -- of one argument that is not overloaded earlier in the current
20110 -- local scope. A check is also made that the argument is a
20111 -- function with one parameter.
20113 --------------------------------------
20114 -- Check_OK_Stream_Convert_Function --
20115 --------------------------------------
20117 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20121 Check_Arg_Is_Local_Name
(Arg
);
20122 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20124 if Has_Homonym
(Ent
) then
20126 ("argument for pragma% may not be overloaded", Arg
);
20129 if Ekind
(Ent
) /= E_Function
20130 or else No
(First_Formal
(Ent
))
20131 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20134 ("argument for pragma% must be function of one argument",
20137 end Check_OK_Stream_Convert_Function
;
20139 -- Start of processing for Stream_Convert
20143 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20144 Check_Arg_Count
(3);
20145 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20146 Check_Optional_Identifier
(Arg2
, Name_Read
);
20147 Check_Optional_Identifier
(Arg3
, Name_Write
);
20148 Check_Arg_Is_Local_Name
(Arg1
);
20149 Check_OK_Stream_Convert_Function
(Arg2
);
20150 Check_OK_Stream_Convert_Function
(Arg3
);
20153 Typ
: constant Entity_Id
:=
20154 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20155 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20156 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20159 Check_First_Subtype
(Arg1
);
20161 -- Check for too early or too late. Note that we don't enforce
20162 -- the rule about primitive operations in this case, since, as
20163 -- is the case for explicit stream attributes themselves, these
20164 -- restrictions are not appropriate. Note that the chaining of
20165 -- the pragma by Rep_Item_Too_Late is actually the critical
20166 -- processing done for this pragma.
20168 if Rep_Item_Too_Early
(Typ
, N
)
20170 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20175 -- Return if previous error
20177 if Etype
(Typ
) = Any_Type
20179 Etype
(Read
) = Any_Type
20181 Etype
(Write
) = Any_Type
20188 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20190 ("incorrect return type for function&", Arg2
);
20193 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20195 ("incorrect parameter type for function&", Arg3
);
20198 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20199 Underlying_Type
(Etype
(Write
))
20202 ("result type of & does not match Read parameter type",
20206 end Stream_Convert
;
20212 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20214 -- This is processed by the parser since some of the style checks
20215 -- take place during source scanning and parsing. This means that
20216 -- we don't need to issue error messages here.
20218 when Pragma_Style_Checks
=> Style_Checks
: declare
20219 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20225 Check_No_Identifiers
;
20227 -- Two argument form
20229 if Arg_Count
= 2 then
20230 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20237 E_Id
:= Get_Pragma_Arg
(Arg2
);
20240 if not Is_Entity_Name
(E_Id
) then
20242 ("second argument of pragma% must be entity name",
20246 E
:= Entity
(E_Id
);
20248 if not Ignore_Style_Checks_Pragmas
then
20253 Set_Suppress_Style_Checks
20254 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20255 exit when No
(Homonym
(E
));
20262 -- One argument form
20265 Check_Arg_Count
(1);
20267 if Nkind
(A
) = N_String_Literal
then
20271 Slen
: constant Natural := Natural (String_Length
(S
));
20272 Options
: String (1 .. Slen
);
20278 C
:= Get_String_Char
(S
, Int
(J
));
20279 exit when not In_Character_Range
(C
);
20280 Options
(J
) := Get_Character
(C
);
20282 -- If at end of string, set options. As per discussion
20283 -- above, no need to check for errors, since we issued
20284 -- them in the parser.
20287 if not Ignore_Style_Checks_Pragmas
then
20288 Set_Style_Check_Options
(Options
);
20298 elsif Nkind
(A
) = N_Identifier
then
20299 if Chars
(A
) = Name_All_Checks
then
20300 if not Ignore_Style_Checks_Pragmas
then
20302 Set_GNAT_Style_Check_Options
;
20304 Set_Default_Style_Check_Options
;
20308 elsif Chars
(A
) = Name_On
then
20309 if not Ignore_Style_Checks_Pragmas
then
20310 Style_Check
:= True;
20313 elsif Chars
(A
) = Name_Off
then
20314 if not Ignore_Style_Checks_Pragmas
then
20315 Style_Check
:= False;
20326 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20328 when Pragma_Subtitle
=>
20330 Check_Arg_Count
(1);
20331 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20332 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20339 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20341 when Pragma_Suppress
=>
20342 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
20348 -- pragma Suppress_All;
20350 -- The only check made here is that the pragma has no arguments.
20351 -- There are no placement rules, and the processing required (setting
20352 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20353 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20354 -- then creates and inserts a pragma Suppress (All_Checks).
20356 when Pragma_Suppress_All
=>
20358 Check_Arg_Count
(0);
20360 -------------------------
20361 -- Suppress_Debug_Info --
20362 -------------------------
20364 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20366 when Pragma_Suppress_Debug_Info
=>
20368 Check_Arg_Count
(1);
20369 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20370 Check_Arg_Is_Local_Name
(Arg1
);
20371 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20373 ----------------------------------
20374 -- Suppress_Exception_Locations --
20375 ----------------------------------
20377 -- pragma Suppress_Exception_Locations;
20379 when Pragma_Suppress_Exception_Locations
=>
20381 Check_Arg_Count
(0);
20382 Check_Valid_Configuration_Pragma
;
20383 Exception_Locations_Suppressed
:= True;
20385 -----------------------------
20386 -- Suppress_Initialization --
20387 -----------------------------
20389 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20391 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20397 Check_Arg_Count
(1);
20398 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20399 Check_Arg_Is_Local_Name
(Arg1
);
20401 E_Id
:= Get_Pragma_Arg
(Arg1
);
20403 if Etype
(E_Id
) = Any_Type
then
20407 E
:= Entity
(E_Id
);
20409 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20411 ("pragma% requires variable, type or subtype", Arg1
);
20414 if Rep_Item_Too_Early
(E
, N
)
20416 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20421 -- For incomplete/private type, set flag on full view
20423 if Is_Incomplete_Or_Private_Type
(E
) then
20424 if No
(Full_View
(Base_Type
(E
))) then
20426 ("argument of pragma% cannot be an incomplete type", Arg1
);
20428 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20431 -- For first subtype, set flag on base type
20433 elsif Is_First_Subtype
(E
) then
20434 Set_Suppress_Initialization
(Base_Type
(E
));
20436 -- For other than first subtype, set flag on subtype or variable
20439 Set_Suppress_Initialization
(E
);
20447 -- pragma System_Name (DIRECT_NAME);
20449 -- Syntax check: one argument, which must be the identifier GNAT or
20450 -- the identifier GCC, no other identifiers are acceptable.
20452 when Pragma_System_Name
=>
20454 Check_No_Identifiers
;
20455 Check_Arg_Count
(1);
20456 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20458 -----------------------------
20459 -- Task_Dispatching_Policy --
20460 -----------------------------
20462 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20464 when Pragma_Task_Dispatching_Policy
=> declare
20468 Check_Ada_83_Warning
;
20469 Check_Arg_Count
(1);
20470 Check_No_Identifiers
;
20471 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20472 Check_Valid_Configuration_Pragma
;
20473 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20474 DP
:= Fold_Upper
(Name_Buffer
(1));
20476 if Task_Dispatching_Policy
/= ' '
20477 and then Task_Dispatching_Policy
/= DP
20479 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20481 ("task dispatching policy incompatible with policy#");
20483 -- Set new policy, but always preserve System_Location since we
20484 -- like the error message with the run time name.
20487 Task_Dispatching_Policy
:= DP
;
20489 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20490 Task_Dispatching_Policy_Sloc
:= Loc
;
20499 -- pragma Task_Info (EXPRESSION);
20501 when Pragma_Task_Info
=> Task_Info
: declare
20502 P
: constant Node_Id
:= Parent
(N
);
20508 if Warn_On_Obsolescent_Feature
then
20510 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20511 & "instead?j?", N
);
20514 if Nkind
(P
) /= N_Task_Definition
then
20515 Error_Pragma
("pragma% must appear in task definition");
20518 Check_No_Identifiers
;
20519 Check_Arg_Count
(1);
20521 Analyze_And_Resolve
20522 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20524 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20528 Ent
:= Defining_Identifier
(Parent
(P
));
20530 -- Check duplicate pragma before we chain the pragma in the Rep
20531 -- Item chain of Ent.
20534 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20536 Error_Pragma
("duplicate pragma% not allowed");
20539 Record_Rep_Item
(Ent
, N
);
20546 -- pragma Task_Name (string_EXPRESSION);
20548 when Pragma_Task_Name
=> Task_Name
: declare
20549 P
: constant Node_Id
:= Parent
(N
);
20554 Check_No_Identifiers
;
20555 Check_Arg_Count
(1);
20557 Arg
:= Get_Pragma_Arg
(Arg1
);
20559 -- The expression is used in the call to Create_Task, and must be
20560 -- expanded there, not in the context of the current spec. It must
20561 -- however be analyzed to capture global references, in case it
20562 -- appears in a generic context.
20564 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20566 if Nkind
(P
) /= N_Task_Definition
then
20570 Ent
:= Defining_Identifier
(Parent
(P
));
20572 -- Check duplicate pragma before we chain the pragma in the Rep
20573 -- Item chain of Ent.
20576 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20578 Error_Pragma
("duplicate pragma% not allowed");
20581 Record_Rep_Item
(Ent
, N
);
20588 -- pragma Task_Storage (
20589 -- [Task_Type =>] LOCAL_NAME,
20590 -- [Top_Guard =>] static_integer_EXPRESSION);
20592 when Pragma_Task_Storage
=> Task_Storage
: declare
20593 Args
: Args_List
(1 .. 2);
20594 Names
: constant Name_List
(1 .. 2) := (
20598 Task_Type
: Node_Id
renames Args
(1);
20599 Top_Guard
: Node_Id
renames Args
(2);
20605 Gather_Associations
(Names
, Args
);
20607 if No
(Task_Type
) then
20609 ("missing task_type argument for pragma%");
20612 Check_Arg_Is_Local_Name
(Task_Type
);
20614 Ent
:= Entity
(Task_Type
);
20616 if not Is_Task_Type
(Ent
) then
20618 ("argument for pragma% must be task type", Task_Type
);
20621 if No
(Top_Guard
) then
20623 ("pragma% takes two arguments", Task_Type
);
20625 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20628 Check_First_Subtype
(Task_Type
);
20630 if Rep_Item_Too_Late
(Ent
, N
) then
20639 -- pragma Test_Case
20640 -- ([Name =>] Static_String_EXPRESSION
20641 -- ,[Mode =>] MODE_TYPE
20642 -- [, Requires => Boolean_EXPRESSION]
20643 -- [, Ensures => Boolean_EXPRESSION]);
20645 -- MODE_TYPE ::= Nominal | Robustness
20647 when Pragma_Test_Case
=>
20651 --------------------------
20652 -- Thread_Local_Storage --
20653 --------------------------
20655 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20657 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20663 Check_Arg_Count
(1);
20664 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20665 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20667 Id
:= Get_Pragma_Arg
(Arg1
);
20670 if not Is_Entity_Name
(Id
)
20671 or else Ekind
(Entity
(Id
)) /= E_Variable
20673 Error_Pragma_Arg
("local variable name required", Arg1
);
20678 if Rep_Item_Too_Early
(E
, N
)
20679 or else Rep_Item_Too_Late
(E
, N
)
20684 Set_Has_Pragma_Thread_Local_Storage
(E
);
20685 Set_Has_Gigi_Rep_Item
(E
);
20686 end Thread_Local_Storage
;
20692 -- pragma Time_Slice (static_duration_EXPRESSION);
20694 when Pragma_Time_Slice
=> Time_Slice
: declare
20700 Check_Arg_Count
(1);
20701 Check_No_Identifiers
;
20702 Check_In_Main_Program
;
20703 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20705 if not Error_Posted
(Arg1
) then
20707 while Present
(Nod
) loop
20708 if Nkind
(Nod
) = N_Pragma
20709 and then Pragma_Name
(Nod
) = Name_Time_Slice
20711 Error_Msg_Name_1
:= Pname
;
20712 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20719 -- Process only if in main unit
20721 if Get_Source_Unit
(Loc
) = Main_Unit
then
20722 Opt
.Time_Slice_Set
:= True;
20723 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20725 if Val
<= Ureal_0
then
20726 Opt
.Time_Slice_Value
:= 0;
20728 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20729 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20732 Opt
.Time_Slice_Value
:=
20733 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20742 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20744 -- TITLING_OPTION ::=
20745 -- [Title =>] STRING_LITERAL
20746 -- | [Subtitle =>] STRING_LITERAL
20748 when Pragma_Title
=> Title
: declare
20749 Args
: Args_List
(1 .. 2);
20750 Names
: constant Name_List
(1 .. 2) := (
20756 Gather_Associations
(Names
, Args
);
20759 for J
in 1 .. 2 loop
20760 if Present
(Args
(J
)) then
20761 Check_Arg_Is_OK_Static_Expression
20762 (Args
(J
), Standard_String
);
20767 ----------------------------
20768 -- Type_Invariant[_Class] --
20769 ----------------------------
20771 -- pragma Type_Invariant[_Class]
20772 -- ([Entity =>] type_LOCAL_NAME,
20773 -- [Check =>] EXPRESSION);
20775 when Pragma_Type_Invariant |
20776 Pragma_Type_Invariant_Class
=>
20777 Type_Invariant
: declare
20778 I_Pragma
: Node_Id
;
20781 Check_Arg_Count
(2);
20783 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20784 -- setting Class_Present for the Type_Invariant_Class case.
20786 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20787 I_Pragma
:= New_Copy
(N
);
20788 Set_Pragma_Identifier
20789 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20790 Rewrite
(N
, I_Pragma
);
20791 Set_Analyzed
(N
, False);
20793 end Type_Invariant
;
20795 ---------------------
20796 -- Unchecked_Union --
20797 ---------------------
20799 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20801 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20802 Assoc
: constant Node_Id
:= Arg1
;
20803 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20813 Check_No_Identifiers
;
20814 Check_Arg_Count
(1);
20815 Check_Arg_Is_Local_Name
(Arg1
);
20817 Find_Type
(Type_Id
);
20819 Typ
:= Entity
(Type_Id
);
20822 or else Rep_Item_Too_Early
(Typ
, N
)
20826 Typ
:= Underlying_Type
(Typ
);
20829 if Rep_Item_Too_Late
(Typ
, N
) then
20833 Check_First_Subtype
(Arg1
);
20835 -- Note remaining cases are references to a type in the current
20836 -- declarative part. If we find an error, we post the error on
20837 -- the relevant type declaration at an appropriate point.
20839 if not Is_Record_Type
(Typ
) then
20840 Error_Msg_N
("unchecked union must be record type", Typ
);
20843 elsif Is_Tagged_Type
(Typ
) then
20844 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20847 elsif not Has_Discriminants
(Typ
) then
20849 ("unchecked union must have one discriminant", Typ
);
20852 -- Note: in previous versions of GNAT we used to check for limited
20853 -- types and give an error, but in fact the standard does allow
20854 -- Unchecked_Union on limited types, so this check was removed.
20856 -- Similarly, GNAT used to require that all discriminants have
20857 -- default values, but this is not mandated by the RM.
20859 -- Proceed with basic error checks completed
20862 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20863 Clist
:= Component_List
(Tdef
);
20865 -- Check presence of component list and variant part
20867 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20869 ("unchecked union must have variant part", Tdef
);
20873 -- Check components
20875 Comp
:= First
(Component_Items
(Clist
));
20876 while Present
(Comp
) loop
20877 Check_Component
(Comp
, Typ
);
20881 -- Check variant part
20883 Vpart
:= Variant_Part
(Clist
);
20885 Variant
:= First
(Variants
(Vpart
));
20886 while Present
(Variant
) loop
20887 Check_Variant
(Variant
, Typ
);
20892 Set_Is_Unchecked_Union
(Typ
);
20893 Set_Convention
(Typ
, Convention_C
);
20894 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20895 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20896 end Unchecked_Union
;
20898 ------------------------
20899 -- Unimplemented_Unit --
20900 ------------------------
20902 -- pragma Unimplemented_Unit;
20904 -- Note: this only gives an error if we are generating code, or if
20905 -- we are in a generic library unit (where the pragma appears in the
20906 -- body, not in the spec).
20908 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20909 Cunitent
: constant Entity_Id
:=
20910 Cunit_Entity
(Get_Source_Unit
(Loc
));
20911 Ent_Kind
: constant Entity_Kind
:=
20916 Check_Arg_Count
(0);
20918 if Operating_Mode
= Generate_Code
20919 or else Ent_Kind
= E_Generic_Function
20920 or else Ent_Kind
= E_Generic_Procedure
20921 or else Ent_Kind
= E_Generic_Package
20923 Get_Name_String
(Chars
(Cunitent
));
20924 Set_Casing
(Mixed_Case
);
20925 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20926 Write_Str
(" is not supported in this configuration");
20928 raise Unrecoverable_Error
;
20930 end Unimplemented_Unit
;
20932 ------------------------
20933 -- Universal_Aliasing --
20934 ------------------------
20936 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20938 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20943 Check_Arg_Count
(1);
20944 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20945 Check_Arg_Is_Local_Name
(Arg1
);
20946 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20948 if E_Id
= Any_Type
then
20950 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20951 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20954 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20955 Record_Rep_Item
(E_Id
, N
);
20956 end Universal_Alias
;
20958 --------------------
20959 -- Universal_Data --
20960 --------------------
20962 -- pragma Universal_Data [(library_unit_NAME)];
20964 when Pragma_Universal_Data
=>
20967 -- If this is a configuration pragma, then set the universal
20968 -- addressing option, otherwise confirm that the pragma satisfies
20969 -- the requirements of library unit pragma placement and leave it
20970 -- to the GNAAMP back end to detect the pragma (avoids transitive
20971 -- setting of the option due to withed units).
20973 if Is_Configuration_Pragma
then
20974 Universal_Addressing_On_AAMP
:= True;
20976 Check_Valid_Library_Unit_Pragma
;
20979 if not AAMP_On_Target
then
20980 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20987 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20989 when Pragma_Unmodified
=> Unmodified
: declare
20990 Arg_Node
: Node_Id
;
20991 Arg_Expr
: Node_Id
;
20992 Arg_Ent
: Entity_Id
;
20996 Check_At_Least_N_Arguments
(1);
20998 -- Loop through arguments
21001 while Present
(Arg_Node
) loop
21002 Check_No_Identifier
(Arg_Node
);
21004 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21005 -- in fact generate reference, so that the entity will have a
21006 -- reference, which will inhibit any warnings about it not
21007 -- being referenced, and also properly show up in the ali file
21008 -- as a reference. But this reference is recorded before the
21009 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21010 -- generated for this reference.
21012 Check_Arg_Is_Local_Name
(Arg_Node
);
21013 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21015 if Is_Entity_Name
(Arg_Expr
) then
21016 Arg_Ent
:= Entity
(Arg_Expr
);
21018 if not Is_Assignable
(Arg_Ent
) then
21020 ("pragma% can only be applied to a variable",
21023 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21035 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21037 -- or when used in a context clause:
21039 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21041 when Pragma_Unreferenced
=> Unreferenced
: declare
21042 Arg_Node
: Node_Id
;
21043 Arg_Expr
: Node_Id
;
21044 Arg_Ent
: Entity_Id
;
21049 Check_At_Least_N_Arguments
(1);
21051 -- Check case of appearing within context clause
21053 if Is_In_Context_Clause
then
21055 -- The arguments must all be units mentioned in a with clause
21056 -- in the same context clause. Note we already checked (in
21057 -- Par.Prag) that the arguments are either identifiers or
21058 -- selected components.
21061 while Present
(Arg_Node
) loop
21062 Citem
:= First
(List_Containing
(N
));
21063 while Citem
/= N
loop
21064 if Nkind
(Citem
) = N_With_Clause
21066 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21068 Set_Has_Pragma_Unreferenced
21071 (Library_Unit
(Citem
))));
21073 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21082 ("argument of pragma% is not withed unit", Arg_Node
);
21088 -- Case of not in list of context items
21092 while Present
(Arg_Node
) loop
21093 Check_No_Identifier
(Arg_Node
);
21095 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21096 -- will in fact generate reference, so that the entity will
21097 -- have a reference, which will inhibit any warnings about
21098 -- it not being referenced, and also properly show up in the
21099 -- ali file as a reference. But this reference is recorded
21100 -- before the Has_Pragma_Unreferenced flag is set, so that
21101 -- no warning is generated for this reference.
21103 Check_Arg_Is_Local_Name
(Arg_Node
);
21104 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21106 if Is_Entity_Name
(Arg_Expr
) then
21107 Arg_Ent
:= Entity
(Arg_Expr
);
21109 -- If the entity is overloaded, the pragma applies to the
21110 -- most recent overloading, as documented. In this case,
21111 -- name resolution does not generate a reference, so it
21112 -- must be done here explicitly.
21114 if Is_Overloaded
(Arg_Expr
) then
21115 Generate_Reference
(Arg_Ent
, N
);
21118 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21126 --------------------------
21127 -- Unreferenced_Objects --
21128 --------------------------
21130 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21132 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21133 Arg_Node
: Node_Id
;
21134 Arg_Expr
: Node_Id
;
21138 Check_At_Least_N_Arguments
(1);
21141 while Present
(Arg_Node
) loop
21142 Check_No_Identifier
(Arg_Node
);
21143 Check_Arg_Is_Local_Name
(Arg_Node
);
21144 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21146 if not Is_Entity_Name
(Arg_Expr
)
21147 or else not Is_Type
(Entity
(Arg_Expr
))
21150 ("argument for pragma% must be type or subtype", Arg_Node
);
21153 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21156 end Unreferenced_Objects
;
21158 ------------------------------
21159 -- Unreserve_All_Interrupts --
21160 ------------------------------
21162 -- pragma Unreserve_All_Interrupts;
21164 when Pragma_Unreserve_All_Interrupts
=>
21166 Check_Arg_Count
(0);
21168 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21169 Unreserve_All_Interrupts
:= True;
21176 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21178 when Pragma_Unsuppress
=>
21180 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
21182 ----------------------------
21183 -- Unevaluated_Use_Of_Old --
21184 ----------------------------
21186 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21188 when Pragma_Unevaluated_Use_Of_Old
=>
21190 Check_Arg_Count
(1);
21191 Check_No_Identifiers
;
21192 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
21194 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21195 -- a declarative part or a package spec.
21197 if not Is_Configuration_Pragma
then
21198 Check_Is_In_Decl_Part_Or_Package_Spec
;
21201 -- Store proper setting of Uneval_Old
21203 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21204 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
21206 -------------------
21207 -- Use_VADS_Size --
21208 -------------------
21210 -- pragma Use_VADS_Size;
21212 when Pragma_Use_VADS_Size
=>
21214 Check_Arg_Count
(0);
21215 Check_Valid_Configuration_Pragma
;
21216 Use_VADS_Size
:= True;
21218 ---------------------
21219 -- Validity_Checks --
21220 ---------------------
21222 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21224 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21225 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21231 Check_Arg_Count
(1);
21232 Check_No_Identifiers
;
21234 -- Pragma always active unless in CodePeer or GNATprove modes,
21235 -- which use a fixed configuration of validity checks.
21237 if not (CodePeer_Mode
or GNATprove_Mode
) then
21238 if Nkind
(A
) = N_String_Literal
then
21242 Slen
: constant Natural := Natural (String_Length
(S
));
21243 Options
: String (1 .. Slen
);
21247 -- Couldn't we use a for loop here over Options'Range???
21251 C
:= Get_String_Char
(S
, Int
(J
));
21253 -- This is a weird test, it skips setting validity
21254 -- checks entirely if any element of S is out of
21255 -- range of Character, what is that about ???
21257 exit when not In_Character_Range
(C
);
21258 Options
(J
) := Get_Character
(C
);
21261 Set_Validity_Check_Options
(Options
);
21269 elsif Nkind
(A
) = N_Identifier
then
21270 if Chars
(A
) = Name_All_Checks
then
21271 Set_Validity_Check_Options
("a");
21272 elsif Chars
(A
) = Name_On
then
21273 Validity_Checks_On
:= True;
21274 elsif Chars
(A
) = Name_Off
then
21275 Validity_Checks_On
:= False;
21279 end Validity_Checks
;
21285 -- pragma Volatile (LOCAL_NAME);
21287 when Pragma_Volatile
=>
21288 Process_Atomic_Independent_Shared_Volatile
;
21290 -------------------------
21291 -- Volatile_Components --
21292 -------------------------
21294 -- pragma Volatile_Components (array_LOCAL_NAME);
21296 -- Volatile is handled by the same circuit as Atomic_Components
21298 ----------------------
21299 -- Warning_As_Error --
21300 ----------------------
21302 -- pragma Warning_As_Error (static_string_EXPRESSION);
21304 when Pragma_Warning_As_Error
=>
21306 Check_Arg_Count
(1);
21307 Check_No_Identifiers
;
21308 Check_Valid_Configuration_Pragma
;
21310 if not Is_Static_String_Expression
(Arg1
) then
21312 ("argument of pragma% must be static string expression",
21315 -- OK static string expression
21318 Acquire_Warning_Match_String
(Arg1
);
21319 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21320 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21321 new String'(Name_Buffer (1 .. Name_Len));
21328 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
21330 -- DETAILS ::= On | Off
21331 -- DETAILS ::= On | Off, local_NAME
21332 -- DETAILS ::= static_string_EXPRESSION
21333 -- DETAILS ::= On | Off, static_string_EXPRESSION
21335 -- TOOL_NAME ::= GNAT | GNATProve
21337 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
21339 -- Note: If the first argument matches an allowed tool name, it is
21340 -- always considered to be a tool name, even if there is a string
21341 -- variable of that name.
21343 -- Note if the second argument of DETAILS is a local_NAME then the
21344 -- second form is always understood. If the intention is to use
21345 -- the fourth form, then you can write NAME & "" to force the
21346 -- intepretation as a static_string_EXPRESSION.
21348 when Pragma_Warnings => Warnings : declare
21349 Reason : String_Id;
21353 Check_At_Least_N_Arguments (1);
21355 -- See if last argument is labeled Reason. If so, make sure we
21356 -- have a string literal or a concatenation of string literals,
21357 -- and acquire the REASON string. Then remove the REASON argument
21358 -- by decreasing Num_Args by one; Remaining processing looks only
21359 -- at first Num_Args arguments).
21362 Last_Arg : constant Node_Id :=
21363 Last (Pragma_Argument_Associations (N));
21366 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21367 and then Chars (Last_Arg) = Name_Reason
21370 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21371 Reason := End_String;
21372 Arg_Count := Arg_Count - 1;
21374 -- Not allowed in compiler units (bootstrap issues)
21376 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21378 -- No REASON string, set null string as reason
21381 Reason := Null_String_Id;
21385 -- Now proceed with REASON taken care of and eliminated
21387 Check_No_Identifiers;
21389 -- If debug flag -gnatd.i is set, pragma is ignored
21391 if Debug_Flag_Dot_I then
21395 -- Process various forms of the pragma
21398 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21399 Shifted_Args : List_Id;
21402 -- See if first argument is a tool name, currently either
21403 -- GNAT or GNATprove. If so, either ignore the pragma if the
21404 -- tool used does not match, or continue as if no tool name
21405 -- was given otherwise, by shifting the arguments.
21407 if Nkind (Argx) = N_Identifier
21408 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
21410 if Chars (Argx) = Name_Gnat then
21411 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
21412 Rewrite (N, Make_Null_Statement (Loc));
21417 elsif Chars (Argx) = Name_Gnatprove then
21418 if not GNATprove_Mode then
21419 Rewrite (N, Make_Null_Statement (Loc));
21425 raise Program_Error;
21428 -- At this point, the pragma Warnings applies to the tool,
21429 -- so continue with shifted arguments.
21431 Arg_Count := Arg_Count - 1;
21433 if Arg_Count = 1 then
21434 Shifted_Args := New_List (New_Copy (Arg2));
21435 elsif Arg_Count = 2 then
21436 Shifted_Args := New_List (New_Copy (Arg2),
21438 elsif Arg_Count = 3 then
21439 Shifted_Args := New_List (New_Copy (Arg2),
21443 raise Program_Error;
21446 Rewrite (N, Make_Pragma (Loc,
21447 Chars => Name_Warnings,
21448 Pragma_Argument_Associations => Shifted_Args));
21453 -- One argument case
21455 if Arg_Count = 1 then
21457 -- On/Off one argument case was processed by parser
21459 if Nkind (Argx) = N_Identifier
21460 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21464 -- One argument case must be ON/OFF or static string expr
21466 elsif not Is_Static_String_Expression (Arg1) then
21468 ("argument of pragma% must be On/Off or static string "
21469 & "expression", Arg1);
21471 -- One argument string expression case
21475 Lit : constant Node_Id := Expr_Value_S (Argx);
21476 Str : constant String_Id := Strval (Lit);
21477 Len : constant Nat := String_Length (Str);
21485 while J <= Len loop
21486 C := Get_String_Char (Str, J);
21487 OK := In_Character_Range (C);
21490 Chr := Get_Character (C);
21492 -- Dash case: only -Wxxx is accepted
21499 C := Get_String_Char (Str, J);
21500 Chr := Get_Character (C);
21501 exit when Chr = 'W
';
21506 elsif J < Len and then Chr = '.' then
21508 C := Get_String_Char (Str, J);
21509 Chr := Get_Character (C);
21511 if not Set_Dot_Warning_Switch (Chr) then
21513 ("invalid warning switch character "
21514 & '.' & Chr, Arg1);
21520 OK := Set_Warning_Switch (Chr);
21526 ("invalid warning switch character " & Chr,
21535 -- Two or more arguments (must be two)
21538 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21539 Check_Arg_Count (2);
21547 E_Id := Get_Pragma_Arg (Arg2);
21550 -- In the expansion of an inlined body, a reference to
21551 -- the formal may be wrapped in a conversion if the
21552 -- actual is a conversion. Retrieve the real entity name.
21554 if (In_Instance_Body or In_Inlined_Body)
21555 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21557 E_Id := Expression (E_Id);
21560 -- Entity name case
21562 if Is_Entity_Name (E_Id) then
21563 E := Entity (E_Id);
21570 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21573 -- For OFF case, make entry in warnings off
21574 -- pragma table for later processing. But we do
21575 -- not do that within an instance, since these
21576 -- warnings are about what is needed in the
21577 -- template, not an instance of it.
21579 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21580 and then Warn_On_Warnings_Off
21581 and then not In_Instance
21583 Warnings_Off_Pragmas.Append ((N, E, Reason));
21586 if Is_Enumeration_Type (E) then
21590 Lit := First_Literal (E);
21591 while Present (Lit) loop
21592 Set_Warnings_Off (Lit);
21593 Next_Literal (Lit);
21598 exit when No (Homonym (E));
21603 -- Error if not entity or static string expression case
21605 elsif not Is_Static_String_Expression (Arg2) then
21607 ("second argument of pragma% must be entity name "
21608 & "or static string expression", Arg2);
21610 -- Static string expression case
21613 Acquire_Warning_Match_String (Arg2);
21615 -- Note on configuration pragma case: If this is a
21616 -- configuration pragma, then for an OFF pragma, we
21617 -- just set Config True in the call, which is all
21618 -- that needs to be done. For the case of ON, this
21619 -- is normally an error, unless it is canceling the
21620 -- effect of a previous OFF pragma in the same file.
21621 -- In any other case, an error will be signalled (ON
21622 -- with no matching OFF).
21624 -- Note: We set Used if we are inside a generic to
21625 -- disable the test that the non-config case actually
21626 -- cancels a warning. That's because we can't be sure
21627 -- there isn't an instantiation in some other unit
21628 -- where a warning is suppressed.
21630 -- We could do a little better here by checking if the
21631 -- generic unit we are inside is public, but for now
21632 -- we don't bother with that refinement.
21634 if Chars (Argx) = Name_Off then
21635 Set_Specific_Warning_Off
21636 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21637 Config => Is_Configuration_Pragma,
21638 Used => Inside_A_Generic or else In_Instance);
21640 elsif Chars (Argx) = Name_On then
21641 Set_Specific_Warning_On
21642 (Loc, Name_Buffer (1 .. Name_Len), Err);
21646 ("??pragma Warnings On with no matching "
21647 & "Warnings Off", Loc);
21656 -------------------
21657 -- Weak_External --
21658 -------------------
21660 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21662 when Pragma_Weak_External => Weak_External : declare
21667 Check_Arg_Count (1);
21668 Check_Optional_Identifier (Arg1, Name_Entity);
21669 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21670 Ent := Entity (Get_Pragma_Arg (Arg1));
21672 if Rep_Item_Too_Early (Ent, N) then
21675 Ent := Underlying_Type (Ent);
21678 -- The only processing required is to link this item on to the
21679 -- list of rep items for the given entity. This is accomplished
21680 -- by the call to Rep_Item_Too_Late (when no error is detected
21681 -- and False is returned).
21683 if Rep_Item_Too_Late (Ent, N) then
21686 Set_Has_Gigi_Rep_Item (Ent);
21690 -----------------------------
21691 -- Wide_Character_Encoding --
21692 -----------------------------
21694 -- pragma Wide_Character_Encoding (IDENTIFIER);
21696 when Pragma_Wide_Character_Encoding =>
21699 -- Nothing to do, handled in parser. Note that we do not enforce
21700 -- configuration pragma placement, this pragma can appear at any
21701 -- place in the source, allowing mixed encodings within a single
21706 --------------------
21707 -- Unknown_Pragma --
21708 --------------------
21710 -- Should be impossible, since the case of an unknown pragma is
21711 -- separately processed before the case statement is entered.
21713 when Unknown_Pragma =>
21714 raise Program_Error;
21717 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21718 -- until AI is formally approved.
21720 -- Check_Order_Dependence;
21723 when Pragma_Exit => null;
21724 end Analyze_Pragma;
21726 ---------------------------------------------
21727 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21728 ---------------------------------------------
21730 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21732 Subp_Id : Entity_Id)
21734 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21735 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21738 Restore_Scope : Boolean := False;
21739 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21742 -- Ensure that the subprogram and its formals are visible when analyzing
21743 -- the expression of the pragma.
21745 if not In_Open_Scopes (Subp_Id) then
21746 Restore_Scope := True;
21747 Push_Scope (Subp_Id);
21748 Install_Formals (Subp_Id);
21751 -- Preanalyze the boolean expression, we treat this as a spec expression
21752 -- (i.e. similar to a default expression).
21754 Expr := Get_Pragma_Arg (Arg1);
21756 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21757 -- the original aspect expression, which is shared with the generated
21760 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21761 Expr := Expression (Corresponding_Aspect (Prag));
21764 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21766 -- For a class-wide condition, a reference to a controlling formal must
21767 -- be interpreted as having the class-wide type (or an access to such)
21768 -- so that the inherited condition can be properly applied to any
21769 -- overriding operation (see ARM12 6.6.1 (7)).
21771 if Class_Present (Prag) then
21772 Class_Wide_Condition : declare
21773 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21775 ACW : Entity_Id := Empty;
21776 -- Access to T'class, created if there is a controlling formal
21777 -- that is an access parameter.
21779 function Get_ACW return Entity_Id;
21780 -- If the expression has a reference to an controlling access
21781 -- parameter, create an access to T'class for the necessary
21782 -- conversions if one does not exist.
21784 function Process (N : Node_Id) return Traverse_Result;
21785 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21786 -- aspect for a primitive subprogram of a tagged type T, a name
21787 -- that denotes a formal parameter of type T is interpreted as
21788 -- having type T'Class. Similarly, a name that denotes a formal
21789 -- accessparameter of type access-to-T is interpreted as having
21790 -- type access-to-T'Class. This ensures the expression is well-
21791 -- defined for a primitive subprogram of a type descended from T.
21792 -- Note that this replacement is not done for selector names in
21793 -- parameter associations. These carry an entity for reference
21794 -- purposes, but semantically they are just identifiers.
21800 function Get_ACW return Entity_Id is
21801 Loc : constant Source_Ptr := Sloc (Prag);
21807 Make_Full_Type_Declaration (Loc,
21808 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21810 Make_Access_To_Object_Definition (Loc,
21811 Subtype_Indication =>
21812 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21813 All_Present => True));
21815 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21817 ACW := Defining_Identifier (Decl);
21818 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21828 function Process (N : Node_Id) return Traverse_Result is
21829 Loc : constant Source_Ptr := Sloc (N);
21833 if Is_Entity_Name (N)
21834 and then Present (Entity (N))
21835 and then Is_Formal (Entity (N))
21836 and then Nkind (Parent (N)) /= N_Type_Conversion
21838 (Nkind (Parent (N)) /= N_Parameter_Association
21839 or else N /= Selector_Name (Parent (N)))
21841 if Etype (Entity (N)) = T then
21842 Typ := Class_Wide_Type (T);
21844 elsif Is_Access_Type (Etype (Entity (N)))
21845 and then Designated_Type (Etype (Entity (N))) = T
21852 if Present (Typ) then
21854 Make_Type_Conversion (Loc,
21856 New_Occurrence_Of (Typ, Loc),
21857 Expression => New_Occurrence_Of (Entity (N), Loc)));
21858 Set_Etype (N, Typ);
21865 procedure Replace_Type is new Traverse_Proc (Process);
21867 -- Start of processing for Class_Wide_Condition
21870 if not Present (T) then
21872 -- Pre'Class/Post'Class aspect cases
21874 if From_Aspect_Specification (Prag) then
21875 if Nam = Name_uPre then
21876 Error_Msg_Name_1 := Name_Pre;
21878 Error_Msg_Name_1 := Name_Post;
21881 Error_Msg_Name_2 := Name_Class;
21884 ("aspect `%''%` can only be specified for a primitive "
21885 & "operation of a tagged type",
21886 Corresponding_Aspect (Prag));
21888 -- Pre_Class, Post_Class pragma cases
21891 if Nam = Name_uPre then
21892 Error_Msg_Name_1 := Name_Pre_Class;
21894 Error_Msg_Name_1 := Name_Post_Class;
21898 ("pragma% can only be specified for a primitive "
21899 & "operation of a tagged type",
21900 Corresponding_Aspect (Prag));
21904 Replace_Type (Get_Pragma_Arg (Arg1));
21905 end Class_Wide_Condition;
21908 -- Remove the subprogram from the scope stack now that the pre-analysis
21909 -- of the precondition/postcondition is done.
21911 if Restore_Scope then
21914 end Analyze_Pre_Post_Condition_In_Decl_Part;
21916 ------------------------------------------
21917 -- Analyze_Refined_Depends_In_Decl_Part --
21918 ------------------------------------------
21920 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21921 Body_Inputs : Elist_Id := No_Elist;
21922 Body_Outputs : Elist_Id := No_Elist;
21923 -- The inputs and outputs of the subprogram body synthesized from pragma
21924 -- Refined_Depends.
21926 Dependencies : List_Id := No_List;
21928 -- The corresponding Depends pragma along with its clauses
21930 Matched_Items : Elist_Id := No_Elist;
21931 -- A list containing the entities of all successfully matched items
21932 -- found in pragma Depends.
21934 Refinements : List_Id := No_List;
21935 -- The clauses of pragma Refined_Depends
21937 Spec_Id : Entity_Id;
21938 -- The entity of the subprogram subject to pragma Refined_Depends
21940 Spec_Inputs : Elist_Id := No_Elist;
21941 Spec_Outputs : Elist_Id := No_Elist;
21942 -- The inputs and outputs of the subprogram spec synthesized from pragma
21945 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21946 -- Try to match a single dependency clause Dep_Clause against one or
21947 -- more refinement clauses found in list Refinements. Each successful
21948 -- match eliminates at least one refinement clause from Refinements.
21950 procedure Check_Output_States;
21951 -- Determine whether pragma Depends contains an output state with a
21952 -- visible refinement and if so, ensure that pragma Refined_Depends
21953 -- mentions all its constituents as outputs.
21955 procedure Normalize_Clauses (Clauses : List_Id);
21956 -- Given a list of dependence or refinement clauses Clauses, normalize
21957 -- each clause by creating multiple dependencies with exactly one input
21960 procedure Report_Extra_Clauses;
21961 -- Emit an error for each extra clause found in list Refinements
21963 -----------------------------
21964 -- Check_Dependency_Clause --
21965 -----------------------------
21967 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21968 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21969 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21971 function Is_In_Out_State_Clause return Boolean;
21972 -- Determine whether dependence clause Dep_Clause denotes an abstract
21973 -- state that depends on itself (State => State).
21975 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21976 -- Determine whether item Item denotes an abstract state with visible
21977 -- null refinement.
21979 procedure Match_Items
21980 (Dep_Item : Node_Id;
21981 Ref_Item : Node_Id;
21982 Matched : out Boolean);
21983 -- Try to match dependence item Dep_Item against refinement item
21984 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21985 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21986 -- the following conformance scenarios is in effect:
21987 -- 1) Both items denote null
21988 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21989 -- 3) Both items denote attribute 'Result
21990 -- 4) Both items denote the same formal parameter
21991 -- 5) Both items denote the same variable
21992 -- 6) Dep_Item is an abstract state with visible null refinement
21993 -- and Ref_Item denotes null.
21994 -- 7) Dep_Item is an abstract state with visible null refinement
21995 -- and Ref_Item is Empty (special case).
21996 -- 8) Dep_Item is an abstract state with visible non-null
21997 -- refinement and Ref_Item denotes one of its constituents.
21998 -- 9) Dep_Item is an abstract state without a visible refinement
21999 -- and Ref_Item denotes the same state.
22000 -- When scenario 8 is in effect, the entity of the abstract state
22001 -- denoted by Dep_Item is added to list Refined_States.
22003 procedure Record_Item
(Item_Id
: Entity_Id
);
22004 -- Store the entity of an item denoted by Item_Id in Matched_Items
22006 ----------------------------
22007 -- Is_In_Out_State_Clause --
22008 ----------------------------
22010 function Is_In_Out_State_Clause
return Boolean is
22011 Dep_Input_Id
: Entity_Id
;
22012 Dep_Output_Id
: Entity_Id
;
22015 -- Detect the following clause:
22018 if Is_Entity_Name
(Dep_Input
)
22019 and then Is_Entity_Name
(Dep_Output
)
22021 -- Handle abstract views generated for limited with clauses
22023 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
22024 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
22027 Ekind
(Dep_Input_Id
) = E_Abstract_State
22028 and then Dep_Input_Id
= Dep_Output_Id
;
22032 end Is_In_Out_State_Clause
;
22034 ---------------------------
22035 -- Is_Null_Refined_State --
22036 ---------------------------
22038 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
22039 Item_Id
: Entity_Id
;
22042 if Is_Entity_Name
(Item
) then
22044 -- Handle abstract views generated for limited with clauses
22046 Item_Id
:= Available_View
(Entity_Of
(Item
));
22048 return Ekind
(Item_Id
) = E_Abstract_State
22049 and then Has_Null_Refinement
(Item_Id
);
22054 end Is_Null_Refined_State
;
22060 procedure Match_Items
22061 (Dep_Item
: Node_Id
;
22062 Ref_Item
: Node_Id
;
22063 Matched
: out Boolean)
22065 Dep_Item_Id
: Entity_Id
;
22066 Ref_Item_Id
: Entity_Id
;
22069 -- Assume that the two items do not match
22073 -- A null matches null or Empty (special case)
22075 if Nkind
(Dep_Item
) = N_Null
22076 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22080 -- Attribute 'Result matches attribute 'Result
22082 elsif Is_Attribute_Result
(Dep_Item
)
22083 and then Is_Attribute_Result
(Dep_Item
)
22087 -- Abstract states, formal parameters and variables
22089 elsif Is_Entity_Name
(Dep_Item
) then
22091 -- Handle abstract views generated for limited with clauses
22093 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
22095 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
22097 -- An abstract state with visible null refinement matches
22098 -- null or Empty (special case).
22100 if Has_Null_Refinement
(Dep_Item_Id
)
22101 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22103 Record_Item
(Dep_Item_Id
);
22106 -- An abstract state with visible non-null refinement
22107 -- matches one of its constituents.
22109 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
22110 if Is_Entity_Name
(Ref_Item
) then
22111 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
22113 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
, E_Variable
)
22114 and then Present
(Encapsulating_State
(Ref_Item_Id
))
22115 and then Encapsulating_State
(Ref_Item_Id
) =
22118 Record_Item
(Dep_Item_Id
);
22123 -- An abstract state without a visible refinement matches
22126 elsif Is_Entity_Name
(Ref_Item
)
22127 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22129 Record_Item
(Dep_Item_Id
);
22133 -- A formal parameter or a variable matches itself
22135 elsif Is_Entity_Name
(Ref_Item
)
22136 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22138 Record_Item
(Dep_Item_Id
);
22148 procedure Record_Item
(Item_Id
: Entity_Id
) is
22150 if not Contains
(Matched_Items
, Item_Id
) then
22151 Add_Item
(Item_Id
, Matched_Items
);
22157 Clause_Matched
: Boolean := False;
22158 Dummy
: Boolean := False;
22159 Inputs_Match
: Boolean;
22160 Next_Ref_Clause
: Node_Id
;
22161 Outputs_Match
: Boolean;
22162 Ref_Clause
: Node_Id
;
22163 Ref_Input
: Node_Id
;
22164 Ref_Output
: Node_Id
;
22166 -- Start of processing for Check_Dependency_Clause
22169 -- Examine all refinement clauses and compare them against the
22170 -- dependence clause.
22172 Ref_Clause
:= First
(Refinements
);
22173 while Present
(Ref_Clause
) loop
22174 Next_Ref_Clause
:= Next
(Ref_Clause
);
22176 -- Obtain the attributes of the current refinement clause
22178 Ref_Input
:= Expression
(Ref_Clause
);
22179 Ref_Output
:= First
(Choices
(Ref_Clause
));
22181 -- The current refinement clause matches the dependence clause
22182 -- when both outputs match and both inputs match. See routine
22183 -- Match_Items for all possible conformance scenarios.
22185 -- Depends Dep_Output => Dep_Input
22189 -- Refined_Depends Ref_Output => Ref_Input
22192 (Dep_Item
=> Dep_Input
,
22193 Ref_Item
=> Ref_Input
,
22194 Matched
=> Inputs_Match
);
22197 (Dep_Item
=> Dep_Output
,
22198 Ref_Item
=> Ref_Output
,
22199 Matched
=> Outputs_Match
);
22201 -- An In_Out state clause may be matched against a refinement with
22202 -- a null input or null output as long as the non-null side of the
22203 -- relation contains a valid constituent of the In_Out_State.
22205 if Is_In_Out_State_Clause
then
22207 -- Depends => (State => State)
22208 -- Refined_Depends => (null => Constit) -- OK
22211 and then not Outputs_Match
22212 and then Nkind
(Ref_Output
) = N_Null
22214 Outputs_Match
:= True;
22217 -- Depends => (State => State)
22218 -- Refined_Depends => (Constit => null) -- OK
22220 if not Inputs_Match
22221 and then Outputs_Match
22222 and then Nkind
(Ref_Input
) = N_Null
22224 Inputs_Match
:= True;
22228 -- The current refinement clause is legally constructed following
22229 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22230 -- the pool of candidates. The seach continues because a single
22231 -- dependence clause may have multiple matching refinements.
22233 if Inputs_Match
and then Outputs_Match
then
22234 Clause_Matched
:= True;
22235 Remove
(Ref_Clause
);
22238 Ref_Clause
:= Next_Ref_Clause
;
22241 -- Depending on the order or composition of refinement clauses, an
22242 -- In_Out state clause may not be directly refinable.
22244 -- Depends => ((Output, State) => (Input, State))
22245 -- Refined_State => (State => (Constit_1, Constit_2))
22246 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22248 -- Matching normalized clause (State => State) fails because there is
22249 -- no direct refinement capable of satisfying this relation. Another
22250 -- similar case arises when clauses (Constit_1 => Input) and (Output
22251 -- => Constit_2) are matched first, leaving no candidates for clause
22252 -- (State => State). Both scenarios are legal as long as one of the
22253 -- previous clauses mentioned a valid constituent of State.
22255 if not Clause_Matched
22256 and then Is_In_Out_State_Clause
22258 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22260 Clause_Matched
:= True;
22263 -- A clause where the input is an abstract state with visible null
22264 -- refinement is implicitly matched when the output has already been
22265 -- matched in a previous clause.
22267 -- Depends => (Output => State) -- implicitly OK
22268 -- Refined_State => (State => null)
22269 -- Refined_Depends => (Output => ...)
22271 if not Clause_Matched
22272 and then Is_Null_Refined_State
(Dep_Input
)
22273 and then Is_Entity_Name
(Dep_Output
)
22275 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
22277 Clause_Matched
:= True;
22280 -- A clause where the output is an abstract state with visible null
22281 -- refinement is implicitly matched when the input has already been
22282 -- matched in a previous clause.
22284 -- Depends => (State => Input) -- implicitly OK
22285 -- Refined_State => (State => null)
22286 -- Refined_Depends => (... => Input)
22288 if not Clause_Matched
22289 and then Is_Null_Refined_State
(Dep_Output
)
22290 and then Is_Entity_Name
(Dep_Input
)
22292 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22294 Clause_Matched
:= True;
22297 -- At this point either all refinement clauses have been examined or
22298 -- pragma Refined_Depends contains a solitary null. Only an abstract
22299 -- state with null refinement can possibly match these cases.
22301 -- Depends => (State => null)
22302 -- Refined_State => (State => null)
22303 -- Refined_Depends => null -- OK
22305 if not Clause_Matched
then
22307 (Dep_Item
=> Dep_Input
,
22309 Matched
=> Inputs_Match
);
22312 (Dep_Item
=> Dep_Output
,
22314 Matched
=> Outputs_Match
);
22316 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
22319 -- If the contents of Refined_Depends are legal, then the current
22320 -- dependence clause should be satisfied either by an explicit match
22321 -- or by one of the special cases.
22323 if not Clause_Matched
then
22325 ("dependence clause of subprogram & has no matching refinement "
22326 & "in body", Dep_Clause
, Spec_Id
);
22328 end Check_Dependency_Clause
;
22330 -------------------------
22331 -- Check_Output_States --
22332 -------------------------
22334 procedure Check_Output_States
is
22335 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22336 -- Determine whether all constituents of state State_Id with visible
22337 -- refinement are used as outputs in pragma Refined_Depends. Emit an
22338 -- error if this is not the case.
22340 -----------------------------
22341 -- Check_Constituent_Usage --
22342 -----------------------------
22344 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22345 Constit_Elmt
: Elmt_Id
;
22346 Constit_Id
: Entity_Id
;
22347 Posted
: Boolean := False;
22350 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22351 while Present
(Constit_Elmt
) loop
22352 Constit_Id
:= Node
(Constit_Elmt
);
22354 -- The constituent acts as an input (SPARK RM 7.2.5(3))
22356 if Present
(Body_Inputs
)
22357 and then Appears_In
(Body_Inputs
, Constit_Id
)
22359 Error_Msg_Name_1
:= Chars
(State_Id
);
22361 ("constituent & of state % must act as output in "
22362 & "dependence refinement", N
, Constit_Id
);
22364 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22366 elsif No
(Body_Outputs
)
22367 or else not Appears_In
(Body_Outputs
, Constit_Id
)
22372 ("output state & must be replaced by all its "
22373 & "constituents in dependence refinement",
22378 ("\constituent & is missing in output list",
22382 Next_Elmt
(Constit_Elmt
);
22384 end Check_Constituent_Usage
;
22389 Item_Elmt
: Elmt_Id
;
22390 Item_Id
: Entity_Id
;
22392 -- Start of processing for Check_Output_States
22395 -- Inspect the outputs of pragma Depends looking for a state with a
22396 -- visible refinement.
22398 if Present
(Spec_Outputs
) then
22399 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
22400 while Present
(Item_Elmt
) loop
22401 Item
:= Node
(Item_Elmt
);
22403 -- Deal with the mixed nature of the input and output lists
22405 if Nkind
(Item
) = N_Defining_Identifier
then
22408 Item_Id
:= Available_View
(Entity_Of
(Item
));
22411 if Ekind
(Item_Id
) = E_Abstract_State
then
22413 -- The state acts as an input-output, skip it
22415 if Present
(Spec_Inputs
)
22416 and then Appears_In
(Spec_Inputs
, Item_Id
)
22420 -- Ensure that all of the constituents are utilized as
22421 -- outputs in pragma Refined_Depends.
22423 elsif Has_Non_Null_Refinement
(Item_Id
) then
22424 Check_Constituent_Usage
(Item_Id
);
22428 Next_Elmt
(Item_Elmt
);
22431 end Check_Output_States
;
22433 -----------------------
22434 -- Normalize_Clauses --
22435 -----------------------
22437 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22438 procedure Normalize_Inputs
(Clause
: Node_Id
);
22439 -- Normalize clause Clause by creating multiple clauses for each
22440 -- input item of Clause. It is assumed that Clause has exactly one
22441 -- output. The transformation is as follows:
22443 -- Output => (Input_1, Input_2) -- original
22445 -- Output => Input_1 -- normalizations
22446 -- Output => Input_2
22448 procedure Normalize_Outputs
(Clause
: Node_Id
);
22449 -- Normalize clause Clause by creating multiple clause for each
22450 -- output item of Clause. The transformation is as follows:
22452 -- (Output_1, Output_2) => Input -- original
22454 -- Output_1 => Input -- normalization
22455 -- Output_2 => Input
22457 ----------------------
22458 -- Normalize_Inputs --
22459 ----------------------
22461 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22462 Inputs
: constant Node_Id
:= Expression
(Clause
);
22463 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22464 Output
: constant List_Id
:= Choices
(Clause
);
22465 Last_Input
: Node_Id
;
22467 New_Clause
: Node_Id
;
22468 Next_Input
: Node_Id
;
22471 -- Normalization is performed only when the original clause has
22472 -- more than one input. Multiple inputs appear as an aggregate.
22474 if Nkind
(Inputs
) = N_Aggregate
then
22475 Last_Input
:= Last
(Expressions
(Inputs
));
22477 -- Create a new clause for each input
22479 Input
:= First
(Expressions
(Inputs
));
22480 while Present
(Input
) loop
22481 Next_Input
:= Next
(Input
);
22483 -- Unhook the current input from the original input list
22484 -- because it will be relocated to a new clause.
22488 -- Special processing for the last input. At this point the
22489 -- original aggregate has been stripped down to one element.
22490 -- Replace the aggregate by the element itself.
22492 if Input
= Last_Input
then
22493 Rewrite
(Inputs
, Input
);
22495 -- Generate a clause of the form:
22500 Make_Component_Association
(Loc
,
22501 Choices
=> New_Copy_List_Tree
(Output
),
22502 Expression
=> Input
);
22504 -- The new clause contains replicated content that has
22505 -- already been analyzed, mark the clause as analyzed.
22507 Set_Analyzed
(New_Clause
);
22508 Insert_After
(Clause
, New_Clause
);
22511 Input
:= Next_Input
;
22514 end Normalize_Inputs
;
22516 -----------------------
22517 -- Normalize_Outputs --
22518 -----------------------
22520 procedure Normalize_Outputs
(Clause
: Node_Id
) is
22521 Inputs
: constant Node_Id
:= Expression
(Clause
);
22522 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22523 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
22524 Last_Output
: Node_Id
;
22525 New_Clause
: Node_Id
;
22526 Next_Output
: Node_Id
;
22530 -- Multiple outputs appear as an aggregate. Nothing to do when
22531 -- the clause has exactly one output.
22533 if Nkind
(Outputs
) = N_Aggregate
then
22534 Last_Output
:= Last
(Expressions
(Outputs
));
22536 -- Create a clause for each output. Note that each time a new
22537 -- clause is created, the original output list slowly shrinks
22538 -- until there is one item left.
22540 Output
:= First
(Expressions
(Outputs
));
22541 while Present
(Output
) loop
22542 Next_Output
:= Next
(Output
);
22544 -- Unhook the output from the original output list as it
22545 -- will be relocated to a new clause.
22549 -- Special processing for the last output. At this point
22550 -- the original aggregate has been stripped down to one
22551 -- element. Replace the aggregate by the element itself.
22553 if Output
= Last_Output
then
22554 Rewrite
(Outputs
, Output
);
22557 -- Generate a clause of the form:
22558 -- (Output => Inputs)
22561 Make_Component_Association
(Loc
,
22562 Choices
=> New_List
(Output
),
22563 Expression
=> New_Copy_Tree
(Inputs
));
22565 -- The new clause contains replicated content that has
22566 -- already been analyzed. There is not need to reanalyze
22569 Set_Analyzed
(New_Clause
);
22570 Insert_After
(Clause
, New_Clause
);
22573 Output
:= Next_Output
;
22576 end Normalize_Outputs
;
22582 -- Start of processing for Normalize_Clauses
22585 Clause
:= First
(Clauses
);
22586 while Present
(Clause
) loop
22587 Normalize_Outputs
(Clause
);
22591 Clause
:= First
(Clauses
);
22592 while Present
(Clause
) loop
22593 Normalize_Inputs
(Clause
);
22596 end Normalize_Clauses
;
22598 --------------------------
22599 -- Report_Extra_Clauses --
22600 --------------------------
22602 procedure Report_Extra_Clauses
is
22606 if Present
(Refinements
) then
22607 Clause
:= First
(Refinements
);
22608 while Present
(Clause
) loop
22610 -- Do not complain about a null input refinement, since a null
22611 -- input legitimately matches anything.
22613 if Nkind
(Clause
) /= N_Component_Association
22614 or else Nkind
(Expression
(Clause
)) /= N_Null
22617 ("unmatched or extra clause in dependence refinement",
22624 end Report_Extra_Clauses
;
22628 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22629 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
22630 Errors
: constant Nat
:= Serious_Errors_Detected
;
22631 Refs
: constant Node_Id
:=
22632 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22637 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22640 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22641 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22643 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22646 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22648 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22649 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22651 if No
(Depends
) then
22653 ("useless refinement, declaration of subprogram & lacks aspect or "
22654 & "pragma Depends", N
, Spec_Id
);
22658 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
22660 -- A null dependency relation renders the refinement useless because it
22661 -- cannot possibly mention abstract states with visible refinement. Note
22662 -- that the inverse is not true as states may be refined to null
22663 -- (SPARK RM 7.2.5(2)).
22665 if Nkind
(Deps
) = N_Null
then
22667 ("useless refinement, subprogram & does not depend on abstract "
22668 & "state with visible refinement", N
, Spec_Id
);
22672 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22673 -- This ensures that the categorization of all refined dependency items
22674 -- is consistent with their role.
22676 Analyze_Depends_In_Decl_Part
(N
);
22678 -- Do not match dependencies against refinements if Refined_Depends is
22679 -- illegal to avoid emitting misleading error.
22681 if Serious_Errors_Detected
= Errors
then
22683 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
22684 -- the inputs and outputs of the subprogram spec and body to verify
22685 -- the use of states with visible refinement and their constituents.
22687 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
22688 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
22690 Collect_Subprogram_Inputs_Outputs
22691 (Subp_Id
=> Spec_Id
,
22692 Synthesize
=> True,
22693 Subp_Inputs
=> Spec_Inputs
,
22694 Subp_Outputs
=> Spec_Outputs
,
22695 Global_Seen
=> Dummy
);
22697 Collect_Subprogram_Inputs_Outputs
22698 (Subp_Id
=> Body_Id
,
22699 Synthesize
=> True,
22700 Subp_Inputs
=> Body_Inputs
,
22701 Subp_Outputs
=> Body_Outputs
,
22702 Global_Seen
=> Dummy
);
22704 -- For an output state with a visible refinement, ensure that all
22705 -- constituents appear as outputs in the dependency refinement.
22707 Check_Output_States
;
22710 -- Matching is disabled in ASIS because clauses are not normalized as
22711 -- this is a tree altering activity similar to expansion.
22717 -- Multiple dependency clauses appear as component associations of an
22718 -- aggregate. Note that the clauses are copied because the algorithm
22719 -- modifies them and this should not be visible in Depends.
22721 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22722 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22723 Normalize_Clauses
(Dependencies
);
22725 if Nkind
(Refs
) = N_Null
then
22726 Refinements
:= No_List
;
22728 -- Multiple dependency clauses appear as component associations of an
22729 -- aggregate. Note that the clauses are copied because the algorithm
22730 -- modifies them and this should not be visible in Refined_Depends.
22732 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22733 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22734 Normalize_Clauses
(Refinements
);
22737 -- At this point the clauses of pragmas Depends and Refined_Depends
22738 -- have been normalized into simple dependencies between one output
22739 -- and one input. Examine all clauses of pragma Depends looking for
22740 -- matching clauses in pragma Refined_Depends.
22742 Clause
:= First
(Dependencies
);
22743 while Present
(Clause
) loop
22744 Check_Dependency_Clause
(Clause
);
22748 if Serious_Errors_Detected
= Errors
then
22749 Report_Extra_Clauses
;
22752 end Analyze_Refined_Depends_In_Decl_Part
;
22754 -----------------------------------------
22755 -- Analyze_Refined_Global_In_Decl_Part --
22756 -----------------------------------------
22758 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22760 -- The corresponding Global pragma
22762 Has_In_State
: Boolean := False;
22763 Has_In_Out_State
: Boolean := False;
22764 Has_Out_State
: Boolean := False;
22765 Has_Proof_In_State
: Boolean := False;
22766 -- These flags are set when the corresponding Global pragma has a state
22767 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22770 Has_Null_State
: Boolean := False;
22771 -- This flag is set when the corresponding Global pragma has at least
22772 -- one state with a null refinement.
22774 In_Constits
: Elist_Id
:= No_Elist
;
22775 In_Out_Constits
: Elist_Id
:= No_Elist
;
22776 Out_Constits
: Elist_Id
:= No_Elist
;
22777 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22778 -- These lists contain the entities of all Input, In_Out, Output and
22779 -- Proof_In constituents that appear in Refined_Global and participate
22780 -- in state refinement.
22782 In_Items
: Elist_Id
:= No_Elist
;
22783 In_Out_Items
: Elist_Id
:= No_Elist
;
22784 Out_Items
: Elist_Id
:= No_Elist
;
22785 Proof_In_Items
: Elist_Id
:= No_Elist
;
22786 -- These list contain the entities of all Input, In_Out, Output and
22787 -- Proof_In items defined in the corresponding Global pragma.
22789 procedure Check_In_Out_States
;
22790 -- Determine whether the corresponding Global pragma mentions In_Out
22791 -- states with visible refinement and if so, ensure that one of the
22792 -- following completions apply to the constituents of the state:
22793 -- 1) there is at least one constituent of mode In_Out
22794 -- 2) there is at least one Input and one Output constituent
22795 -- 3) not all constituents are present and one of them is of mode
22797 -- This routine may remove elements from In_Constits, In_Out_Constits,
22798 -- Out_Constits and Proof_In_Constits.
22800 procedure Check_Input_States
;
22801 -- Determine whether the corresponding Global pragma mentions Input
22802 -- states with visible refinement and if so, ensure that at least one of
22803 -- its constituents appears as an Input item in Refined_Global.
22804 -- This routine may remove elements from In_Constits, In_Out_Constits,
22805 -- Out_Constits and Proof_In_Constits.
22807 procedure Check_Output_States
;
22808 -- Determine whether the corresponding Global pragma mentions Output
22809 -- states with visible refinement and if so, ensure that all of its
22810 -- constituents appear as Output items in Refined_Global.
22811 -- This routine may remove elements from In_Constits, In_Out_Constits,
22812 -- Out_Constits and Proof_In_Constits.
22814 procedure Check_Proof_In_States
;
22815 -- Determine whether the corresponding Global pragma mentions Proof_In
22816 -- states with visible refinement and if so, ensure that at least one of
22817 -- its constituents appears as a Proof_In item in Refined_Global.
22818 -- This routine may remove elements from In_Constits, In_Out_Constits,
22819 -- Out_Constits and Proof_In_Constits.
22821 procedure Check_Refined_Global_List
22823 Global_Mode
: Name_Id
:= Name_Input
);
22824 -- Verify the legality of a single global list declaration. Global_Mode
22825 -- denotes the current mode in effect.
22827 procedure Collect_Global_Items
(Prag
: Node_Id
);
22828 -- Gather all input, in out, output and Proof_In items of pragma Prag
22829 -- in lists In_Items, In_Out_Items, Out_Items and Proof_In_Items. Flags
22830 -- Has_In_State, Has_In_Out_State, Has_Out_State and Has_Proof_In_State
22831 -- are set when there is at least one abstract state with visible
22832 -- refinement available in the corresponding mode. Flag Has_Null_State
22833 -- is set when at least state has a null refinement.
22835 function Present_Then_Remove
22837 Item
: Entity_Id
) return Boolean;
22838 -- Search List for a particular entity Item. If Item has been found,
22839 -- remove it from List. This routine is used to strip lists In_Constits,
22840 -- In_Out_Constits and Out_Constits of valid constituents.
22842 procedure Report_Extra_Constituents
;
22843 -- Emit an error for each constituent found in lists In_Constits,
22844 -- In_Out_Constits and Out_Constits.
22846 -------------------------
22847 -- Check_In_Out_States --
22848 -------------------------
22850 procedure Check_In_Out_States
is
22851 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22852 -- Determine whether one of the following coverage scenarios is in
22854 -- 1) there is at least one constituent of mode In_Out
22855 -- 2) there is at least one Input and one Output constituent
22856 -- 3) not all constituents are present and one of them is of mode
22858 -- If this is not the case, emit an error.
22860 -----------------------------
22861 -- Check_Constituent_Usage --
22862 -----------------------------
22864 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22865 Constit_Elmt
: Elmt_Id
;
22866 Constit_Id
: Entity_Id
;
22867 Has_Missing
: Boolean := False;
22868 In_Out_Seen
: Boolean := False;
22869 In_Seen
: Boolean := False;
22870 Out_Seen
: Boolean := False;
22873 -- Process all the constituents of the state and note their modes
22874 -- within the global refinement.
22876 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22877 while Present
(Constit_Elmt
) loop
22878 Constit_Id
:= Node
(Constit_Elmt
);
22880 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22883 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22884 In_Out_Seen
:= True;
22886 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22889 -- A Proof_In constituent cannot participate in the completion
22890 -- of an Output state (SPARK RM 7.2.4(5)).
22892 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22893 Error_Msg_Name_1
:= Chars
(State_Id
);
22895 ("constituent & of state % must have mode Input, In_Out "
22896 & "or Output in global refinement",
22900 Has_Missing
:= True;
22903 Next_Elmt
(Constit_Elmt
);
22906 -- A single In_Out constituent is a valid completion
22908 if In_Out_Seen
then
22911 -- A pair of one Input and one Output constituent is a valid
22914 elsif In_Seen
and then Out_Seen
then
22917 -- A single Output constituent is a valid completion only when
22918 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22920 elsif Has_Missing
and then Out_Seen
then
22925 ("global refinement of state & redefines the mode of its "
22926 & "constituents", N
, State_Id
);
22928 end Check_Constituent_Usage
;
22932 Item_Elmt
: Elmt_Id
;
22933 Item_Id
: Entity_Id
;
22935 -- Start of processing for Check_In_Out_States
22938 -- Inspect the In_Out items of the corresponding Global pragma
22939 -- looking for a state with a visible refinement.
22941 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22942 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22943 while Present
(Item_Elmt
) loop
22944 Item_Id
:= Node
(Item_Elmt
);
22946 -- Ensure that one of the three coverage variants is satisfied
22948 if Ekind
(Item_Id
) = E_Abstract_State
22949 and then Has_Non_Null_Refinement
(Item_Id
)
22951 Check_Constituent_Usage
(Item_Id
);
22954 Next_Elmt
(Item_Elmt
);
22957 end Check_In_Out_States
;
22959 ------------------------
22960 -- Check_Input_States --
22961 ------------------------
22963 procedure Check_Input_States
is
22964 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22965 -- Determine whether at least one constituent of state State_Id with
22966 -- visible refinement is used and has mode Input. Ensure that the
22967 -- remaining constituents do not have In_Out, Output or Proof_In
22970 -----------------------------
22971 -- Check_Constituent_Usage --
22972 -----------------------------
22974 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22975 Constit_Elmt
: Elmt_Id
;
22976 Constit_Id
: Entity_Id
;
22977 In_Seen
: Boolean := False;
22980 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22981 while Present
(Constit_Elmt
) loop
22982 Constit_Id
:= Node
(Constit_Elmt
);
22984 -- At least one of the constituents appears as an Input
22986 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22989 -- The constituent appears in the global refinement, but has
22990 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22992 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22993 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22994 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22996 Error_Msg_Name_1
:= Chars
(State_Id
);
22998 ("constituent & of state % must have mode Input in global "
22999 & "refinement", N
, Constit_Id
);
23002 Next_Elmt
(Constit_Elmt
);
23005 -- Not one of the constituents appeared as Input
23007 if not In_Seen
then
23009 ("global refinement of state & must include at least one "
23010 & "constituent of mode Input", N
, State_Id
);
23012 end Check_Constituent_Usage
;
23016 Item_Elmt
: Elmt_Id
;
23017 Item_Id
: Entity_Id
;
23019 -- Start of processing for Check_Input_States
23022 -- Inspect the Input items of the corresponding Global pragma
23023 -- looking for a state with a visible refinement.
23025 if Has_In_State
and then Present
(In_Items
) then
23026 Item_Elmt
:= First_Elmt
(In_Items
);
23027 while Present
(Item_Elmt
) loop
23028 Item_Id
:= Node
(Item_Elmt
);
23030 -- Ensure that at least one of the constituents is utilized and
23031 -- is of mode Input.
23033 if Ekind
(Item_Id
) = E_Abstract_State
23034 and then Has_Non_Null_Refinement
(Item_Id
)
23036 Check_Constituent_Usage
(Item_Id
);
23039 Next_Elmt
(Item_Elmt
);
23042 end Check_Input_States
;
23044 -------------------------
23045 -- Check_Output_States --
23046 -------------------------
23048 procedure Check_Output_States
is
23049 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23050 -- Determine whether all constituents of state State_Id with visible
23051 -- refinement are used and have mode Output. Emit an error if this is
23054 -----------------------------
23055 -- Check_Constituent_Usage --
23056 -----------------------------
23058 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23059 Constit_Elmt
: Elmt_Id
;
23060 Constit_Id
: Entity_Id
;
23061 Posted
: Boolean := False;
23064 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23065 while Present
(Constit_Elmt
) loop
23066 Constit_Id
:= Node
(Constit_Elmt
);
23068 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
23071 -- The constituent appears in the global refinement, but has
23072 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
23074 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23075 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23076 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
23078 Error_Msg_Name_1
:= Chars
(State_Id
);
23080 ("constituent & of state % must have mode Output in "
23081 & "global refinement", N
, Constit_Id
);
23083 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23089 ("output state & must be replaced by all its "
23090 & "constituents in global refinement", N
, State_Id
);
23094 ("\constituent & is missing in output list",
23098 Next_Elmt
(Constit_Elmt
);
23100 end Check_Constituent_Usage
;
23104 Item_Elmt
: Elmt_Id
;
23105 Item_Id
: Entity_Id
;
23107 -- Start of processing for Check_Output_States
23110 -- Inspect the Output items of the corresponding Global pragma
23111 -- looking for a state with a visible refinement.
23113 if Has_Out_State
and then Present
(Out_Items
) then
23114 Item_Elmt
:= First_Elmt
(Out_Items
);
23115 while Present
(Item_Elmt
) loop
23116 Item_Id
:= Node
(Item_Elmt
);
23118 -- Ensure that all of the constituents are utilized and they
23119 -- have mode Output.
23121 if Ekind
(Item_Id
) = E_Abstract_State
23122 and then Has_Non_Null_Refinement
(Item_Id
)
23124 Check_Constituent_Usage
(Item_Id
);
23127 Next_Elmt
(Item_Elmt
);
23130 end Check_Output_States
;
23132 ---------------------------
23133 -- Check_Proof_In_States --
23134 ---------------------------
23136 procedure Check_Proof_In_States
is
23137 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23138 -- Determine whether at least one constituent of state State_Id with
23139 -- visible refinement is used and has mode Proof_In. Ensure that the
23140 -- remaining constituents do not have Input, In_Out or Output modes.
23142 -----------------------------
23143 -- Check_Constituent_Usage --
23144 -----------------------------
23146 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23147 Constit_Elmt
: Elmt_Id
;
23148 Constit_Id
: Entity_Id
;
23149 Proof_In_Seen
: Boolean := False;
23152 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23153 while Present
(Constit_Elmt
) loop
23154 Constit_Id
:= Node
(Constit_Elmt
);
23156 -- At least one of the constituents appears as Proof_In
23158 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23159 Proof_In_Seen
:= True;
23161 -- The constituent appears in the global refinement, but has
23162 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23164 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23165 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23166 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23168 Error_Msg_Name_1
:= Chars
(State_Id
);
23170 ("constituent & of state % must have mode Proof_In in "
23171 & "global refinement", N
, Constit_Id
);
23174 Next_Elmt
(Constit_Elmt
);
23177 -- Not one of the constituents appeared as Proof_In
23179 if not Proof_In_Seen
then
23181 ("global refinement of state & must include at least one "
23182 & "constituent of mode Proof_In", N
, State_Id
);
23184 end Check_Constituent_Usage
;
23188 Item_Elmt
: Elmt_Id
;
23189 Item_Id
: Entity_Id
;
23191 -- Start of processing for Check_Proof_In_States
23194 -- Inspect the Proof_In items of the corresponding Global pragma
23195 -- looking for a state with a visible refinement.
23197 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23198 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23199 while Present
(Item_Elmt
) loop
23200 Item_Id
:= Node
(Item_Elmt
);
23202 -- Ensure that at least one of the constituents is utilized and
23203 -- is of mode Proof_In
23205 if Ekind
(Item_Id
) = E_Abstract_State
23206 and then Has_Non_Null_Refinement
(Item_Id
)
23208 Check_Constituent_Usage
(Item_Id
);
23211 Next_Elmt
(Item_Elmt
);
23214 end Check_Proof_In_States
;
23216 -------------------------------
23217 -- Check_Refined_Global_List --
23218 -------------------------------
23220 procedure Check_Refined_Global_List
23222 Global_Mode
: Name_Id
:= Name_Input
)
23224 procedure Check_Refined_Global_Item
23226 Global_Mode
: Name_Id
);
23227 -- Verify the legality of a single global item declaration. Parameter
23228 -- Global_Mode denotes the current mode in effect.
23230 -------------------------------
23231 -- Check_Refined_Global_Item --
23232 -------------------------------
23234 procedure Check_Refined_Global_Item
23236 Global_Mode
: Name_Id
)
23238 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23240 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23241 -- Issue a common error message for all mode mismatches. Expect
23242 -- denotes the expected mode.
23244 -----------------------------
23245 -- Inconsistent_Mode_Error --
23246 -----------------------------
23248 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23251 ("global item & has inconsistent modes", Item
, Item_Id
);
23253 Error_Msg_Name_1
:= Global_Mode
;
23254 Error_Msg_Name_2
:= Expect
;
23255 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
23256 end Inconsistent_Mode_Error
;
23258 -- Start of processing for Check_Refined_Global_Item
23261 -- When the state or variable acts as a constituent of another
23262 -- state with a visible refinement, collect it for the state
23263 -- completeness checks performed later on.
23265 if Present
(Encapsulating_State
(Item_Id
))
23266 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23268 if Global_Mode
= Name_Input
then
23269 Add_Item
(Item_Id
, In_Constits
);
23271 elsif Global_Mode
= Name_In_Out
then
23272 Add_Item
(Item_Id
, In_Out_Constits
);
23274 elsif Global_Mode
= Name_Output
then
23275 Add_Item
(Item_Id
, Out_Constits
);
23277 elsif Global_Mode
= Name_Proof_In
then
23278 Add_Item
(Item_Id
, Proof_In_Constits
);
23281 -- When not a constituent, ensure that both occurrences of the
23282 -- item in pragmas Global and Refined_Global match.
23284 elsif Contains
(In_Items
, Item_Id
) then
23285 if Global_Mode
/= Name_Input
then
23286 Inconsistent_Mode_Error
(Name_Input
);
23289 elsif Contains
(In_Out_Items
, Item_Id
) then
23290 if Global_Mode
/= Name_In_Out
then
23291 Inconsistent_Mode_Error
(Name_In_Out
);
23294 elsif Contains
(Out_Items
, Item_Id
) then
23295 if Global_Mode
/= Name_Output
then
23296 Inconsistent_Mode_Error
(Name_Output
);
23299 elsif Contains
(Proof_In_Items
, Item_Id
) then
23302 -- The item does not appear in the corresponding Global pragma,
23303 -- it must be an extra (SPARK RM 7.2.4(3)).
23306 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
23308 end Check_Refined_Global_Item
;
23314 -- Start of processing for Check_Refined_Global_List
23317 if Nkind
(List
) = N_Null
then
23320 -- Single global item declaration
23322 elsif Nkind_In
(List
, N_Expanded_Name
,
23324 N_Selected_Component
)
23326 Check_Refined_Global_Item
(List
, Global_Mode
);
23328 -- Simple global list or moded global list declaration
23330 elsif Nkind
(List
) = N_Aggregate
then
23332 -- The declaration of a simple global list appear as a collection
23335 if Present
(Expressions
(List
)) then
23336 Item
:= First
(Expressions
(List
));
23337 while Present
(Item
) loop
23338 Check_Refined_Global_Item
(Item
, Global_Mode
);
23343 -- The declaration of a moded global list appears as a collection
23344 -- of component associations where individual choices denote
23347 elsif Present
(Component_Associations
(List
)) then
23348 Item
:= First
(Component_Associations
(List
));
23349 while Present
(Item
) loop
23350 Check_Refined_Global_List
23351 (List
=> Expression
(Item
),
23352 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23360 raise Program_Error
;
23366 raise Program_Error
;
23368 end Check_Refined_Global_List
;
23370 --------------------------
23371 -- Collect_Global_Items --
23372 --------------------------
23374 procedure Collect_Global_Items
(Prag
: Node_Id
) is
23375 procedure Process_Global_List
23377 Mode
: Name_Id
:= Name_Input
);
23378 -- Collect all items housed in a global list. Formal Mode denotes the
23379 -- current mode in effect.
23381 -------------------------
23382 -- Process_Global_List --
23383 -------------------------
23385 procedure Process_Global_List
23387 Mode
: Name_Id
:= Name_Input
)
23389 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
23390 -- Add a single item to the appropriate list. Formal Mode denotes
23391 -- the current mode in effect.
23393 -------------------------
23394 -- Process_Global_Item --
23395 -------------------------
23397 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
23398 Item_Id
: constant Entity_Id
:=
23399 Available_View
(Entity_Of
(Item
));
23400 -- The above handles abstract views of variables and states
23401 -- built for limited with clauses.
23404 -- Signal that the global list contains at least one abstract
23405 -- state with a visible refinement. Note that the refinement
23406 -- may be null in which case there are no constituents.
23408 if Ekind
(Item_Id
) = E_Abstract_State
then
23409 if Has_Null_Refinement
(Item_Id
) then
23410 Has_Null_State
:= True;
23412 elsif Has_Non_Null_Refinement
(Item_Id
) then
23413 if Mode
= Name_Input
then
23414 Has_In_State
:= True;
23415 elsif Mode
= Name_In_Out
then
23416 Has_In_Out_State
:= True;
23417 elsif Mode
= Name_Output
then
23418 Has_Out_State
:= True;
23419 elsif Mode
= Name_Proof_In
then
23420 Has_Proof_In_State
:= True;
23425 -- Add the item to the proper list
23427 if Mode
= Name_Input
then
23428 Add_Item
(Item_Id
, In_Items
);
23429 elsif Mode
= Name_In_Out
then
23430 Add_Item
(Item_Id
, In_Out_Items
);
23431 elsif Mode
= Name_Output
then
23432 Add_Item
(Item_Id
, Out_Items
);
23433 elsif Mode
= Name_Proof_In
then
23434 Add_Item
(Item_Id
, Proof_In_Items
);
23436 end Process_Global_Item
;
23442 -- Start of processing for Process_Global_List
23445 if Nkind
(List
) = N_Null
then
23448 -- Single global item declaration
23450 elsif Nkind_In
(List
, N_Expanded_Name
,
23452 N_Selected_Component
)
23454 Process_Global_Item
(List
, Mode
);
23456 -- Single global list or moded global list declaration
23458 elsif Nkind
(List
) = N_Aggregate
then
23460 -- The declaration of a simple global list appear as a
23461 -- collection of expressions.
23463 if Present
(Expressions
(List
)) then
23464 Item
:= First
(Expressions
(List
));
23465 while Present
(Item
) loop
23466 Process_Global_Item
(Item
, Mode
);
23470 -- The declaration of a moded global list appears as a
23471 -- collection of component associations where individual
23472 -- choices denote mode.
23474 elsif Present
(Component_Associations
(List
)) then
23475 Item
:= First
(Component_Associations
(List
));
23476 while Present
(Item
) loop
23477 Process_Global_List
23478 (List
=> Expression
(Item
),
23479 Mode
=> Chars
(First
(Choices
(Item
))));
23487 raise Program_Error
;
23490 -- To accomodate partial decoration of disabled SPARK features,
23491 -- this routine may be called with illegal input. If this is the
23492 -- case, do not raise Program_Error.
23497 end Process_Global_List
;
23499 -- Start of processing for Collect_Global_Items
23502 Process_Global_List
23503 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
))));
23504 end Collect_Global_Items
;
23506 -------------------------
23507 -- Present_Then_Remove --
23508 -------------------------
23510 function Present_Then_Remove
23512 Item
: Entity_Id
) return Boolean
23517 if Present
(List
) then
23518 Elmt
:= First_Elmt
(List
);
23519 while Present
(Elmt
) loop
23520 if Node
(Elmt
) = Item
then
23521 Remove_Elmt
(List
, Elmt
);
23530 end Present_Then_Remove
;
23532 -------------------------------
23533 -- Report_Extra_Constituents --
23534 -------------------------------
23536 procedure Report_Extra_Constituents
is
23537 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23538 -- Emit an error for every element of List
23540 ---------------------------------------
23541 -- Report_Extra_Constituents_In_List --
23542 ---------------------------------------
23544 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23545 Constit_Elmt
: Elmt_Id
;
23548 if Present
(List
) then
23549 Constit_Elmt
:= First_Elmt
(List
);
23550 while Present
(Constit_Elmt
) loop
23551 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23552 Next_Elmt
(Constit_Elmt
);
23555 end Report_Extra_Constituents_In_List
;
23557 -- Start of processing for Report_Extra_Constituents
23560 Report_Extra_Constituents_In_List
(In_Constits
);
23561 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23562 Report_Extra_Constituents_In_List
(Out_Constits
);
23563 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23564 end Report_Extra_Constituents
;
23568 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23569 Errors
: constant Nat
:= Serious_Errors_Detected
;
23570 Items
: constant Node_Id
:=
23571 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23572 Spec_Id
: Entity_Id
;
23574 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23577 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23578 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23580 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23583 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23585 -- The subprogram declaration lacks pragma Global. This renders
23586 -- Refined_Global useless as there is nothing to refine.
23588 if No
(Global
) then
23590 ("useless refinement, declaration of subprogram & lacks aspect or "
23591 & "pragma Global", N
, Spec_Id
);
23595 -- Extract all relevant items from the corresponding Global pragma
23597 Collect_Global_Items
(Global
);
23599 -- Corresponding Global pragma must mention at least one state witha
23600 -- visible refinement at the point Refined_Global is processed. States
23601 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23603 if not Has_In_State
23604 and then not Has_In_Out_State
23605 and then not Has_Out_State
23606 and then not Has_Proof_In_State
23607 and then not Has_Null_State
23610 ("useless refinement, subprogram & does not depend on abstract "
23611 & "state with visible refinement", N
, Spec_Id
);
23615 -- The global refinement of inputs and outputs cannot be null when the
23616 -- corresponding Global pragma contains at least one item except in the
23617 -- case where we have states with null refinements.
23619 if Nkind
(Items
) = N_Null
23621 (Present
(In_Items
)
23622 or else Present
(In_Out_Items
)
23623 or else Present
(Out_Items
)
23624 or else Present
(Proof_In_Items
))
23625 and then not Has_Null_State
23628 ("refinement cannot be null, subprogram & has global items",
23633 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23634 -- This ensures that the categorization of all refined global items is
23635 -- consistent with their role.
23637 Analyze_Global_In_Decl_Part
(N
);
23639 -- Perform all refinement checks with respect to completeness and mode
23642 if Serious_Errors_Detected
= Errors
then
23643 Check_Refined_Global_List
(Items
);
23646 -- For Input states with visible refinement, at least one constituent
23647 -- must be used as an Input in the global refinement.
23649 if Serious_Errors_Detected
= Errors
then
23650 Check_Input_States
;
23653 -- Verify all possible completion variants for In_Out states with
23654 -- visible refinement.
23656 if Serious_Errors_Detected
= Errors
then
23657 Check_In_Out_States
;
23660 -- For Output states with visible refinement, all constituents must be
23661 -- used as Outputs in the global refinement.
23663 if Serious_Errors_Detected
= Errors
then
23664 Check_Output_States
;
23667 -- For Proof_In states with visible refinement, at least one constituent
23668 -- must be used as Proof_In in the global refinement.
23670 if Serious_Errors_Detected
= Errors
then
23671 Check_Proof_In_States
;
23674 -- Emit errors for all constituents that belong to other states with
23675 -- visible refinement that do not appear in Global.
23677 if Serious_Errors_Detected
= Errors
then
23678 Report_Extra_Constituents
;
23680 end Analyze_Refined_Global_In_Decl_Part
;
23682 ----------------------------------------
23683 -- Analyze_Refined_State_In_Decl_Part --
23684 ----------------------------------------
23686 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23687 Available_States
: Elist_Id
:= No_Elist
;
23688 -- A list of all abstract states defined in the package declaration that
23689 -- are available for refinement. The list is used to report unrefined
23692 Body_Id
: Entity_Id
;
23693 -- The body entity of the package subject to pragma Refined_State
23695 Body_States
: Elist_Id
:= No_Elist
;
23696 -- A list of all hidden states that appear in the body of the related
23697 -- package. The list is used to report unused hidden states.
23699 Constituents_Seen
: Elist_Id
:= No_Elist
;
23700 -- A list that contains all constituents processed so far. The list is
23701 -- used to detect multiple uses of the same constituent.
23703 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23704 -- A list that contains all refined states processed so far. The list is
23705 -- used to detect duplicate refinements.
23707 Spec_Id
: Entity_Id
;
23708 -- The spec entity of the package subject to pragma Refined_State
23710 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23711 -- Perform full analysis of a single refinement clause
23713 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23714 -- Gather the entities of all abstract states and variables declared in
23715 -- the body state space of package Pack_Id.
23717 procedure Report_Unrefined_States
(States
: Elist_Id
);
23718 -- Emit errors for all unrefined abstract states found in list States
23720 procedure Report_Unused_States
(States
: Elist_Id
);
23721 -- Emit errors for all unused states found in list States
23723 -------------------------------
23724 -- Analyze_Refinement_Clause --
23725 -------------------------------
23727 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23728 AR_Constit
: Entity_Id
:= Empty
;
23729 AW_Constit
: Entity_Id
:= Empty
;
23730 ER_Constit
: Entity_Id
:= Empty
;
23731 EW_Constit
: Entity_Id
:= Empty
;
23732 -- The entities of external constituents that contain one of the
23733 -- following enabled properties: Async_Readers, Async_Writers,
23734 -- Effective_Reads and Effective_Writes.
23736 External_Constit_Seen
: Boolean := False;
23737 -- Flag used to mark when at least one external constituent is part
23738 -- of the state refinement.
23740 Non_Null_Seen
: Boolean := False;
23741 Null_Seen
: Boolean := False;
23742 -- Flags used to detect multiple uses of null in a single clause or a
23743 -- mixture of null and non-null constituents.
23745 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23746 -- A list of all candidate constituents subject to indicator Part_Of
23747 -- where the encapsulating state is the current state.
23750 State_Id
: Entity_Id
;
23751 -- The current state being refined
23753 procedure Analyze_Constituent
(Constit
: Node_Id
);
23754 -- Perform full analysis of a single constituent
23756 procedure Check_External_Property
23757 (Prop_Nam
: Name_Id
;
23759 Constit
: Entity_Id
);
23760 -- Determine whether a property denoted by name Prop_Nam is present
23761 -- in both the refined state and constituent Constit. Flag Enabled
23762 -- should be set when the property applies to the refined state. If
23763 -- this is not the case, emit an error message.
23765 procedure Check_Matching_State
;
23766 -- Determine whether the state being refined appears in list
23767 -- Available_States. Emit an error when attempting to re-refine the
23768 -- state or when the state is not defined in the package declaration,
23769 -- otherwise remove the state from Available_States.
23771 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23772 -- Emit errors for all unused Part_Of constituents in list Constits
23774 -------------------------
23775 -- Analyze_Constituent --
23776 -------------------------
23778 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23779 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23780 -- Verify that the constituent Constit_Id is a Ghost entity if the
23781 -- abstract state being refined is also Ghost. If this is the case
23782 -- verify that the Ghost policy in effect at the point of state
23783 -- and constituent declaration is the same.
23785 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23786 -- Determine whether constituent Constit denoted by its entity
23787 -- Constit_Id appears in Hidden_States. Emit an error when the
23788 -- constituent is not a valid hidden state of the related package
23789 -- or when it is used more than once. Otherwise remove the
23790 -- constituent from Hidden_States.
23792 --------------------------------
23793 -- Check_Matching_Constituent --
23794 --------------------------------
23796 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23797 procedure Collect_Constituent
;
23798 -- Add constituent Constit_Id to the refinements of State_Id
23800 -------------------------
23801 -- Collect_Constituent --
23802 -------------------------
23804 procedure Collect_Constituent
is
23806 -- Add the constituent to the list of processed items to aid
23807 -- with the detection of duplicates.
23809 Add_Item
(Constit_Id
, Constituents_Seen
);
23811 -- Collect the constituent in the list of refinement items
23812 -- and establish a relation between the refined state and
23815 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23816 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23818 -- The state has at least one legal constituent, mark the
23819 -- start of the refinement region. The region ends when the
23820 -- body declarations end (see routine Analyze_Declarations).
23822 Set_Has_Visible_Refinement
(State_Id
);
23824 -- When the constituent is external, save its relevant
23825 -- property for further checks.
23827 if Async_Readers_Enabled
(Constit_Id
) then
23828 AR_Constit
:= Constit_Id
;
23829 External_Constit_Seen
:= True;
23832 if Async_Writers_Enabled
(Constit_Id
) then
23833 AW_Constit
:= Constit_Id
;
23834 External_Constit_Seen
:= True;
23837 if Effective_Reads_Enabled
(Constit_Id
) then
23838 ER_Constit
:= Constit_Id
;
23839 External_Constit_Seen
:= True;
23842 if Effective_Writes_Enabled
(Constit_Id
) then
23843 EW_Constit
:= Constit_Id
;
23844 External_Constit_Seen
:= True;
23846 end Collect_Constituent
;
23850 State_Elmt
: Elmt_Id
;
23852 -- Start of processing for Check_Matching_Constituent
23855 -- Detect a duplicate use of a constituent
23857 if Contains
(Constituents_Seen
, Constit_Id
) then
23859 ("duplicate use of constituent &", Constit
, Constit_Id
);
23863 -- The constituent is subject to a Part_Of indicator
23865 if Present
(Encapsulating_State
(Constit_Id
)) then
23866 if Encapsulating_State
(Constit_Id
) = State_Id
then
23867 Check_Ghost_Constituent
(Constit_Id
);
23868 Remove
(Part_Of_Constits
, Constit_Id
);
23869 Collect_Constituent
;
23871 -- The constituent is part of another state and is used
23872 -- incorrectly in the refinement of the current state.
23875 Error_Msg_Name_1
:= Chars
(State_Id
);
23877 ("& cannot act as constituent of state %",
23878 Constit
, Constit_Id
);
23880 ("\Part_Of indicator specifies & as encapsulating "
23881 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23884 -- The only other source of legal constituents is the body
23885 -- state space of the related package.
23888 if Present
(Body_States
) then
23889 State_Elmt
:= First_Elmt
(Body_States
);
23890 while Present
(State_Elmt
) loop
23892 -- Consume a valid constituent to signal that it has
23893 -- been encountered.
23895 if Node
(State_Elmt
) = Constit_Id
then
23896 Check_Ghost_Constituent
(Constit_Id
);
23898 Remove_Elmt
(Body_States
, State_Elmt
);
23899 Collect_Constituent
;
23903 Next_Elmt
(State_Elmt
);
23907 -- If we get here, then the constituent is not a hidden
23908 -- state of the related package and may not be used in a
23909 -- refinement (SPARK RM 7.2.2(9)).
23911 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23913 ("cannot use & in refinement, constituent is not a hidden "
23914 & "state of package %", Constit
, Constit_Id
);
23916 end Check_Matching_Constituent
;
23918 -----------------------------
23919 -- Check_Ghost_Constituent --
23920 -----------------------------
23922 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
23924 if Is_Ghost_Entity
(State_Id
) then
23925 if Is_Ghost_Entity
(Constit_Id
) then
23927 -- The Ghost policy in effect at the point of abstract
23928 -- state declaration and constituent must match
23929 -- (SPARK RM 6.9(16)).
23931 if Is_Checked_Ghost_Entity
(State_Id
)
23932 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
23934 Error_Msg_Sloc
:= Sloc
(Constit
);
23937 ("incompatible ghost policies in effect", State
);
23939 ("\abstract state & declared with ghost policy "
23940 & "Check", State
, State_Id
);
23942 ("\constituent & declared # with ghost policy "
23943 & "Ignore", State
, Constit_Id
);
23945 elsif Is_Ignored_Ghost_Entity
(State_Id
)
23946 and then Is_Checked_Ghost_Entity
(Constit_Id
)
23948 Error_Msg_Sloc
:= Sloc
(Constit
);
23951 ("incompatible ghost policies in effect", State
);
23953 ("\abstract state & declared with ghost policy "
23954 & "Ignore", State
, State_Id
);
23956 ("\constituent & declared # with ghost policy "
23957 & "Check", State
, Constit_Id
);
23960 -- A constituent of a Ghost abstract state must be a Ghost
23961 -- entity (SPARK RM 7.2.2(12)).
23965 ("constituent of ghost state & must be ghost",
23966 Constit
, State_Id
);
23969 end Check_Ghost_Constituent
;
23973 Constit_Id
: Entity_Id
;
23975 -- Start of processing for Analyze_Constituent
23978 -- Detect multiple uses of null in a single refinement clause or a
23979 -- mixture of null and non-null constituents.
23981 if Nkind
(Constit
) = N_Null
then
23984 ("multiple null constituents not allowed", Constit
);
23986 elsif Non_Null_Seen
then
23988 ("cannot mix null and non-null constituents", Constit
);
23993 -- Collect the constituent in the list of refinement items
23995 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23997 -- The state has at least one legal constituent, mark the
23998 -- start of the refinement region. The region ends when the
23999 -- body declarations end (see Analyze_Declarations).
24001 Set_Has_Visible_Refinement
(State_Id
);
24004 -- Non-null constituents
24007 Non_Null_Seen
:= True;
24011 ("cannot mix null and non-null constituents", Constit
);
24015 Resolve_State
(Constit
);
24017 -- Ensure that the constituent denotes a valid state or a
24020 if Is_Entity_Name
(Constit
) then
24021 Constit_Id
:= Entity_Of
(Constit
);
24023 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
24024 Check_Matching_Constituent
(Constit_Id
);
24028 ("constituent & must denote a variable or state (SPARK "
24029 & "RM 7.2.2(5))", Constit
, Constit_Id
);
24032 -- The constituent is illegal
24035 SPARK_Msg_N
("malformed constituent", Constit
);
24038 end Analyze_Constituent
;
24040 -----------------------------
24041 -- Check_External_Property --
24042 -----------------------------
24044 procedure Check_External_Property
24045 (Prop_Nam
: Name_Id
;
24047 Constit
: Entity_Id
)
24050 Error_Msg_Name_1
:= Prop_Nam
;
24052 -- The property is enabled in the related Abstract_State pragma
24053 -- that defines the state (SPARK RM 7.2.8(3)).
24056 if No
(Constit
) then
24058 ("external state & requires at least one constituent with "
24059 & "property %", State
, State_Id
);
24062 -- The property is missing in the declaration of the state, but
24063 -- a constituent is introducing it in the state refinement
24064 -- (SPARK RM 7.2.8(3)).
24066 elsif Present
(Constit
) then
24067 Error_Msg_Name_2
:= Chars
(Constit
);
24069 ("external state & lacks property % set by constituent %",
24072 end Check_External_Property
;
24074 --------------------------
24075 -- Check_Matching_State --
24076 --------------------------
24078 procedure Check_Matching_State
is
24079 State_Elmt
: Elmt_Id
;
24082 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
24084 if Contains
(Refined_States_Seen
, State_Id
) then
24086 ("duplicate refinement of state &", State
, State_Id
);
24090 -- Inspect the abstract states defined in the package declaration
24091 -- looking for a match.
24093 State_Elmt
:= First_Elmt
(Available_States
);
24094 while Present
(State_Elmt
) loop
24096 -- A valid abstract state is being refined in the body. Add
24097 -- the state to the list of processed refined states to aid
24098 -- with the detection of duplicate refinements. Remove the
24099 -- state from Available_States to signal that it has already
24102 if Node
(State_Elmt
) = State_Id
then
24103 Add_Item
(State_Id
, Refined_States_Seen
);
24104 Remove_Elmt
(Available_States
, State_Elmt
);
24108 Next_Elmt
(State_Elmt
);
24111 -- If we get here, we are refining a state that is not defined in
24112 -- the package declaration.
24114 Error_Msg_Name_1
:= Chars
(Spec_Id
);
24116 ("cannot refine state, & is not defined in package %",
24118 end Check_Matching_State
;
24120 --------------------------------
24121 -- Report_Unused_Constituents --
24122 --------------------------------
24124 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
24125 Constit_Elmt
: Elmt_Id
;
24126 Constit_Id
: Entity_Id
;
24127 Posted
: Boolean := False;
24130 if Present
(Constits
) then
24131 Constit_Elmt
:= First_Elmt
(Constits
);
24132 while Present
(Constit_Elmt
) loop
24133 Constit_Id
:= Node
(Constit_Elmt
);
24135 -- Generate an error message of the form:
24137 -- state ... has unused Part_Of constituents
24138 -- abstract state ... defined at ...
24139 -- variable ... defined at ...
24144 ("state & has unused Part_Of constituents",
24148 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
24150 if Ekind
(Constit_Id
) = E_Abstract_State
then
24152 ("\abstract state & defined #", State
, Constit_Id
);
24155 ("\variable & defined #", State
, Constit_Id
);
24158 Next_Elmt
(Constit_Elmt
);
24161 end Report_Unused_Constituents
;
24163 -- Local declarations
24165 Body_Ref
: Node_Id
;
24166 Body_Ref_Elmt
: Elmt_Id
;
24168 Extra_State
: Node_Id
;
24170 -- Start of processing for Analyze_Refinement_Clause
24173 -- A refinement clause appears as a component association where the
24174 -- sole choice is the state and the expressions are the constituents.
24175 -- This is a syntax error, always report.
24177 if Nkind
(Clause
) /= N_Component_Association
then
24178 Error_Msg_N
("malformed state refinement clause", Clause
);
24182 -- Analyze the state name of a refinement clause
24184 State
:= First
(Choices
(Clause
));
24187 Resolve_State
(State
);
24189 -- Ensure that the state name denotes a valid abstract state that is
24190 -- defined in the spec of the related package.
24192 if Is_Entity_Name
(State
) then
24193 State_Id
:= Entity_Of
(State
);
24195 -- Catch any attempts to re-refine a state or refine a state that
24196 -- is not defined in the package declaration.
24198 if Ekind
(State_Id
) = E_Abstract_State
then
24199 Check_Matching_State
;
24202 ("& must denote an abstract state", State
, State_Id
);
24206 -- References to a state with visible refinement are illegal.
24207 -- When nested packages are involved, detecting such references is
24208 -- tricky because pragma Refined_State is analyzed later than the
24209 -- offending pragma Depends or Global. References that occur in
24210 -- such nested context are stored in a list. Emit errors for all
24211 -- references found in Body_References (SPARK RM 6.1.4(8)).
24213 if Present
(Body_References
(State_Id
)) then
24214 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
24215 while Present
(Body_Ref_Elmt
) loop
24216 Body_Ref
:= Node
(Body_Ref_Elmt
);
24218 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
24219 Error_Msg_Sloc
:= Sloc
(State
);
24220 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
24222 Next_Elmt
(Body_Ref_Elmt
);
24226 -- The state name is illegal. This is a syntax error, always report.
24229 Error_Msg_N
("malformed state name in refinement clause", State
);
24233 -- A refinement clause may only refine one state at a time
24235 Extra_State
:= Next
(State
);
24237 if Present
(Extra_State
) then
24239 ("refinement clause cannot cover multiple states", Extra_State
);
24242 -- Replicate the Part_Of constituents of the refined state because
24243 -- the algorithm will consume items.
24245 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
24247 -- Analyze all constituents of the refinement. Multiple constituents
24248 -- appear as an aggregate.
24250 Constit
:= Expression
(Clause
);
24252 if Nkind
(Constit
) = N_Aggregate
then
24253 if Present
(Component_Associations
(Constit
)) then
24255 ("constituents of refinement clause must appear in "
24256 & "positional form", Constit
);
24258 else pragma Assert
(Present
(Expressions
(Constit
)));
24259 Constit
:= First
(Expressions
(Constit
));
24260 while Present
(Constit
) loop
24261 Analyze_Constituent
(Constit
);
24267 -- Various forms of a single constituent. Note that these may include
24268 -- malformed constituents.
24271 Analyze_Constituent
(Constit
);
24274 -- A refined external state is subject to special rules with respect
24275 -- to its properties and constituents.
24277 if Is_External_State
(State_Id
) then
24279 -- The set of properties that all external constituents yield must
24280 -- match that of the refined state. There are two cases to detect:
24281 -- the refined state lacks a property or has an extra property.
24283 if External_Constit_Seen
then
24284 Check_External_Property
24285 (Prop_Nam
=> Name_Async_Readers
,
24286 Enabled
=> Async_Readers_Enabled
(State_Id
),
24287 Constit
=> AR_Constit
);
24289 Check_External_Property
24290 (Prop_Nam
=> Name_Async_Writers
,
24291 Enabled
=> Async_Writers_Enabled
(State_Id
),
24292 Constit
=> AW_Constit
);
24294 Check_External_Property
24295 (Prop_Nam
=> Name_Effective_Reads
,
24296 Enabled
=> Effective_Reads_Enabled
(State_Id
),
24297 Constit
=> ER_Constit
);
24299 Check_External_Property
24300 (Prop_Nam
=> Name_Effective_Writes
,
24301 Enabled
=> Effective_Writes_Enabled
(State_Id
),
24302 Constit
=> EW_Constit
);
24304 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24306 elsif Null_Seen
then
24309 -- The external state has constituents, but none of them are
24310 -- external (SPARK RM 7.2.8(2)).
24314 ("external state & requires at least one external "
24315 & "constituent or null refinement", State
, State_Id
);
24318 -- When a refined state is not external, it should not have external
24319 -- constituents (SPARK RM 7.2.8(1)).
24321 elsif External_Constit_Seen
then
24323 ("non-external state & cannot contain external constituents in "
24324 & "refinement", State
, State_Id
);
24327 -- Ensure that all Part_Of candidate constituents have been mentioned
24328 -- in the refinement clause.
24330 Report_Unused_Constituents
(Part_Of_Constits
);
24331 end Analyze_Refinement_Clause
;
24333 -------------------------
24334 -- Collect_Body_States --
24335 -------------------------
24337 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24338 Result
: Elist_Id
:= No_Elist
;
24339 -- A list containing all body states of Pack_Id
24341 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24342 -- Gather the entities of all abstract states and variables declared
24343 -- in the visible state space of package Pack_Id.
24345 ----------------------------
24346 -- Collect_Visible_States --
24347 ----------------------------
24349 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24350 Item_Id
: Entity_Id
;
24353 -- Traverse the entity chain of the package and inspect all
24356 Item_Id
:= First_Entity
(Pack_Id
);
24357 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24359 -- Do not consider internally generated items as those cannot
24360 -- be named and participate in refinement.
24362 if not Comes_From_Source
(Item_Id
) then
24365 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24366 Add_Item
(Item_Id
, Result
);
24368 -- Recursively gather the visible states of a nested package
24370 elsif Ekind
(Item_Id
) = E_Package
then
24371 Collect_Visible_States
(Item_Id
);
24374 Next_Entity
(Item_Id
);
24376 end Collect_Visible_States
;
24380 Pack_Body
: constant Node_Id
:=
24381 Declaration_Node
(Body_Entity
(Pack_Id
));
24383 Item_Id
: Entity_Id
;
24385 -- Start of processing for Collect_Body_States
24388 -- Inspect the declarations of the body looking for source variables,
24389 -- packages and package instantiations.
24391 Decl
:= First
(Declarations
(Pack_Body
));
24392 while Present
(Decl
) loop
24393 if Nkind
(Decl
) = N_Object_Declaration
then
24394 Item_Id
:= Defining_Entity
(Decl
);
24396 -- Capture source variables only as internally generated
24397 -- temporaries cannot be named and participate in refinement.
24399 if Ekind
(Item_Id
) = E_Variable
24400 and then Comes_From_Source
(Item_Id
)
24402 Add_Item
(Item_Id
, Result
);
24405 elsif Nkind
(Decl
) = N_Package_Declaration
then
24406 Item_Id
:= Defining_Entity
(Decl
);
24408 -- Capture the visible abstract states and variables of a
24409 -- source package [instantiation].
24411 if Comes_From_Source
(Item_Id
) then
24412 Collect_Visible_States
(Item_Id
);
24420 end Collect_Body_States
;
24422 -----------------------------
24423 -- Report_Unrefined_States --
24424 -----------------------------
24426 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24427 State_Elmt
: Elmt_Id
;
24430 if Present
(States
) then
24431 State_Elmt
:= First_Elmt
(States
);
24432 while Present
(State_Elmt
) loop
24434 ("abstract state & must be refined", Node
(State_Elmt
));
24436 Next_Elmt
(State_Elmt
);
24439 end Report_Unrefined_States
;
24441 --------------------------
24442 -- Report_Unused_States --
24443 --------------------------
24445 procedure Report_Unused_States
(States
: Elist_Id
) is
24446 Posted
: Boolean := False;
24447 State_Elmt
: Elmt_Id
;
24448 State_Id
: Entity_Id
;
24451 if Present
(States
) then
24452 State_Elmt
:= First_Elmt
(States
);
24453 while Present
(State_Elmt
) loop
24454 State_Id
:= Node
(State_Elmt
);
24456 -- Generate an error message of the form:
24458 -- body of package ... has unused hidden states
24459 -- abstract state ... defined at ...
24460 -- variable ... defined at ...
24465 ("body of package & has unused hidden states", Body_Id
);
24468 Error_Msg_Sloc
:= Sloc
(State_Id
);
24470 if Ekind
(State_Id
) = E_Abstract_State
then
24472 ("\abstract state & defined #", Body_Id
, State_Id
);
24475 ("\variable & defined #", Body_Id
, State_Id
);
24478 Next_Elmt
(State_Elmt
);
24481 end Report_Unused_States
;
24483 -- Local declarations
24485 Body_Decl
: constant Node_Id
:= Parent
(N
);
24486 Clauses
: constant Node_Id
:=
24487 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
24490 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24495 Body_Id
:= Defining_Entity
(Body_Decl
);
24496 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
24498 -- Replicate the abstract states declared by the package because the
24499 -- matching algorithm will consume states.
24501 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24503 -- Gather all abstract states and variables declared in the visible
24504 -- state space of the package body. These items must be utilized as
24505 -- constituents in a state refinement.
24507 Body_States
:= Collect_Body_States
(Spec_Id
);
24509 -- Multiple non-null state refinements appear as an aggregate
24511 if Nkind
(Clauses
) = N_Aggregate
then
24512 if Present
(Expressions
(Clauses
)) then
24514 ("state refinements must appear as component associations",
24517 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24518 Clause
:= First
(Component_Associations
(Clauses
));
24519 while Present
(Clause
) loop
24520 Analyze_Refinement_Clause
(Clause
);
24526 -- Various forms of a single state refinement. Note that these may
24527 -- include malformed refinements.
24530 Analyze_Refinement_Clause
(Clauses
);
24533 -- List all abstract states that were left unrefined
24535 Report_Unrefined_States
(Available_States
);
24537 -- Ensure that all abstract states and variables declared in the body
24538 -- state space of the related package are utilized as constituents.
24540 Report_Unused_States
(Body_States
);
24541 end Analyze_Refined_State_In_Decl_Part
;
24543 ------------------------------------
24544 -- Analyze_Test_Case_In_Decl_Part --
24545 ------------------------------------
24547 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
24549 -- Install formals and push subprogram spec onto scope stack so that we
24550 -- can see the formals from the pragma.
24553 Install_Formals
(S
);
24555 -- Preanalyze the boolean expressions, we treat these as spec
24556 -- expressions (i.e. similar to a default expression).
24558 if Pragma_Name
(N
) = Name_Test_Case
then
24559 Preanalyze_CTC_Args
24561 Get_Requires_From_CTC_Pragma
(N
),
24562 Get_Ensures_From_CTC_Pragma
(N
));
24565 -- Remove the subprogram from the scope stack now that the pre-analysis
24566 -- of the expressions in the contract case or test case is done.
24569 end Analyze_Test_Case_In_Decl_Part
;
24575 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24580 if Present
(List
) then
24581 Elmt
:= First_Elmt
(List
);
24582 while Present
(Elmt
) loop
24583 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24586 Id
:= Entity_Of
(Node
(Elmt
));
24589 if Id
= Item_Id
then
24600 -----------------------------
24601 -- Check_Applicable_Policy --
24602 -----------------------------
24604 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24608 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
24611 -- No effect if not valid assertion kind name
24613 if not Is_Valid_Assertion_Kind
(Ename
) then
24617 -- Loop through entries in check policy list
24619 PP
:= Opt
.Check_Policy_List
;
24620 while Present
(PP
) loop
24622 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24623 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24627 or else Pnm
= Name_Assertion
24628 or else (Pnm
= Name_Statement_Assertions
24629 and then Nam_In
(Ename
, Name_Assert
,
24630 Name_Assert_And_Cut
,
24632 Name_Loop_Invariant
,
24633 Name_Loop_Variant
))
24635 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24638 when Name_Off | Name_Ignore
=>
24639 Set_Is_Ignored
(N
, True);
24640 Set_Is_Checked
(N
, False);
24642 when Name_On | Name_Check
=>
24643 Set_Is_Checked
(N
, True);
24644 Set_Is_Ignored
(N
, False);
24646 when Name_Disable
=>
24647 Set_Is_Ignored
(N
, True);
24648 Set_Is_Checked
(N
, False);
24649 Set_Is_Disabled
(N
, True);
24651 -- That should be exhaustive, the null here is a defence
24652 -- against a malformed tree from previous errors.
24661 PP
:= Next_Pragma
(PP
);
24665 -- If there are no specific entries that matched, then we let the
24666 -- setting of assertions govern. Note that this provides the needed
24667 -- compatibility with the RM for the cases of assertion, invariant,
24668 -- precondition, predicate, and postcondition.
24670 if Assertions_Enabled
then
24671 Set_Is_Checked
(N
, True);
24672 Set_Is_Ignored
(N
, False);
24674 Set_Is_Checked
(N
, False);
24675 Set_Is_Ignored
(N
, True);
24677 end Check_Applicable_Policy
;
24679 -------------------------------
24680 -- Check_External_Properties --
24681 -------------------------------
24683 procedure Check_External_Properties
24691 -- All properties enabled
24693 if AR
and AW
and ER
and EW
then
24696 -- Async_Readers + Effective_Writes
24697 -- Async_Readers + Async_Writers + Effective_Writes
24699 elsif AR
and EW
and not ER
then
24702 -- Async_Writers + Effective_Reads
24703 -- Async_Readers + Async_Writers + Effective_Reads
24705 elsif AW
and ER
and not EW
then
24708 -- Async_Readers + Async_Writers
24710 elsif AR
and AW
and not ER
and not EW
then
24715 elsif AR
and not AW
and not ER
and not EW
then
24720 elsif AW
and not AR
and not ER
and not EW
then
24725 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24728 end Check_External_Properties
;
24734 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24738 -- Loop through entries in check policy list
24740 PP
:= Opt
.Check_Policy_List
;
24741 while Present
(PP
) loop
24743 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24744 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24748 or else (Pnm
= Name_Assertion
24749 and then Is_Valid_Assertion_Kind
(Nam
))
24750 or else (Pnm
= Name_Statement_Assertions
24751 and then Nam_In
(Nam
, Name_Assert
,
24752 Name_Assert_And_Cut
,
24754 Name_Loop_Invariant
,
24755 Name_Loop_Variant
))
24757 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24758 when Name_On | Name_Check
=>
24760 when Name_Off | Name_Ignore
=>
24761 return Name_Ignore
;
24762 when Name_Disable
=>
24763 return Name_Disable
;
24765 raise Program_Error
;
24769 PP
:= Next_Pragma
(PP
);
24774 -- If there are no specific entries that matched, then we let the
24775 -- setting of assertions govern. Note that this provides the needed
24776 -- compatibility with the RM for the cases of assertion, invariant,
24777 -- precondition, predicate, and postcondition.
24779 if Assertions_Enabled
then
24782 return Name_Ignore
;
24786 ---------------------------
24787 -- Check_Missing_Part_Of --
24788 ---------------------------
24790 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24791 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24792 -- Determine whether a package denoted by Pack_Id declares at least one
24795 -----------------------
24796 -- Has_Visible_State --
24797 -----------------------
24799 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24800 Item_Id
: Entity_Id
;
24803 -- Traverse the entity chain of the package trying to find at least
24804 -- one visible abstract state, variable or a package [instantiation]
24805 -- that declares a visible state.
24807 Item_Id
:= First_Entity
(Pack_Id
);
24808 while Present
(Item_Id
)
24809 and then not In_Private_Part
(Item_Id
)
24811 -- Do not consider internally generated items
24813 if not Comes_From_Source
(Item_Id
) then
24816 -- A visible state has been found
24818 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24821 -- Recursively peek into nested packages and instantiations
24823 elsif Ekind
(Item_Id
) = E_Package
24824 and then Has_Visible_State
(Item_Id
)
24829 Next_Entity
(Item_Id
);
24833 end Has_Visible_State
;
24837 Pack_Id
: Entity_Id
;
24838 Placement
: State_Space_Kind
;
24840 -- Start of processing for Check_Missing_Part_Of
24843 -- Do not consider abstract states, variables or package instantiations
24844 -- coming from an instance as those always inherit the Part_Of indicator
24845 -- of the instance itself.
24847 if In_Instance
then
24850 -- Do not consider internally generated entities as these can never
24851 -- have a Part_Of indicator.
24853 elsif not Comes_From_Source
(Item_Id
) then
24856 -- Perform these checks only when SPARK_Mode is enabled as they will
24857 -- interfere with standard Ada rules and produce false positives.
24859 elsif SPARK_Mode
/= On
then
24863 -- Find where the abstract state, variable or package instantiation
24864 -- lives with respect to the state space.
24866 Find_Placement_In_State_Space
24867 (Item_Id
=> Item_Id
,
24868 Placement
=> Placement
,
24869 Pack_Id
=> Pack_Id
);
24871 -- Items that appear in a non-package construct (subprogram, block, etc)
24872 -- do not require a Part_Of indicator because they can never act as a
24875 if Placement
= Not_In_Package
then
24878 -- An item declared in the body state space of a package always act as a
24879 -- constituent and does not need explicit Part_Of indicator.
24881 elsif Placement
= Body_State_Space
then
24884 -- In general an item declared in the visible state space of a package
24885 -- does not require a Part_Of indicator. The only exception is when the
24886 -- related package is a private child unit in which case Part_Of must
24887 -- denote a state in the parent unit or in one of its descendants.
24889 elsif Placement
= Visible_State_Space
then
24890 if Is_Child_Unit
(Pack_Id
)
24891 and then Is_Private_Descendant
(Pack_Id
)
24893 -- A package instantiation does not need a Part_Of indicator when
24894 -- the related generic template has no visible state.
24896 if Ekind
(Item_Id
) = E_Package
24897 and then Is_Generic_Instance
(Item_Id
)
24898 and then not Has_Visible_State
(Item_Id
)
24902 -- All other cases require Part_Of
24906 ("indicator Part_Of is required in this context "
24907 & "(SPARK RM 7.2.6(3))", Item_Id
);
24908 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24910 ("\& is declared in the visible part of private child "
24911 & "unit %", Item_Id
);
24915 -- When the item appears in the private state space of a packge, it must
24916 -- be a part of some state declared by the said package.
24918 else pragma Assert
(Placement
= Private_State_Space
);
24920 -- The related package does not declare a state, the item cannot act
24921 -- as a Part_Of constituent.
24923 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24926 -- A package instantiation does not need a Part_Of indicator when the
24927 -- related generic template has no visible state.
24929 elsif Ekind
(Pack_Id
) = E_Package
24930 and then Is_Generic_Instance
(Pack_Id
)
24931 and then not Has_Visible_State
(Pack_Id
)
24935 -- All other cases require Part_Of
24939 ("indicator Part_Of is required in this context "
24940 & "(SPARK RM 7.2.6(2))", Item_Id
);
24941 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24943 ("\& is declared in the private part of package %", Item_Id
);
24946 end Check_Missing_Part_Of
;
24948 ---------------------------------
24949 -- Check_SPARK_Aspect_For_ASIS --
24950 ---------------------------------
24952 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
24956 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
24957 Expr
:= Expression
(Corresponding_Aspect
(N
));
24958 if Nkind
(Expr
) /= N_Aggregate
then
24959 Preanalyze_And_Resolve
(Expr
);
24963 Comps
: constant List_Id
:= Component_Associations
(Expr
);
24964 Exprs
: constant List_Id
:= Expressions
(Expr
);
24969 E
:= First
(Exprs
);
24970 while Present
(E
) loop
24975 C
:= First
(Comps
);
24976 while Present
(C
) loop
24977 Analyze
(Expression
(C
));
24983 end Check_SPARK_Aspect_For_ASIS
;
24985 -------------------------------------
24986 -- Check_State_And_Constituent_Use --
24987 -------------------------------------
24989 procedure Check_State_And_Constituent_Use
24990 (States
: Elist_Id
;
24991 Constits
: Elist_Id
;
24994 function Find_Encapsulating_State
24995 (Constit_Id
: Entity_Id
) return Entity_Id
;
24996 -- Given the entity of a constituent, try to find a corresponding
24997 -- encapsulating state that appears in the same context. The routine
24998 -- returns Empty is no such state is found.
25000 ------------------------------
25001 -- Find_Encapsulating_State --
25002 ------------------------------
25004 function Find_Encapsulating_State
25005 (Constit_Id
: Entity_Id
) return Entity_Id
25007 State_Id
: Entity_Id
;
25010 -- Since a constituent may be part of a larger constituent set, climb
25011 -- the encapsulated state chain looking for a state that appears in
25012 -- the same context.
25014 State_Id
:= Encapsulating_State
(Constit_Id
);
25015 while Present
(State_Id
) loop
25016 if Contains
(States
, State_Id
) then
25020 State_Id
:= Encapsulating_State
(State_Id
);
25024 end Find_Encapsulating_State
;
25028 Constit_Elmt
: Elmt_Id
;
25029 Constit_Id
: Entity_Id
;
25030 State_Id
: Entity_Id
;
25032 -- Start of processing for Check_State_And_Constituent_Use
25035 -- Nothing to do if there are no states or constituents
25037 if No
(States
) or else No
(Constits
) then
25041 -- Inspect the list of constituents and try to determine whether its
25042 -- encapsulating state is in list States.
25044 Constit_Elmt
:= First_Elmt
(Constits
);
25045 while Present
(Constit_Elmt
) loop
25046 Constit_Id
:= Node
(Constit_Elmt
);
25048 -- Determine whether the constituent is part of an encapsulating
25049 -- state that appears in the same context and if this is the case,
25050 -- emit an error (SPARK RM 7.2.6(7)).
25052 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
25054 if Present
(State_Id
) then
25055 Error_Msg_Name_1
:= Chars
(Constit_Id
);
25057 ("cannot mention state & and its constituent % in the same "
25058 & "context", Context
, State_Id
);
25062 Next_Elmt
(Constit_Elmt
);
25064 end Check_State_And_Constituent_Use
;
25066 ---------------------------------------
25067 -- Collect_Subprogram_Inputs_Outputs --
25068 ---------------------------------------
25070 procedure Collect_Subprogram_Inputs_Outputs
25071 (Subp_Id
: Entity_Id
;
25072 Synthesize
: Boolean := False;
25073 Subp_Inputs
: in out Elist_Id
;
25074 Subp_Outputs
: in out Elist_Id
;
25075 Global_Seen
: out Boolean)
25077 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
25078 -- Collect all relevant items from a dependency clause
25080 procedure Collect_Global_List
25082 Mode
: Name_Id
:= Name_Input
);
25083 -- Collect all relevant items from a global list
25085 -------------------------------
25086 -- Collect_Dependency_Clause --
25087 -------------------------------
25089 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
25090 procedure Collect_Dependency_Item
25092 Is_Input
: Boolean);
25093 -- Add an item to the proper subprogram input or output collection
25095 -----------------------------
25096 -- Collect_Dependency_Item --
25097 -----------------------------
25099 procedure Collect_Dependency_Item
25101 Is_Input
: Boolean)
25106 -- Nothing to collect when the item is null
25108 if Nkind
(Item
) = N_Null
then
25111 -- Ditto for attribute 'Result
25113 elsif Is_Attribute_Result
(Item
) then
25116 -- Multiple items appear as an aggregate
25118 elsif Nkind
(Item
) = N_Aggregate
then
25119 Extra
:= First
(Expressions
(Item
));
25120 while Present
(Extra
) loop
25121 Collect_Dependency_Item
(Extra
, Is_Input
);
25125 -- Otherwise this is a solitary item
25129 Add_Item
(Item
, Subp_Inputs
);
25131 Add_Item
(Item
, Subp_Outputs
);
25134 end Collect_Dependency_Item
;
25136 -- Start of processing for Collect_Dependency_Clause
25139 if Nkind
(Clause
) = N_Null
then
25142 -- A dependency cause appears as component association
25144 elsif Nkind
(Clause
) = N_Component_Association
then
25145 Collect_Dependency_Item
25146 (Expression
(Clause
), Is_Input
=> True);
25147 Collect_Dependency_Item
25148 (First
(Choices
(Clause
)), Is_Input
=> False);
25150 -- To accomodate partial decoration of disabled SPARK features, this
25151 -- routine may be called with illegal input. If this is the case, do
25152 -- not raise Program_Error.
25157 end Collect_Dependency_Clause
;
25159 -------------------------
25160 -- Collect_Global_List --
25161 -------------------------
25163 procedure Collect_Global_List
25165 Mode
: Name_Id
:= Name_Input
)
25167 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25168 -- Add an item to the proper subprogram input or output collection
25170 -------------------------
25171 -- Collect_Global_Item --
25172 -------------------------
25174 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25176 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
25177 Add_Item
(Item
, Subp_Inputs
);
25180 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
25181 Add_Item
(Item
, Subp_Outputs
);
25183 end Collect_Global_Item
;
25190 -- Start of processing for Collect_Global_List
25193 if Nkind
(List
) = N_Null
then
25196 -- Single global item declaration
25198 elsif Nkind_In
(List
, N_Expanded_Name
,
25200 N_Selected_Component
)
25202 Collect_Global_Item
(List
, Mode
);
25204 -- Simple global list or moded global list declaration
25206 elsif Nkind
(List
) = N_Aggregate
then
25207 if Present
(Expressions
(List
)) then
25208 Item
:= First
(Expressions
(List
));
25209 while Present
(Item
) loop
25210 Collect_Global_Item
(Item
, Mode
);
25215 Assoc
:= First
(Component_Associations
(List
));
25216 while Present
(Assoc
) loop
25217 Collect_Global_List
25218 (List
=> Expression
(Assoc
),
25219 Mode
=> Chars
(First
(Choices
(Assoc
))));
25224 -- To accomodate partial decoration of disabled SPARK features, this
25225 -- routine may be called with illegal input. If this is the case, do
25226 -- not raise Program_Error.
25231 end Collect_Global_List
;
25235 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
25239 Formal
: Entity_Id
;
25242 Spec_Id
: Entity_Id
;
25244 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25247 Global_Seen
:= False;
25249 -- Find the entity of the corresponding spec when processing a body
25251 if Nkind
(Subp_Decl
) = N_Subprogram_Body
25252 and then Present
(Corresponding_Spec
(Subp_Decl
))
25254 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
25256 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25257 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25259 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
25262 Spec_Id
:= Subp_Id
;
25265 -- Process all formal parameters
25267 Formal
:= First_Formal
(Spec_Id
);
25268 while Present
(Formal
) loop
25269 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
25270 Add_Item
(Formal
, Subp_Inputs
);
25273 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
25274 Add_Item
(Formal
, Subp_Outputs
);
25276 -- Out parameters can act as inputs when the related type is
25277 -- tagged, unconstrained array, unconstrained record or record
25278 -- with unconstrained components.
25280 if Ekind
(Formal
) = E_Out_Parameter
25281 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25283 Add_Item
(Formal
, Subp_Inputs
);
25287 Next_Formal
(Formal
);
25290 -- When processing a subprogram body, look for pragmas Refined_Depends
25291 -- and Refined_Global as they specify the inputs and outputs.
25293 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25294 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
25295 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25297 -- Subprogram declaration case, look for pragmas Depends and Global
25300 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25301 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25304 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
25305 -- because it provides finer granularity of inputs and outputs.
25307 if Present
(Global
) then
25308 Global_Seen
:= True;
25309 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
25311 -- The pragma may not have been analyzed because of the arbitrary
25312 -- declaration order of aspects. Make sure that it is analyzed for
25313 -- the purposes of item extraction.
25315 if not Analyzed
(List
) then
25316 if Pragma_Name
(Global
) = Name_Refined_Global
then
25317 Analyze_Refined_Global_In_Decl_Part
(Global
);
25319 Analyze_Global_In_Decl_Part
(Global
);
25323 Collect_Global_List
(List
);
25325 -- When the related subprogram lacks pragma [Refined_]Global, fall back
25326 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
25327 -- the inputs and outputs from [Refined_]Depends.
25329 elsif Synthesize
and then Present
(Depends
) then
25331 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
25333 -- Multiple dependency clauses appear as an aggregate
25335 if Nkind
(Clauses
) = N_Aggregate
then
25336 Clause
:= First
(Component_Associations
(Clauses
));
25337 while Present
(Clause
) loop
25338 Collect_Dependency_Clause
(Clause
);
25342 -- Otherwise this is a single dependency clause
25345 Collect_Dependency_Clause
(Clauses
);
25348 end Collect_Subprogram_Inputs_Outputs
;
25350 ---------------------------------
25351 -- Delay_Config_Pragma_Analyze --
25352 ---------------------------------
25354 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25356 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25357 Name_Priority_Specific_Dispatching
);
25358 end Delay_Config_Pragma_Analyze
;
25360 -------------------------------------
25361 -- Find_Related_Subprogram_Or_Body --
25362 -------------------------------------
25364 function Find_Related_Subprogram_Or_Body
25366 Do_Checks
: Boolean := False) return Node_Id
25368 Context
: constant Node_Id
:= Parent
(Prag
);
25369 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25372 Look_For_Body
: constant Boolean :=
25373 Nam_In
(Nam
, Name_Refined_Depends
,
25374 Name_Refined_Global
,
25375 Name_Refined_Post
);
25376 -- Refinement pragmas must be associated with a subprogram body [stub]
25379 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
25381 -- If the pragma is a byproduct of aspect expansion, return the related
25382 -- context of the original aspect.
25384 if Present
(Corresponding_Aspect
(Prag
)) then
25385 return Parent
(Corresponding_Aspect
(Prag
));
25388 -- Otherwise the pragma is a source construct, most likely part of a
25389 -- declarative list. Skip preceding declarations while looking for a
25390 -- proper subprogram declaration.
25392 pragma Assert
(Is_List_Member
(Prag
));
25394 Stmt
:= Prev
(Prag
);
25395 while Present
(Stmt
) loop
25397 -- Skip prior pragmas, but check for duplicates
25399 if Nkind
(Stmt
) = N_Pragma
then
25400 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
25401 Error_Msg_Name_1
:= Nam
;
25402 Error_Msg_Sloc
:= Sloc
(Stmt
);
25403 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25406 -- Emit an error when a refinement pragma appears on an expression
25407 -- function without a completion.
25410 and then Look_For_Body
25411 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25412 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25413 and then not Has_Completion
(Defining_Entity
(Stmt
))
25415 Error_Msg_Name_1
:= Nam
;
25417 ("pragma % cannot apply to a stand alone expression function",
25422 -- The refinement pragma applies to a subprogram body stub
25424 elsif Look_For_Body
25425 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25429 -- Skip internally generated code
25431 elsif not Comes_From_Source
(Stmt
) then
25434 -- Return the current construct which is either a subprogram body,
25435 -- a subprogram declaration or is illegal.
25444 -- If we fall through, then the pragma was either the first declaration
25445 -- or it was preceded by other pragmas and no source constructs.
25447 -- The pragma is associated with a library-level subprogram
25449 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25450 return Unit
(Parent
(Context
));
25452 -- The pragma appears inside the declarative part of a subprogram body
25454 elsif Nkind
(Context
) = N_Subprogram_Body
then
25457 -- No candidate subprogram [body] found
25462 end Find_Related_Subprogram_Or_Body
;
25464 -------------------------
25465 -- Get_Base_Subprogram --
25466 -------------------------
25468 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25469 Result
: Entity_Id
;
25472 -- Follow subprogram renaming chain
25476 if Is_Subprogram
(Result
)
25478 Nkind
(Parent
(Declaration_Node
(Result
))) =
25479 N_Subprogram_Renaming_Declaration
25480 and then Present
(Alias
(Result
))
25482 Result
:= Alias
(Result
);
25486 end Get_Base_Subprogram
;
25488 -----------------------
25489 -- Get_SPARK_Mode_Type --
25490 -----------------------
25492 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25494 if N
= Name_On
then
25496 elsif N
= Name_Off
then
25499 -- Any other argument is illegal
25502 raise Program_Error
;
25504 end Get_SPARK_Mode_Type
;
25506 --------------------------------
25507 -- Get_SPARK_Mode_From_Pragma --
25508 --------------------------------
25510 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25515 pragma Assert
(Nkind
(N
) = N_Pragma
);
25516 Args
:= Pragma_Argument_Associations
(N
);
25518 -- Extract the mode from the argument list
25520 if Present
(Args
) then
25521 Mode
:= First
(Pragma_Argument_Associations
(N
));
25522 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25524 -- If SPARK_Mode pragma has no argument, default is ON
25529 end Get_SPARK_Mode_From_Pragma
;
25531 ---------------------------
25532 -- Has_Extra_Parentheses --
25533 ---------------------------
25535 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25539 -- The aggregate should not have an expression list because a clause
25540 -- is always interpreted as a component association. The only way an
25541 -- expression list can sneak in is by adding extra parentheses around
25542 -- the individual clauses:
25544 -- Depends (Output => Input) -- proper form
25545 -- Depends ((Output => Input)) -- extra parentheses
25547 -- Since the extra parentheses are not allowed by the syntax of the
25548 -- pragma, flag them now to avoid emitting misleading errors down the
25551 if Nkind
(Clause
) = N_Aggregate
25552 and then Present
(Expressions
(Clause
))
25554 Expr
:= First
(Expressions
(Clause
));
25555 while Present
(Expr
) loop
25557 -- A dependency clause surrounded by extra parentheses appears
25558 -- as an aggregate of component associations with an optional
25559 -- Paren_Count set.
25561 if Nkind
(Expr
) = N_Aggregate
25562 and then Present
(Component_Associations
(Expr
))
25565 ("dependency clause contains extra parentheses", Expr
);
25567 -- Otherwise the expression is a malformed construct
25570 SPARK_Msg_N
("malformed dependency clause", Expr
);
25580 end Has_Extra_Parentheses
;
25586 procedure Initialize
is
25597 Dummy
:= Dummy
+ 1;
25600 -----------------------------
25601 -- Is_Config_Static_String --
25602 -----------------------------
25604 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25606 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25607 -- This is an internal recursive function that is just like the outer
25608 -- function except that it adds the string to the name buffer rather
25609 -- than placing the string in the name buffer.
25611 ------------------------------
25612 -- Add_Config_Static_String --
25613 ------------------------------
25615 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25622 if Nkind
(N
) = N_Op_Concat
then
25623 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25624 N
:= Right_Opnd
(N
);
25630 if Nkind
(N
) /= N_String_Literal
then
25631 Error_Msg_N
("string literal expected for pragma argument", N
);
25635 for J
in 1 .. String_Length
(Strval
(N
)) loop
25636 C
:= Get_String_Char
(Strval
(N
), J
);
25638 if not In_Character_Range
(C
) then
25640 ("string literal contains invalid wide character",
25641 Sloc
(N
) + 1 + Source_Ptr
(J
));
25645 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25650 end Add_Config_Static_String
;
25652 -- Start of processing for Is_Config_Static_String
25657 return Add_Config_Static_String
(Arg
);
25658 end Is_Config_Static_String
;
25660 -------------------------------
25661 -- Is_Elaboration_SPARK_Mode --
25662 -------------------------------
25664 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
25667 (Nkind
(N
) = N_Pragma
25668 and then Pragma_Name
(N
) = Name_SPARK_Mode
25669 and then Is_List_Member
(N
));
25671 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25672 -- appears in the statement part of the body.
25675 Present
(Parent
(N
))
25676 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
25677 and then List_Containing
(N
) = Statements
(Parent
(N
))
25678 and then Present
(Parent
(Parent
(N
)))
25679 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
25680 end Is_Elaboration_SPARK_Mode
;
25682 -----------------------------------------
25683 -- Is_Non_Significant_Pragma_Reference --
25684 -----------------------------------------
25686 -- This function makes use of the following static table which indicates
25687 -- whether appearance of some name in a given pragma is to be considered
25688 -- as a reference for the purposes of warnings about unreferenced objects.
25690 -- -1 indicates that appearence in any argument is significant
25691 -- 0 indicates that appearance in any argument is not significant
25692 -- +n indicates that appearance as argument n is significant, but all
25693 -- other arguments are not significant
25694 -- 9n arguments from n on are significant, before n inisignificant
25696 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
25697 (Pragma_Abort_Defer
=> -1,
25698 Pragma_Abstract_State
=> -1,
25699 Pragma_Ada_83
=> -1,
25700 Pragma_Ada_95
=> -1,
25701 Pragma_Ada_05
=> -1,
25702 Pragma_Ada_2005
=> -1,
25703 Pragma_Ada_12
=> -1,
25704 Pragma_Ada_2012
=> -1,
25705 Pragma_All_Calls_Remote
=> -1,
25706 Pragma_Allow_Integer_Address
=> -1,
25707 Pragma_Annotate
=> 93,
25708 Pragma_Assert
=> -1,
25709 Pragma_Assert_And_Cut
=> -1,
25710 Pragma_Assertion_Policy
=> 0,
25711 Pragma_Assume
=> -1,
25712 Pragma_Assume_No_Invalid_Values
=> 0,
25713 Pragma_Async_Readers
=> 0,
25714 Pragma_Async_Writers
=> 0,
25715 Pragma_Asynchronous
=> 0,
25716 Pragma_Atomic
=> 0,
25717 Pragma_Atomic_Components
=> 0,
25718 Pragma_Attach_Handler
=> -1,
25719 Pragma_Attribute_Definition
=> 92,
25720 Pragma_Check
=> -1,
25721 Pragma_Check_Float_Overflow
=> 0,
25722 Pragma_Check_Name
=> 0,
25723 Pragma_Check_Policy
=> 0,
25724 Pragma_CIL_Constructor
=> 0,
25725 Pragma_CPP_Class
=> 0,
25726 Pragma_CPP_Constructor
=> 0,
25727 Pragma_CPP_Virtual
=> 0,
25728 Pragma_CPP_Vtable
=> 0,
25730 Pragma_C_Pass_By_Copy
=> 0,
25731 Pragma_Comment
=> -1,
25732 Pragma_Common_Object
=> 0,
25733 Pragma_Compile_Time_Error
=> -1,
25734 Pragma_Compile_Time_Warning
=> -1,
25735 Pragma_Compiler_Unit
=> -1,
25736 Pragma_Compiler_Unit_Warning
=> -1,
25737 Pragma_Complete_Representation
=> 0,
25738 Pragma_Complex_Representation
=> 0,
25739 Pragma_Component_Alignment
=> 0,
25740 Pragma_Contract_Cases
=> -1,
25741 Pragma_Controlled
=> 0,
25742 Pragma_Convention
=> 0,
25743 Pragma_Convention_Identifier
=> 0,
25744 Pragma_Debug
=> -1,
25745 Pragma_Debug_Policy
=> 0,
25746 Pragma_Detect_Blocking
=> 0,
25747 Pragma_Default_Initial_Condition
=> -1,
25748 Pragma_Default_Scalar_Storage_Order
=> 0,
25749 Pragma_Default_Storage_Pool
=> 0,
25750 Pragma_Depends
=> -1,
25751 Pragma_Disable_Atomic_Synchronization
=> 0,
25752 Pragma_Discard_Names
=> 0,
25753 Pragma_Dispatching_Domain
=> -1,
25754 Pragma_Effective_Reads
=> 0,
25755 Pragma_Effective_Writes
=> 0,
25756 Pragma_Elaborate
=> 0,
25757 Pragma_Elaborate_All
=> 0,
25758 Pragma_Elaborate_Body
=> 0,
25759 Pragma_Elaboration_Checks
=> 0,
25760 Pragma_Eliminate
=> 0,
25761 Pragma_Enable_Atomic_Synchronization
=> 0,
25762 Pragma_Export
=> -1,
25763 Pragma_Export_Function
=> -1,
25764 Pragma_Export_Object
=> -1,
25765 Pragma_Export_Procedure
=> -1,
25766 Pragma_Export_Value
=> -1,
25767 Pragma_Export_Valued_Procedure
=> -1,
25768 Pragma_Extend_System
=> -1,
25769 Pragma_Extensions_Allowed
=> 0,
25770 Pragma_Extensions_Visible
=> 0,
25771 Pragma_External
=> -1,
25772 Pragma_Favor_Top_Level
=> 0,
25773 Pragma_External_Name_Casing
=> 0,
25774 Pragma_Fast_Math
=> 0,
25775 Pragma_Finalize_Storage_Only
=> 0,
25777 Pragma_Global
=> -1,
25778 Pragma_Ident
=> -1,
25779 Pragma_Implementation_Defined
=> -1,
25780 Pragma_Implemented
=> -1,
25781 Pragma_Implicit_Packing
=> 0,
25782 Pragma_Import
=> 93,
25783 Pragma_Import_Function
=> 0,
25784 Pragma_Import_Object
=> 0,
25785 Pragma_Import_Procedure
=> 0,
25786 Pragma_Import_Valued_Procedure
=> 0,
25787 Pragma_Independent
=> 0,
25788 Pragma_Independent_Components
=> 0,
25789 Pragma_Initial_Condition
=> -1,
25790 Pragma_Initialize_Scalars
=> 0,
25791 Pragma_Initializes
=> -1,
25792 Pragma_Inline
=> 0,
25793 Pragma_Inline_Always
=> 0,
25794 Pragma_Inline_Generic
=> 0,
25795 Pragma_Inspection_Point
=> -1,
25796 Pragma_Interface
=> 92,
25797 Pragma_Interface_Name
=> 0,
25798 Pragma_Interrupt_Handler
=> -1,
25799 Pragma_Interrupt_Priority
=> -1,
25800 Pragma_Interrupt_State
=> -1,
25801 Pragma_Invariant
=> -1,
25802 Pragma_Java_Constructor
=> -1,
25803 Pragma_Java_Interface
=> -1,
25804 Pragma_Keep_Names
=> 0,
25805 Pragma_License
=> 0,
25806 Pragma_Link_With
=> -1,
25807 Pragma_Linker_Alias
=> -1,
25808 Pragma_Linker_Constructor
=> -1,
25809 Pragma_Linker_Destructor
=> -1,
25810 Pragma_Linker_Options
=> -1,
25811 Pragma_Linker_Section
=> 0,
25813 Pragma_Lock_Free
=> 0,
25814 Pragma_Locking_Policy
=> 0,
25815 Pragma_Loop_Invariant
=> -1,
25816 Pragma_Loop_Optimize
=> 0,
25817 Pragma_Loop_Variant
=> -1,
25818 Pragma_Machine_Attribute
=> -1,
25820 Pragma_Main_Storage
=> -1,
25821 Pragma_Memory_Size
=> 0,
25822 Pragma_No_Return
=> 0,
25823 Pragma_No_Body
=> 0,
25824 Pragma_No_Elaboration_Code_All
=> 0,
25825 Pragma_No_Inline
=> 0,
25826 Pragma_No_Run_Time
=> -1,
25827 Pragma_No_Strict_Aliasing
=> -1,
25828 Pragma_No_Tagged_Streams
=> 0,
25829 Pragma_Normalize_Scalars
=> 0,
25830 Pragma_Obsolescent
=> 0,
25831 Pragma_Optimize
=> 0,
25832 Pragma_Optimize_Alignment
=> 0,
25833 Pragma_Overflow_Mode
=> 0,
25834 Pragma_Overriding_Renamings
=> 0,
25835 Pragma_Ordered
=> 0,
25838 Pragma_Part_Of
=> 0,
25839 Pragma_Partition_Elaboration_Policy
=> 0,
25840 Pragma_Passive
=> 0,
25841 Pragma_Persistent_BSS
=> 0,
25842 Pragma_Polling
=> 0,
25843 Pragma_Prefix_Exception_Messages
=> 0,
25845 Pragma_Postcondition
=> -1,
25846 Pragma_Post_Class
=> -1,
25848 Pragma_Precondition
=> -1,
25849 Pragma_Predicate
=> -1,
25850 Pragma_Preelaborable_Initialization
=> -1,
25851 Pragma_Preelaborate
=> 0,
25852 Pragma_Pre_Class
=> -1,
25853 Pragma_Priority
=> -1,
25854 Pragma_Priority_Specific_Dispatching
=> 0,
25855 Pragma_Profile
=> 0,
25856 Pragma_Profile_Warnings
=> 0,
25857 Pragma_Propagate_Exceptions
=> 0,
25858 Pragma_Provide_Shift_Operators
=> 0,
25859 Pragma_Psect_Object
=> 0,
25861 Pragma_Pure_Function
=> 0,
25862 Pragma_Queuing_Policy
=> 0,
25863 Pragma_Rational
=> 0,
25864 Pragma_Ravenscar
=> 0,
25865 Pragma_Refined_Depends
=> -1,
25866 Pragma_Refined_Global
=> -1,
25867 Pragma_Refined_Post
=> -1,
25868 Pragma_Refined_State
=> -1,
25869 Pragma_Relative_Deadline
=> 0,
25870 Pragma_Remote_Access_Type
=> -1,
25871 Pragma_Remote_Call_Interface
=> -1,
25872 Pragma_Remote_Types
=> -1,
25873 Pragma_Restricted_Run_Time
=> 0,
25874 Pragma_Restriction_Warnings
=> 0,
25875 Pragma_Restrictions
=> 0,
25876 Pragma_Reviewable
=> -1,
25877 Pragma_Short_Circuit_And_Or
=> 0,
25878 Pragma_Share_Generic
=> 0,
25879 Pragma_Shared
=> 0,
25880 Pragma_Shared_Passive
=> 0,
25881 Pragma_Short_Descriptors
=> 0,
25882 Pragma_Simple_Storage_Pool_Type
=> 0,
25883 Pragma_Source_File_Name
=> 0,
25884 Pragma_Source_File_Name_Project
=> 0,
25885 Pragma_Source_Reference
=> 0,
25886 Pragma_SPARK_Mode
=> 0,
25887 Pragma_Storage_Size
=> -1,
25888 Pragma_Storage_Unit
=> 0,
25889 Pragma_Static_Elaboration_Desired
=> 0,
25890 Pragma_Stream_Convert
=> 0,
25891 Pragma_Style_Checks
=> 0,
25892 Pragma_Subtitle
=> 0,
25893 Pragma_Suppress
=> 0,
25894 Pragma_Suppress_Exception_Locations
=> 0,
25895 Pragma_Suppress_All
=> 0,
25896 Pragma_Suppress_Debug_Info
=> 0,
25897 Pragma_Suppress_Initialization
=> 0,
25898 Pragma_System_Name
=> 0,
25899 Pragma_Task_Dispatching_Policy
=> 0,
25900 Pragma_Task_Info
=> -1,
25901 Pragma_Task_Name
=> -1,
25902 Pragma_Task_Storage
=> -1,
25903 Pragma_Test_Case
=> -1,
25904 Pragma_Thread_Local_Storage
=> -1,
25905 Pragma_Time_Slice
=> -1,
25907 Pragma_Type_Invariant
=> -1,
25908 Pragma_Type_Invariant_Class
=> -1,
25909 Pragma_Unchecked_Union
=> 0,
25910 Pragma_Unimplemented_Unit
=> 0,
25911 Pragma_Universal_Aliasing
=> 0,
25912 Pragma_Universal_Data
=> 0,
25913 Pragma_Unmodified
=> 0,
25914 Pragma_Unreferenced
=> 0,
25915 Pragma_Unreferenced_Objects
=> 0,
25916 Pragma_Unreserve_All_Interrupts
=> 0,
25917 Pragma_Unsuppress
=> 0,
25918 Pragma_Unevaluated_Use_Of_Old
=> 0,
25919 Pragma_Use_VADS_Size
=> 0,
25920 Pragma_Validity_Checks
=> 0,
25921 Pragma_Volatile
=> 0,
25922 Pragma_Volatile_Components
=> 0,
25923 Pragma_Warning_As_Error
=> 0,
25924 Pragma_Warnings
=> 0,
25925 Pragma_Weak_External
=> 0,
25926 Pragma_Wide_Character_Encoding
=> 0,
25927 Unknown_Pragma
=> 0);
25929 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25935 function Arg_No
return Nat
;
25936 -- Returns an integer showing what argument we are in. A value of
25937 -- zero means we are not in any of the arguments.
25943 function Arg_No
return Nat
is
25948 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25962 -- Start of processing for Non_Significant_Pragma_Reference
25967 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25971 Id
:= Get_Pragma_Id
(Parent
(P
));
25972 C
:= Sig_Flags
(Id
);
25987 return AN
< (C
- 90);
25993 end Is_Non_Significant_Pragma_Reference
;
25995 ------------------------------
25996 -- Is_Pragma_String_Literal --
25997 ------------------------------
25999 -- This function returns true if the corresponding pragma argument is a
26000 -- static string expression. These are the only cases in which string
26001 -- literals can appear as pragma arguments. We also allow a string literal
26002 -- as the first argument to pragma Assert (although it will of course
26003 -- always generate a type error).
26005 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
26006 Pragn
: constant Node_Id
:= Parent
(Par
);
26007 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
26008 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
26014 N
:= First
(Assoc
);
26021 if Pname
= Name_Assert
then
26024 elsif Pname
= Name_Export
then
26027 elsif Pname
= Name_Ident
then
26030 elsif Pname
= Name_Import
then
26033 elsif Pname
= Name_Interface_Name
then
26036 elsif Pname
= Name_Linker_Alias
then
26039 elsif Pname
= Name_Linker_Section
then
26042 elsif Pname
= Name_Machine_Attribute
then
26045 elsif Pname
= Name_Source_File_Name
then
26048 elsif Pname
= Name_Source_Reference
then
26051 elsif Pname
= Name_Title
then
26054 elsif Pname
= Name_Subtitle
then
26060 end Is_Pragma_String_Literal
;
26062 ---------------------------
26063 -- Is_Private_SPARK_Mode --
26064 ---------------------------
26066 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
26069 (Nkind
(N
) = N_Pragma
26070 and then Pragma_Name
(N
) = Name_SPARK_Mode
26071 and then Is_List_Member
(N
));
26073 -- For pragma SPARK_Mode to be private, it has to appear in the private
26074 -- declarations of a package.
26077 Present
(Parent
(N
))
26078 and then Nkind
(Parent
(N
)) = N_Package_Specification
26079 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
26080 end Is_Private_SPARK_Mode
;
26082 -------------------------------------
26083 -- Is_Unconstrained_Or_Tagged_Item --
26084 -------------------------------------
26086 function Is_Unconstrained_Or_Tagged_Item
26087 (Item
: Entity_Id
) return Boolean
26089 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
26090 -- Determine whether record type Typ has at least one unconstrained
26093 ---------------------------------
26094 -- Has_Unconstrained_Component --
26095 ---------------------------------
26097 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
26101 Comp
:= First_Component
(Typ
);
26102 while Present
(Comp
) loop
26103 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
26107 Next_Component
(Comp
);
26111 end Has_Unconstrained_Component
;
26115 Typ
: constant Entity_Id
:= Etype
(Item
);
26117 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26120 if Is_Tagged_Type
(Typ
) then
26123 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
26126 elsif Is_Record_Type
(Typ
) then
26127 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
26130 return Has_Unconstrained_Component
(Typ
);
26133 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
26139 end Is_Unconstrained_Or_Tagged_Item
;
26141 -----------------------------
26142 -- Is_Valid_Assertion_Kind --
26143 -----------------------------
26145 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
26152 Name_Static_Predicate |
26153 Name_Dynamic_Predicate |
26158 Name_Type_Invariant |
26159 Name_uType_Invariant |
26163 Name_Assert_And_Cut |
26165 Name_Contract_Cases |
26167 Name_Default_Initial_Condition |
26169 Name_Initial_Condition |
26172 Name_Loop_Invariant |
26173 Name_Loop_Variant |
26174 Name_Postcondition |
26175 Name_Precondition |
26177 Name_Refined_Post |
26178 Name_Statement_Assertions
=> return True;
26180 when others => return False;
26182 end Is_Valid_Assertion_Kind
;
26184 -----------------------------------------
26185 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
26186 -----------------------------------------
26188 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
26189 Aspects
: constant List_Id
:= New_List
;
26190 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
26191 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
26193 Original_Aspects
: List_Id
;
26194 -- To capture global references, a copy of the created aspects must be
26195 -- inserted in the original tree.
26198 Prag_Arg_Ass
: Node_Id
;
26199 Prag_Id
: Pragma_Id
;
26202 -- Check for any PPC pragmas that appear within Decl
26204 Prag
:= Next
(Decl
);
26205 while Nkind
(Prag
) = N_Pragma
loop
26206 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
26209 when Pragma_Postcondition | Pragma_Precondition
=>
26210 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
26212 -- Make an aspect from any PPC pragma
26214 Append_To
(Aspects
,
26215 Make_Aspect_Specification
(Loc
,
26217 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
26219 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
26221 -- Generate the analysis information in the pragma expression
26222 -- and then set the pragma node analyzed to avoid any further
26225 Analyze
(Expression
(Prag_Arg_Ass
));
26226 Set_Analyzed
(Prag
, True);
26228 when others => null;
26234 -- Set all new aspects into the generic declaration node
26236 if Is_Non_Empty_List
(Aspects
) then
26238 -- Create the list of aspects to be inserted in the original tree
26240 Original_Aspects
:= Copy_Separate_List
(Aspects
);
26242 -- Check if Decl already has aspects
26244 -- Attach the new lists of aspects to both the generic copy and the
26247 if Has_Aspects
(Decl
) then
26248 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
26249 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
26252 Set_Parent
(Aspects
, Decl
);
26253 Set_Aspect_Specifications
(Decl
, Aspects
);
26254 Set_Parent
(Original_Aspects
, Or_Decl
);
26255 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
26258 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
26260 -------------------------
26261 -- Preanalyze_CTC_Args --
26262 -------------------------
26264 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
26266 -- Preanalyze the boolean expressions, we treat these as spec
26267 -- expressions (i.e. similar to a default expression).
26269 if Present
(Arg_Req
) then
26270 Preanalyze_Assert_Expression
26271 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
26273 -- In ASIS mode, for a pragma generated from a source aspect, also
26274 -- analyze the original aspect expression.
26276 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26277 Preanalyze_Assert_Expression
26278 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
26282 if Present
(Arg_Ens
) then
26283 Preanalyze_Assert_Expression
26284 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
26286 -- In ASIS mode, for a pragma generated from a source aspect, also
26287 -- analyze the original aspect expression.
26289 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26290 Preanalyze_Assert_Expression
26291 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
26294 end Preanalyze_CTC_Args
;
26296 --------------------------------------
26297 -- Process_Compilation_Unit_Pragmas --
26298 --------------------------------------
26300 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26302 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26303 -- strange because it comes at the end of the unit. Rational has the
26304 -- same name for a pragma, but treats it as a program unit pragma, In
26305 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26306 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26307 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26308 -- the context clause to ensure the correct processing.
26310 if Has_Pragma_Suppress_All
(N
) then
26311 Prepend_To
(Context_Items
(N
),
26312 Make_Pragma
(Sloc
(N
),
26313 Chars
=> Name_Suppress
,
26314 Pragma_Argument_Associations
=> New_List
(
26315 Make_Pragma_Argument_Association
(Sloc
(N
),
26316 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26319 -- Nothing else to do at the current time
26321 end Process_Compilation_Unit_Pragmas
;
26323 ------------------------------------
26324 -- Record_Possible_Body_Reference --
26325 ------------------------------------
26327 procedure Record_Possible_Body_Reference
26328 (State_Id
: Entity_Id
;
26332 Spec_Id
: Entity_Id
;
26335 -- Ensure that we are dealing with a reference to a state
26337 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26339 -- Climb the tree starting from the reference looking for a package body
26340 -- whose spec declares the referenced state. This criteria automatically
26341 -- excludes references in package specs which are legal. Note that it is
26342 -- not wise to emit an error now as the package body may lack pragma
26343 -- Refined_State or the referenced state may not be mentioned in the
26344 -- refinement. This approach avoids the generation of misleading errors.
26347 while Present
(Context
) loop
26348 if Nkind
(Context
) = N_Package_Body
then
26349 Spec_Id
:= Corresponding_Spec
(Context
);
26351 if Present
(Abstract_States
(Spec_Id
))
26352 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26354 if No
(Body_References
(State_Id
)) then
26355 Set_Body_References
(State_Id
, New_Elmt_List
);
26358 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
26363 Context
:= Parent
(Context
);
26365 end Record_Possible_Body_Reference
;
26367 ------------------------------
26368 -- Relocate_Pragmas_To_Body --
26369 ------------------------------
26371 procedure Relocate_Pragmas_To_Body
26372 (Subp_Body
: Node_Id
;
26373 Target_Body
: Node_Id
:= Empty
)
26375 procedure Relocate_Pragma
(Prag
: Node_Id
);
26376 -- Remove a single pragma from its current list and add it to the
26377 -- declarations of the proper body (either Subp_Body or Target_Body).
26379 ---------------------
26380 -- Relocate_Pragma --
26381 ---------------------
26383 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26388 -- When subprogram stubs or expression functions are involves, the
26389 -- destination declaration list belongs to the proper body.
26391 if Present
(Target_Body
) then
26392 Target
:= Target_Body
;
26394 Target
:= Subp_Body
;
26397 Decls
:= Declarations
(Target
);
26401 Set_Declarations
(Target
, Decls
);
26404 -- Unhook the pragma from its current list
26407 Prepend
(Prag
, Decls
);
26408 end Relocate_Pragma
;
26412 Body_Id
: constant Entity_Id
:=
26413 Defining_Unit_Name
(Specification
(Subp_Body
));
26414 Next_Stmt
: Node_Id
;
26417 -- Start of processing for Relocate_Pragmas_To_Body
26420 -- Do not process a body that comes from a separate unit as no construct
26421 -- can possibly follow it.
26423 if not Is_List_Member
(Subp_Body
) then
26426 -- Do not relocate pragmas that follow a stub if the stub does not have
26429 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26430 and then No
(Target_Body
)
26434 -- Do not process internally generated routine _Postconditions
26436 elsif Ekind
(Body_Id
) = E_Procedure
26437 and then Chars
(Body_Id
) = Name_uPostconditions
26442 -- Look at what is following the body. We are interested in certain kind
26443 -- of pragmas (either from source or byproducts of expansion) that can
26444 -- apply to a body [stub].
26446 Stmt
:= Next
(Subp_Body
);
26447 while Present
(Stmt
) loop
26449 -- Preserve the following statement for iteration purposes due to a
26450 -- possible relocation of a pragma.
26452 Next_Stmt
:= Next
(Stmt
);
26454 -- Move a candidate pragma following the body to the declarations of
26457 if Nkind
(Stmt
) = N_Pragma
26458 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26460 Relocate_Pragma
(Stmt
);
26462 -- Skip internally generated code
26464 elsif not Comes_From_Source
(Stmt
) then
26467 -- No candidate pragmas are available for relocation
26475 end Relocate_Pragmas_To_Body
;
26477 -------------------
26478 -- Resolve_State --
26479 -------------------
26481 procedure Resolve_State
(N
: Node_Id
) is
26486 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26487 Func
:= Entity
(N
);
26489 -- Handle overloading of state names by functions. Traverse the
26490 -- homonym chain looking for an abstract state.
26492 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26493 State
:= Homonym
(Func
);
26494 while Present
(State
) loop
26496 -- Resolve the overloading by setting the proper entity of the
26497 -- reference to that of the state.
26499 if Ekind
(State
) = E_Abstract_State
then
26500 Set_Etype
(N
, Standard_Void_Type
);
26501 Set_Entity
(N
, State
);
26502 Set_Associated_Node
(N
, State
);
26506 State
:= Homonym
(State
);
26509 -- A function can never act as a state. If the homonym chain does
26510 -- not contain a corresponding state, then something went wrong in
26511 -- the overloading mechanism.
26513 raise Program_Error
;
26518 ----------------------------
26519 -- Rewrite_Assertion_Kind --
26520 ----------------------------
26522 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26526 if Nkind
(N
) = N_Attribute_Reference
26527 and then Attribute_Name
(N
) = Name_Class
26528 and then Nkind
(Prefix
(N
)) = N_Identifier
26530 case Chars
(Prefix
(N
)) is
26535 when Name_Type_Invariant
=>
26536 Nam
:= Name_uType_Invariant
;
26537 when Name_Invariant
=>
26538 Nam
:= Name_uInvariant
;
26543 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26545 end Rewrite_Assertion_Kind
;
26553 Dummy
:= Dummy
+ 1;
26556 --------------------------------
26557 -- Set_Encoded_Interface_Name --
26558 --------------------------------
26560 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26561 Str
: constant String_Id
:= Strval
(S
);
26562 Len
: constant Int
:= String_Length
(Str
);
26567 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26570 -- Stores encoded value of character code CC. The encoding we use an
26571 -- underscore followed by four lower case hex digits.
26577 procedure Encode
is
26579 Store_String_Char
(Get_Char_Code
('_'));
26581 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26583 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26585 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26587 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26590 -- Start of processing for Set_Encoded_Interface_Name
26593 -- If first character is asterisk, this is a link name, and we leave it
26594 -- completely unmodified. We also ignore null strings (the latter case
26595 -- happens only in error cases) and no encoding should occur for Java or
26596 -- AAMP interface names.
26599 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26600 or else VM_Target
/= No_VM
26601 or else AAMP_On_Target
26603 Set_Interface_Name
(E
, S
);
26608 CC
:= Get_String_Char
(Str
, J
);
26610 exit when not In_Character_Range
(CC
);
26612 C
:= Get_Character
(CC
);
26614 exit when C
/= '_' and then C
/= '$'
26615 and then C
not in '0' .. '9'
26616 and then C
not in 'a' .. 'z'
26617 and then C
not in 'A' .. 'Z';
26620 Set_Interface_Name
(E
, S
);
26628 -- Here we need to encode. The encoding we use as follows:
26629 -- three underscores + four hex digits (lower case)
26633 for J
in 1 .. String_Length
(Str
) loop
26634 CC
:= Get_String_Char
(Str
, J
);
26636 if not In_Character_Range
(CC
) then
26639 C
:= Get_Character
(CC
);
26641 if C
= '_' or else C
= '$'
26642 or else C
in '0' .. '9'
26643 or else C
in 'a' .. 'z'
26644 or else C
in 'A' .. 'Z'
26646 Store_String_Char
(CC
);
26653 Set_Interface_Name
(E
,
26654 Make_String_Literal
(Sloc
(S
),
26655 Strval
=> End_String
));
26657 end Set_Encoded_Interface_Name
;
26659 ------------------------
26660 -- Set_Elab_Unit_Name --
26661 ------------------------
26663 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26668 if Nkind
(N
) = N_Identifier
26669 and then Nkind
(With_Item
) = N_Identifier
26671 Set_Entity
(N
, Entity
(With_Item
));
26673 elsif Nkind
(N
) = N_Selected_Component
then
26674 Change_Selected_Component_To_Expanded_Name
(N
);
26675 Set_Entity
(N
, Entity
(With_Item
));
26676 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26678 Pref
:= Prefix
(N
);
26679 Scop
:= Scope
(Entity
(N
));
26680 while Nkind
(Pref
) = N_Selected_Component
loop
26681 Change_Selected_Component_To_Expanded_Name
(Pref
);
26682 Set_Entity
(Selector_Name
(Pref
), Scop
);
26683 Set_Entity
(Pref
, Scop
);
26684 Pref
:= Prefix
(Pref
);
26685 Scop
:= Scope
(Scop
);
26688 Set_Entity
(Pref
, Scop
);
26691 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
26692 end Set_Elab_Unit_Name
;