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).
3114 procedure Pragma_Misplaced
;
3115 pragma No_Return
(Pragma_Misplaced
);
3116 -- Issue fatal error message for misplaced pragma
3118 procedure Process_Atomic_Independent_Shared_Volatile
;
3119 -- Common processing for pragmas Atomic, Independent, Shared, Volatile.
3120 -- Note that Shared is an obsolete Ada 83 pragma and treated as being
3121 -- identical in effect to pragma Atomic.
3123 procedure Process_Compile_Time_Warning_Or_Error
;
3124 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3126 procedure Process_Convention
3127 (C
: out Convention_Id
;
3128 Ent
: out Entity_Id
);
3129 -- Common processing for Convention, Interface, Import and Export.
3130 -- Checks first two arguments of pragma, and sets the appropriate
3131 -- convention value in the specified entity or entities. On return
3132 -- C is the convention, Ent is the referenced entity.
3134 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3135 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3136 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3138 procedure Process_Extended_Import_Export_Object_Pragma
3139 (Arg_Internal
: Node_Id
;
3140 Arg_External
: Node_Id
;
3141 Arg_Size
: Node_Id
);
3142 -- Common processing for the pragmas Import/Export_Object. The three
3143 -- arguments correspond to the three named parameters of the pragmas. An
3144 -- argument is empty if the corresponding parameter is not present in
3147 procedure Process_Extended_Import_Export_Internal_Arg
3148 (Arg_Internal
: Node_Id
:= Empty
);
3149 -- Common processing for all extended Import and Export pragmas. The
3150 -- argument is the pragma parameter for the Internal argument. If
3151 -- Arg_Internal is empty or inappropriate, an error message is posted.
3152 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3153 -- set to identify the referenced entity.
3155 procedure Process_Extended_Import_Export_Subprogram_Pragma
3156 (Arg_Internal
: Node_Id
;
3157 Arg_External
: Node_Id
;
3158 Arg_Parameter_Types
: Node_Id
;
3159 Arg_Result_Type
: Node_Id
:= Empty
;
3160 Arg_Mechanism
: Node_Id
;
3161 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3162 -- Common processing for all extended Import and Export pragmas applying
3163 -- to subprograms. The caller omits any arguments that do not apply to
3164 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3165 -- only in the Import_Function and Export_Function cases). The argument
3166 -- names correspond to the allowed pragma association identifiers.
3168 procedure Process_Generic_List
;
3169 -- Common processing for Share_Generic and Inline_Generic
3171 procedure Process_Import_Or_Interface
;
3172 -- Common processing for Import or Interface
3174 procedure Process_Import_Predefined_Type
;
3175 -- Processing for completing a type with pragma Import. This is used
3176 -- to declare types that match predefined C types, especially for cases
3177 -- without corresponding Ada predefined type.
3179 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3180 -- Inline status of a subprogram, indicated as follows:
3181 -- Suppressed: inlining is suppressed for the subprogram
3182 -- Disabled: no inlining is requested for the subprogram
3183 -- Enabled: inlining is requested/required for the subprogram
3185 procedure Process_Inline
(Status
: Inline_Status
);
3186 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3187 -- indicates the inline status specified by the pragma.
3189 procedure Process_Interface_Name
3190 (Subprogram_Def
: Entity_Id
;
3192 Link_Arg
: Node_Id
);
3193 -- Given the last two arguments of pragma Import, pragma Export, or
3194 -- pragma Interface_Name, performs validity checks and sets the
3195 -- Interface_Name field of the given subprogram entity to the
3196 -- appropriate external or link name, depending on the arguments given.
3197 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3198 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3199 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3200 -- nor Link_Arg is present, the interface name is set to the default
3201 -- from the subprogram name.
3203 procedure Process_Interrupt_Or_Attach_Handler
;
3204 -- Common processing for Interrupt and Attach_Handler pragmas
3206 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3207 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3208 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3209 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3210 -- is not set in the Restrictions case.
3212 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3213 -- Common processing for Suppress and Unsuppress. The boolean parameter
3214 -- Suppress_Case is True for the Suppress case, and False for the
3217 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3218 -- This procedure sets the Is_Exported flag for the given entity,
3219 -- checking that the entity was not previously imported. Arg is
3220 -- the argument that specified the entity. A check is also made
3221 -- for exporting inappropriate entities.
3223 procedure Set_Extended_Import_Export_External_Name
3224 (Internal_Ent
: Entity_Id
;
3225 Arg_External
: Node_Id
);
3226 -- Common processing for all extended import export pragmas. The first
3227 -- argument, Internal_Ent, is the internal entity, which has already
3228 -- been checked for validity by the caller. Arg_External is from the
3229 -- Import or Export pragma, and may be null if no External parameter
3230 -- was present. If Arg_External is present and is a non-null string
3231 -- (a null string is treated as the default), then the Interface_Name
3232 -- field of Internal_Ent is set appropriately.
3234 procedure Set_Imported
(E
: Entity_Id
);
3235 -- This procedure sets the Is_Imported flag for the given entity,
3236 -- checking that it is not previously exported or imported.
3238 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3239 -- Mech is a parameter passing mechanism (see Import_Function syntax
3240 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3241 -- has the right form, and if not issues an error message. If the
3242 -- argument has the right form then the Mechanism field of Ent is
3243 -- set appropriately.
3245 procedure Set_Rational_Profile
;
3246 -- Activate the set of configuration pragmas and permissions that make
3247 -- up the Rational profile.
3249 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3250 -- Activate the set of configuration pragmas and restrictions that make
3251 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3252 -- is used for error messages on any constructs violating the profile.
3254 ----------------------------------
3255 -- Acquire_Warning_Match_String --
3256 ----------------------------------
3258 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3260 String_To_Name_Buffer
3261 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3263 -- Add asterisk at start if not already there
3265 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3266 Name_Buffer
(2 .. Name_Len
+ 1) :=
3267 Name_Buffer
(1 .. Name_Len
);
3268 Name_Buffer
(1) := '*';
3269 Name_Len
:= Name_Len
+ 1;
3272 -- Add asterisk at end if not already there
3274 if Name_Buffer
(Name_Len
) /= '*' then
3275 Name_Len
:= Name_Len
+ 1;
3276 Name_Buffer
(Name_Len
) := '*';
3278 end Acquire_Warning_Match_String
;
3280 ---------------------
3281 -- Ada_2005_Pragma --
3282 ---------------------
3284 procedure Ada_2005_Pragma
is
3286 if Ada_Version
<= Ada_95
then
3287 Check_Restriction
(No_Implementation_Pragmas
, N
);
3289 end Ada_2005_Pragma
;
3291 ---------------------
3292 -- Ada_2012_Pragma --
3293 ---------------------
3295 procedure Ada_2012_Pragma
is
3297 if Ada_Version
<= Ada_2005
then
3298 Check_Restriction
(No_Implementation_Pragmas
, N
);
3300 end Ada_2012_Pragma
;
3302 ---------------------
3303 -- Analyze_Part_Of --
3304 ---------------------
3306 procedure Analyze_Part_Of
3307 (Item_Id
: Entity_Id
;
3310 Legal
: out Boolean)
3312 Pack_Id
: Entity_Id
;
3313 Placement
: State_Space_Kind
;
3314 Parent_Unit
: Entity_Id
;
3315 State_Id
: Entity_Id
;
3318 -- Assume that the pragma/option is illegal
3322 if Nkind_In
(State
, N_Expanded_Name
,
3324 N_Selected_Component
)
3327 Resolve_State
(State
);
3329 if Is_Entity_Name
(State
)
3330 and then Ekind
(Entity
(State
)) = E_Abstract_State
3332 State_Id
:= Entity
(State
);
3336 ("indicator Part_Of must denote an abstract state", State
);
3340 -- This is a syntax error, always report
3344 ("indicator Part_Of must denote an abstract state", State
);
3348 -- Determine where the state, variable or the package instantiation
3349 -- lives with respect to the enclosing packages or package bodies (if
3350 -- any). This placement dictates the legality of the encapsulating
3353 Find_Placement_In_State_Space
3354 (Item_Id
=> Item_Id
,
3355 Placement
=> Placement
,
3356 Pack_Id
=> Pack_Id
);
3358 -- The item appears in a non-package construct with a declarative
3359 -- part (subprogram, block, etc). As such, the item is not allowed
3360 -- to be a part of an encapsulating state because the item is not
3363 if Placement
= Not_In_Package
then
3365 ("indicator Part_Of cannot appear in this context "
3366 & "(SPARK RM 7.2.6(5))", Indic
);
3367 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3369 ("\& is not part of the hidden state of package %",
3372 -- The item appears in the visible state space of some package. In
3373 -- general this scenario does not warrant Part_Of except when the
3374 -- package is a private child unit and the encapsulating state is
3375 -- declared in a parent unit or a public descendant of that parent
3378 elsif Placement
= Visible_State_Space
then
3379 if Is_Child_Unit
(Pack_Id
)
3380 and then Is_Private_Descendant
(Pack_Id
)
3382 -- A variable or state abstraction which is part of the
3383 -- visible state of a private child unit (or one of its public
3384 -- descendants) must have its Part_Of indicator specified. The
3385 -- Part_Of indicator must denote a state abstraction declared
3386 -- by either the parent unit of the private unit or by a public
3387 -- descendant of that parent unit.
3389 -- Find nearest private ancestor (which can be the current unit
3392 Parent_Unit
:= Pack_Id
;
3393 while Present
(Parent_Unit
) loop
3394 exit when Private_Present
3395 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3396 Parent_Unit
:= Scope
(Parent_Unit
);
3399 Parent_Unit
:= Scope
(Parent_Unit
);
3401 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3403 ("indicator Part_Of must denote an abstract state of& "
3404 & "or public descendant (SPARK RM 7.2.6(3))",
3405 Indic
, Parent_Unit
);
3407 elsif Scope
(State_Id
) = Parent_Unit
3408 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3410 not Is_Private_Descendant
(Scope
(State_Id
)))
3416 ("indicator Part_Of must denote an abstract state of& "
3417 & "or public descendant (SPARK RM 7.2.6(3))",
3418 Indic
, Parent_Unit
);
3421 -- Indicator Part_Of is not needed when the related package is not
3422 -- a private child unit or a public descendant thereof.
3426 ("indicator Part_Of cannot appear in this context "
3427 & "(SPARK RM 7.2.6(5))", Indic
);
3428 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3430 ("\& is declared in the visible part of package %",
3434 -- When the item appears in the private state space of a package, the
3435 -- encapsulating state must be declared in the same package.
3437 elsif Placement
= Private_State_Space
then
3438 if Scope
(State_Id
) /= Pack_Id
then
3440 ("indicator Part_Of must designate an abstract state of "
3441 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3442 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3444 ("\& is declared in the private part of package %",
3448 -- Items declared in the body state space of a package do not need
3449 -- Part_Of indicators as the refinement has already been seen.
3453 ("indicator Part_Of cannot appear in this context "
3454 & "(SPARK RM 7.2.6(5))", Indic
);
3456 if Scope
(State_Id
) = Pack_Id
then
3457 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3459 ("\& is declared in the body of package %", Indic
, Item_Id
);
3464 end Analyze_Part_Of
;
3466 ----------------------------
3467 -- Analyze_Refined_Pragma --
3468 ----------------------------
3470 procedure Analyze_Refined_Pragma
3471 (Spec_Id
: out Entity_Id
;
3472 Body_Id
: out Entity_Id
;
3473 Legal
: out Boolean)
3475 Body_Decl
: Node_Id
;
3476 Spec_Decl
: Node_Id
;
3479 -- Assume that the pragma is illegal
3486 Check_Arg_Count
(1);
3487 Check_No_Identifiers
;
3489 if Nam_In
(Pname
, Name_Refined_Depends
,
3490 Name_Refined_Global
,
3493 Ensure_Aggregate_Form
(Arg1
);
3496 -- Verify the placement of the pragma and check for duplicates. The
3497 -- pragma must apply to a subprogram body [stub].
3499 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3501 -- Extract the entities of the spec and body
3503 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3504 Body_Id
:= Defining_Entity
(Body_Decl
);
3505 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3507 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3508 Body_Id
:= Defining_Entity
(Body_Decl
);
3509 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3516 -- The pragma must apply to the second declaration of a subprogram.
3517 -- In other words, the body [stub] cannot acts as a spec.
3519 if No
(Spec_Id
) then
3520 Error_Pragma
("pragma % cannot apply to a stand alone body");
3523 -- Catch the case where the subprogram body is a subunit and acts as
3524 -- the third declaration of the subprogram.
3526 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3527 Error_Pragma
("pragma % cannot apply to a subunit");
3531 -- The pragma can only apply to the body [stub] of a subprogram
3532 -- declared in the visible part of a package. Retrieve the context of
3533 -- the subprogram declaration.
3535 Spec_Decl
:= Parent
(Parent
(Spec_Id
));
3537 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3539 ("pragma % must apply to the body of a subprogram declared in a "
3540 & "package specification");
3544 -- If we get here, then the pragma is legal
3547 end Analyze_Refined_Pragma
;
3549 --------------------------
3550 -- Check_Ada_83_Warning --
3551 --------------------------
3553 procedure Check_Ada_83_Warning
is
3555 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3556 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3558 end Check_Ada_83_Warning
;
3560 ---------------------
3561 -- Check_Arg_Count --
3562 ---------------------
3564 procedure Check_Arg_Count
(Required
: Nat
) is
3566 if Arg_Count
/= Required
then
3567 Error_Pragma
("wrong number of arguments for pragma%");
3569 end Check_Arg_Count
;
3571 --------------------------------
3572 -- Check_Arg_Is_External_Name --
3573 --------------------------------
3575 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3576 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3579 if Nkind
(Argx
) = N_Identifier
then
3583 Analyze_And_Resolve
(Argx
, Standard_String
);
3585 if Is_OK_Static_Expression
(Argx
) then
3588 elsif Etype
(Argx
) = Any_Type
then
3591 -- An interesting special case, if we have a string literal and
3592 -- we are in Ada 83 mode, then we allow it even though it will
3593 -- not be flagged as static. This allows expected Ada 83 mode
3594 -- use of external names which are string literals, even though
3595 -- technically these are not static in Ada 83.
3597 elsif Ada_Version
= Ada_83
3598 and then Nkind
(Argx
) = N_String_Literal
3602 -- Static expression that raises Constraint_Error. This has
3603 -- already been flagged, so just exit from pragma processing.
3605 elsif Is_OK_Static_Expression
(Argx
) then
3608 -- Here we have a real error (non-static expression)
3611 Error_Msg_Name_1
:= Pname
;
3614 Msg
: constant String :=
3615 "argument for pragma% must be a identifier or "
3616 & "static string expression!";
3618 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3623 end Check_Arg_Is_External_Name
;
3625 -----------------------------
3626 -- Check_Arg_Is_Identifier --
3627 -----------------------------
3629 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3630 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3632 if Nkind
(Argx
) /= N_Identifier
then
3634 ("argument for pragma% must be identifier", Argx
);
3636 end Check_Arg_Is_Identifier
;
3638 ----------------------------------
3639 -- Check_Arg_Is_Integer_Literal --
3640 ----------------------------------
3642 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3643 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3645 if Nkind
(Argx
) /= N_Integer_Literal
then
3647 ("argument for pragma% must be integer literal", Argx
);
3649 end Check_Arg_Is_Integer_Literal
;
3651 -------------------------------------------
3652 -- Check_Arg_Is_Library_Level_Local_Name --
3653 -------------------------------------------
3657 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3658 -- | library_unit_NAME
3660 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3662 Check_Arg_Is_Local_Name
(Arg
);
3664 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3665 and then Comes_From_Source
(N
)
3668 ("argument for pragma% must be library level entity", Arg
);
3670 end Check_Arg_Is_Library_Level_Local_Name
;
3672 -----------------------------
3673 -- Check_Arg_Is_Local_Name --
3674 -----------------------------
3678 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3679 -- | library_unit_NAME
3681 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3682 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3687 if Nkind
(Argx
) not in N_Direct_Name
3688 and then (Nkind
(Argx
) /= N_Attribute_Reference
3689 or else Present
(Expressions
(Argx
))
3690 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3691 and then (not Is_Entity_Name
(Argx
)
3692 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3694 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3697 -- No further check required if not an entity name
3699 if not Is_Entity_Name
(Argx
) then
3705 Ent
: constant Entity_Id
:= Entity
(Argx
);
3706 Scop
: constant Entity_Id
:= Scope
(Ent
);
3709 -- Case of a pragma applied to a compilation unit: pragma must
3710 -- occur immediately after the program unit in the compilation.
3712 if Is_Compilation_Unit
(Ent
) then
3714 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3717 -- Case of pragma placed immediately after spec
3719 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3722 -- Case of pragma placed immediately after body
3724 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3725 and then Present
(Corresponding_Body
(Decl
))
3729 (Parent
(Unit_Declaration_Node
3730 (Corresponding_Body
(Decl
))));
3732 -- All other cases are illegal
3739 -- Special restricted placement rule from 10.2.1(11.8/2)
3741 elsif Is_Generic_Formal
(Ent
)
3742 and then Prag_Id
= Pragma_Preelaborable_Initialization
3744 OK
:= List_Containing
(N
) =
3745 Generic_Formal_Declarations
3746 (Unit_Declaration_Node
(Scop
));
3748 -- If this is an aspect applied to a subprogram body, the
3749 -- pragma is inserted in its declarative part.
3751 elsif From_Aspect_Specification
(N
)
3752 and then Ent
= Current_Scope
3754 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3758 -- If the aspect is a predicate (possibly others ???) and the
3759 -- context is a record type, this is a discriminant expression
3760 -- within a type declaration, that freezes the predicated
3763 elsif From_Aspect_Specification
(N
)
3764 and then Prag_Id
= Pragma_Predicate
3765 and then Ekind
(Current_Scope
) = E_Record_Type
3766 and then Scop
= Scope
(Current_Scope
)
3770 -- Default case, just check that the pragma occurs in the scope
3771 -- of the entity denoted by the name.
3774 OK
:= Current_Scope
= Scop
;
3779 ("pragma% argument must be in same declarative part", Arg
);
3783 end Check_Arg_Is_Local_Name
;
3785 ---------------------------------
3786 -- Check_Arg_Is_Locking_Policy --
3787 ---------------------------------
3789 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3790 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3793 Check_Arg_Is_Identifier
(Argx
);
3795 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3796 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3798 end Check_Arg_Is_Locking_Policy
;
3800 -----------------------------------------------
3801 -- Check_Arg_Is_Partition_Elaboration_Policy --
3802 -----------------------------------------------
3804 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3805 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3808 Check_Arg_Is_Identifier
(Argx
);
3810 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3812 ("& is not a valid partition elaboration policy name", Argx
);
3814 end Check_Arg_Is_Partition_Elaboration_Policy
;
3816 -------------------------
3817 -- Check_Arg_Is_One_Of --
3818 -------------------------
3820 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3821 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3824 Check_Arg_Is_Identifier
(Argx
);
3826 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3827 Error_Msg_Name_2
:= N1
;
3828 Error_Msg_Name_3
:= N2
;
3829 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3831 end Check_Arg_Is_One_Of
;
3833 procedure Check_Arg_Is_One_Of
3835 N1
, N2
, N3
: Name_Id
)
3837 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3840 Check_Arg_Is_Identifier
(Argx
);
3842 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3843 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3845 end Check_Arg_Is_One_Of
;
3847 procedure Check_Arg_Is_One_Of
3849 N1
, N2
, N3
, N4
: Name_Id
)
3851 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3854 Check_Arg_Is_Identifier
(Argx
);
3856 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3857 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3859 end Check_Arg_Is_One_Of
;
3861 procedure Check_Arg_Is_One_Of
3863 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3865 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3868 Check_Arg_Is_Identifier
(Argx
);
3870 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3871 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3873 end Check_Arg_Is_One_Of
;
3875 ---------------------------------
3876 -- Check_Arg_Is_Queuing_Policy --
3877 ---------------------------------
3879 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
3880 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3883 Check_Arg_Is_Identifier
(Argx
);
3885 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
3886 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
3888 end Check_Arg_Is_Queuing_Policy
;
3890 ---------------------------------------
3891 -- Check_Arg_Is_OK_Static_Expression --
3892 ---------------------------------------
3894 procedure Check_Arg_Is_OK_Static_Expression
3896 Typ
: Entity_Id
:= Empty
)
3899 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
3900 end Check_Arg_Is_OK_Static_Expression
;
3902 ------------------------------------------
3903 -- Check_Arg_Is_Task_Dispatching_Policy --
3904 ------------------------------------------
3906 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
3907 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3910 Check_Arg_Is_Identifier
(Argx
);
3912 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
3914 ("& is not an allowed task dispatching policy name", Argx
);
3916 end Check_Arg_Is_Task_Dispatching_Policy
;
3918 ---------------------
3919 -- Check_Arg_Order --
3920 ---------------------
3922 procedure Check_Arg_Order
(Names
: Name_List
) is
3925 Highest_So_Far
: Natural := 0;
3926 -- Highest index in Names seen do far
3930 for J
in 1 .. Arg_Count
loop
3931 if Chars
(Arg
) /= No_Name
then
3932 for K
in Names
'Range loop
3933 if Chars
(Arg
) = Names
(K
) then
3934 if K
< Highest_So_Far
then
3935 Error_Msg_Name_1
:= Pname
;
3937 ("parameters out of order for pragma%", Arg
);
3938 Error_Msg_Name_1
:= Names
(K
);
3939 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
3940 Error_Msg_N
("\% must appear before %", Arg
);
3944 Highest_So_Far
:= K
;
3952 end Check_Arg_Order
;
3954 --------------------------------
3955 -- Check_At_Least_N_Arguments --
3956 --------------------------------
3958 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
3960 if Arg_Count
< N
then
3961 Error_Pragma
("too few arguments for pragma%");
3963 end Check_At_Least_N_Arguments
;
3965 -------------------------------
3966 -- Check_At_Most_N_Arguments --
3967 -------------------------------
3969 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
3972 if Arg_Count
> N
then
3974 for J
in 1 .. N
loop
3976 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
3979 end Check_At_Most_N_Arguments
;
3981 ---------------------
3982 -- Check_Component --
3983 ---------------------
3985 procedure Check_Component
3988 In_Variant_Part
: Boolean := False)
3990 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
3991 Sindic
: constant Node_Id
:=
3992 Subtype_Indication
(Component_Definition
(Comp
));
3993 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
3996 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
3997 -- object constraint, then the component type shall be an Unchecked_
4000 if Nkind
(Sindic
) = N_Subtype_Indication
4001 and then Has_Per_Object_Constraint
(Comp_Id
)
4002 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4005 ("component subtype subject to per-object constraint "
4006 & "must be an Unchecked_Union", Comp
);
4008 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4009 -- the body of a generic unit, or within the body of any of its
4010 -- descendant library units, no part of the type of a component
4011 -- declared in a variant_part of the unchecked union type shall be of
4012 -- a formal private type or formal private extension declared within
4013 -- the formal part of the generic unit.
4015 elsif Ada_Version
>= Ada_2012
4016 and then In_Generic_Body
(UU_Typ
)
4017 and then In_Variant_Part
4018 and then Is_Private_Type
(Typ
)
4019 and then Is_Generic_Type
(Typ
)
4022 ("component of unchecked union cannot be of generic type", Comp
);
4024 elsif Needs_Finalization
(Typ
) then
4026 ("component of unchecked union cannot be controlled", Comp
);
4028 elsif Has_Task
(Typ
) then
4030 ("component of unchecked union cannot have tasks", Comp
);
4032 end Check_Component
;
4034 -----------------------------
4035 -- Check_Declaration_Order --
4036 -----------------------------
4038 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4039 procedure Check_Aspect_Specification_Order
;
4040 -- Inspect the aspect specifications of the context to determine the
4043 --------------------------------------
4044 -- Check_Aspect_Specification_Order --
4045 --------------------------------------
4047 procedure Check_Aspect_Specification_Order
is
4048 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4049 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4053 -- Both aspects must be part of the same aspect specification list
4056 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4058 -- Try to reach Second starting from First in a left to right
4059 -- traversal of the aspect specifications.
4061 Asp
:= Next
(Asp_First
);
4062 while Present
(Asp
) loop
4064 -- The order is ok, First is followed by Second
4066 if Asp
= Asp_Second
then
4073 -- If we get here, then the aspects are out of order
4075 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4076 end Check_Aspect_Specification_Order
;
4082 -- Start of processing for Check_Declaration_Order
4085 -- Cannot check the order if one of the pragmas is missing
4087 if No
(First
) or else No
(Second
) then
4091 -- Set up the error names in case the order is incorrect
4093 Error_Msg_Name_1
:= Pragma_Name
(First
);
4094 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4096 if From_Aspect_Specification
(First
) then
4098 -- Both pragmas are actually aspects, check their declaration
4099 -- order in the associated aspect specification list. Otherwise
4100 -- First is an aspect and Second a source pragma.
4102 if From_Aspect_Specification
(Second
) then
4103 Check_Aspect_Specification_Order
;
4106 -- Abstract_States is a source pragma
4109 if From_Aspect_Specification
(Second
) then
4110 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4112 -- Both pragmas are source constructs. Try to reach First from
4113 -- Second by traversing the declarations backwards.
4116 Stmt
:= Prev
(Second
);
4117 while Present
(Stmt
) loop
4119 -- The order is ok, First is followed by Second
4121 if Stmt
= First
then
4128 -- If we get here, then the pragmas are out of order
4130 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4133 end Check_Declaration_Order
;
4135 ----------------------------
4136 -- Check_Duplicate_Pragma --
4137 ----------------------------
4139 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4140 Id
: Entity_Id
:= E
;
4144 -- Nothing to do if this pragma comes from an aspect specification,
4145 -- since we could not be duplicating a pragma, and we dealt with the
4146 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4148 if From_Aspect_Specification
(N
) then
4152 -- Otherwise current pragma may duplicate previous pragma or a
4153 -- previously given aspect specification or attribute definition
4154 -- clause for the same pragma.
4156 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4160 -- If the entity is a type, then we have to make sure that the
4161 -- ostensible duplicate is not for a parent type from which this
4165 if Nkind
(P
) = N_Pragma
then
4167 Args
: constant List_Id
:=
4168 Pragma_Argument_Associations
(P
);
4171 and then Is_Entity_Name
(Expression
(First
(Args
)))
4172 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4173 and then Entity
(Expression
(First
(Args
))) /= E
4179 elsif Nkind
(P
) = N_Aspect_Specification
4180 and then Is_Type
(Entity
(P
))
4181 and then Entity
(P
) /= E
4187 -- Here we have a definite duplicate
4189 Error_Msg_Name_1
:= Pragma_Name
(N
);
4190 Error_Msg_Sloc
:= Sloc
(P
);
4192 -- For a single protected or a single task object, the error is
4193 -- issued on the original entity.
4195 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4196 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4199 if Nkind
(P
) = N_Aspect_Specification
4200 or else From_Aspect_Specification
(P
)
4202 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4204 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4209 end Check_Duplicate_Pragma
;
4211 ----------------------------------
4212 -- Check_Duplicated_Export_Name --
4213 ----------------------------------
4215 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4216 String_Val
: constant String_Id
:= Strval
(Nam
);
4219 -- We are only interested in the export case, and in the case of
4220 -- generics, it is the instance, not the template, that is the
4221 -- problem (the template will generate a warning in any case).
4223 if not Inside_A_Generic
4224 and then (Prag_Id
= Pragma_Export
4226 Prag_Id
= Pragma_Export_Procedure
4228 Prag_Id
= Pragma_Export_Valued_Procedure
4230 Prag_Id
= Pragma_Export_Function
)
4232 for J
in Externals
.First
.. Externals
.Last
loop
4233 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4234 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4235 Error_Msg_N
("external name duplicates name given#", Nam
);
4240 Externals
.Append
(Nam
);
4242 end Check_Duplicated_Export_Name
;
4244 ----------------------------------------
4245 -- Check_Expr_Is_OK_Static_Expression --
4246 ----------------------------------------
4248 procedure Check_Expr_Is_OK_Static_Expression
4250 Typ
: Entity_Id
:= Empty
)
4253 if Present
(Typ
) then
4254 Analyze_And_Resolve
(Expr
, Typ
);
4256 Analyze_And_Resolve
(Expr
);
4259 if Is_OK_Static_Expression
(Expr
) then
4262 elsif Etype
(Expr
) = Any_Type
then
4265 -- An interesting special case, if we have a string literal and we
4266 -- are in Ada 83 mode, then we allow it even though it will not be
4267 -- flagged as static. This allows the use of Ada 95 pragmas like
4268 -- Import in Ada 83 mode. They will of course be flagged with
4269 -- warnings as usual, but will not cause errors.
4271 elsif Ada_Version
= Ada_83
4272 and then Nkind
(Expr
) = N_String_Literal
4276 -- Static expression that raises Constraint_Error. This has already
4277 -- been flagged, so just exit from pragma processing.
4279 elsif Is_OK_Static_Expression
(Expr
) then
4282 -- Finally, we have a real error
4285 Error_Msg_Name_1
:= Pname
;
4286 Flag_Non_Static_Expr
4287 (Fix_Error
("argument for pragma% must be a static expression!"),
4291 end Check_Expr_Is_OK_Static_Expression
;
4293 -------------------------
4294 -- Check_First_Subtype --
4295 -------------------------
4297 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4298 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4299 Ent
: constant Entity_Id
:= Entity
(Argx
);
4302 if Is_First_Subtype
(Ent
) then
4305 elsif Is_Type
(Ent
) then
4307 ("pragma% cannot apply to subtype", Argx
);
4309 elsif Is_Object
(Ent
) then
4311 ("pragma% cannot apply to object, requires a type", Argx
);
4315 ("pragma% cannot apply to&, requires a type", Argx
);
4317 end Check_First_Subtype
;
4319 ----------------------
4320 -- Check_Identifier --
4321 ----------------------
4323 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4326 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4328 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4329 Error_Msg_Name_1
:= Pname
;
4330 Error_Msg_Name_2
:= Id
;
4331 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4335 end Check_Identifier
;
4337 --------------------------------
4338 -- Check_Identifier_Is_One_Of --
4339 --------------------------------
4341 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4344 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4346 if Chars
(Arg
) = No_Name
then
4347 Error_Msg_Name_1
:= Pname
;
4348 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4351 elsif Chars
(Arg
) /= N1
4352 and then Chars
(Arg
) /= N2
4354 Error_Msg_Name_1
:= Pname
;
4355 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4359 end Check_Identifier_Is_One_Of
;
4361 ---------------------------
4362 -- Check_In_Main_Program --
4363 ---------------------------
4365 procedure Check_In_Main_Program
is
4366 P
: constant Node_Id
:= Parent
(N
);
4369 -- Must be at in subprogram body
4371 if Nkind
(P
) /= N_Subprogram_Body
then
4372 Error_Pragma
("% pragma allowed only in subprogram");
4374 -- Otherwise warn if obviously not main program
4376 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4377 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4379 Error_Msg_Name_1
:= Pname
;
4381 ("??pragma% is only effective in main program", N
);
4383 end Check_In_Main_Program
;
4385 ---------------------------------------
4386 -- Check_Interrupt_Or_Attach_Handler --
4387 ---------------------------------------
4389 procedure Check_Interrupt_Or_Attach_Handler
is
4390 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4391 Handler_Proc
, Proc_Scope
: Entity_Id
;
4396 if Prag_Id
= Pragma_Interrupt_Handler
then
4397 Check_Restriction
(No_Dynamic_Attachment
, N
);
4400 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4401 Proc_Scope
:= Scope
(Handler_Proc
);
4403 -- On AAMP only, a pragma Interrupt_Handler is supported for
4404 -- nonprotected parameterless procedures.
4406 if not AAMP_On_Target
4407 or else Prag_Id
= Pragma_Attach_Handler
4409 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4411 ("argument of pragma% must be protected procedure", Arg1
);
4414 -- For pragma case (as opposed to access case), check placement.
4415 -- We don't need to do that for aspects, because we have the
4416 -- check that they aspect applies an appropriate procedure.
4418 if not From_Aspect_Specification
(N
)
4419 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4421 Error_Pragma
("pragma% must be in protected definition");
4425 if not Is_Library_Level_Entity
(Proc_Scope
)
4426 or else (AAMP_On_Target
4427 and then not Is_Library_Level_Entity
(Handler_Proc
))
4430 ("argument for pragma% must be library level entity", Arg1
);
4433 -- AI05-0033: A pragma cannot appear within a generic body, because
4434 -- instance can be in a nested scope. The check that protected type
4435 -- is itself a library-level declaration is done elsewhere.
4437 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4438 -- handle code prior to AI-0033. Analysis tools typically are not
4439 -- interested in this pragma in any case, so no need to worry too
4440 -- much about its placement.
4442 if Inside_A_Generic
then
4443 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4444 and then In_Package_Body
(Scope
(Current_Scope
))
4445 and then not Relaxed_RM_Semantics
4447 Error_Pragma
("pragma% cannot be used inside a generic");
4450 end Check_Interrupt_Or_Attach_Handler
;
4452 ---------------------------------
4453 -- Check_Loop_Pragma_Placement --
4454 ---------------------------------
4456 procedure Check_Loop_Pragma_Placement
is
4457 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4458 -- Verify whether the current pragma is properly grouped with other
4459 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4460 -- related loop where the pragma appears.
4462 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4463 -- Determine whether an arbitrary statement Stmt denotes pragma
4464 -- Loop_Invariant or Loop_Variant.
4466 procedure Placement_Error
(Constr
: Node_Id
);
4467 pragma No_Return
(Placement_Error
);
4468 -- Node Constr denotes the last loop restricted construct before we
4469 -- encountered an illegal relation between enclosing constructs. Emit
4470 -- an error depending on what Constr was.
4472 --------------------------------
4473 -- Check_Loop_Pragma_Grouping --
4474 --------------------------------
4476 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4477 Stop_Search
: exception;
4478 -- This exception is used to terminate the recursive descent of
4479 -- routine Check_Grouping.
4481 procedure Check_Grouping
(L
: List_Id
);
4482 -- Find the first group of pragmas in list L and if successful,
4483 -- ensure that the current pragma is part of that group. The
4484 -- routine raises Stop_Search once such a check is performed to
4485 -- halt the recursive descent.
4487 procedure Grouping_Error
(Prag
: Node_Id
);
4488 pragma No_Return
(Grouping_Error
);
4489 -- Emit an error concerning the current pragma indicating that it
4490 -- should be placed after pragma Prag.
4492 --------------------
4493 -- Check_Grouping --
4494 --------------------
4496 procedure Check_Grouping
(L
: List_Id
) is
4502 -- Inspect the list of declarations or statements looking for
4503 -- the first grouping of pragmas:
4506 -- pragma Loop_Invariant ...;
4507 -- pragma Loop_Variant ...;
4509 -- pragma Loop_Variant ...; -- current pragma
4511 -- If the current pragma is not in the grouping, then it must
4512 -- either appear in a different declarative or statement list
4513 -- or the construct at (1) is separating the pragma from the
4517 while Present
(Stmt
) loop
4519 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4520 -- inside a loop or a block housed inside a loop. Inspect
4521 -- the declarations and statements of the block as they may
4522 -- contain the first grouping.
4524 if Nkind
(Stmt
) = N_Block_Statement
then
4525 HSS
:= Handled_Statement_Sequence
(Stmt
);
4527 Check_Grouping
(Declarations
(Stmt
));
4529 if Present
(HSS
) then
4530 Check_Grouping
(Statements
(HSS
));
4533 -- First pragma of the first topmost grouping has been found
4535 elsif Is_Loop_Pragma
(Stmt
) then
4537 -- The group and the current pragma are not in the same
4538 -- declarative or statement list.
4540 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4541 Grouping_Error
(Stmt
);
4543 -- Try to reach the current pragma from the first pragma
4544 -- of the grouping while skipping other members:
4546 -- pragma Loop_Invariant ...; -- first pragma
4547 -- pragma Loop_Variant ...; -- member
4549 -- pragma Loop_Variant ...; -- current pragma
4552 while Present
(Stmt
) loop
4554 -- The current pragma is either the first pragma
4555 -- of the group or is a member of the group. Stop
4556 -- the search as the placement is legal.
4561 -- Skip group members, but keep track of the last
4562 -- pragma in the group.
4564 elsif Is_Loop_Pragma
(Stmt
) then
4567 -- A non-pragma is separating the group from the
4568 -- current pragma, the placement is illegal.
4571 Grouping_Error
(Prag
);
4577 -- If the traversal did not reach the current pragma,
4578 -- then the list must be malformed.
4580 raise Program_Error
;
4588 --------------------
4589 -- Grouping_Error --
4590 --------------------
4592 procedure Grouping_Error
(Prag
: Node_Id
) is
4594 Error_Msg_Sloc
:= Sloc
(Prag
);
4595 Error_Pragma
("pragma% must appear next to pragma#");
4598 -- Start of processing for Check_Loop_Pragma_Grouping
4601 -- Inspect the statements of the loop or nested blocks housed
4602 -- within to determine whether the current pragma is part of the
4603 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4605 Check_Grouping
(Statements
(Loop_Stmt
));
4608 when Stop_Search
=> null;
4609 end Check_Loop_Pragma_Grouping
;
4611 --------------------
4612 -- Is_Loop_Pragma --
4613 --------------------
4615 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4617 -- Inspect the original node as Loop_Invariant and Loop_Variant
4618 -- pragmas are rewritten to null when assertions are disabled.
4620 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4622 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4623 Name_Loop_Invariant
,
4630 ---------------------
4631 -- Placement_Error --
4632 ---------------------
4634 procedure Placement_Error
(Constr
: Node_Id
) is
4635 LA
: constant String := " with Loop_Entry";
4638 if Prag_Id
= Pragma_Assert
then
4639 Error_Msg_String
(1 .. LA
'Length) := LA
;
4640 Error_Msg_Strlen
:= LA
'Length;
4642 Error_Msg_Strlen
:= 0;
4645 if Nkind
(Constr
) = N_Pragma
then
4647 ("pragma %~ must appear immediately within the statements "
4651 ("block containing pragma %~ must appear immediately within "
4652 & "the statements of a loop", Constr
);
4654 end Placement_Error
;
4656 -- Local declarations
4661 -- Start of processing for Check_Loop_Pragma_Placement
4664 -- Check that pragma appears immediately within a loop statement,
4665 -- ignoring intervening block statements.
4669 while Present
(Stmt
) loop
4671 -- The pragma or previous block must appear immediately within the
4672 -- current block's declarative or statement part.
4674 if Nkind
(Stmt
) = N_Block_Statement
then
4675 if (No
(Declarations
(Stmt
))
4676 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4678 List_Containing
(Prev
) /=
4679 Statements
(Handled_Statement_Sequence
(Stmt
))
4681 Placement_Error
(Prev
);
4684 -- Keep inspecting the parents because we are now within a
4685 -- chain of nested blocks.
4689 Stmt
:= Parent
(Stmt
);
4692 -- The pragma or previous block must appear immediately within the
4693 -- statements of the loop.
4695 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4696 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4697 Placement_Error
(Prev
);
4700 -- Stop the traversal because we reached the innermost loop
4701 -- regardless of whether we encountered an error or not.
4705 -- Ignore a handled statement sequence. Note that this node may
4706 -- be related to a subprogram body in which case we will emit an
4707 -- error on the next iteration of the search.
4709 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4710 Stmt
:= Parent
(Stmt
);
4712 -- Any other statement breaks the chain from the pragma to the
4716 Placement_Error
(Prev
);
4721 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4722 -- grouped together with other such pragmas.
4724 if Is_Loop_Pragma
(N
) then
4726 -- The previous check should have located the related loop
4728 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4729 Check_Loop_Pragma_Grouping
(Stmt
);
4731 end Check_Loop_Pragma_Placement
;
4733 -------------------------------------------
4734 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4735 -------------------------------------------
4737 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4746 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4749 elsif Nkind_In
(P
, N_Package_Specification
,
4754 -- Note: the following tests seem a little peculiar, because
4755 -- they test for bodies, but if we were in the statement part
4756 -- of the body, we would already have hit the handled statement
4757 -- sequence, so the only way we get here is by being in the
4758 -- declarative part of the body.
4760 elsif Nkind_In
(P
, N_Subprogram_Body
,
4771 Error_Pragma
("pragma% is not in declarative part or package spec");
4772 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4774 -------------------------
4775 -- Check_No_Identifier --
4776 -------------------------
4778 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4780 if Nkind
(Arg
) = N_Pragma_Argument_Association
4781 and then Chars
(Arg
) /= No_Name
4783 Error_Pragma_Arg_Ident
4784 ("pragma% does not permit identifier& here", Arg
);
4786 end Check_No_Identifier
;
4788 --------------------------
4789 -- Check_No_Identifiers --
4790 --------------------------
4792 procedure Check_No_Identifiers
is
4796 for J
in 1 .. Arg_Count
loop
4797 Check_No_Identifier
(Arg_Node
);
4800 end Check_No_Identifiers
;
4802 ------------------------
4803 -- Check_No_Link_Name --
4804 ------------------------
4806 procedure Check_No_Link_Name
is
4808 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4812 if Present
(Arg4
) then
4814 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4816 end Check_No_Link_Name
;
4818 -------------------------------
4819 -- Check_Optional_Identifier --
4820 -------------------------------
4822 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4825 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4826 and then Chars
(Arg
) /= No_Name
4828 if Chars
(Arg
) /= Id
then
4829 Error_Msg_Name_1
:= Pname
;
4830 Error_Msg_Name_2
:= Id
;
4831 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4835 end Check_Optional_Identifier
;
4837 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4839 Name_Buffer
(1 .. Id
'Length) := Id
;
4840 Name_Len
:= Id
'Length;
4841 Check_Optional_Identifier
(Arg
, Name_Find
);
4842 end Check_Optional_Identifier
;
4844 --------------------
4845 -- Check_Pre_Post --
4846 --------------------
4848 procedure Check_Pre_Post
is
4853 if not Is_List_Member
(N
) then
4857 -- If we are within an inlined body, the legality of the pragma
4858 -- has been checked already.
4860 if In_Inlined_Body
then
4864 -- Search prior declarations
4867 while Present
(Prev
(P
)) loop
4870 -- If the previous node is a generic subprogram, do not go to to
4871 -- the original node, which is the unanalyzed tree: we need to
4872 -- attach the pre/postconditions to the analyzed version at this
4873 -- point. They get propagated to the original tree when analyzing
4874 -- the corresponding body.
4876 if Nkind
(P
) not in N_Generic_Declaration
then
4877 PO
:= Original_Node
(P
);
4882 -- Skip past prior pragma
4884 if Nkind
(PO
) = N_Pragma
then
4887 -- Skip stuff not coming from source
4889 elsif not Comes_From_Source
(PO
) then
4891 -- The condition may apply to a subprogram instantiation
4893 if Nkind
(PO
) = N_Subprogram_Declaration
4894 and then Present
(Generic_Parent
(Specification
(PO
)))
4898 elsif Nkind
(PO
) = N_Subprogram_Declaration
4899 and then In_Instance
4903 -- For all other cases of non source code, do nothing
4909 -- Only remaining possibility is subprogram declaration
4916 -- If we fall through loop, pragma is at start of list, so see if it
4917 -- is at the start of declarations of a subprogram body.
4921 if Nkind
(PO
) = N_Subprogram_Body
4922 and then List_Containing
(N
) = Declarations
(PO
)
4924 -- This is only allowed if there is no separate specification
4926 if Present
(Corresponding_Spec
(PO
)) then
4928 ("pragma% must apply to subprogram specification");
4935 --------------------------------------
4936 -- Check_Precondition_Postcondition --
4937 --------------------------------------
4939 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
4943 procedure Chain_PPC
(PO
: Node_Id
);
4944 -- If PO is an entry or a [generic] subprogram declaration node, then
4945 -- the precondition/postcondition applies to this subprogram and the
4946 -- processing for the pragma is completed. Otherwise the pragma is
4953 procedure Chain_PPC
(PO
: Node_Id
) is
4957 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
4958 if not From_Aspect_Specification
(N
) then
4960 ("pragma% cannot be applied to abstract subprogram");
4962 elsif Class_Present
(N
) then
4967 ("aspect % requires ''Class for abstract subprogram");
4970 -- AI05-0230: The same restriction applies to null procedures. For
4971 -- compatibility with earlier uses of the Ada pragma, apply this
4972 -- rule only to aspect specifications.
4974 -- The above discrepency needs documentation. Robert is dubious
4975 -- about whether it is a good idea ???
4977 elsif Nkind
(PO
) = N_Subprogram_Declaration
4978 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
4979 and then Null_Present
(Specification
(PO
))
4980 and then From_Aspect_Specification
(N
)
4981 and then not Class_Present
(N
)
4984 ("aspect % requires ''Class for null procedure");
4986 -- Pre/postconditions are legal on a subprogram body if it is not
4987 -- a completion of a declaration. They are also legal on a stub
4988 -- with no previous declarations (this is checked when processing
4989 -- the corresponding aspects).
4991 elsif Nkind
(PO
) = N_Subprogram_Body
4992 and then Acts_As_Spec
(PO
)
4996 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
4999 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5000 N_Expression_Function
,
5001 N_Generic_Subprogram_Declaration
,
5002 N_Entry_Declaration
)
5007 -- Here if we have [generic] subprogram or entry declaration
5009 if Nkind
(PO
) = N_Entry_Declaration
then
5010 S
:= Defining_Entity
(PO
);
5012 S
:= Defining_Unit_Name
(Specification
(PO
));
5014 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
5015 S
:= Defining_Identifier
(S
);
5019 -- Note: we do not analyze the pragma at this point. Instead we
5020 -- delay this analysis until the end of the declarative part in
5021 -- which the pragma appears. This implements the required delay
5022 -- in this analysis, allowing forward references. The analysis
5023 -- happens at the end of Analyze_Declarations.
5025 -- Chain spec PPC pragma to list for subprogram
5027 Add_Contract_Item
(N
, S
);
5029 -- Return indicating spec case
5035 -- Start of processing for Check_Precondition_Postcondition
5038 if not Is_List_Member
(N
) then
5042 -- Preanalyze message argument if present. Visibility in this
5043 -- argument is established at the point of pragma occurrence.
5045 if Arg_Count
= 2 then
5046 Check_Optional_Identifier
(Arg2
, Name_Message
);
5047 Preanalyze_Spec_Expression
5048 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5051 -- For a pragma PPC in the extended main source unit, record enabled
5054 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5055 Set_SCO_Pragma_Enabled
(Loc
);
5058 -- If we are within an inlined body, the legality of the pragma
5059 -- has been checked already.
5061 if In_Inlined_Body
then
5066 -- Search prior declarations
5069 while Present
(Prev
(P
)) loop
5072 -- If the previous node is a generic subprogram, do not go to to
5073 -- the original node, which is the unanalyzed tree: we need to
5074 -- attach the pre/postconditions to the analyzed version at this
5075 -- point. They get propagated to the original tree when analyzing
5076 -- the corresponding body.
5078 if Nkind
(P
) not in N_Generic_Declaration
then
5079 PO
:= Original_Node
(P
);
5084 -- Skip past prior pragma
5086 if Nkind
(PO
) = N_Pragma
then
5089 -- Skip stuff not coming from source
5091 elsif not Comes_From_Source
(PO
) then
5093 -- The condition may apply to a subprogram instantiation
5095 if Nkind
(PO
) = N_Subprogram_Declaration
5096 and then Present
(Generic_Parent
(Specification
(PO
)))
5101 elsif Nkind
(PO
) = N_Subprogram_Declaration
5102 and then In_Instance
5107 -- For all other cases of non source code, do nothing
5113 -- Only remaining possibility is subprogram declaration
5121 -- If we fall through loop, pragma is at start of list, so see if it
5122 -- is at the start of declarations of a subprogram body.
5126 if Nkind
(PO
) = N_Subprogram_Body
5127 and then List_Containing
(N
) = Declarations
(PO
)
5129 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
5131 -- Analyze pragma expression for correctness and for ASIS use
5133 Preanalyze_Assert_Expression
5134 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
5136 -- In ASIS mode, for a pragma generated from a source aspect,
5137 -- also analyze the original aspect expression.
5139 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5140 Preanalyze_Assert_Expression
5141 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
5145 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5146 -- The copy is needed because the pragma is expanded into other
5147 -- constructs which are not acceptable in the N_Contract node.
5149 if Acts_As_Spec
(PO
) and then GNATprove_Mode
then
5151 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
5154 -- Preanalyze the pragma
5156 Preanalyze_Assert_Expression
5158 (First
(Pragma_Argument_Associations
(Prag
))),
5161 -- Preanalyze the corresponding aspect (if any)
5163 if Present
(Corresponding_Aspect
(Prag
)) then
5164 Preanalyze_Assert_Expression
5165 (Expression
(Corresponding_Aspect
(Prag
)),
5169 -- Chain the copy on the contract of the body
5172 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
5179 -- See if it is in the pragmas after a library level subprogram
5181 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
5183 -- In GNATprove mode, analyze pragma expression for correctness,
5184 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5185 -- no later point at which the aspect will be analyzed.
5187 if GNATprove_Mode
or ASIS_Mode
then
5188 Analyze_Pre_Post_Condition_In_Decl_Part
5189 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
5192 Chain_PPC
(Unit
(Parent
(PO
)));
5196 -- If we fall through, pragma was misplaced
5199 end Check_Precondition_Postcondition
;
5201 -----------------------------
5202 -- Check_Static_Constraint --
5203 -----------------------------
5205 -- Note: for convenience in writing this procedure, in addition to
5206 -- the officially (i.e. by spec) allowed argument which is always a
5207 -- constraint, it also allows ranges and discriminant associations.
5208 -- Above is not clear ???
5210 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5212 procedure Require_Static
(E
: Node_Id
);
5213 -- Require given expression to be static expression
5215 --------------------
5216 -- Require_Static --
5217 --------------------
5219 procedure Require_Static
(E
: Node_Id
) is
5221 if not Is_OK_Static_Expression
(E
) then
5222 Flag_Non_Static_Expr
5223 ("non-static constraint not allowed in Unchecked_Union!", E
);
5228 -- Start of processing for Check_Static_Constraint
5231 case Nkind
(Constr
) is
5232 when N_Discriminant_Association
=>
5233 Require_Static
(Expression
(Constr
));
5236 Require_Static
(Low_Bound
(Constr
));
5237 Require_Static
(High_Bound
(Constr
));
5239 when N_Attribute_Reference
=>
5240 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5241 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5243 when N_Range_Constraint
=>
5244 Check_Static_Constraint
(Range_Expression
(Constr
));
5246 when N_Index_Or_Discriminant_Constraint
=>
5250 IDC
:= First
(Constraints
(Constr
));
5251 while Present
(IDC
) loop
5252 Check_Static_Constraint
(IDC
);
5260 end Check_Static_Constraint
;
5262 ---------------------
5263 -- Check_Test_Case --
5264 ---------------------
5266 procedure Check_Test_Case
is
5270 procedure Chain_CTC
(PO
: Node_Id
);
5271 -- If PO is a [generic] subprogram declaration node, then the
5272 -- test-case applies to this subprogram and the processing for
5273 -- the pragma is completed. Otherwise the pragma is misplaced.
5279 procedure Chain_CTC
(PO
: Node_Id
) is
5280 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
5285 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
5287 ("pragma% cannot be applied to abstract subprogram");
5289 elsif Nkind
(PO
) = N_Entry_Declaration
then
5290 Error_Pragma
("pragma% cannot be applied to entry");
5292 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
5293 N_Generic_Subprogram_Declaration
)
5298 -- Here if we have [generic] subprogram declaration
5300 S
:= Defining_Unit_Name
(Specification
(PO
));
5302 -- Note: we do not analyze the pragma at this point. Instead we
5303 -- delay this analysis until the end of the declarative part in
5304 -- which the pragma appears. This implements the required delay
5305 -- in this analysis, allowing forward references. The analysis
5306 -- happens at the end of Analyze_Declarations.
5308 -- There should not be another test-case with the same name
5309 -- associated to this subprogram.
5311 CTC
:= Contract_Test_Cases
(Contract
(S
));
5312 while Present
(CTC
) loop
5314 -- Omit pragma Contract_Cases because it does not introduce
5315 -- a unique case name and it does not follow the syntax of
5318 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
5321 elsif String_Equal
(Name
, Get_Name_From_CTC_Pragma
(CTC
)) then
5322 Error_Msg_Sloc
:= Sloc
(CTC
);
5323 Error_Pragma
("name for pragma% is already used#");
5326 CTC
:= Next_Pragma
(CTC
);
5329 -- Chain spec CTC pragma to list for subprogram
5331 Add_Contract_Item
(N
, S
);
5334 -- Start of processing for Check_Test_Case
5337 -- First check pragma arguments
5339 Check_At_Least_N_Arguments
(2);
5340 Check_At_Most_N_Arguments
(4);
5342 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
5344 Check_Optional_Identifier
(Arg1
, Name_Name
);
5345 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
5347 -- In ASIS mode, for a pragma generated from a source aspect, also
5348 -- analyze the original aspect expression.
5350 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
5351 Check_Expr_Is_OK_Static_Expression
5352 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
5355 Check_Optional_Identifier
(Arg2
, Name_Mode
);
5356 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
5358 if Arg_Count
= 4 then
5359 Check_Identifier
(Arg3
, Name_Requires
);
5360 Check_Identifier
(Arg4
, Name_Ensures
);
5362 elsif Arg_Count
= 3 then
5363 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
5366 -- Check pragma placement
5368 if not Is_List_Member
(N
) then
5372 -- Test-case should only appear in package spec unit
5374 if Get_Source_Unit
(N
) = No_Unit
5375 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Current_Sem_Unit
)),
5376 N_Package_Declaration
,
5377 N_Generic_Package_Declaration
)
5382 -- Search prior declarations
5385 while Present
(Prev
(P
)) loop
5388 -- If the previous node is a generic subprogram, do not go to to
5389 -- the original node, which is the unanalyzed tree: we need to
5390 -- attach the test-case to the analyzed version at this point.
5391 -- They get propagated to the original tree when analyzing the
5392 -- corresponding body.
5394 if Nkind
(P
) not in N_Generic_Declaration
then
5395 PO
:= Original_Node
(P
);
5400 -- Skip past prior pragma
5402 if Nkind
(PO
) = N_Pragma
then
5405 -- Skip stuff not coming from source
5407 elsif not Comes_From_Source
(PO
) then
5410 -- Only remaining possibility is subprogram declaration. First
5411 -- check that it is declared directly in a package declaration.
5412 -- This may be either the package declaration for the current unit
5413 -- being defined or a local package declaration.
5415 elsif not Present
(Parent
(Parent
(PO
)))
5416 or else not Present
(Parent
(Parent
(Parent
(PO
))))
5417 or else not Nkind_In
(Parent
(Parent
(PO
)),
5418 N_Package_Declaration
,
5419 N_Generic_Package_Declaration
)
5429 -- If we fall through, pragma was misplaced
5432 end Check_Test_Case
;
5434 --------------------------------------
5435 -- Check_Valid_Configuration_Pragma --
5436 --------------------------------------
5438 -- A configuration pragma must appear in the context clause of a
5439 -- compilation unit, and only other pragmas may precede it. Note that
5440 -- the test also allows use in a configuration pragma file.
5442 procedure Check_Valid_Configuration_Pragma
is
5444 if not Is_Configuration_Pragma
then
5445 Error_Pragma
("incorrect placement for configuration pragma%");
5447 end Check_Valid_Configuration_Pragma
;
5449 -------------------------------------
5450 -- Check_Valid_Library_Unit_Pragma --
5451 -------------------------------------
5453 procedure Check_Valid_Library_Unit_Pragma
is
5455 Parent_Node
: Node_Id
;
5456 Unit_Name
: Entity_Id
;
5457 Unit_Kind
: Node_Kind
;
5458 Unit_Node
: Node_Id
;
5459 Sindex
: Source_File_Index
;
5462 if not Is_List_Member
(N
) then
5466 Plist
:= List_Containing
(N
);
5467 Parent_Node
:= Parent
(Plist
);
5469 if Parent_Node
= Empty
then
5472 -- Case of pragma appearing after a compilation unit. In this case
5473 -- it must have an argument with the corresponding name and must
5474 -- be part of the following pragmas of its parent.
5476 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5477 if Plist
/= Pragmas_After
(Parent_Node
) then
5480 elsif Arg_Count
= 0 then
5482 ("argument required if outside compilation unit");
5485 Check_No_Identifiers
;
5486 Check_Arg_Count
(1);
5487 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5488 Unit_Kind
:= Nkind
(Unit_Node
);
5490 Analyze
(Get_Pragma_Arg
(Arg1
));
5492 if Unit_Kind
= N_Generic_Subprogram_Declaration
5493 or else Unit_Kind
= N_Subprogram_Declaration
5495 Unit_Name
:= Defining_Entity
(Unit_Node
);
5497 elsif Unit_Kind
in N_Generic_Instantiation
then
5498 Unit_Name
:= Defining_Entity
(Unit_Node
);
5501 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5504 if Chars
(Unit_Name
) /=
5505 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5508 ("pragma% argument is not current unit name", Arg1
);
5511 if Ekind
(Unit_Name
) = E_Package
5512 and then Present
(Renamed_Entity
(Unit_Name
))
5514 Error_Pragma
("pragma% not allowed for renamed package");
5518 -- Pragma appears other than after a compilation unit
5521 -- Here we check for the generic instantiation case and also
5522 -- for the case of processing a generic formal package. We
5523 -- detect these cases by noting that the Sloc on the node
5524 -- does not belong to the current compilation unit.
5526 Sindex
:= Source_Index
(Current_Sem_Unit
);
5528 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5529 Rewrite
(N
, Make_Null_Statement
(Loc
));
5532 -- If before first declaration, the pragma applies to the
5533 -- enclosing unit, and the name if present must be this name.
5535 elsif Is_Before_First_Decl
(N
, Plist
) then
5536 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5537 Unit_Kind
:= Nkind
(Unit_Node
);
5539 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5542 elsif Unit_Kind
= N_Subprogram_Body
5543 and then not Acts_As_Spec
(Unit_Node
)
5547 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5550 elsif Nkind
(Parent_Node
) = N_Package_Specification
5551 and then Plist
= Private_Declarations
(Parent_Node
)
5555 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5556 or else Nkind
(Parent_Node
) =
5557 N_Generic_Subprogram_Declaration
)
5558 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5562 elsif Arg_Count
> 0 then
5563 Analyze
(Get_Pragma_Arg
(Arg1
));
5565 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5567 ("name in pragma% must be enclosing unit", Arg1
);
5570 -- It is legal to have no argument in this context
5576 -- Error if not before first declaration. This is because a
5577 -- library unit pragma argument must be the name of a library
5578 -- unit (RM 10.1.5(7)), but the only names permitted in this
5579 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5580 -- generic subprogram declarations or generic instantiations.
5584 ("pragma% misplaced, must be before first declaration");
5588 end Check_Valid_Library_Unit_Pragma
;
5594 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5595 Clist
: constant Node_Id
:= Component_List
(Variant
);
5599 Comp
:= First
(Component_Items
(Clist
));
5600 while Present
(Comp
) loop
5601 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5606 ---------------------------
5607 -- Ensure_Aggregate_Form --
5608 ---------------------------
5610 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5611 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5612 Loc
: constant Source_Ptr
:= Sloc
(Arg
);
5613 Nam
: constant Name_Id
:= Chars
(Arg
);
5614 Comps
: List_Id
:= No_List
;
5615 Exprs
: List_Id
:= No_List
;
5617 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5618 -- Used to restore Comes_From_Source_Default
5621 -- The argument is already in aggregate form, but the presence of a
5622 -- name causes this to be interpreted as a named association which in
5623 -- turn must be converted into an aggregate.
5625 -- pragma Global (In_Out => (A, B, C))
5629 -- pragma Global ((In_Out => (A, B, C)))
5631 -- aggregate aggregate
5633 if Nkind
(Expr
) = N_Aggregate
then
5634 if Nam
= No_Name
then
5638 -- Do not transform a null argument into an aggregate as N_Null has
5639 -- special meaning in formal verification pragmas.
5641 elsif Nkind
(Expr
) = N_Null
then
5645 -- Everything comes from source if the original comes from source
5647 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5649 -- Positional argument is transformed into an aggregate with an
5650 -- Expressions list.
5652 if Nam
= No_Name
then
5653 Exprs
:= New_List
(Relocate_Node
(Expr
));
5655 -- An associative argument is transformed into an aggregate with
5656 -- Component_Associations.
5660 Make_Component_Association
(Loc
,
5661 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5662 Expression
=> Relocate_Node
(Expr
)));
5665 -- Remove the pragma argument name as this information has been
5666 -- captured in the aggregate.
5668 Set_Chars
(Arg
, No_Name
);
5670 Set_Expression
(Arg
,
5671 Make_Aggregate
(Loc
,
5672 Component_Associations
=> Comps
,
5673 Expressions
=> Exprs
));
5675 -- Restore Comes_From_Source default
5677 Set_Comes_From_Source_Default
(CFSD
);
5678 end Ensure_Aggregate_Form
;
5684 procedure Error_Pragma
(Msg
: String) is
5686 Error_Msg_Name_1
:= Pname
;
5687 Error_Msg_N
(Fix_Error
(Msg
), N
);
5691 ----------------------
5692 -- Error_Pragma_Arg --
5693 ----------------------
5695 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5697 Error_Msg_Name_1
:= Pname
;
5698 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5700 end Error_Pragma_Arg
;
5702 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5704 Error_Msg_Name_1
:= Pname
;
5705 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5706 Error_Pragma_Arg
(Msg2
, Arg
);
5707 end Error_Pragma_Arg
;
5709 ----------------------------
5710 -- Error_Pragma_Arg_Ident --
5711 ----------------------------
5713 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5715 Error_Msg_Name_1
:= Pname
;
5716 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5718 end Error_Pragma_Arg_Ident
;
5720 ----------------------
5721 -- Error_Pragma_Ref --
5722 ----------------------
5724 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5726 Error_Msg_Name_1
:= Pname
;
5727 Error_Msg_Sloc
:= Sloc
(Ref
);
5728 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5730 end Error_Pragma_Ref
;
5732 ------------------------
5733 -- Find_Lib_Unit_Name --
5734 ------------------------
5736 function Find_Lib_Unit_Name
return Entity_Id
is
5738 -- Return inner compilation unit entity, for case of nested
5739 -- categorization pragmas. This happens in generic unit.
5741 if Nkind
(Parent
(N
)) = N_Package_Specification
5742 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5744 return Defining_Entity
(Parent
(N
));
5746 return Current_Scope
;
5748 end Find_Lib_Unit_Name
;
5750 ----------------------------
5751 -- Find_Program_Unit_Name --
5752 ----------------------------
5754 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5755 Unit_Name
: Entity_Id
;
5756 Unit_Kind
: Node_Kind
;
5757 P
: constant Node_Id
:= Parent
(N
);
5760 if Nkind
(P
) = N_Compilation_Unit
then
5761 Unit_Kind
:= Nkind
(Unit
(P
));
5763 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5764 N_Package_Declaration
)
5765 or else Unit_Kind
in N_Generic_Declaration
5767 Unit_Name
:= Defining_Entity
(Unit
(P
));
5769 if Chars
(Id
) = Chars
(Unit_Name
) then
5770 Set_Entity
(Id
, Unit_Name
);
5771 Set_Etype
(Id
, Etype
(Unit_Name
));
5773 Set_Etype
(Id
, Any_Type
);
5775 ("cannot find program unit referenced by pragma%");
5779 Set_Etype
(Id
, Any_Type
);
5780 Error_Pragma
("pragma% inapplicable to this unit");
5786 end Find_Program_Unit_Name
;
5788 -----------------------------------------
5789 -- Find_Unique_Parameterless_Procedure --
5790 -----------------------------------------
5792 function Find_Unique_Parameterless_Procedure
5794 Arg
: Node_Id
) return Entity_Id
5796 Proc
: Entity_Id
:= Empty
;
5799 -- The body of this procedure needs some comments ???
5801 if not Is_Entity_Name
(Name
) then
5803 ("argument of pragma% must be entity name", Arg
);
5805 elsif not Is_Overloaded
(Name
) then
5806 Proc
:= Entity
(Name
);
5808 if Ekind
(Proc
) /= E_Procedure
5809 or else Present
(First_Formal
(Proc
))
5812 ("argument of pragma% must be parameterless procedure", Arg
);
5817 Found
: Boolean := False;
5819 Index
: Interp_Index
;
5822 Get_First_Interp
(Name
, Index
, It
);
5823 while Present
(It
.Nam
) loop
5826 if Ekind
(Proc
) = E_Procedure
5827 and then No
(First_Formal
(Proc
))
5831 Set_Entity
(Name
, Proc
);
5832 Set_Is_Overloaded
(Name
, False);
5835 ("ambiguous handler name for pragma% ", Arg
);
5839 Get_Next_Interp
(Index
, It
);
5844 ("argument of pragma% must be parameterless procedure",
5847 Proc
:= Entity
(Name
);
5853 end Find_Unique_Parameterless_Procedure
;
5859 function Fix_Error
(Msg
: String) return String is
5860 Res
: String (Msg
'Range) := Msg
;
5861 Res_Last
: Natural := Msg
'Last;
5865 -- If we have a rewriting of another pragma, go to that pragma
5867 if Is_Rewrite_Substitution
(N
)
5868 and then Nkind
(Original_Node
(N
)) = N_Pragma
5870 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5873 -- Case where pragma comes from an aspect specification
5875 if From_Aspect_Specification
(N
) then
5877 -- Change appearence of "pragma" in message to "aspect"
5880 while J
<= Res_Last
- 5 loop
5881 if Res
(J
.. J
+ 5) = "pragma" then
5882 Res
(J
.. J
+ 5) := "aspect";
5890 -- Change "argument of" at start of message to "entity for"
5893 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5895 Res
(Res
'First .. Res
'First + 9) := "entity for";
5896 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5897 Res
(Res
'First + 11 .. Res_Last
);
5898 Res_Last
:= Res_Last
- 1;
5901 -- Change "argument" at start of message to "entity"
5904 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5906 Res
(Res
'First .. Res
'First + 5) := "entity";
5907 Res
(Res
'First + 6 .. Res_Last
- 2) :=
5908 Res
(Res
'First + 8 .. Res_Last
);
5909 Res_Last
:= Res_Last
- 2;
5912 -- Get name from corresponding aspect
5914 Error_Msg_Name_1
:= Original_Aspect_Name
(N
);
5917 -- Return possibly modified message
5919 return Res
(Res
'First .. Res_Last
);
5922 -------------------------
5923 -- Gather_Associations --
5924 -------------------------
5926 procedure Gather_Associations
5928 Args
: out Args_List
)
5933 -- Initialize all parameters to Empty
5935 for J
in Args
'Range loop
5939 -- That's all we have to do if there are no argument associations
5941 if No
(Pragma_Argument_Associations
(N
)) then
5945 -- Otherwise first deal with any positional parameters present
5947 Arg
:= First
(Pragma_Argument_Associations
(N
));
5948 for Index
in Args
'Range loop
5949 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
5950 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5954 -- Positional parameters all processed, if any left, then we
5955 -- have too many positional parameters.
5957 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
5959 ("too many positional associations for pragma%", Arg
);
5962 -- Process named parameters if any are present
5964 while Present
(Arg
) loop
5965 if Chars
(Arg
) = No_Name
then
5967 ("positional association cannot follow named association",
5971 for Index
in Names
'Range loop
5972 if Names
(Index
) = Chars
(Arg
) then
5973 if Present
(Args
(Index
)) then
5975 ("duplicate argument association for pragma%", Arg
);
5977 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5982 if Index
= Names
'Last then
5983 Error_Msg_Name_1
:= Pname
;
5984 Error_Msg_N
("pragma% does not allow & argument", Arg
);
5986 -- Check for possible misspelling
5988 for Index1
in Names
'Range loop
5989 if Is_Bad_Spelling_Of
5990 (Chars
(Arg
), Names
(Index1
))
5992 Error_Msg_Name_1
:= Names
(Index1
);
5993 Error_Msg_N
-- CODEFIX
5994 ("\possible misspelling of%", Arg
);
6006 end Gather_Associations
;
6012 procedure GNAT_Pragma
is
6014 -- We need to check the No_Implementation_Pragmas restriction for
6015 -- the case of a pragma from source. Note that the case of aspects
6016 -- generating corresponding pragmas marks these pragmas as not being
6017 -- from source, so this test also catches that case.
6019 if Comes_From_Source
(N
) then
6020 Check_Restriction
(No_Implementation_Pragmas
, N
);
6024 --------------------------
6025 -- Is_Before_First_Decl --
6026 --------------------------
6028 function Is_Before_First_Decl
6029 (Pragma_Node
: Node_Id
;
6030 Decls
: List_Id
) return Boolean
6032 Item
: Node_Id
:= First
(Decls
);
6035 -- Only other pragmas can come before this pragma
6038 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6041 elsif Item
= Pragma_Node
then
6047 end Is_Before_First_Decl
;
6049 -----------------------------
6050 -- Is_Configuration_Pragma --
6051 -----------------------------
6053 -- A configuration pragma must appear in the context clause of a
6054 -- compilation unit, and only other pragmas may precede it. Note that
6055 -- the test below also permits use in a configuration pragma file.
6057 function Is_Configuration_Pragma
return Boolean is
6058 Lis
: constant List_Id
:= List_Containing
(N
);
6059 Par
: constant Node_Id
:= Parent
(N
);
6063 -- If no parent, then we are in the configuration pragma file,
6064 -- so the placement is definitely appropriate.
6069 -- Otherwise we must be in the context clause of a compilation unit
6070 -- and the only thing allowed before us in the context list is more
6071 -- configuration pragmas.
6073 elsif Nkind
(Par
) = N_Compilation_Unit
6074 and then Context_Items
(Par
) = Lis
6081 elsif Nkind
(Prg
) /= N_Pragma
then
6091 end Is_Configuration_Pragma
;
6093 --------------------------
6094 -- Is_In_Context_Clause --
6095 --------------------------
6097 function Is_In_Context_Clause
return Boolean is
6099 Parent_Node
: Node_Id
;
6102 if not Is_List_Member
(N
) then
6106 Plist
:= List_Containing
(N
);
6107 Parent_Node
:= Parent
(Plist
);
6109 if Parent_Node
= Empty
6110 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6111 or else Context_Items
(Parent_Node
) /= Plist
6118 end Is_In_Context_Clause
;
6120 ---------------------------------
6121 -- Is_Static_String_Expression --
6122 ---------------------------------
6124 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6125 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6126 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6129 Analyze_And_Resolve
(Argx
);
6131 -- Special case Ada 83, where the expression will never be static,
6132 -- but we will return true if we had a string literal to start with.
6134 if Ada_Version
= Ada_83
then
6137 -- Normal case, true only if we end up with a string literal that
6138 -- is marked as being the result of evaluating a static expression.
6141 return Is_OK_Static_Expression
(Argx
)
6142 and then Nkind
(Argx
) = N_String_Literal
;
6145 end Is_Static_String_Expression
;
6147 ----------------------
6148 -- Pragma_Misplaced --
6149 ----------------------
6151 procedure Pragma_Misplaced
is
6153 Error_Pragma
("incorrect placement of pragma%");
6154 end Pragma_Misplaced
;
6156 ------------------------------------------------
6157 -- Process_Atomic_Independent_Shared_Volatile --
6158 ------------------------------------------------
6160 procedure Process_Atomic_Independent_Shared_Volatile
is
6167 procedure Set_Atomic
(E
: Entity_Id
);
6168 -- Set given type as atomic, and if no explicit alignment was given,
6169 -- set alignment to unknown, since back end knows what the alignment
6170 -- requirements are for atomic arrays. Note: this step is necessary
6171 -- for derived types.
6177 procedure Set_Atomic
(E
: Entity_Id
) is
6181 if not Has_Alignment_Clause
(E
) then
6182 Set_Alignment
(E
, Uint_0
);
6186 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6189 Check_Ada_83_Warning
;
6190 Check_No_Identifiers
;
6191 Check_Arg_Count
(1);
6192 Check_Arg_Is_Local_Name
(Arg1
);
6193 E_Id
:= Get_Pragma_Arg
(Arg1
);
6195 if Etype
(E_Id
) = Any_Type
then
6200 D
:= Declaration_Node
(E
);
6203 -- Check duplicate before we chain ourselves
6205 Check_Duplicate_Pragma
(E
);
6207 -- Now check appropriateness of the entity
6210 if Rep_Item_Too_Early
(E
, N
)
6212 Rep_Item_Too_Late
(E
, N
)
6216 Check_First_Subtype
(Arg1
);
6219 if Prag_Id
= Pragma_Atomic
or else Prag_Id
= Pragma_Shared
then
6221 Set_Atomic
(Underlying_Type
(E
));
6222 Set_Atomic
(Base_Type
(E
));
6225 -- Atomic/Shared imply both Independent and Volatile
6227 if Prag_Id
/= Pragma_Volatile
then
6228 Set_Is_Independent
(E
);
6229 Set_Is_Independent
(Underlying_Type
(E
));
6230 Set_Is_Independent
(Base_Type
(E
));
6232 if Prag_Id
= Pragma_Independent
then
6233 Independence_Checks
.Append
((N
, Base_Type
(E
)));
6237 -- Attribute belongs on the base type. If the view of the type is
6238 -- currently private, it also belongs on the underlying type.
6240 if Prag_Id
/= Pragma_Independent
then
6241 Set_Is_Volatile
(Base_Type
(E
));
6242 Set_Is_Volatile
(Underlying_Type
(E
));
6244 Set_Treat_As_Volatile
(E
);
6245 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6248 elsif K
= N_Object_Declaration
6249 or else (K
= N_Component_Declaration
6250 and then Original_Record_Component
(E
) = E
)
6252 if Rep_Item_Too_Late
(E
, N
) then
6256 if Prag_Id
= Pragma_Atomic
or else Prag_Id
= Pragma_Shared
then
6259 -- If the object declaration has an explicit initialization, a
6260 -- temporary may have to be created to hold the expression, to
6261 -- ensure that access to the object remain atomic.
6263 if Nkind
(Parent
(E
)) = N_Object_Declaration
6264 and then Present
(Expression
(Parent
(E
)))
6266 Set_Has_Delayed_Freeze
(E
);
6269 -- An interesting improvement here. If an object of composite
6270 -- type X is declared atomic, and the type X isn't, that's a
6271 -- pity, since it may not have appropriate alignment etc. We
6272 -- can rescue this in the special case where the object and
6273 -- type are in the same unit by just setting the type as
6274 -- atomic, so that the back end will process it as atomic.
6276 -- Note: we used to do this for elementary types as well,
6277 -- but that turns out to be a bad idea and can have unwanted
6278 -- effects, most notably if the type is elementary, the object
6279 -- a simple component within a record, and both are in a spec:
6280 -- every object of this type in the entire program will be
6281 -- treated as atomic, thus incurring a potentially costly
6282 -- synchronization operation for every access.
6284 -- Of course it would be best if the back end could just adjust
6285 -- the alignment etc for the specific object, but that's not
6286 -- something we are capable of doing at this point.
6288 Utyp
:= Underlying_Type
(Etype
(E
));
6291 and then Is_Composite_Type
(Utyp
)
6292 and then Sloc
(E
) > No_Location
6293 and then Sloc
(Utyp
) > No_Location
6295 Get_Source_File_Index
(Sloc
(E
)) =
6296 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6298 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
6302 -- Atomic/Shared imply both Independent and Volatile
6304 if Prag_Id
/= Pragma_Volatile
then
6305 Set_Is_Independent
(E
);
6307 if Prag_Id
= Pragma_Independent
then
6308 Independence_Checks
.Append
((N
, E
));
6312 if Prag_Id
/= Pragma_Independent
then
6313 Set_Is_Volatile
(E
);
6314 Set_Treat_As_Volatile
(E
);
6318 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6321 -- The following check is only relevant when SPARK_Mode is on as
6322 -- this is not a standard Ada legality rule. Pragma Volatile can
6323 -- only apply to a full type declaration or an object declaration
6324 -- (SPARK RM C.6(1)).
6327 and then Prag_Id
= Pragma_Volatile
6328 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6329 N_Object_Declaration
)
6332 ("argument of pragma % must denote a full type or object "
6333 & "declaration", Arg1
);
6335 end Process_Atomic_Independent_Shared_Volatile
;
6337 -------------------------------------------
6338 -- Process_Compile_Time_Warning_Or_Error --
6339 -------------------------------------------
6341 procedure Process_Compile_Time_Warning_Or_Error
is
6342 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6345 Check_Arg_Count
(2);
6346 Check_No_Identifiers
;
6347 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6348 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6350 if Compile_Time_Known_Value
(Arg1x
) then
6351 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6353 Str
: constant String_Id
:=
6354 Strval
(Get_Pragma_Arg
(Arg2
));
6355 Len
: constant Int
:= String_Length
(Str
);
6360 Cent
: constant Entity_Id
:=
6361 Cunit_Entity
(Current_Sem_Unit
);
6363 Force
: constant Boolean :=
6364 Prag_Id
= Pragma_Compile_Time_Warning
6366 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6367 and then (Ekind
(Cent
) /= E_Package
6368 or else not In_Private_Part
(Cent
));
6369 -- Set True if this is the warning case, and we are in the
6370 -- visible part of a package spec, or in a subprogram spec,
6371 -- in which case we want to force the client to see the
6372 -- warning, even though it is not in the main unit.
6375 -- Loop through segments of message separated by line feeds.
6376 -- We output these segments as separate messages with
6377 -- continuation marks for all but the first.
6382 Error_Msg_Strlen
:= 0;
6384 -- Loop to copy characters from argument to error message
6388 exit when Ptr
> Len
;
6389 CC
:= Get_String_Char
(Str
, Ptr
);
6392 -- Ignore wide chars ??? else store character
6394 if In_Character_Range
(CC
) then
6395 C
:= Get_Character
(CC
);
6396 exit when C
= ASCII
.LF
;
6397 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6398 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6402 -- Here with one line ready to go
6404 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6406 -- If this is a warning in a spec, then we want clients
6407 -- to see the warning, so mark the message with the
6408 -- special sequence !! to force the warning. In the case
6409 -- of a package spec, we do not force this if we are in
6410 -- the private part of the spec.
6413 if Cont
= False then
6414 Error_Msg_N
("<<~!!", Arg1
);
6417 Error_Msg_N
("\<<~!!", Arg1
);
6420 -- Error, rather than warning, or in a body, so we do not
6421 -- need to force visibility for client (error will be
6422 -- output in any case, and this is the situation in which
6423 -- we do not want a client to get a warning, since the
6424 -- warning is in the body or the spec private part).
6427 if Cont
= False then
6428 Error_Msg_N
("<<~", Arg1
);
6431 Error_Msg_N
("\<<~", Arg1
);
6435 exit when Ptr
> Len
;
6440 end Process_Compile_Time_Warning_Or_Error
;
6442 ------------------------
6443 -- Process_Convention --
6444 ------------------------
6446 procedure Process_Convention
6447 (C
: out Convention_Id
;
6448 Ent
: out Entity_Id
)
6452 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6453 -- Called if we have more than one Export/Import/Convention pragma.
6454 -- This is generally illegal, but we have a special case of allowing
6455 -- Import and Interface to coexist if they specify the convention in
6456 -- a consistent manner. We are allowed to do this, since Interface is
6457 -- an implementation defined pragma, and we choose to do it since we
6458 -- know Rational allows this combination. S is the entity id of the
6459 -- subprogram in question. This procedure also sets the special flag
6460 -- Import_Interface_Present in both pragmas in the case where we do
6461 -- have matching Import and Interface pragmas.
6463 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6464 -- Set convention in entity E, and also flag that the entity has a
6465 -- convention pragma. If entity is for a private or incomplete type,
6466 -- also set convention and flag on underlying type. This procedure
6467 -- also deals with the special case of C_Pass_By_Copy convention,
6468 -- and error checks for inappropriate convention specification.
6470 -------------------------------
6471 -- Diagnose_Multiple_Pragmas --
6472 -------------------------------
6474 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6475 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6479 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6480 -- Decl is a pragma node. This function returns True if this
6481 -- pragma has a first argument that is an identifier with a
6482 -- Chars field corresponding to the Convention_Id C.
6484 function Same_Name
(Decl
: Node_Id
) return Boolean;
6485 -- Decl is a pragma node. This function returns True if this
6486 -- pragma has a second argument that is an identifier with a
6487 -- Chars field that matches the Chars of the current subprogram.
6489 ---------------------
6490 -- Same_Convention --
6491 ---------------------
6493 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6494 Arg1
: constant Node_Id
:=
6495 First
(Pragma_Argument_Associations
(Decl
));
6498 if Present
(Arg1
) then
6500 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6502 if Nkind
(Arg
) = N_Identifier
6503 and then Is_Convention_Name
(Chars
(Arg
))
6504 and then Get_Convention_Id
(Chars
(Arg
)) = C
6512 end Same_Convention
;
6518 function Same_Name
(Decl
: Node_Id
) return Boolean is
6519 Arg1
: constant Node_Id
:=
6520 First
(Pragma_Argument_Associations
(Decl
));
6528 Arg2
:= Next
(Arg1
);
6535 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6537 if Nkind
(Arg
) = N_Identifier
6538 and then Chars
(Arg
) = Chars
(S
)
6547 -- Start of processing for Diagnose_Multiple_Pragmas
6552 -- Definitely give message if we have Convention/Export here
6554 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6557 -- If we have an Import or Export, scan back from pragma to
6558 -- find any previous pragma applying to the same procedure.
6559 -- The scan will be terminated by the start of the list, or
6560 -- hitting the subprogram declaration. This won't allow one
6561 -- pragma to appear in the public part and one in the private
6562 -- part, but that seems very unlikely in practice.
6566 while Present
(Decl
) and then Decl
/= Pdec
loop
6568 -- Look for pragma with same name as us
6570 if Nkind
(Decl
) = N_Pragma
6571 and then Same_Name
(Decl
)
6573 -- Give error if same as our pragma or Export/Convention
6575 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6581 -- Case of Import/Interface or the other way round
6583 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6586 -- Here we know that we have Import and Interface. It
6587 -- doesn't matter which way round they are. See if
6588 -- they specify the same convention. If so, all OK,
6589 -- and set special flags to stop other messages
6591 if Same_Convention
(Decl
) then
6592 Set_Import_Interface_Present
(N
);
6593 Set_Import_Interface_Present
(Decl
);
6596 -- If different conventions, special message
6599 Error_Msg_Sloc
:= Sloc
(Decl
);
6601 ("convention differs from that given#", Arg1
);
6611 -- Give message if needed if we fall through those tests
6612 -- except on Relaxed_RM_Semantics where we let go: either this
6613 -- is a case accepted/ignored by other Ada compilers (e.g.
6614 -- a mix of Convention and Import), or another error will be
6615 -- generated later (e.g. using both Import and Export).
6617 if Err
and not Relaxed_RM_Semantics
then
6619 ("at most one Convention/Export/Import pragma is allowed",
6622 end Diagnose_Multiple_Pragmas
;
6624 --------------------------------
6625 -- Set_Convention_From_Pragma --
6626 --------------------------------
6628 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6630 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6631 -- for an overridden dispatching operation. Technically this is
6632 -- an amendment and should only be done in Ada 2005 mode. However,
6633 -- this is clearly a mistake, since the problem that is addressed
6634 -- by this AI is that there is a clear gap in the RM.
6636 if Is_Dispatching_Operation
(E
)
6637 and then Present
(Overridden_Operation
(E
))
6638 and then C
/= Convention
(Overridden_Operation
(E
))
6641 ("cannot change convention for overridden dispatching "
6642 & "operation", Arg1
);
6645 -- Special checks for Convention_Stdcall
6647 if C
= Convention_Stdcall
then
6649 -- A dispatching call is not allowed. A dispatching subprogram
6650 -- cannot be used to interface to the Win32 API, so in fact
6651 -- this check does not impose any effective restriction.
6653 if Is_Dispatching_Operation
(E
) then
6654 Error_Msg_Sloc
:= Sloc
(E
);
6656 -- Note: make this unconditional so that if there is more
6657 -- than one call to which the pragma applies, we get a
6658 -- message for each call. Also don't use Error_Pragma,
6659 -- so that we get multiple messages.
6662 ("dispatching subprogram# cannot use Stdcall convention!",
6665 -- Subprograms are not allowed
6667 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6671 and then Ekind
(E
) /= E_Variable
6673 -- An access to subprogram is also allowed
6677 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6679 -- Allow internal call to set convention of subprogram type
6681 and then not (Ekind
(E
) = E_Subprogram_Type
)
6684 ("second argument of pragma% must be subprogram (type)",
6689 -- Set the convention
6691 Set_Convention
(E
, C
);
6692 Set_Has_Convention_Pragma
(E
);
6694 -- For the case of a record base type, also set the convention of
6695 -- any anonymous access types declared in the record which do not
6696 -- currently have a specified convention.
6698 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6703 Comp
:= First_Component
(E
);
6704 while Present
(Comp
) loop
6705 if Present
(Etype
(Comp
))
6706 and then Ekind_In
(Etype
(Comp
),
6707 E_Anonymous_Access_Type
,
6708 E_Anonymous_Access_Subprogram_Type
)
6709 and then not Has_Convention_Pragma
(Comp
)
6711 Set_Convention
(Comp
, C
);
6714 Next_Component
(Comp
);
6719 -- Deal with incomplete/private type case, where underlying type
6720 -- is available, so set convention of that underlying type.
6722 if Is_Incomplete_Or_Private_Type
(E
)
6723 and then Present
(Underlying_Type
(E
))
6725 Set_Convention
(Underlying_Type
(E
), C
);
6726 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6729 -- A class-wide type should inherit the convention of the specific
6730 -- root type (although this isn't specified clearly by the RM).
6732 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6733 Set_Convention
(Class_Wide_Type
(E
), C
);
6736 -- If the entity is a record type, then check for special case of
6737 -- C_Pass_By_Copy, which is treated the same as C except that the
6738 -- special record flag is set. This convention is only permitted
6739 -- on record types (see AI95-00131).
6741 if Cname
= Name_C_Pass_By_Copy
then
6742 if Is_Record_Type
(E
) then
6743 Set_C_Pass_By_Copy
(Base_Type
(E
));
6744 elsif Is_Incomplete_Or_Private_Type
(E
)
6745 and then Is_Record_Type
(Underlying_Type
(E
))
6747 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6750 ("C_Pass_By_Copy convention allowed only for record type",
6755 -- If the entity is a derived boolean type, check for the special
6756 -- case of convention C, C++, or Fortran, where we consider any
6757 -- nonzero value to represent true.
6759 if Is_Discrete_Type
(E
)
6760 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6766 C
= Convention_Fortran
)
6768 Set_Nonzero_Is_True
(Base_Type
(E
));
6770 end Set_Convention_From_Pragma
;
6774 Comp_Unit
: Unit_Number_Type
;
6779 -- Start of processing for Process_Convention
6782 Check_At_Least_N_Arguments
(2);
6783 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6784 Check_Arg_Is_Identifier
(Arg1
);
6785 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6787 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6788 -- tested again below to set the critical flag).
6790 if Cname
= Name_C_Pass_By_Copy
then
6793 -- Otherwise we must have something in the standard convention list
6795 elsif Is_Convention_Name
(Cname
) then
6796 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6798 -- Otherwise warn on unrecognized convention
6801 if Warn_On_Export_Import
then
6803 ("??unrecognized convention name, C assumed",
6804 Get_Pragma_Arg
(Arg1
));
6810 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6811 Check_Arg_Is_Local_Name
(Arg2
);
6813 Id
:= Get_Pragma_Arg
(Arg2
);
6816 if not Is_Entity_Name
(Id
) then
6817 Error_Pragma_Arg
("entity name required", Arg2
);
6822 -- Set entity to return
6826 -- Ada_Pass_By_Copy special checking
6828 if C
= Convention_Ada_Pass_By_Copy
then
6829 if not Is_First_Subtype
(E
) then
6831 ("convention `Ada_Pass_By_Copy` only allowed for types",
6835 if Is_By_Reference_Type
(E
) then
6837 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6841 -- Ada_Pass_By_Reference special checking
6843 elsif C
= Convention_Ada_Pass_By_Reference
then
6844 if not Is_First_Subtype
(E
) then
6846 ("convention `Ada_Pass_By_Reference` only allowed for types",
6850 if Is_By_Copy_Type
(E
) then
6852 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6857 -- Go to renamed subprogram if present, since convention applies to
6858 -- the actual renamed entity, not to the renaming entity. If the
6859 -- subprogram is inherited, go to parent subprogram.
6861 if Is_Subprogram
(E
)
6862 and then Present
(Alias
(E
))
6864 if Nkind
(Parent
(Declaration_Node
(E
))) =
6865 N_Subprogram_Renaming_Declaration
6867 if Scope
(E
) /= Scope
(Alias
(E
)) then
6869 ("cannot apply pragma% to non-local entity&#", E
);
6874 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6875 N_Private_Extension_Declaration
)
6876 and then Scope
(E
) = Scope
(Alias
(E
))
6880 -- Return the parent subprogram the entity was inherited from
6886 -- Check that we are not applying this to a specless body. Relax this
6887 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6889 if Is_Subprogram
(E
)
6890 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6891 and then not Relaxed_RM_Semantics
6894 ("pragma% requires separate spec and must come before body");
6897 -- Check that we are not applying this to a named constant
6899 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6900 Error_Msg_Name_1
:= Pname
;
6902 ("cannot apply pragma% to named constant!",
6903 Get_Pragma_Arg
(Arg2
));
6905 ("\supply appropriate type for&!", Arg2
);
6908 if Ekind
(E
) = E_Enumeration_Literal
then
6909 Error_Pragma
("enumeration literal not allowed for pragma%");
6912 -- Check for rep item appearing too early or too late
6914 if Etype
(E
) = Any_Type
6915 or else Rep_Item_Too_Early
(E
, N
)
6919 elsif Present
(Underlying_Type
(E
)) then
6920 E
:= Underlying_Type
(E
);
6923 if Rep_Item_Too_Late
(E
, N
) then
6927 if Has_Convention_Pragma
(E
) then
6928 Diagnose_Multiple_Pragmas
(E
);
6930 elsif Convention
(E
) = Convention_Protected
6931 or else Ekind
(Scope
(E
)) = E_Protected_Type
6934 ("a protected operation cannot be given a different convention",
6938 -- For Intrinsic, a subprogram is required
6940 if C
= Convention_Intrinsic
6941 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
6944 ("second argument of pragma% must be a subprogram", Arg2
);
6947 -- Deal with non-subprogram cases
6949 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
6950 Set_Convention_From_Pragma
(E
);
6953 Check_First_Subtype
(Arg2
);
6954 Set_Convention_From_Pragma
(Base_Type
(E
));
6956 -- For access subprograms, we must set the convention on the
6957 -- internally generated directly designated type as well.
6959 if Ekind
(E
) = E_Access_Subprogram_Type
then
6960 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
6964 -- For the subprogram case, set proper convention for all homonyms
6965 -- in same scope and the same declarative part, i.e. the same
6966 -- compilation unit.
6969 Comp_Unit
:= Get_Source_Unit
(E
);
6970 Set_Convention_From_Pragma
(E
);
6972 -- Treat a pragma Import as an implicit body, and pragma import
6973 -- as implicit reference (for navigation in GPS).
6975 if Prag_Id
= Pragma_Import
then
6976 Generate_Reference
(E
, Id
, 'b');
6978 -- For exported entities we restrict the generation of references
6979 -- to entities exported to foreign languages since entities
6980 -- exported to Ada do not provide further information to GPS and
6981 -- add undesired references to the output of the gnatxref tool.
6983 elsif Prag_Id
= Pragma_Export
6984 and then Convention
(E
) /= Convention_Ada
6986 Generate_Reference
(E
, Id
, 'i');
6989 -- If the pragma comes from from an aspect, it only applies to the
6990 -- given entity, not its homonyms.
6992 if From_Aspect_Specification
(N
) then
6996 -- Otherwise Loop through the homonyms of the pragma argument's
6997 -- entity, an apply convention to those in the current scope.
7003 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7005 -- Ignore entry for which convention is already set
7007 if Has_Convention_Pragma
(E1
) then
7011 -- Do not set the pragma on inherited operations or on formal
7014 if Comes_From_Source
(E1
)
7015 and then Comp_Unit
= Get_Source_Unit
(E1
)
7016 and then not Is_Formal_Subprogram
(E1
)
7017 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7018 N_Full_Type_Declaration
7020 if Present
(Alias
(E1
))
7021 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7024 ("cannot apply pragma% to non-local entity& declared#",
7028 Set_Convention_From_Pragma
(E1
);
7030 if Prag_Id
= Pragma_Import
then
7031 Generate_Reference
(E1
, Id
, 'b');
7039 end Process_Convention
;
7041 ----------------------------------------
7042 -- Process_Disable_Enable_Atomic_Sync --
7043 ----------------------------------------
7045 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7047 Check_No_Identifiers
;
7048 Check_At_Most_N_Arguments
(1);
7050 -- Modeled internally as
7051 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7055 Pragma_Identifier
=>
7056 Make_Identifier
(Loc
, Nam
),
7057 Pragma_Argument_Associations
=> New_List
(
7058 Make_Pragma_Argument_Association
(Loc
,
7060 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7062 if Present
(Arg1
) then
7063 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7067 end Process_Disable_Enable_Atomic_Sync
;
7069 -------------------------------------------------
7070 -- Process_Extended_Import_Export_Internal_Arg --
7071 -------------------------------------------------
7073 procedure Process_Extended_Import_Export_Internal_Arg
7074 (Arg_Internal
: Node_Id
:= Empty
)
7077 if No
(Arg_Internal
) then
7078 Error_Pragma
("Internal parameter required for pragma%");
7081 if Nkind
(Arg_Internal
) = N_Identifier
then
7084 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7085 and then (Prag_Id
= Pragma_Import_Function
7087 Prag_Id
= Pragma_Export_Function
)
7093 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7096 Check_Arg_Is_Local_Name
(Arg_Internal
);
7097 end Process_Extended_Import_Export_Internal_Arg
;
7099 --------------------------------------------------
7100 -- Process_Extended_Import_Export_Object_Pragma --
7101 --------------------------------------------------
7103 procedure Process_Extended_Import_Export_Object_Pragma
7104 (Arg_Internal
: Node_Id
;
7105 Arg_External
: Node_Id
;
7111 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7112 Def_Id
:= Entity
(Arg_Internal
);
7114 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7116 ("pragma% must designate an object", Arg_Internal
);
7119 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7121 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7124 ("previous Common/Psect_Object applies, pragma % not permitted",
7128 if Rep_Item_Too_Late
(Def_Id
, N
) then
7132 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7134 if Present
(Arg_Size
) then
7135 Check_Arg_Is_External_Name
(Arg_Size
);
7138 -- Export_Object case
7140 if Prag_Id
= Pragma_Export_Object
then
7141 if not Is_Library_Level_Entity
(Def_Id
) then
7143 ("argument for pragma% must be library level entity",
7147 if Ekind
(Current_Scope
) = E_Generic_Package
then
7148 Error_Pragma
("pragma& cannot appear in a generic unit");
7151 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7153 ("exported object must have compile time known size",
7157 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7158 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7160 Set_Exported
(Def_Id
, Arg_Internal
);
7163 -- Import_Object case
7166 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7168 ("cannot use pragma% for task/protected object",
7172 if Ekind
(Def_Id
) = E_Constant
then
7174 ("cannot import a constant", Arg_Internal
);
7177 if Warn_On_Export_Import
7178 and then Has_Discriminants
(Etype
(Def_Id
))
7181 ("imported value must be initialized??", Arg_Internal
);
7184 if Warn_On_Export_Import
7185 and then Is_Access_Type
(Etype
(Def_Id
))
7188 ("cannot import object of an access type??", Arg_Internal
);
7191 if Warn_On_Export_Import
7192 and then Is_Imported
(Def_Id
)
7194 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7196 -- Check for explicit initialization present. Note that an
7197 -- initialization generated by the code generator, e.g. for an
7198 -- access type, does not count here.
7200 elsif Present
(Expression
(Parent
(Def_Id
)))
7203 (Original_Node
(Expression
(Parent
(Def_Id
))))
7205 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7207 ("imported entities cannot be initialized (RM B.1(24))",
7208 "\no initialization allowed for & declared#", Arg1
);
7210 Set_Imported
(Def_Id
);
7211 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7214 end Process_Extended_Import_Export_Object_Pragma
;
7216 ------------------------------------------------------
7217 -- Process_Extended_Import_Export_Subprogram_Pragma --
7218 ------------------------------------------------------
7220 procedure Process_Extended_Import_Export_Subprogram_Pragma
7221 (Arg_Internal
: Node_Id
;
7222 Arg_External
: Node_Id
;
7223 Arg_Parameter_Types
: Node_Id
;
7224 Arg_Result_Type
: Node_Id
:= Empty
;
7225 Arg_Mechanism
: Node_Id
;
7226 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7232 Ambiguous
: Boolean;
7235 function Same_Base_Type
7237 Formal
: Entity_Id
) return Boolean;
7238 -- Determines if Ptype references the type of Formal. Note that only
7239 -- the base types need to match according to the spec. Ptype here is
7240 -- the argument from the pragma, which is either a type name, or an
7241 -- access attribute.
7243 --------------------
7244 -- Same_Base_Type --
7245 --------------------
7247 function Same_Base_Type
7249 Formal
: Entity_Id
) return Boolean
7251 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7255 -- Case where pragma argument is typ'Access
7257 if Nkind
(Ptype
) = N_Attribute_Reference
7258 and then Attribute_Name
(Ptype
) = Name_Access
7260 Pref
:= Prefix
(Ptype
);
7263 if not Is_Entity_Name
(Pref
)
7264 or else Entity
(Pref
) = Any_Type
7269 -- We have a match if the corresponding argument is of an
7270 -- anonymous access type, and its designated type matches the
7271 -- type of the prefix of the access attribute
7273 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7274 and then Base_Type
(Entity
(Pref
)) =
7275 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7277 -- Case where pragma argument is a type name
7282 if not Is_Entity_Name
(Ptype
)
7283 or else Entity
(Ptype
) = Any_Type
7288 -- We have a match if the corresponding argument is of the type
7289 -- given in the pragma (comparing base types)
7291 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7295 -- Start of processing for
7296 -- Process_Extended_Import_Export_Subprogram_Pragma
7299 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7303 -- Loop through homonyms (overloadings) of the entity
7305 Hom_Id
:= Entity
(Arg_Internal
);
7306 while Present
(Hom_Id
) loop
7307 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7309 -- We need a subprogram in the current scope
7311 if not Is_Subprogram
(Def_Id
)
7312 or else Scope
(Def_Id
) /= Current_Scope
7319 -- Pragma cannot apply to subprogram body
7321 if Is_Subprogram
(Def_Id
)
7322 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7326 ("pragma% requires separate spec"
7327 & " and must come before body");
7330 -- Test result type if given, note that the result type
7331 -- parameter can only be present for the function cases.
7333 if Present
(Arg_Result_Type
)
7334 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7338 elsif Etype
(Def_Id
) /= Standard_Void_Type
7340 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7344 -- Test parameter types if given. Note that this parameter
7345 -- has not been analyzed (and must not be, since it is
7346 -- semantic nonsense), so we get it as the parser left it.
7348 elsif Present
(Arg_Parameter_Types
) then
7349 Check_Matching_Types
: declare
7354 Formal
:= First_Formal
(Def_Id
);
7356 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7357 if Present
(Formal
) then
7361 -- A list of one type, e.g. (List) is parsed as
7362 -- a parenthesized expression.
7364 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7365 and then Paren_Count
(Arg_Parameter_Types
) = 1
7368 or else Present
(Next_Formal
(Formal
))
7373 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7376 -- A list of more than one type is parsed as a aggregate
7378 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7379 and then Paren_Count
(Arg_Parameter_Types
) = 0
7381 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7382 while Present
(Ptype
) or else Present
(Formal
) loop
7385 or else not Same_Base_Type
(Ptype
, Formal
)
7390 Next_Formal
(Formal
);
7395 -- Anything else is of the wrong form
7399 ("wrong form for Parameter_Types parameter",
7400 Arg_Parameter_Types
);
7402 end Check_Matching_Types
;
7405 -- Match is now False if the entry we found did not match
7406 -- either a supplied Parameter_Types or Result_Types argument
7412 -- Ambiguous case, the flag Ambiguous shows if we already
7413 -- detected this and output the initial messages.
7416 if not Ambiguous
then
7418 Error_Msg_Name_1
:= Pname
;
7420 ("pragma% does not uniquely identify subprogram!",
7422 Error_Msg_Sloc
:= Sloc
(Ent
);
7423 Error_Msg_N
("matching subprogram #!", N
);
7427 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7428 Error_Msg_N
("matching subprogram #!", N
);
7433 Hom_Id
:= Homonym
(Hom_Id
);
7436 -- See if we found an entry
7439 if not Ambiguous
then
7440 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7442 ("pragma% cannot be given for generic subprogram");
7445 ("pragma% does not identify local subprogram");
7452 -- Import pragmas must be for imported entities
7454 if Prag_Id
= Pragma_Import_Function
7456 Prag_Id
= Pragma_Import_Procedure
7458 Prag_Id
= Pragma_Import_Valued_Procedure
7460 if not Is_Imported
(Ent
) then
7462 ("pragma Import or Interface must precede pragma%");
7465 -- Here we have the Export case which can set the entity as exported
7467 -- But does not do so if the specified external name is null, since
7468 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7469 -- compatible) to request no external name.
7471 elsif Nkind
(Arg_External
) = N_String_Literal
7472 and then String_Length
(Strval
(Arg_External
)) = 0
7476 -- In all other cases, set entity as exported
7479 Set_Exported
(Ent
, Arg_Internal
);
7482 -- Special processing for Valued_Procedure cases
7484 if Prag_Id
= Pragma_Import_Valued_Procedure
7486 Prag_Id
= Pragma_Export_Valued_Procedure
7488 Formal
:= First_Formal
(Ent
);
7491 Error_Pragma
("at least one parameter required for pragma%");
7493 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7494 Error_Pragma
("first parameter must have mode out for pragma%");
7497 Set_Is_Valued_Procedure
(Ent
);
7501 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7503 -- Process Result_Mechanism argument if present. We have already
7504 -- checked that this is only allowed for the function case.
7506 if Present
(Arg_Result_Mechanism
) then
7507 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7510 -- Process Mechanism parameter if present. Note that this parameter
7511 -- is not analyzed, and must not be analyzed since it is semantic
7512 -- nonsense, so we get it in exactly as the parser left it.
7514 if Present
(Arg_Mechanism
) then
7522 -- A single mechanism association without a formal parameter
7523 -- name is parsed as a parenthesized expression. All other
7524 -- cases are parsed as aggregates, so we rewrite the single
7525 -- parameter case as an aggregate for consistency.
7527 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7528 and then Paren_Count
(Arg_Mechanism
) = 1
7530 Rewrite
(Arg_Mechanism
,
7531 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7532 Expressions
=> New_List
(
7533 Relocate_Node
(Arg_Mechanism
))));
7536 -- Case of only mechanism name given, applies to all formals
7538 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7539 Formal
:= First_Formal
(Ent
);
7540 while Present
(Formal
) loop
7541 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7542 Next_Formal
(Formal
);
7545 -- Case of list of mechanism associations given
7548 if Null_Record_Present
(Arg_Mechanism
) then
7550 ("inappropriate form for Mechanism parameter",
7554 -- Deal with positional ones first
7556 Formal
:= First_Formal
(Ent
);
7558 if Present
(Expressions
(Arg_Mechanism
)) then
7559 Mname
:= First
(Expressions
(Arg_Mechanism
));
7560 while Present
(Mname
) loop
7563 ("too many mechanism associations", Mname
);
7566 Set_Mechanism_Value
(Formal
, Mname
);
7567 Next_Formal
(Formal
);
7572 -- Deal with named entries
7574 if Present
(Component_Associations
(Arg_Mechanism
)) then
7575 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7576 while Present
(Massoc
) loop
7577 Choice
:= First
(Choices
(Massoc
));
7579 if Nkind
(Choice
) /= N_Identifier
7580 or else Present
(Next
(Choice
))
7583 ("incorrect form for mechanism association",
7587 Formal
:= First_Formal
(Ent
);
7591 ("parameter name & not present", Choice
);
7594 if Chars
(Choice
) = Chars
(Formal
) then
7596 (Formal
, Expression
(Massoc
));
7598 -- Set entity on identifier (needed by ASIS)
7600 Set_Entity
(Choice
, Formal
);
7605 Next_Formal
(Formal
);
7614 end Process_Extended_Import_Export_Subprogram_Pragma
;
7616 --------------------------
7617 -- Process_Generic_List --
7618 --------------------------
7620 procedure Process_Generic_List
is
7625 Check_No_Identifiers
;
7626 Check_At_Least_N_Arguments
(1);
7628 -- Check all arguments are names of generic units or instances
7631 while Present
(Arg
) loop
7632 Exp
:= Get_Pragma_Arg
(Arg
);
7635 if not Is_Entity_Name
(Exp
)
7637 (not Is_Generic_Instance
(Entity
(Exp
))
7639 not Is_Generic_Unit
(Entity
(Exp
)))
7642 ("pragma% argument must be name of generic unit/instance",
7648 end Process_Generic_List
;
7650 ------------------------------------
7651 -- Process_Import_Predefined_Type --
7652 ------------------------------------
7654 procedure Process_Import_Predefined_Type
is
7655 Loc
: constant Source_Ptr
:= Sloc
(N
);
7657 Ftyp
: Node_Id
:= Empty
;
7663 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7666 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7667 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7671 Ftyp
:= Node
(Elmt
);
7673 if Present
(Ftyp
) then
7675 -- Don't build a derived type declaration, because predefined C
7676 -- types have no declaration anywhere, so cannot really be named.
7677 -- Instead build a full type declaration, starting with an
7678 -- appropriate type definition is built
7680 if Is_Floating_Point_Type
(Ftyp
) then
7681 Def
:= Make_Floating_Point_Definition
(Loc
,
7682 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7683 Make_Real_Range_Specification
(Loc
,
7684 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7685 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7687 -- Should never have a predefined type we cannot handle
7690 raise Program_Error
;
7693 -- Build and insert a Full_Type_Declaration, which will be
7694 -- analyzed as soon as this list entry has been analyzed.
7696 Decl
:= Make_Full_Type_Declaration
(Loc
,
7697 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7698 Type_Definition
=> Def
);
7700 Insert_After
(N
, Decl
);
7701 Mark_Rewrite_Insertion
(Decl
);
7704 Error_Pragma_Arg
("no matching type found for pragma%",
7707 end Process_Import_Predefined_Type
;
7709 ---------------------------------
7710 -- Process_Import_Or_Interface --
7711 ---------------------------------
7713 procedure Process_Import_Or_Interface
is
7719 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7720 -- pragma Import (Entity, "external name");
7722 if Relaxed_RM_Semantics
7723 and then Arg_Count
= 2
7724 and then Prag_Id
= Pragma_Import
7725 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7728 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7731 if not Is_Entity_Name
(Def_Id
) then
7732 Error_Pragma_Arg
("entity name required", Arg1
);
7735 Def_Id
:= Entity
(Def_Id
);
7736 Kill_Size_Check_Code
(Def_Id
);
7737 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7740 Process_Convention
(C
, Def_Id
);
7741 Kill_Size_Check_Code
(Def_Id
);
7742 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7745 -- Various error checks
7747 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7749 -- We do not permit Import to apply to a renaming declaration
7751 if Present
(Renamed_Object
(Def_Id
)) then
7753 ("pragma% not allowed for object renaming", Arg2
);
7755 -- User initialization is not allowed for imported object, but
7756 -- the object declaration may contain a default initialization,
7757 -- that will be discarded. Note that an explicit initialization
7758 -- only counts if it comes from source, otherwise it is simply
7759 -- the code generator making an implicit initialization explicit.
7761 elsif Present
(Expression
(Parent
(Def_Id
)))
7762 and then Comes_From_Source
7763 (Original_Node
(Expression
(Parent
(Def_Id
))))
7765 -- Set imported flag to prevent cascaded errors
7767 Set_Is_Imported
(Def_Id
);
7769 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7771 ("no initialization allowed for declaration of& #",
7772 "\imported entities cannot be initialized (RM B.1(24))",
7776 -- If the pragma comes from an aspect specification the
7777 -- Is_Imported flag has already been set.
7779 if not From_Aspect_Specification
(N
) then
7780 Set_Imported
(Def_Id
);
7783 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7785 -- Note that we do not set Is_Public here. That's because we
7786 -- only want to set it if there is no address clause, and we
7787 -- don't know that yet, so we delay that processing till
7790 -- pragma Import completes deferred constants
7792 if Ekind
(Def_Id
) = E_Constant
then
7793 Set_Has_Completion
(Def_Id
);
7796 -- It is not possible to import a constant of an unconstrained
7797 -- array type (e.g. string) because there is no simple way to
7798 -- write a meaningful subtype for it.
7800 if Is_Array_Type
(Etype
(Def_Id
))
7801 and then not Is_Constrained
(Etype
(Def_Id
))
7804 ("imported constant& must have a constrained subtype",
7809 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7811 -- If the name is overloaded, pragma applies to all of the denoted
7812 -- entities in the same declarative part, unless the pragma comes
7813 -- from an aspect specification or was generated by the compiler
7814 -- (such as for pragma Provide_Shift_Operators).
7817 while Present
(Hom_Id
) loop
7819 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7821 -- Ignore inherited subprograms because the pragma will apply
7822 -- to the parent operation, which is the one called.
7824 if Is_Overloadable
(Def_Id
)
7825 and then Present
(Alias
(Def_Id
))
7829 -- If it is not a subprogram, it must be in an outer scope and
7830 -- pragma does not apply.
7832 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7835 -- The pragma does not apply to primitives of interfaces
7837 elsif Is_Dispatching_Operation
(Def_Id
)
7838 and then Present
(Find_Dispatching_Type
(Def_Id
))
7839 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7843 -- Verify that the homonym is in the same declarative part (not
7844 -- just the same scope). If the pragma comes from an aspect
7845 -- specification we know that it is part of the declaration.
7847 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7848 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7849 and then not From_Aspect_Specification
(N
)
7854 -- If the pragma comes from an aspect specification the
7855 -- Is_Imported flag has already been set.
7857 if not From_Aspect_Specification
(N
) then
7858 Set_Imported
(Def_Id
);
7861 -- Reject an Import applied to an abstract subprogram
7863 if Is_Subprogram
(Def_Id
)
7864 and then Is_Abstract_Subprogram
(Def_Id
)
7866 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7868 ("cannot import abstract subprogram& declared#",
7872 -- Special processing for Convention_Intrinsic
7874 if C
= Convention_Intrinsic
then
7876 -- Link_Name argument not allowed for intrinsic
7880 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7882 -- If no external name is present, then check that this
7883 -- is a valid intrinsic subprogram. If an external name
7884 -- is present, then this is handled by the back end.
7887 Check_Intrinsic_Subprogram
7888 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7892 -- Verify that the subprogram does not have a completion
7893 -- through a renaming declaration. For other completions the
7894 -- pragma appears as a too late representation.
7897 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7901 and then Nkind
(Decl
) = N_Subprogram_Declaration
7902 and then Present
(Corresponding_Body
(Decl
))
7903 and then Nkind
(Unit_Declaration_Node
7904 (Corresponding_Body
(Decl
))) =
7905 N_Subprogram_Renaming_Declaration
7907 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7909 ("cannot import&, renaming already provided for "
7910 & "declaration #", N
, Def_Id
);
7914 -- If the pragma comes from an aspect specification, there
7915 -- must be an Import aspect specified as well. In the rare
7916 -- case where Import is set to False, the suprogram needs to
7917 -- have a local completion.
7920 Imp_Aspect
: constant Node_Id
:=
7921 Find_Aspect
(Def_Id
, Aspect_Import
);
7925 if Present
(Imp_Aspect
)
7926 and then Present
(Expression
(Imp_Aspect
))
7928 Expr
:= Expression
(Imp_Aspect
);
7929 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7931 if Is_Entity_Name
(Expr
)
7932 and then Entity
(Expr
) = Standard_True
7934 Set_Has_Completion
(Def_Id
);
7937 -- If there is no expression, the default is True, as for
7938 -- all boolean aspects. Same for the older pragma.
7941 Set_Has_Completion
(Def_Id
);
7945 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7948 if Is_Compilation_Unit
(Hom_Id
) then
7950 -- Its possible homonyms are not affected by the pragma.
7951 -- Such homonyms might be present in the context of other
7952 -- units being compiled.
7956 elsif From_Aspect_Specification
(N
) then
7959 -- If the pragma was created by the compiler, then we don't
7960 -- want it to apply to other homonyms. This kind of case can
7961 -- occur when using pragma Provide_Shift_Operators, which
7962 -- generates implicit shift and rotate operators with Import
7963 -- pragmas that might apply to earlier explicit or implicit
7964 -- declarations marked with Import (for example, coming from
7965 -- an earlier pragma Provide_Shift_Operators for another type),
7966 -- and we don't generally want other homonyms being treated
7967 -- as imported or the pragma flagged as an illegal duplicate.
7969 elsif not Comes_From_Source
(N
) then
7973 Hom_Id
:= Homonym
(Hom_Id
);
7977 -- When the convention is Java or CIL, we also allow Import to
7978 -- be given for packages, generic packages, exceptions, record
7979 -- components, and access to subprograms.
7981 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
7983 (Is_Package_Or_Generic_Package
(Def_Id
)
7984 or else Ekind
(Def_Id
) = E_Exception
7985 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
7986 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
7988 Set_Imported
(Def_Id
);
7989 Set_Is_Public
(Def_Id
);
7990 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7992 -- Import a CPP class
7994 elsif C
= Convention_CPP
7995 and then (Is_Record_Type
(Def_Id
)
7996 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
7998 if Ekind
(Def_Id
) = E_Incomplete_Type
then
7999 if Present
(Full_View
(Def_Id
)) then
8000 Def_Id
:= Full_View
(Def_Id
);
8004 ("cannot import 'C'P'P type before full declaration seen",
8005 Get_Pragma_Arg
(Arg2
));
8007 -- Although we have reported the error we decorate it as
8008 -- CPP_Class to avoid reporting spurious errors
8010 Set_Is_CPP_Class
(Def_Id
);
8015 -- Types treated as CPP classes must be declared limited (note:
8016 -- this used to be a warning but there is no real benefit to it
8017 -- since we did effectively intend to treat the type as limited
8020 if not Is_Limited_Type
(Def_Id
) then
8022 ("imported 'C'P'P type must be limited",
8023 Get_Pragma_Arg
(Arg2
));
8026 if Etype
(Def_Id
) /= Def_Id
8027 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8029 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8032 Set_Is_CPP_Class
(Def_Id
);
8034 -- Imported CPP types must not have discriminants (because C++
8035 -- classes do not have discriminants).
8037 if Has_Discriminants
(Def_Id
) then
8039 ("imported 'C'P'P type cannot have discriminants",
8040 First
(Discriminant_Specifications
8041 (Declaration_Node
(Def_Id
))));
8044 -- Check that components of imported CPP types do not have default
8045 -- expressions. For private types this check is performed when the
8046 -- full view is analyzed (see Process_Full_View).
8048 if not Is_Private_Type
(Def_Id
) then
8049 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8052 -- Import a CPP exception
8054 elsif C
= Convention_CPP
8055 and then Ekind
(Def_Id
) = E_Exception
8059 ("'External_'Name arguments is required for 'Cpp exception",
8062 -- As only a string is allowed, Check_Arg_Is_External_Name
8065 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8068 if Present
(Arg4
) then
8070 ("Link_Name argument not allowed for imported Cpp exception",
8074 -- Do not call Set_Interface_Name as the name of the exception
8075 -- shouldn't be modified (and in particular it shouldn't be
8076 -- the External_Name). For exceptions, the External_Name is the
8077 -- name of the RTTI structure.
8079 -- ??? Emit an error if pragma Import/Export_Exception is present
8081 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8083 Check_Arg_Count
(3);
8084 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8086 Process_Import_Predefined_Type
;
8090 ("second argument of pragma% must be object, subprogram "
8091 & "or incomplete type",
8095 -- If this pragma applies to a compilation unit, then the unit, which
8096 -- is a subprogram, does not require (or allow) a body. We also do
8097 -- not need to elaborate imported procedures.
8099 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8101 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8103 Set_Body_Required
(Cunit
, False);
8106 end Process_Import_Or_Interface
;
8108 --------------------
8109 -- Process_Inline --
8110 --------------------
8112 procedure Process_Inline
(Status
: Inline_Status
) is
8119 procedure Make_Inline
(Subp
: Entity_Id
);
8120 -- Subp is the defining unit name of the subprogram declaration. Set
8121 -- the flag, as well as the flag in the corresponding body, if there
8124 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8125 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8126 -- Has_Pragma_Inline_Always for the Inline_Always case.
8128 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8129 -- Returns True if it can be determined at this stage that inlining
8130 -- is not possible, for example if the body is available and contains
8131 -- exception handlers, we prevent inlining, since otherwise we can
8132 -- get undefined symbols at link time. This function also emits a
8133 -- warning if front-end inlining is enabled and the pragma appears
8136 -- ??? is business with link symbols still valid, or does it relate
8137 -- to front end ZCX which is being phased out ???
8139 ---------------------------
8140 -- Inlining_Not_Possible --
8141 ---------------------------
8143 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8144 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8148 if Nkind
(Decl
) = N_Subprogram_Body
then
8149 Stats
:= Handled_Statement_Sequence
(Decl
);
8150 return Present
(Exception_Handlers
(Stats
))
8151 or else Present
(At_End_Proc
(Stats
));
8153 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8154 and then Present
(Corresponding_Body
(Decl
))
8156 if Front_End_Inlining
8157 and then Analyzed
(Corresponding_Body
(Decl
))
8159 Error_Msg_N
("pragma appears too late, ignored??", N
);
8162 -- If the subprogram is a renaming as body, the body is just a
8163 -- call to the renamed subprogram, and inlining is trivially
8167 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8168 N_Subprogram_Renaming_Declaration
8174 Handled_Statement_Sequence
8175 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8178 Present
(Exception_Handlers
(Stats
))
8179 or else Present
(At_End_Proc
(Stats
));
8183 -- If body is not available, assume the best, the check is
8184 -- performed again when compiling enclosing package bodies.
8188 end Inlining_Not_Possible
;
8194 procedure Make_Inline
(Subp
: Entity_Id
) is
8195 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8196 Inner_Subp
: Entity_Id
:= Subp
;
8199 -- Ignore if bad type, avoid cascaded error
8201 if Etype
(Subp
) = Any_Type
then
8205 -- Ignore if all inlining is suppressed
8207 elsif Suppress_All_Inlining
then
8211 -- If inlining is not possible, for now do not treat as an error
8213 elsif Status
/= Suppressed
8214 and then Inlining_Not_Possible
(Subp
)
8219 -- Here we have a candidate for inlining, but we must exclude
8220 -- derived operations. Otherwise we would end up trying to inline
8221 -- a phantom declaration, and the result would be to drag in a
8222 -- body which has no direct inlining associated with it. That
8223 -- would not only be inefficient but would also result in the
8224 -- backend doing cross-unit inlining in cases where it was
8225 -- definitely inappropriate to do so.
8227 -- However, a simple Comes_From_Source test is insufficient, since
8228 -- we do want to allow inlining of generic instances which also do
8229 -- not come from source. We also need to recognize specs generated
8230 -- by the front-end for bodies that carry the pragma. Finally,
8231 -- predefined operators do not come from source but are not
8232 -- inlineable either.
8234 elsif Is_Generic_Instance
(Subp
)
8235 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8239 elsif not Comes_From_Source
(Subp
)
8240 and then Scope
(Subp
) /= Standard_Standard
8246 -- The referenced entity must either be the enclosing entity, or
8247 -- an entity declared within the current open scope.
8249 if Present
(Scope
(Subp
))
8250 and then Scope
(Subp
) /= Current_Scope
8251 and then Subp
/= Current_Scope
8254 ("argument of% must be entity in current scope", Assoc
);
8258 -- Processing for procedure, operator or function. If subprogram
8259 -- is aliased (as for an instance) indicate that the renamed
8260 -- entity (if declared in the same unit) is inlined.
8262 if Is_Subprogram
(Subp
) then
8263 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8265 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8266 Set_Inline_Flags
(Inner_Subp
);
8268 Decl
:= Parent
(Parent
(Inner_Subp
));
8270 if Nkind
(Decl
) = N_Subprogram_Declaration
8271 and then Present
(Corresponding_Body
(Decl
))
8273 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8275 elsif Is_Generic_Instance
(Subp
) then
8277 -- Indicate that the body needs to be created for
8278 -- inlining subsequent calls. The instantiation node
8279 -- follows the declaration of the wrapper package
8282 if Scope
(Subp
) /= Standard_Standard
8284 Need_Subprogram_Instance_Body
8285 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8291 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8292 -- appear in a formal part to apply to a formal subprogram.
8293 -- Do not apply check within an instance or a formal package
8294 -- the test will have been applied to the original generic.
8296 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8297 and then List_Containing
(Decl
) = List_Containing
(N
)
8298 and then not In_Instance
8301 ("Inline cannot apply to a formal subprogram", N
);
8303 -- If Subp is a renaming, it is the renamed entity that
8304 -- will appear in any call, and be inlined. However, for
8305 -- ASIS uses it is convenient to indicate that the renaming
8306 -- itself is an inlined subprogram, so that some gnatcheck
8307 -- rules can be applied in the absence of expansion.
8309 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8310 Set_Inline_Flags
(Subp
);
8316 -- For a generic subprogram set flag as well, for use at the point
8317 -- of instantiation, to determine whether the body should be
8320 elsif Is_Generic_Subprogram
(Subp
) then
8321 Set_Inline_Flags
(Subp
);
8324 -- Literals are by definition inlined
8326 elsif Kind
= E_Enumeration_Literal
then
8329 -- Anything else is an error
8333 ("expect subprogram name for pragma%", Assoc
);
8337 ----------------------
8338 -- Set_Inline_Flags --
8339 ----------------------
8341 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8343 -- First set the Has_Pragma_XXX flags and issue the appropriate
8344 -- errors and warnings for suspicious combinations.
8346 if Prag_Id
= Pragma_No_Inline
then
8347 if Has_Pragma_Inline_Always
(Subp
) then
8349 ("Inline_Always and No_Inline are mutually exclusive", N
);
8350 elsif Has_Pragma_Inline
(Subp
) then
8352 ("Inline and No_Inline both specified for& ??",
8353 N
, Entity
(Subp_Id
));
8356 Set_Has_Pragma_No_Inline
(Subp
);
8358 if Prag_Id
= Pragma_Inline_Always
then
8359 if Has_Pragma_No_Inline
(Subp
) then
8361 ("Inline_Always and No_Inline are mutually exclusive",
8365 Set_Has_Pragma_Inline_Always
(Subp
);
8367 if Has_Pragma_No_Inline
(Subp
) then
8369 ("Inline and No_Inline both specified for& ??",
8370 N
, Entity
(Subp_Id
));
8374 if not Has_Pragma_Inline
(Subp
) then
8375 Set_Has_Pragma_Inline
(Subp
);
8379 -- Then adjust the Is_Inlined flag. It can never be set if the
8380 -- subprogram is subject to pragma No_Inline.
8384 Set_Is_Inlined
(Subp
, False);
8388 if not Has_Pragma_No_Inline
(Subp
) then
8389 Set_Is_Inlined
(Subp
, True);
8392 end Set_Inline_Flags
;
8394 -- Start of processing for Process_Inline
8397 Check_No_Identifiers
;
8398 Check_At_Least_N_Arguments
(1);
8400 if Status
= Enabled
then
8401 Inline_Processing_Required
:= True;
8405 while Present
(Assoc
) loop
8406 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8410 if Is_Entity_Name
(Subp_Id
) then
8411 Subp
:= Entity
(Subp_Id
);
8413 if Subp
= Any_Id
then
8415 -- If previous error, avoid cascaded errors
8417 Check_Error_Detected
;
8423 -- For the pragma case, climb homonym chain. This is
8424 -- what implements allowing the pragma in the renaming
8425 -- case, with the result applying to the ancestors, and
8426 -- also allows Inline to apply to all previous homonyms.
8428 if not From_Aspect_Specification
(N
) then
8429 while Present
(Homonym
(Subp
))
8430 and then Scope
(Homonym
(Subp
)) = Current_Scope
8432 Make_Inline
(Homonym
(Subp
));
8433 Subp
:= Homonym
(Subp
);
8440 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8447 ----------------------------
8448 -- Process_Interface_Name --
8449 ----------------------------
8451 procedure Process_Interface_Name
8452 (Subprogram_Def
: Entity_Id
;
8458 String_Val
: String_Id
;
8460 procedure Check_Form_Of_Interface_Name
8462 Ext_Name_Case
: Boolean);
8463 -- SN is a string literal node for an interface name. This routine
8464 -- performs some minimal checks that the name is reasonable. In
8465 -- particular that no spaces or other obviously incorrect characters
8466 -- appear. This is only a warning, since any characters are allowed.
8467 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8469 ----------------------------------
8470 -- Check_Form_Of_Interface_Name --
8471 ----------------------------------
8473 procedure Check_Form_Of_Interface_Name
8475 Ext_Name_Case
: Boolean)
8477 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8478 SL
: constant Nat
:= String_Length
(S
);
8483 Error_Msg_N
("interface name cannot be null string", SN
);
8486 for J
in 1 .. SL
loop
8487 C
:= Get_String_Char
(S
, J
);
8489 -- Look for dubious character and issue unconditional warning.
8490 -- Definitely dubious if not in character range.
8492 if not In_Character_Range
(C
)
8494 -- For all cases except CLI target,
8495 -- commas, spaces and slashes are dubious (in CLI, we use
8496 -- commas and backslashes in external names to specify
8497 -- assembly version and public key, while slashes and spaces
8498 -- can be used in names to mark nested classes and
8501 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8502 and then (Get_Character
(C
) = ','
8504 Get_Character
(C
) = '\'))
8505 or else (VM_Target
/= CLI_Target
8506 and then (Get_Character
(C
) = ' '
8508 Get_Character
(C
) = '/'))
8511 ("??interface name contains illegal character",
8512 Sloc
(SN
) + Source_Ptr
(J
));
8515 end Check_Form_Of_Interface_Name
;
8517 -- Start of processing for Process_Interface_Name
8520 if No
(Link_Arg
) then
8521 if No
(Ext_Arg
) then
8522 if VM_Target
= CLI_Target
8523 and then Ekind
(Subprogram_Def
) = E_Package
8524 and then Nkind
(Parent
(Subprogram_Def
)) =
8525 N_Package_Specification
8526 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8531 (Generic_Parent
(Parent
(Subprogram_Def
))));
8536 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8538 Link_Nam
:= Expression
(Ext_Arg
);
8541 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8542 Ext_Nam
:= Expression
(Ext_Arg
);
8547 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8548 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8549 Ext_Nam
:= Expression
(Ext_Arg
);
8550 Link_Nam
:= Expression
(Link_Arg
);
8553 -- Check expressions for external name and link name are static
8555 if Present
(Ext_Nam
) then
8556 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8557 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8559 -- Verify that external name is not the name of a local entity,
8560 -- which would hide the imported one and could lead to run-time
8561 -- surprises. The problem can only arise for entities declared in
8562 -- a package body (otherwise the external name is fully qualified
8563 -- and will not conflict).
8571 if Prag_Id
= Pragma_Import
then
8572 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8574 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8576 if Nam
/= Chars
(Subprogram_Def
)
8577 and then Present
(E
)
8578 and then not Is_Overloadable
(E
)
8579 and then Is_Immediately_Visible
(E
)
8580 and then not Is_Imported
(E
)
8581 and then Ekind
(Scope
(E
)) = E_Package
8584 while Present
(Par
) loop
8585 if Nkind
(Par
) = N_Package_Body
then
8586 Error_Msg_Sloc
:= Sloc
(E
);
8588 ("imported entity is hidden by & declared#",
8593 Par
:= Parent
(Par
);
8600 if Present
(Link_Nam
) then
8601 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8602 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8605 -- If there is no link name, just set the external name
8607 if No
(Link_Nam
) then
8608 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8610 -- For the Link_Name case, the given literal is preceded by an
8611 -- asterisk, which indicates to GCC that the given name should be
8612 -- taken literally, and in particular that no prepending of
8613 -- underlines should occur, even in systems where this is the
8619 if VM_Target
= No_VM
then
8620 Store_String_Char
(Get_Char_Code
('*'));
8623 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8624 Store_String_Chars
(String_Val
);
8626 Make_String_Literal
(Sloc
(Link_Nam
),
8627 Strval
=> End_String
);
8630 -- Set the interface name. If the entity is a generic instance, use
8631 -- its alias, which is the callable entity.
8633 if Is_Generic_Instance
(Subprogram_Def
) then
8634 Set_Encoded_Interface_Name
8635 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8637 Set_Encoded_Interface_Name
8638 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8641 -- We allow duplicated export names in CIL/Java, as they are always
8642 -- enclosed in a namespace that differentiates them, and overloaded
8643 -- entities are supported by the VM.
8645 if Convention
(Subprogram_Def
) /= Convention_CIL
8647 Convention
(Subprogram_Def
) /= Convention_Java
8649 Check_Duplicated_Export_Name
(Link_Nam
);
8651 end Process_Interface_Name
;
8653 -----------------------------------------
8654 -- Process_Interrupt_Or_Attach_Handler --
8655 -----------------------------------------
8657 procedure Process_Interrupt_Or_Attach_Handler
is
8658 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8659 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8660 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8663 Set_Is_Interrupt_Handler
(Handler_Proc
);
8665 -- If the pragma is not associated with a handler procedure within a
8666 -- protected type, then it must be for a nonprotected procedure for
8667 -- the AAMP target, in which case we don't associate a representation
8668 -- item with the procedure's scope.
8670 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8671 if Prag_Id
= Pragma_Interrupt_Handler
8673 Prag_Id
= Pragma_Attach_Handler
8675 Record_Rep_Item
(Proc_Scope
, N
);
8678 end Process_Interrupt_Or_Attach_Handler
;
8680 --------------------------------------------------
8681 -- Process_Restrictions_Or_Restriction_Warnings --
8682 --------------------------------------------------
8684 -- Note: some of the simple identifier cases were handled in par-prag,
8685 -- but it is harmless (and more straightforward) to simply handle all
8686 -- cases here, even if it means we repeat a bit of work in some cases.
8688 procedure Process_Restrictions_Or_Restriction_Warnings
8692 R_Id
: Restriction_Id
;
8698 -- Ignore all Restrictions pragmas in CodePeer mode
8700 if CodePeer_Mode
then
8704 Check_Ada_83_Warning
;
8705 Check_At_Least_N_Arguments
(1);
8706 Check_Valid_Configuration_Pragma
;
8709 while Present
(Arg
) loop
8711 Expr
:= Get_Pragma_Arg
(Arg
);
8713 -- Case of no restriction identifier present
8715 if Id
= No_Name
then
8716 if Nkind
(Expr
) /= N_Identifier
then
8718 ("invalid form for restriction", Arg
);
8723 (Process_Restriction_Synonyms
(Expr
));
8725 if R_Id
not in All_Boolean_Restrictions
then
8726 Error_Msg_Name_1
:= Pname
;
8728 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8730 -- Check for possible misspelling
8732 for J
in Restriction_Id
loop
8734 Rnm
: constant String := Restriction_Id
'Image (J
);
8737 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8738 Name_Len
:= Rnm
'Length;
8739 Set_Casing
(All_Lower_Case
);
8741 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8743 (Identifier_Casing
(Current_Source_File
));
8744 Error_Msg_String
(1 .. Rnm
'Length) :=
8745 Name_Buffer
(1 .. Name_Len
);
8746 Error_Msg_Strlen
:= Rnm
'Length;
8747 Error_Msg_N
-- CODEFIX
8748 ("\possible misspelling of ""~""",
8749 Get_Pragma_Arg
(Arg
));
8758 if Implementation_Restriction
(R_Id
) then
8759 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8762 -- Special processing for No_Elaboration_Code restriction
8764 if R_Id
= No_Elaboration_Code
then
8766 -- Restriction is only recognized within a configuration
8767 -- pragma file, or within a unit of the main extended
8768 -- program. Note: the test for Main_Unit is needed to
8769 -- properly include the case of configuration pragma files.
8771 if not (Current_Sem_Unit
= Main_Unit
8772 or else In_Extended_Main_Source_Unit
(N
))
8776 -- Don't allow in a subunit unless already specified in
8779 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8780 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8781 and then not Restriction_Active
(No_Elaboration_Code
)
8784 ("invalid specification of ""No_Elaboration_Code""",
8787 ("\restriction cannot be specified in a subunit", N
);
8789 ("\unless also specified in body or spec", N
);
8792 -- If we accept a No_Elaboration_Code restriction, then it
8793 -- needs to be added to the configuration restriction set so
8794 -- that we get proper application to other units in the main
8795 -- extended source as required.
8798 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8802 -- If this is a warning, then set the warning unless we already
8803 -- have a real restriction active (we never want a warning to
8804 -- override a real restriction).
8807 if not Restriction_Active
(R_Id
) then
8808 Set_Restriction
(R_Id
, N
);
8809 Restriction_Warnings
(R_Id
) := True;
8812 -- If real restriction case, then set it and make sure that the
8813 -- restriction warning flag is off, since a real restriction
8814 -- always overrides a warning.
8817 Set_Restriction
(R_Id
, N
);
8818 Restriction_Warnings
(R_Id
) := False;
8821 -- Check for obsolescent restrictions in Ada 2005 mode
8824 and then Ada_Version
>= Ada_2005
8825 and then (R_Id
= No_Asynchronous_Control
8827 R_Id
= No_Unchecked_Deallocation
8829 R_Id
= No_Unchecked_Conversion
)
8831 Check_Restriction
(No_Obsolescent_Features
, N
);
8834 -- A very special case that must be processed here: pragma
8835 -- Restrictions (No_Exceptions) turns off all run-time
8836 -- checking. This is a bit dubious in terms of the formal
8837 -- language definition, but it is what is intended by RM
8838 -- H.4(12). Restriction_Warnings never affects generated code
8839 -- so this is done only in the real restriction case.
8841 -- Atomic_Synchronization is not a real check, so it is not
8842 -- affected by this processing).
8844 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8845 -- run-time checks in CodePeer and GNATprove modes: we want to
8846 -- generate checks for analysis purposes, as set respectively
8847 -- by -gnatC and -gnatd.F
8850 and then not (CodePeer_Mode
or GNATprove_Mode
)
8851 and then R_Id
= No_Exceptions
8853 for J
in Scope_Suppress
.Suppress
'Range loop
8854 if J
/= Atomic_Synchronization
then
8855 Scope_Suppress
.Suppress
(J
) := True;
8860 -- Case of No_Dependence => unit-name. Note that the parser
8861 -- already made the necessary entry in the No_Dependence table.
8863 elsif Id
= Name_No_Dependence
then
8864 if not OK_No_Dependence_Unit_Name
(Expr
) then
8868 -- Case of No_Specification_Of_Aspect => aspect-identifier
8870 elsif Id
= Name_No_Specification_Of_Aspect
then
8875 if Nkind
(Expr
) /= N_Identifier
then
8878 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8881 if A_Id
= No_Aspect
then
8882 Error_Pragma_Arg
("invalid restriction name", Arg
);
8884 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8888 -- Case of No_Use_Of_Attribute => attribute-identifier
8890 elsif Id
= Name_No_Use_Of_Attribute
then
8891 if Nkind
(Expr
) /= N_Identifier
8892 or else not Is_Attribute_Name
(Chars
(Expr
))
8894 Error_Msg_N
("unknown attribute name??", Expr
);
8897 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8900 -- Case of No_Use_Of_Entity => fully-qualified-name
8902 elsif Id
= Name_No_Use_Of_Entity
then
8904 -- Restriction is only recognized within a configuration
8905 -- pragma file, or within a unit of the main extended
8906 -- program. Note: the test for Main_Unit is needed to
8907 -- properly include the case of configuration pragma files.
8909 if Current_Sem_Unit
= Main_Unit
8910 or else In_Extended_Main_Source_Unit
(N
)
8912 if not OK_No_Dependence_Unit_Name
(Expr
) then
8913 Error_Msg_N
("wrong form for entity name", Expr
);
8915 Set_Restriction_No_Use_Of_Entity
8916 (Expr
, Warn
, No_Profile
);
8920 -- Case of No_Use_Of_Pragma => pragma-identifier
8922 elsif Id
= Name_No_Use_Of_Pragma
then
8923 if Nkind
(Expr
) /= N_Identifier
8924 or else not Is_Pragma_Name
(Chars
(Expr
))
8926 Error_Msg_N
("unknown pragma name??", Expr
);
8928 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8931 -- All other cases of restriction identifier present
8934 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8935 Analyze_And_Resolve
(Expr
, Any_Integer
);
8937 if R_Id
not in All_Parameter_Restrictions
then
8939 ("invalid restriction parameter identifier", Arg
);
8941 elsif not Is_OK_Static_Expression
(Expr
) then
8942 Flag_Non_Static_Expr
8943 ("value must be static expression!", Expr
);
8946 elsif not Is_Integer_Type
(Etype
(Expr
))
8947 or else Expr_Value
(Expr
) < 0
8950 ("value must be non-negative integer", Arg
);
8953 -- Restriction pragma is active
8955 Val
:= Expr_Value
(Expr
);
8957 if not UI_Is_In_Int_Range
(Val
) then
8959 ("pragma ignored, value too large??", Arg
);
8962 -- Warning case. If the real restriction is active, then we
8963 -- ignore the request, since warning never overrides a real
8964 -- restriction. Otherwise we set the proper warning. Note that
8965 -- this circuit sets the warning again if it is already set,
8966 -- which is what we want, since the constant may have changed.
8969 if not Restriction_Active
(R_Id
) then
8971 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
8972 Restriction_Warnings
(R_Id
) := True;
8975 -- Real restriction case, set restriction and make sure warning
8976 -- flag is off since real restriction always overrides warning.
8979 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
8980 Restriction_Warnings
(R_Id
) := False;
8986 end Process_Restrictions_Or_Restriction_Warnings
;
8988 ---------------------------------
8989 -- Process_Suppress_Unsuppress --
8990 ---------------------------------
8992 -- Note: this procedure makes entries in the check suppress data
8993 -- structures managed by Sem. See spec of package Sem for full
8994 -- details on how we handle recording of check suppression.
8996 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9001 In_Package_Spec
: constant Boolean :=
9002 Is_Package_Or_Generic_Package
(Current_Scope
)
9003 and then not In_Package_Body
(Current_Scope
);
9005 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9006 -- Used to suppress a single check on the given entity
9008 --------------------------------
9009 -- Suppress_Unsuppress_Echeck --
9010 --------------------------------
9012 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9014 -- Check for error of trying to set atomic synchronization for
9015 -- a non-atomic variable.
9017 if C
= Atomic_Synchronization
9018 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9021 ("pragma & requires atomic type or variable",
9022 Pragma_Identifier
(Original_Node
(N
)));
9025 Set_Checks_May_Be_Suppressed
(E
);
9027 if In_Package_Spec
then
9028 Push_Global_Suppress_Stack_Entry
9031 Suppress
=> Suppress_Case
);
9033 Push_Local_Suppress_Stack_Entry
9036 Suppress
=> Suppress_Case
);
9039 -- If this is a first subtype, and the base type is distinct,
9040 -- then also set the suppress flags on the base type.
9042 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9043 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9045 end Suppress_Unsuppress_Echeck
;
9047 -- Start of processing for Process_Suppress_Unsuppress
9050 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9051 -- on user code: we want to generate checks for analysis purposes, as
9052 -- set respectively by -gnatC and -gnatd.F
9054 if (CodePeer_Mode
or GNATprove_Mode
)
9055 and then Comes_From_Source
(N
)
9060 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9061 -- declarative part or a package spec (RM 11.5(5)).
9063 if not Is_Configuration_Pragma
then
9064 Check_Is_In_Decl_Part_Or_Package_Spec
;
9067 Check_At_Least_N_Arguments
(1);
9068 Check_At_Most_N_Arguments
(2);
9069 Check_No_Identifier
(Arg1
);
9070 Check_Arg_Is_Identifier
(Arg1
);
9072 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9074 if C
= No_Check_Id
then
9076 ("argument of pragma% is not valid check name", Arg1
);
9079 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9081 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9083 ("Suppress of Elaboration_Check ignored in SPARK??",
9084 "\elaboration checking rules are statically enforced "
9085 & "(SPARK RM 7.7)", Arg1
);
9088 -- One-argument case
9090 if Arg_Count
= 1 then
9092 -- Make an entry in the local scope suppress table. This is the
9093 -- table that directly shows the current value of the scope
9094 -- suppress check for any check id value.
9096 if C
= All_Checks
then
9098 -- For All_Checks, we set all specific predefined checks with
9099 -- the exception of Elaboration_Check, which is handled
9100 -- specially because of not wanting All_Checks to have the
9101 -- effect of deactivating static elaboration order processing.
9102 -- Atomic_Synchronization is also not affected, since this is
9103 -- not a real check.
9105 for J
in Scope_Suppress
.Suppress
'Range loop
9106 if J
/= Elaboration_Check
9108 J
/= Atomic_Synchronization
9110 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9114 -- If not All_Checks, and predefined check, then set appropriate
9115 -- scope entry. Note that we will set Elaboration_Check if this
9116 -- is explicitly specified. Atomic_Synchronization is allowed
9117 -- only if internally generated and entity is atomic.
9119 elsif C
in Predefined_Check_Id
9120 and then (not Comes_From_Source
(N
)
9121 or else C
/= Atomic_Synchronization
)
9123 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9126 -- Also make an entry in the Local_Entity_Suppress table
9128 Push_Local_Suppress_Stack_Entry
9131 Suppress
=> Suppress_Case
);
9133 -- Case of two arguments present, where the check is suppressed for
9134 -- a specified entity (given as the second argument of the pragma)
9137 -- This is obsolescent in Ada 2005 mode
9139 if Ada_Version
>= Ada_2005
then
9140 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9143 Check_Optional_Identifier
(Arg2
, Name_On
);
9144 E_Id
:= Get_Pragma_Arg
(Arg2
);
9147 if not Is_Entity_Name
(E_Id
) then
9149 ("second argument of pragma% must be entity name", Arg2
);
9158 -- Enforce RM 11.5(7) which requires that for a pragma that
9159 -- appears within a package spec, the named entity must be
9160 -- within the package spec. We allow the package name itself
9161 -- to be mentioned since that makes sense, although it is not
9162 -- strictly allowed by 11.5(7).
9165 and then E
/= Current_Scope
9166 and then Scope
(E
) /= Current_Scope
9169 ("entity in pragma% is not in package spec (RM 11.5(7))",
9173 -- Loop through homonyms. As noted below, in the case of a package
9174 -- spec, only homonyms within the package spec are considered.
9177 Suppress_Unsuppress_Echeck
(E
, C
);
9179 if Is_Generic_Instance
(E
)
9180 and then Is_Subprogram
(E
)
9181 and then Present
(Alias
(E
))
9183 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9186 -- Move to next homonym if not aspect spec case
9188 exit when From_Aspect_Specification
(N
);
9192 -- If we are within a package specification, the pragma only
9193 -- applies to homonyms in the same scope.
9195 exit when In_Package_Spec
9196 and then Scope
(E
) /= Current_Scope
;
9199 end Process_Suppress_Unsuppress
;
9205 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9207 if Is_Imported
(E
) then
9209 ("cannot export entity& that was previously imported", Arg
);
9211 elsif Present
(Address_Clause
(E
))
9212 and then not Relaxed_RM_Semantics
9215 ("cannot export entity& that has an address clause", Arg
);
9218 Set_Is_Exported
(E
);
9220 -- Generate a reference for entity explicitly, because the
9221 -- identifier may be overloaded and name resolution will not
9224 Generate_Reference
(E
, Arg
);
9226 -- Deal with exporting non-library level entity
9228 if not Is_Library_Level_Entity
(E
) then
9230 -- Not allowed at all for subprograms
9232 if Is_Subprogram
(E
) then
9233 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9235 -- Otherwise set public and statically allocated
9239 Set_Is_Statically_Allocated
(E
);
9241 -- Warn if the corresponding W flag is set
9243 if Warn_On_Export_Import
9245 -- Only do this for something that was in the source. Not
9246 -- clear if this can be False now (there used for sure to be
9247 -- cases on some systems where it was False), but anyway the
9248 -- test is harmless if not needed, so it is retained.
9250 and then Comes_From_Source
(Arg
)
9253 ("?x?& has been made static as a result of Export",
9256 ("\?x?this usage is non-standard and non-portable",
9262 if Warn_On_Export_Import
and then Is_Type
(E
) then
9263 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9266 if Warn_On_Export_Import
and Inside_A_Generic
then
9268 ("all instances of& will have the same external name?x?",
9273 ----------------------------------------------
9274 -- Set_Extended_Import_Export_External_Name --
9275 ----------------------------------------------
9277 procedure Set_Extended_Import_Export_External_Name
9278 (Internal_Ent
: Entity_Id
;
9279 Arg_External
: Node_Id
)
9281 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9285 if No
(Arg_External
) then
9289 Check_Arg_Is_External_Name
(Arg_External
);
9291 if Nkind
(Arg_External
) = N_String_Literal
then
9292 if String_Length
(Strval
(Arg_External
)) = 0 then
9295 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9298 elsif Nkind
(Arg_External
) = N_Identifier
then
9299 New_Name
:= Get_Default_External_Name
(Arg_External
);
9301 -- Check_Arg_Is_External_Name should let through only identifiers and
9302 -- string literals or static string expressions (which are folded to
9303 -- string literals).
9306 raise Program_Error
;
9309 -- If we already have an external name set (by a prior normal Import
9310 -- or Export pragma), then the external names must match
9312 if Present
(Interface_Name
(Internal_Ent
)) then
9314 -- Ignore mismatching names in CodePeer mode, to support some
9315 -- old compilers which would export the same procedure under
9316 -- different names, e.g:
9318 -- pragma Export_Procedure (P, "a");
9319 -- pragma Export_Procedure (P, "b");
9321 if CodePeer_Mode
then
9325 Check_Matching_Internal_Names
: declare
9326 S1
: constant String_Id
:= Strval
(Old_Name
);
9327 S2
: constant String_Id
:= Strval
(New_Name
);
9330 pragma No_Return
(Mismatch
);
9331 -- Called if names do not match
9337 procedure Mismatch
is
9339 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9341 ("external name does not match that given #",
9345 -- Start of processing for Check_Matching_Internal_Names
9348 if String_Length
(S1
) /= String_Length
(S2
) then
9352 for J
in 1 .. String_Length
(S1
) loop
9353 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9358 end Check_Matching_Internal_Names
;
9360 -- Otherwise set the given name
9363 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9364 Check_Duplicated_Export_Name
(New_Name
);
9366 end Set_Extended_Import_Export_External_Name
;
9372 procedure Set_Imported
(E
: Entity_Id
) is
9374 -- Error message if already imported or exported
9376 if Is_Exported
(E
) or else Is_Imported
(E
) then
9378 -- Error if being set Exported twice
9380 if Is_Exported
(E
) then
9381 Error_Msg_NE
("entity& was previously exported", N
, E
);
9383 -- Ignore error in CodePeer mode where we treat all imported
9384 -- subprograms as unknown.
9386 elsif CodePeer_Mode
then
9389 -- OK if Import/Interface case
9391 elsif Import_Interface_Present
(N
) then
9394 -- Error if being set Imported twice
9397 Error_Msg_NE
("entity& was previously imported", N
, E
);
9400 Error_Msg_Name_1
:= Pname
;
9402 ("\(pragma% applies to all previous entities)", N
);
9404 Error_Msg_Sloc
:= Sloc
(E
);
9405 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9407 -- Here if not previously imported or exported, OK to import
9410 Set_Is_Imported
(E
);
9412 -- For subprogram, set Import_Pragma field
9414 if Is_Subprogram
(E
) then
9415 Set_Import_Pragma
(E
, N
);
9418 -- If the entity is an object that is not at the library level,
9419 -- then it is statically allocated. We do not worry about objects
9420 -- with address clauses in this context since they are not really
9421 -- imported in the linker sense.
9424 and then not Is_Library_Level_Entity
(E
)
9425 and then No
(Address_Clause
(E
))
9427 Set_Is_Statically_Allocated
(E
);
9434 -------------------------
9435 -- Set_Mechanism_Value --
9436 -------------------------
9438 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9439 -- analyzed, since it is semantic nonsense), so we get it in the exact
9440 -- form created by the parser.
9442 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9443 procedure Bad_Mechanism
;
9444 pragma No_Return
(Bad_Mechanism
);
9445 -- Signal bad mechanism name
9447 -------------------------
9448 -- Bad_Mechanism_Value --
9449 -------------------------
9451 procedure Bad_Mechanism
is
9453 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9456 -- Start of processing for Set_Mechanism_Value
9459 if Mechanism
(Ent
) /= Default_Mechanism
then
9461 ("mechanism for & has already been set", Mech_Name
, Ent
);
9464 -- MECHANISM_NAME ::= value | reference
9466 if Nkind
(Mech_Name
) = N_Identifier
then
9467 if Chars
(Mech_Name
) = Name_Value
then
9468 Set_Mechanism
(Ent
, By_Copy
);
9471 elsif Chars
(Mech_Name
) = Name_Reference
then
9472 Set_Mechanism
(Ent
, By_Reference
);
9475 elsif Chars
(Mech_Name
) = Name_Copy
then
9477 ("bad mechanism name, Value assumed", Mech_Name
);
9486 end Set_Mechanism_Value
;
9488 --------------------------
9489 -- Set_Rational_Profile --
9490 --------------------------
9492 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9493 -- and extension to the semantics of renaming declarations.
9495 procedure Set_Rational_Profile
is
9497 Implicit_Packing
:= True;
9498 Overriding_Renamings
:= True;
9499 Use_VADS_Size
:= True;
9500 end Set_Rational_Profile
;
9502 ---------------------------
9503 -- Set_Ravenscar_Profile --
9504 ---------------------------
9506 -- The tasks to be done here are
9508 -- Set required policies
9510 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9511 -- pragma Locking_Policy (Ceiling_Locking)
9513 -- Set Detect_Blocking mode
9515 -- Set required restrictions (see System.Rident for detailed list)
9517 -- Set the No_Dependence rules
9518 -- No_Dependence => Ada.Asynchronous_Task_Control
9519 -- No_Dependence => Ada.Calendar
9520 -- No_Dependence => Ada.Execution_Time.Group_Budget
9521 -- No_Dependence => Ada.Execution_Time.Timers
9522 -- No_Dependence => Ada.Task_Attributes
9523 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9525 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9526 Prefix_Entity
: Entity_Id
;
9527 Selector_Entity
: Entity_Id
;
9528 Prefix_Node
: Node_Id
;
9532 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9534 if Task_Dispatching_Policy
/= ' '
9535 and then Task_Dispatching_Policy
/= 'F'
9537 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9538 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9540 -- Set the FIFO_Within_Priorities policy, but always preserve
9541 -- System_Location since we like the error message with the run time
9545 Task_Dispatching_Policy
:= 'F';
9547 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9548 Task_Dispatching_Policy_Sloc
:= Loc
;
9552 -- pragma Locking_Policy (Ceiling_Locking)
9554 if Locking_Policy
/= ' '
9555 and then Locking_Policy
/= 'C'
9557 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9558 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9560 -- Set the Ceiling_Locking policy, but preserve System_Location since
9561 -- we like the error message with the run time name.
9564 Locking_Policy
:= 'C';
9566 if Locking_Policy_Sloc
/= System_Location
then
9567 Locking_Policy_Sloc
:= Loc
;
9571 -- pragma Detect_Blocking
9573 Detect_Blocking
:= True;
9575 -- Set the corresponding restrictions
9577 Set_Profile_Restrictions
9578 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9580 -- Set the No_Dependence restrictions
9582 -- The following No_Dependence restrictions:
9583 -- No_Dependence => Ada.Asynchronous_Task_Control
9584 -- No_Dependence => Ada.Calendar
9585 -- No_Dependence => Ada.Task_Attributes
9586 -- are already set by previous call to Set_Profile_Restrictions.
9588 -- Set the following restrictions which were added to Ada 2005:
9589 -- No_Dependence => Ada.Execution_Time.Group_Budget
9590 -- No_Dependence => Ada.Execution_Time.Timers
9592 if Ada_Version
>= Ada_2005
then
9593 Name_Buffer
(1 .. 3) := "ada";
9596 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9598 Name_Buffer
(1 .. 14) := "execution_time";
9601 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9604 Make_Selected_Component
9606 Prefix
=> Prefix_Entity
,
9607 Selector_Name
=> Selector_Entity
);
9609 Name_Buffer
(1 .. 13) := "group_budgets";
9612 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9615 Make_Selected_Component
9617 Prefix
=> Prefix_Node
,
9618 Selector_Name
=> Selector_Entity
);
9620 Set_Restriction_No_Dependence
9622 Warn
=> Treat_Restrictions_As_Warnings
,
9623 Profile
=> Ravenscar
);
9625 Name_Buffer
(1 .. 6) := "timers";
9628 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9631 Make_Selected_Component
9633 Prefix
=> Prefix_Node
,
9634 Selector_Name
=> Selector_Entity
);
9636 Set_Restriction_No_Dependence
9638 Warn
=> Treat_Restrictions_As_Warnings
,
9639 Profile
=> Ravenscar
);
9642 -- Set the following restrictions which was added to Ada 2012 (see
9644 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9646 if Ada_Version
>= Ada_2012
then
9647 Name_Buffer
(1 .. 6) := "system";
9650 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9652 Name_Buffer
(1 .. 15) := "multiprocessors";
9655 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9658 Make_Selected_Component
9660 Prefix
=> Prefix_Entity
,
9661 Selector_Name
=> Selector_Entity
);
9663 Name_Buffer
(1 .. 19) := "dispatching_domains";
9666 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9669 Make_Selected_Component
9671 Prefix
=> Prefix_Node
,
9672 Selector_Name
=> Selector_Entity
);
9674 Set_Restriction_No_Dependence
9676 Warn
=> Treat_Restrictions_As_Warnings
,
9677 Profile
=> Ravenscar
);
9679 end Set_Ravenscar_Profile
;
9681 -- Start of processing for Analyze_Pragma
9684 -- The following code is a defense against recursion. Not clear that
9685 -- this can happen legitimately, but perhaps some error situations
9686 -- can cause it, and we did see this recursion during testing.
9688 if Analyzed
(N
) then
9691 Set_Analyzed
(N
, True);
9694 -- Deal with unrecognized pragma
9696 Pname
:= Pragma_Name
(N
);
9698 if not Is_Pragma_Name
(Pname
) then
9699 if Warn_On_Unrecognized_Pragma
then
9700 Error_Msg_Name_1
:= Pname
;
9701 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9703 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9704 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9705 Error_Msg_Name_1
:= PN
;
9706 Error_Msg_N
-- CODEFIX
9707 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9716 -- Here to start processing for recognized pragma
9718 Prag_Id
:= Get_Pragma_Id
(Pname
);
9719 Pname
:= Original_Aspect_Name
(N
);
9721 -- Capture setting of Opt.Uneval_Old
9723 case Opt
.Uneval_Old
is
9725 Set_Uneval_Old_Accept
(N
);
9729 Set_Uneval_Old_Warn
(N
);
9731 raise Program_Error
;
9734 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9735 -- is already set, indicating that we have already checked the policy
9736 -- at the right point. This happens for example in the case of a pragma
9737 -- that is derived from an Aspect.
9739 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9742 -- For a pragma that is a rewriting of another pragma, copy the
9743 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9745 elsif Is_Rewrite_Substitution
(N
)
9746 and then Nkind
(Original_Node
(N
)) = N_Pragma
9747 and then Original_Node
(N
) /= N
9749 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9750 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9752 -- Otherwise query the applicable policy at this point
9755 Check_Applicable_Policy
(N
);
9757 -- If pragma is disabled, rewrite as NULL and skip analysis
9759 if Is_Disabled
(N
) then
9760 Rewrite
(N
, Make_Null_Statement
(Loc
));
9774 if Present
(Pragma_Argument_Associations
(N
)) then
9775 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9776 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9778 if Present
(Arg1
) then
9779 Arg2
:= Next
(Arg1
);
9781 if Present
(Arg2
) then
9782 Arg3
:= Next
(Arg2
);
9784 if Present
(Arg3
) then
9785 Arg4
:= Next
(Arg3
);
9791 Check_Restriction_No_Use_Of_Pragma
(N
);
9793 -- An enumeration type defines the pragmas that are supported by the
9794 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9795 -- into the corresponding enumeration value for the following case.
9803 -- pragma Abort_Defer;
9805 when Pragma_Abort_Defer
=>
9807 Check_Arg_Count
(0);
9809 -- The only required semantic processing is to check the
9810 -- placement. This pragma must appear at the start of the
9811 -- statement sequence of a handled sequence of statements.
9813 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9814 or else N
/= First
(Statements
(Parent
(N
)))
9819 --------------------
9820 -- Abstract_State --
9821 --------------------
9823 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9825 -- ABSTRACT_STATE_LIST ::=
9827 -- | STATE_NAME_WITH_OPTIONS
9828 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9830 -- STATE_NAME_WITH_OPTIONS ::=
9832 -- | (STATE_NAME with OPTION_LIST)
9834 -- OPTION_LIST ::= OPTION {, OPTION}
9838 -- | NAME_VALUE_OPTION
9840 -- SIMPLE_OPTION ::= Ghost
9842 -- NAME_VALUE_OPTION ::=
9843 -- Part_Of => ABSTRACT_STATE
9844 -- | External [=> EXTERNAL_PROPERTY_LIST]
9846 -- EXTERNAL_PROPERTY_LIST ::=
9847 -- EXTERNAL_PROPERTY
9848 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9850 -- EXTERNAL_PROPERTY ::=
9851 -- Async_Readers [=> boolean_EXPRESSION]
9852 -- | Async_Writers [=> boolean_EXPRESSION]
9853 -- | Effective_Reads [=> boolean_EXPRESSION]
9854 -- | Effective_Writes [=> boolean_EXPRESSION]
9855 -- others => boolean_EXPRESSION
9857 -- STATE_NAME ::= defining_identifier
9859 -- ABSTRACT_STATE ::= name
9861 when Pragma_Abstract_State
=> Abstract_State
: declare
9862 Missing_Parentheses
: Boolean := False;
9863 -- Flag set when a state declaration with options is not properly
9866 -- Flags used to verify the consistency of states
9868 Non_Null_Seen
: Boolean := False;
9869 Null_Seen
: Boolean := False;
9871 procedure Analyze_Abstract_State
9873 Pack_Id
: Entity_Id
);
9874 -- Verify the legality of a single state declaration. Create and
9875 -- decorate a state abstraction entity and introduce it into the
9876 -- visibility chain. Pack_Id denotes the entity or the related
9877 -- package where pragma Abstract_State appears.
9879 ----------------------------
9880 -- Analyze_Abstract_State --
9881 ----------------------------
9883 procedure Analyze_Abstract_State
9885 Pack_Id
: Entity_Id
)
9887 -- Flags used to verify the consistency of options
9889 AR_Seen
: Boolean := False;
9890 AW_Seen
: Boolean := False;
9891 ER_Seen
: Boolean := False;
9892 EW_Seen
: Boolean := False;
9893 External_Seen
: Boolean := False;
9894 Others_Seen
: Boolean := False;
9895 Part_Of_Seen
: Boolean := False;
9897 -- Flags used to store the static value of all external states'
9900 AR_Val
: Boolean := False;
9901 AW_Val
: Boolean := False;
9902 ER_Val
: Boolean := False;
9903 EW_Val
: Boolean := False;
9905 State_Id
: Entity_Id
:= Empty
;
9906 -- The entity to be generated for the current state declaration
9908 procedure Analyze_External_Option
(Opt
: Node_Id
);
9909 -- Verify the legality of option External
9911 procedure Analyze_External_Property
9913 Expr
: Node_Id
:= Empty
);
9914 -- Verify the legailty of a single external property. Prop
9915 -- denotes the external property. Expr is the expression used
9916 -- to set the property.
9918 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9919 -- Verify the legality of option Part_Of
9921 procedure Check_Duplicate_Option
9923 Status
: in out Boolean);
9924 -- Flag Status denotes whether a particular option has been
9925 -- seen while processing a state. This routine verifies that
9926 -- Opt is not a duplicate option and sets the flag Status
9927 -- (SPARK RM 7.1.4(1)).
9929 procedure Check_Duplicate_Property
9931 Status
: in out Boolean);
9932 -- Flag Status denotes whether a particular property has been
9933 -- seen while processing option External. This routine verifies
9934 -- that Prop is not a duplicate property and sets flag Status.
9935 -- Opt is not a duplicate property and sets the flag Status.
9936 -- (SPARK RM 7.1.4(2))
9938 procedure Create_Abstract_State
9943 -- Generate an abstract state entity with name Nam and enter it
9944 -- into visibility. Decl is the "declaration" of the state as
9945 -- it appears in pragma Abstract_State. Loc is the location of
9946 -- the related state "declaration". Flag Is_Null should be set
9947 -- when the associated Abstract_State pragma defines a null
9950 -----------------------------
9951 -- Analyze_External_Option --
9952 -----------------------------
9954 procedure Analyze_External_Option
(Opt
: Node_Id
) is
9955 Errors
: constant Nat
:= Serious_Errors_Detected
;
9957 Props
: Node_Id
:= Empty
;
9960 Check_Duplicate_Option
(Opt
, External_Seen
);
9962 if Nkind
(Opt
) = N_Component_Association
then
9963 Props
:= Expression
(Opt
);
9966 -- External state with properties
9968 if Present
(Props
) then
9970 -- Multiple properties appear as an aggregate
9972 if Nkind
(Props
) = N_Aggregate
then
9974 -- Simple property form
9976 Prop
:= First
(Expressions
(Props
));
9977 while Present
(Prop
) loop
9978 Analyze_External_Property
(Prop
);
9982 -- Property with expression form
9984 Prop
:= First
(Component_Associations
(Props
));
9985 while Present
(Prop
) loop
9986 Analyze_External_Property
9987 (Prop
=> First
(Choices
(Prop
)),
9988 Expr
=> Expression
(Prop
));
9996 Analyze_External_Property
(Props
);
9999 -- An external state defined without any properties defaults
10000 -- all properties to True.
10009 -- Once all external properties have been processed, verify
10010 -- their mutual interaction. Do not perform the check when
10011 -- at least one of the properties is illegal as this will
10012 -- produce a bogus error.
10014 if Errors
= Serious_Errors_Detected
then
10015 Check_External_Properties
10016 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10018 end Analyze_External_Option
;
10020 -------------------------------
10021 -- Analyze_External_Property --
10022 -------------------------------
10024 procedure Analyze_External_Property
10026 Expr
: Node_Id
:= Empty
)
10028 Expr_Val
: Boolean;
10031 -- Check the placement of "others" (if available)
10033 if Nkind
(Prop
) = N_Others_Choice
then
10034 if Others_Seen
then
10036 ("only one others choice allowed in option External",
10039 Others_Seen
:= True;
10042 elsif Others_Seen
then
10044 ("others must be the last property in option External",
10047 -- The only remaining legal options are the four predefined
10048 -- external properties.
10050 elsif Nkind
(Prop
) = N_Identifier
10051 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10052 Name_Async_Writers
,
10053 Name_Effective_Reads
,
10054 Name_Effective_Writes
)
10058 -- Otherwise the construct is not a valid property
10061 SPARK_Msg_N
("invalid external state property", Prop
);
10065 -- Ensure that the expression of the external state property
10066 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10068 if Present
(Expr
) then
10069 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10071 if Is_OK_Static_Expression
(Expr
) then
10072 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10075 ("expression of external state property must be "
10079 -- The lack of expression defaults the property to True
10085 -- Named properties
10087 if Nkind
(Prop
) = N_Identifier
then
10088 if Chars
(Prop
) = Name_Async_Readers
then
10089 Check_Duplicate_Property
(Prop
, AR_Seen
);
10090 AR_Val
:= Expr_Val
;
10092 elsif Chars
(Prop
) = Name_Async_Writers
then
10093 Check_Duplicate_Property
(Prop
, AW_Seen
);
10094 AW_Val
:= Expr_Val
;
10096 elsif Chars
(Prop
) = Name_Effective_Reads
then
10097 Check_Duplicate_Property
(Prop
, ER_Seen
);
10098 ER_Val
:= Expr_Val
;
10101 Check_Duplicate_Property
(Prop
, EW_Seen
);
10102 EW_Val
:= Expr_Val
;
10105 -- The handling of property "others" must take into account
10106 -- all other named properties that have been encountered so
10107 -- far. Only those that have not been seen are affected by
10111 if not AR_Seen
then
10112 AR_Val
:= Expr_Val
;
10115 if not AW_Seen
then
10116 AW_Val
:= Expr_Val
;
10119 if not ER_Seen
then
10120 ER_Val
:= Expr_Val
;
10123 if not EW_Seen
then
10124 EW_Val
:= Expr_Val
;
10127 end Analyze_External_Property
;
10129 ----------------------------
10130 -- Analyze_Part_Of_Option --
10131 ----------------------------
10133 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10134 Encaps
: constant Node_Id
:= Expression
(Opt
);
10135 Encaps_Id
: Entity_Id
;
10139 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10142 (Item_Id
=> State_Id
,
10144 Indic
=> First
(Choices
(Opt
)),
10147 -- The Part_Of indicator turns an abstract state into a
10148 -- constituent of the encapsulating state.
10151 Encaps_Id
:= Entity
(Encaps
);
10153 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
10154 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
10156 end Analyze_Part_Of_Option
;
10158 ----------------------------
10159 -- Check_Duplicate_Option --
10160 ----------------------------
10162 procedure Check_Duplicate_Option
10164 Status
: in out Boolean)
10168 SPARK_Msg_N
("duplicate state option", Opt
);
10172 end Check_Duplicate_Option
;
10174 ------------------------------
10175 -- Check_Duplicate_Property --
10176 ------------------------------
10178 procedure Check_Duplicate_Property
10180 Status
: in out Boolean)
10184 SPARK_Msg_N
("duplicate external property", Prop
);
10188 end Check_Duplicate_Property
;
10190 ---------------------------
10191 -- Create_Abstract_State --
10192 ---------------------------
10194 procedure Create_Abstract_State
10201 -- The abstract state may be semi-declared when the related
10202 -- package was withed through a limited with clause. In that
10203 -- case reuse the entity to fully declare the state.
10205 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10206 State_Id
:= Entity
(Decl
);
10208 -- Otherwise the elaboration of pragma Abstract_State
10209 -- declares the state.
10212 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10214 if Present
(Decl
) then
10215 Set_Entity
(Decl
, State_Id
);
10219 -- Null states never come from source
10221 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10222 Set_Parent
(State_Id
, State
);
10223 Set_Ekind
(State_Id
, E_Abstract_State
);
10224 Set_Etype
(State_Id
, Standard_Void_Type
);
10225 Set_Encapsulating_State
(State_Id
, Empty
);
10226 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10227 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10229 -- An abstract state declared within a Ghost region becomes
10230 -- Ghost (SPARK RM 6.9(2)).
10232 if Ghost_Mode
> None
then
10233 Set_Is_Ghost_Entity
(State_Id
);
10236 -- Establish a link between the state declaration and the
10237 -- abstract state entity. Note that a null state remains as
10238 -- N_Null and does not carry any linkages.
10240 if not Is_Null
then
10241 if Present
(Decl
) then
10242 Set_Entity
(Decl
, State_Id
);
10243 Set_Etype
(Decl
, Standard_Void_Type
);
10246 -- Every non-null state must be defined, nameable and
10249 Push_Scope
(Pack_Id
);
10250 Generate_Definition
(State_Id
);
10251 Enter_Name
(State_Id
);
10254 end Create_Abstract_State
;
10261 -- Start of processing for Analyze_Abstract_State
10264 -- A package with a null abstract state is not allowed to
10265 -- declare additional states.
10269 ("package & has null abstract state", State
, Pack_Id
);
10271 -- Null states appear as internally generated entities
10273 elsif Nkind
(State
) = N_Null
then
10274 Create_Abstract_State
10275 (Nam
=> New_Internal_Name
('S'),
10277 Loc
=> Sloc
(State
),
10281 -- Catch a case where a null state appears in a list of
10282 -- non-null states.
10284 if Non_Null_Seen
then
10286 ("package & has non-null abstract state",
10290 -- Simple state declaration
10292 elsif Nkind
(State
) = N_Identifier
then
10293 Create_Abstract_State
10294 (Nam
=> Chars
(State
),
10296 Loc
=> Sloc
(State
),
10298 Non_Null_Seen
:= True;
10300 -- State declaration with various options. This construct
10301 -- appears as an extension aggregate in the tree.
10303 elsif Nkind
(State
) = N_Extension_Aggregate
then
10304 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10305 Create_Abstract_State
10306 (Nam
=> Chars
(Ancestor_Part
(State
)),
10307 Decl
=> Ancestor_Part
(State
),
10308 Loc
=> Sloc
(Ancestor_Part
(State
)),
10310 Non_Null_Seen
:= True;
10313 ("state name must be an identifier",
10314 Ancestor_Part
(State
));
10317 -- Options External and Ghost appear as expressions
10319 Opt
:= First
(Expressions
(State
));
10320 while Present
(Opt
) loop
10321 if Nkind
(Opt
) = N_Identifier
then
10322 if Chars
(Opt
) = Name_External
then
10323 Analyze_External_Option
(Opt
);
10325 elsif Chars
(Opt
) = Name_Ghost
then
10326 if Present
(State_Id
) then
10327 Set_Is_Ghost_Entity
(State_Id
);
10330 -- Option Part_Of without an encapsulating state is
10331 -- illegal. (SPARK RM 7.1.4(9)).
10333 elsif Chars
(Opt
) = Name_Part_Of
then
10335 ("indicator Part_Of must denote an abstract "
10338 -- Do not emit an error message when a previous state
10339 -- declaration with options was not parenthesized as
10340 -- the option is actually another state declaration.
10342 -- with Abstract_State
10343 -- (State_1 with ..., -- missing parentheses
10344 -- (State_2 with ...),
10345 -- State_3) -- ok state declaration
10347 elsif Missing_Parentheses
then
10350 -- Otherwise the option is not allowed. Note that it
10351 -- is not possible to distinguish between an option
10352 -- and a state declaration when a previous state with
10353 -- options not properly parentheses.
10355 -- with Abstract_State
10356 -- (State_1 with ..., -- missing parentheses
10357 -- State_2); -- could be an option
10361 ("simple option not allowed in state declaration",
10365 -- Catch a case where missing parentheses around a state
10366 -- declaration with options cause a subsequent state
10367 -- declaration with options to be treated as an option.
10369 -- with Abstract_State
10370 -- (State_1 with ..., -- missing parentheses
10371 -- (State_2 with ...))
10373 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10374 Missing_Parentheses
:= True;
10376 ("state declaration must be parenthesized",
10377 Ancestor_Part
(State
));
10379 -- Otherwise the option is malformed
10382 SPARK_Msg_N
("malformed option", Opt
);
10388 -- Options External and Part_Of appear as component
10391 Opt
:= First
(Component_Associations
(State
));
10392 while Present
(Opt
) loop
10393 Opt_Nam
:= First
(Choices
(Opt
));
10395 if Nkind
(Opt_Nam
) = N_Identifier
then
10396 if Chars
(Opt_Nam
) = Name_External
then
10397 Analyze_External_Option
(Opt
);
10399 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10400 Analyze_Part_Of_Option
(Opt
);
10403 SPARK_Msg_N
("invalid state option", Opt
);
10406 SPARK_Msg_N
("invalid state option", Opt
);
10412 -- Any other attempt to declare a state is illegal. This is a
10413 -- syntax error, always report.
10416 Error_Msg_N
("malformed abstract state declaration", State
);
10420 -- Guard against a junk state. In such cases no entity is
10421 -- generated and the subsequent checks cannot be applied.
10423 if Present
(State_Id
) then
10425 -- Verify whether the state does not introduce an illegal
10426 -- hidden state within a package subject to a null abstract
10429 Check_No_Hidden_State
(State_Id
);
10431 -- Check whether the lack of option Part_Of agrees with the
10432 -- placement of the abstract state with respect to the state
10435 if not Part_Of_Seen
then
10436 Check_Missing_Part_Of
(State_Id
);
10439 -- Associate the state with its related package
10441 if No
(Abstract_States
(Pack_Id
)) then
10442 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10445 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10447 end Analyze_Abstract_State
;
10451 Context
: constant Node_Id
:= Parent
(Parent
(N
));
10452 Pack_Id
: Entity_Id
;
10455 -- Start of processing for Abstract_State
10459 Check_No_Identifiers
;
10460 Check_Arg_Count
(1);
10461 Ensure_Aggregate_Form
(Arg1
);
10463 -- Ensure the proper placement of the pragma. Abstract states must
10464 -- be associated with a package declaration.
10466 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
10467 N_Package_Declaration
)
10473 State
:= Expression
(Arg1
);
10474 Pack_Id
:= Defining_Entity
(Context
);
10476 -- Mark the associated package as Ghost if it is subject to aspect
10477 -- or pragma Ghost as this affects the declaration of an abstract
10480 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10481 Set_Is_Ghost_Entity
(Pack_Id
);
10484 -- Multiple non-null abstract states appear as an aggregate
10486 if Nkind
(State
) = N_Aggregate
then
10487 State
:= First
(Expressions
(State
));
10488 while Present
(State
) loop
10489 Analyze_Abstract_State
(State
, Pack_Id
);
10493 -- Various forms of a single abstract state. Note that these may
10494 -- include malformed state declarations.
10497 Analyze_Abstract_State
(State
, Pack_Id
);
10500 -- Save the pragma for retrieval by other tools
10502 Add_Contract_Item
(N
, Pack_Id
);
10504 -- Verify the declaration order of pragmas Abstract_State and
10507 Check_Declaration_Order
10509 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10510 end Abstract_State
;
10518 -- Note: this pragma also has some specific processing in Par.Prag
10519 -- because we want to set the Ada version mode during parsing.
10521 when Pragma_Ada_83
=>
10523 Check_Arg_Count
(0);
10525 -- We really should check unconditionally for proper configuration
10526 -- pragma placement, since we really don't want mixed Ada modes
10527 -- within a single unit, and the GNAT reference manual has always
10528 -- said this was a configuration pragma, but we did not check and
10529 -- are hesitant to add the check now.
10531 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10532 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10533 -- or Ada 2012 mode.
10535 if Ada_Version
>= Ada_2005
then
10536 Check_Valid_Configuration_Pragma
;
10539 -- Now set Ada 83 mode
10541 Ada_Version
:= Ada_83
;
10542 Ada_Version_Explicit
:= Ada_83
;
10543 Ada_Version_Pragma
:= N
;
10551 -- Note: this pragma also has some specific processing in Par.Prag
10552 -- because we want to set the Ada 83 version mode during parsing.
10554 when Pragma_Ada_95
=>
10556 Check_Arg_Count
(0);
10558 -- We really should check unconditionally for proper configuration
10559 -- pragma placement, since we really don't want mixed Ada modes
10560 -- within a single unit, and the GNAT reference manual has always
10561 -- said this was a configuration pragma, but we did not check and
10562 -- are hesitant to add the check now.
10564 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10565 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10567 if Ada_Version
>= Ada_2005
then
10568 Check_Valid_Configuration_Pragma
;
10571 -- Now set Ada 95 mode
10573 Ada_Version
:= Ada_95
;
10574 Ada_Version_Explicit
:= Ada_95
;
10575 Ada_Version_Pragma
:= N
;
10577 ---------------------
10578 -- Ada_05/Ada_2005 --
10579 ---------------------
10582 -- pragma Ada_05 (LOCAL_NAME);
10584 -- pragma Ada_2005;
10585 -- pragma Ada_2005 (LOCAL_NAME):
10587 -- Note: these pragmas also have some specific processing in Par.Prag
10588 -- because we want to set the Ada 2005 version mode during parsing.
10590 -- The one argument form is used for managing the transition from
10591 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10592 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10593 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10594 -- mode, a preference rule is established which does not choose
10595 -- such an entity unless it is unambiguously specified. This avoids
10596 -- extra subprograms marked this way from generating ambiguities in
10597 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10598 -- intended for exclusive use in the GNAT run-time library.
10600 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10606 if Arg_Count
= 1 then
10607 Check_Arg_Is_Local_Name
(Arg1
);
10608 E_Id
:= Get_Pragma_Arg
(Arg1
);
10610 if Etype
(E_Id
) = Any_Type
then
10614 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10615 Record_Rep_Item
(Entity
(E_Id
), N
);
10618 Check_Arg_Count
(0);
10620 -- For Ada_2005 we unconditionally enforce the documented
10621 -- configuration pragma placement, since we do not want to
10622 -- tolerate mixed modes in a unit involving Ada 2005. That
10623 -- would cause real difficulties for those cases where there
10624 -- are incompatibilities between Ada 95 and Ada 2005.
10626 Check_Valid_Configuration_Pragma
;
10628 -- Now set appropriate Ada mode
10630 Ada_Version
:= Ada_2005
;
10631 Ada_Version_Explicit
:= Ada_2005
;
10632 Ada_Version_Pragma
:= N
;
10636 ---------------------
10637 -- Ada_12/Ada_2012 --
10638 ---------------------
10641 -- pragma Ada_12 (LOCAL_NAME);
10643 -- pragma Ada_2012;
10644 -- pragma Ada_2012 (LOCAL_NAME):
10646 -- Note: these pragmas also have some specific processing in Par.Prag
10647 -- because we want to set the Ada 2012 version mode during parsing.
10649 -- The one argument form is used for managing the transition from Ada
10650 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10651 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10652 -- mode will generate a warning. In addition, in any pre-Ada_2012
10653 -- mode, a preference rule is established which does not choose
10654 -- such an entity unless it is unambiguously specified. This avoids
10655 -- extra subprograms marked this way from generating ambiguities in
10656 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10657 -- intended for exclusive use in the GNAT run-time library.
10659 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10665 if Arg_Count
= 1 then
10666 Check_Arg_Is_Local_Name
(Arg1
);
10667 E_Id
:= Get_Pragma_Arg
(Arg1
);
10669 if Etype
(E_Id
) = Any_Type
then
10673 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10674 Record_Rep_Item
(Entity
(E_Id
), N
);
10677 Check_Arg_Count
(0);
10679 -- For Ada_2012 we unconditionally enforce the documented
10680 -- configuration pragma placement, since we do not want to
10681 -- tolerate mixed modes in a unit involving Ada 2012. That
10682 -- would cause real difficulties for those cases where there
10683 -- are incompatibilities between Ada 95 and Ada 2012. We could
10684 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10686 Check_Valid_Configuration_Pragma
;
10688 -- Now set appropriate Ada mode
10690 Ada_Version
:= Ada_2012
;
10691 Ada_Version_Explicit
:= Ada_2012
;
10692 Ada_Version_Pragma
:= N
;
10696 ----------------------
10697 -- All_Calls_Remote --
10698 ----------------------
10700 -- pragma All_Calls_Remote [(library_package_NAME)];
10702 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10703 Lib_Entity
: Entity_Id
;
10706 Check_Ada_83_Warning
;
10707 Check_Valid_Library_Unit_Pragma
;
10709 if Nkind
(N
) = N_Null_Statement
then
10713 Lib_Entity
:= Find_Lib_Unit_Name
;
10715 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10717 if Present
(Lib_Entity
)
10718 and then not Debug_Flag_U
10720 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10721 Error_Pragma
("pragma% only apply to rci unit");
10723 -- Set flag for entity of the library unit
10726 Set_Has_All_Calls_Remote
(Lib_Entity
);
10730 end All_Calls_Remote
;
10732 ---------------------------
10733 -- Allow_Integer_Address --
10734 ---------------------------
10736 -- pragma Allow_Integer_Address;
10738 when Pragma_Allow_Integer_Address
=>
10740 Check_Valid_Configuration_Pragma
;
10741 Check_Arg_Count
(0);
10743 -- If Address is a private type, then set the flag to allow
10744 -- integer address values. If Address is not private, then this
10745 -- pragma has no purpose, so it is simply ignored. Not clear if
10746 -- there are any such targets now.
10748 if Opt
.Address_Is_Private
then
10749 Opt
.Allow_Integer_Address
:= True;
10757 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10758 -- ARG ::= NAME | EXPRESSION
10760 -- The first two arguments are by convention intended to refer to an
10761 -- external tool and a tool-specific function. These arguments are
10764 when Pragma_Annotate
=> Annotate
: declare
10770 Check_At_Least_N_Arguments
(1);
10772 -- See if last argument is Entity => local_Name, and if so process
10773 -- and then remove it for remaining processing.
10776 Last_Arg
: constant Node_Id
:=
10777 Last
(Pragma_Argument_Associations
(N
));
10780 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10781 and then Chars
(Last_Arg
) = Name_Entity
10783 Check_Arg_Is_Local_Name
(Last_Arg
);
10784 Arg_Count
:= Arg_Count
- 1;
10786 -- Not allowed in compiler units (bootstrap issues)
10788 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10792 -- Continue processing with last argument removed for now
10794 Check_Arg_Is_Identifier
(Arg1
);
10795 Check_No_Identifiers
;
10798 -- Second parameter is optional, it is never analyzed
10803 -- Here if we have a second parameter
10806 -- Second parameter must be identifier
10808 Check_Arg_Is_Identifier
(Arg2
);
10810 -- Process remaining parameters if any
10812 Arg
:= Next
(Arg2
);
10813 while Present
(Arg
) loop
10814 Exp
:= Get_Pragma_Arg
(Arg
);
10817 if Is_Entity_Name
(Exp
) then
10820 -- For string literals, we assume Standard_String as the
10821 -- type, unless the string contains wide or wide_wide
10824 elsif Nkind
(Exp
) = N_String_Literal
then
10825 if Has_Wide_Wide_Character
(Exp
) then
10826 Resolve
(Exp
, Standard_Wide_Wide_String
);
10827 elsif Has_Wide_Character
(Exp
) then
10828 Resolve
(Exp
, Standard_Wide_String
);
10830 Resolve
(Exp
, Standard_String
);
10833 elsif Is_Overloaded
(Exp
) then
10835 ("ambiguous argument for pragma%", Exp
);
10846 -------------------------------------------------
10847 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10848 -------------------------------------------------
10851 -- ( [Check => ] Boolean_EXPRESSION
10852 -- [, [Message =>] Static_String_EXPRESSION]);
10854 -- pragma Assert_And_Cut
10855 -- ( [Check => ] Boolean_EXPRESSION
10856 -- [, [Message =>] Static_String_EXPRESSION]);
10859 -- ( [Check => ] Boolean_EXPRESSION
10860 -- [, [Message =>] Static_String_EXPRESSION]);
10862 -- pragma Loop_Invariant
10863 -- ( [Check => ] Boolean_EXPRESSION
10864 -- [, [Message =>] Static_String_EXPRESSION]);
10866 when Pragma_Assert |
10867 Pragma_Assert_And_Cut |
10869 Pragma_Loop_Invariant
=>
10871 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10872 -- Determine whether expression Expr contains a Loop_Entry
10873 -- attribute reference.
10875 -------------------------
10876 -- Contains_Loop_Entry --
10877 -------------------------
10879 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10880 Has_Loop_Entry
: Boolean := False;
10882 function Process
(N
: Node_Id
) return Traverse_Result
;
10883 -- Process function for traversal to look for Loop_Entry
10889 function Process
(N
: Node_Id
) return Traverse_Result
is
10891 if Nkind
(N
) = N_Attribute_Reference
10892 and then Attribute_Name
(N
) = Name_Loop_Entry
10894 Has_Loop_Entry
:= True;
10901 procedure Traverse
is new Traverse_Proc
(Process
);
10903 -- Start of processing for Contains_Loop_Entry
10907 return Has_Loop_Entry
;
10908 end Contains_Loop_Entry
;
10915 -- Start of processing for Assert
10918 -- Assert is an Ada 2005 RM-defined pragma
10920 if Prag_Id
= Pragma_Assert
then
10923 -- The remaining ones are GNAT pragmas
10929 Check_At_Least_N_Arguments
(1);
10930 Check_At_Most_N_Arguments
(2);
10931 Check_Arg_Order
((Name_Check
, Name_Message
));
10932 Check_Optional_Identifier
(Arg1
, Name_Check
);
10933 Expr
:= Get_Pragma_Arg
(Arg1
);
10935 -- Special processing for Loop_Invariant, Loop_Variant or for
10936 -- other cases where a Loop_Entry attribute is present. If the
10937 -- assertion pragma contains attribute Loop_Entry, ensure that
10938 -- the related pragma is within a loop.
10940 if Prag_Id
= Pragma_Loop_Invariant
10941 or else Prag_Id
= Pragma_Loop_Variant
10942 or else Contains_Loop_Entry
(Expr
)
10944 Check_Loop_Pragma_Placement
;
10946 -- Perform preanalysis to deal with embedded Loop_Entry
10949 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10952 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10953 -- a corresponding Check pragma:
10955 -- pragma Check (name, condition [, msg]);
10957 -- Where name is the identifier matching the pragma name. So
10958 -- rewrite pragma in this manner, transfer the message argument
10959 -- if present, and analyze the result
10961 -- Note: When dealing with a semantically analyzed tree, the
10962 -- information that a Check node N corresponds to a source Assert,
10963 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10964 -- pragma kind of Original_Node(N).
10967 Make_Pragma_Argument_Association
(Loc
,
10968 Expression
=> Make_Identifier
(Loc
, Pname
)),
10969 Make_Pragma_Argument_Association
(Sloc
(Expr
),
10970 Expression
=> Expr
));
10972 if Arg_Count
> 1 then
10973 Check_Optional_Identifier
(Arg2
, Name_Message
);
10975 -- Provide semantic annnotations for optional argument, for
10976 -- ASIS use, before rewriting.
10978 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
10979 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
10982 -- Rewrite as Check pragma
10986 Chars
=> Name_Check
,
10987 Pragma_Argument_Associations
=> Newa
));
10991 ----------------------
10992 -- Assertion_Policy --
10993 ----------------------
10995 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10997 -- The following form is Ada 2012 only, but we allow it in all modes
10999 -- Pragma Assertion_Policy (
11000 -- ASSERTION_KIND => POLICY_IDENTIFIER
11001 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11003 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11005 -- RM_ASSERTION_KIND ::= Assert |
11006 -- Static_Predicate |
11007 -- Dynamic_Predicate |
11012 -- Type_Invariant |
11013 -- Type_Invariant'Class
11015 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11017 -- Contract_Cases |
11019 -- Default_Initial_Condition |
11021 -- Initial_Condition |
11022 -- Loop_Invariant |
11028 -- Statement_Assertions
11030 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11031 -- ID_ASSERTION_KIND list contains implementation-defined additions
11032 -- recognized by GNAT. The effect is to control the behavior of
11033 -- identically named aspects and pragmas, depending on the specified
11034 -- policy identifier:
11036 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11038 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11039 -- implementation defined addition that results in totally ignoring
11040 -- the corresponding assertion. If Disable is specified, then the
11041 -- argument of the assertion is not even analyzed. This is useful
11042 -- when the aspect/pragma argument references entities in a with'ed
11043 -- package that is replaced by a dummy package in the final build.
11045 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11046 -- and Type_Invariant'Class were recognized by the parser and
11047 -- transformed into references to the special internal identifiers
11048 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11049 -- processing is required here.
11051 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11060 -- This can always appear as a configuration pragma
11062 if Is_Configuration_Pragma
then
11065 -- It can also appear in a declarative part or package spec in Ada
11066 -- 2012 mode. We allow this in other modes, but in that case we
11067 -- consider that we have an Ada 2012 pragma on our hands.
11070 Check_Is_In_Decl_Part_Or_Package_Spec
;
11074 -- One argument case with no identifier (first form above)
11077 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11078 or else Chars
(Arg1
) = No_Name
)
11080 Check_Arg_Is_One_Of
11081 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11083 -- Treat one argument Assertion_Policy as equivalent to:
11085 -- pragma Check_Policy (Assertion, policy)
11087 -- So rewrite pragma in that manner and link on to the chain
11088 -- of Check_Policy pragmas, marking the pragma as analyzed.
11090 Policy
:= Get_Pragma_Arg
(Arg1
);
11094 Chars
=> Name_Check_Policy
,
11095 Pragma_Argument_Associations
=> New_List
(
11096 Make_Pragma_Argument_Association
(Loc
,
11097 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11099 Make_Pragma_Argument_Association
(Loc
,
11101 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11104 -- Here if we have two or more arguments
11107 Check_At_Least_N_Arguments
(1);
11110 -- Loop through arguments
11113 while Present
(Arg
) loop
11114 LocP
:= Sloc
(Arg
);
11116 -- Kind must be specified
11118 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11119 or else Chars
(Arg
) = No_Name
11122 ("missing assertion kind for pragma%", Arg
);
11125 -- Check Kind and Policy have allowed forms
11127 Kind
:= Chars
(Arg
);
11129 if not Is_Valid_Assertion_Kind
(Kind
) then
11131 ("invalid assertion kind for pragma%", Arg
);
11134 Check_Arg_Is_One_Of
11135 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11137 -- Rewrite the Assertion_Policy pragma as a series of
11138 -- Check_Policy pragmas of the form:
11140 -- Check_Policy (Kind, Policy);
11142 -- Note: the insertion of the pragmas cannot be done with
11143 -- Insert_Action because in the configuration case, there
11144 -- are no scopes on the scope stack and the mechanism will
11147 Insert_Before_And_Analyze
(N
,
11149 Chars
=> Name_Check_Policy
,
11150 Pragma_Argument_Associations
=> New_List
(
11151 Make_Pragma_Argument_Association
(LocP
,
11152 Expression
=> Make_Identifier
(LocP
, Kind
)),
11153 Make_Pragma_Argument_Association
(LocP
,
11154 Expression
=> Get_Pragma_Arg
(Arg
)))));
11159 -- Rewrite the Assertion_Policy pragma as null since we have
11160 -- now inserted all the equivalent Check pragmas.
11162 Rewrite
(N
, Make_Null_Statement
(Loc
));
11165 end Assertion_Policy
;
11167 ------------------------------
11168 -- Assume_No_Invalid_Values --
11169 ------------------------------
11171 -- pragma Assume_No_Invalid_Values (On | Off);
11173 when Pragma_Assume_No_Invalid_Values
=>
11175 Check_Valid_Configuration_Pragma
;
11176 Check_Arg_Count
(1);
11177 Check_No_Identifiers
;
11178 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11180 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11181 Assume_No_Invalid_Values
:= True;
11183 Assume_No_Invalid_Values
:= False;
11186 --------------------------
11187 -- Attribute_Definition --
11188 --------------------------
11190 -- pragma Attribute_Definition
11191 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11192 -- [Entity =>] LOCAL_NAME,
11193 -- [Expression =>] EXPRESSION | NAME);
11195 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11196 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11201 Check_Arg_Count
(3);
11202 Check_Optional_Identifier
(Arg1
, "attribute");
11203 Check_Optional_Identifier
(Arg2
, "entity");
11204 Check_Optional_Identifier
(Arg3
, "expression");
11206 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11207 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11211 Check_Arg_Is_Local_Name
(Arg2
);
11213 -- If the attribute is not recognized, then issue a warning (not
11214 -- an error), and ignore the pragma.
11216 Aname
:= Chars
(Attribute_Designator
);
11218 if not Is_Attribute_Name
(Aname
) then
11219 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11223 -- Otherwise, rewrite the pragma as an attribute definition clause
11226 Make_Attribute_Definition_Clause
(Loc
,
11227 Name
=> Get_Pragma_Arg
(Arg2
),
11229 Expression
=> Get_Pragma_Arg
(Arg3
)));
11231 end Attribute_Definition
;
11233 ------------------------------------------------------------------
11234 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11235 ------------------------------------------------------------------
11237 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11238 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11239 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11240 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11242 -- FLAG ::= boolean_EXPRESSION
11244 when Pragma_Async_Readers |
11245 Pragma_Async_Writers |
11246 Pragma_Effective_Reads |
11247 Pragma_Effective_Writes
=>
11248 Async_Effective
: declare
11252 Obj_Id
: Entity_Id
;
11256 Check_No_Identifiers
;
11257 Check_At_Least_N_Arguments
(1);
11258 Check_At_Most_N_Arguments
(2);
11259 Check_Arg_Is_Local_Name
(Arg1
);
11260 Error_Msg_Name_1
:= Pname
;
11262 Obj
:= Get_Pragma_Arg
(Arg1
);
11263 Expr
:= Get_Pragma_Arg
(Arg2
);
11265 -- Perform minimal verification to ensure that the argument is at
11266 -- least a variable. Subsequent finer grained checks will be done
11267 -- at the end of the declarative region the contains the pragma.
11269 if Is_Entity_Name
(Obj
)
11270 and then Present
(Entity
(Obj
))
11271 and then Ekind
(Entity
(Obj
)) = E_Variable
11273 Obj_Id
:= Entity
(Obj
);
11275 -- Detect a duplicate pragma. Note that it is not efficient to
11276 -- examine preceding statements as Boolean aspects may appear
11277 -- anywhere between the related object declaration and its
11278 -- freeze point. As an alternative, inspect the contents of the
11279 -- variable contract.
11281 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11283 if Present
(Duplic
) then
11284 Error_Msg_Sloc
:= Sloc
(Duplic
);
11285 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11287 -- No duplicate detected
11290 if Present
(Expr
) then
11291 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11294 -- Chain the pragma on the contract for further processing
11296 Add_Contract_Item
(N
, Obj_Id
);
11299 Error_Pragma
("pragma % must apply to a volatile object");
11301 end Async_Effective
;
11307 -- pragma Asynchronous (LOCAL_NAME);
11309 when Pragma_Asynchronous
=> Asynchronous
: declare
11315 Formal
: Entity_Id
;
11317 procedure Process_Async_Pragma
;
11318 -- Common processing for procedure and access-to-procedure case
11320 --------------------------
11321 -- Process_Async_Pragma --
11322 --------------------------
11324 procedure Process_Async_Pragma
is
11327 Set_Is_Asynchronous
(Nm
);
11331 -- The formals should be of mode IN (RM E.4.1(6))
11334 while Present
(S
) loop
11335 Formal
:= Defining_Identifier
(S
);
11337 if Nkind
(Formal
) = N_Defining_Identifier
11338 and then Ekind
(Formal
) /= E_In_Parameter
11341 ("pragma% procedure can only have IN parameter",
11348 Set_Is_Asynchronous
(Nm
);
11349 end Process_Async_Pragma
;
11351 -- Start of processing for pragma Asynchronous
11354 Check_Ada_83_Warning
;
11355 Check_No_Identifiers
;
11356 Check_Arg_Count
(1);
11357 Check_Arg_Is_Local_Name
(Arg1
);
11359 if Debug_Flag_U
then
11363 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11364 Analyze
(Get_Pragma_Arg
(Arg1
));
11365 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11367 if not Is_Remote_Call_Interface
(C_Ent
)
11368 and then not Is_Remote_Types
(C_Ent
)
11370 -- This pragma should only appear in an RCI or Remote Types
11371 -- unit (RM E.4.1(4)).
11374 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11377 if Ekind
(Nm
) = E_Procedure
11378 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11380 if not Is_Remote_Call_Interface
(Nm
) then
11382 ("pragma% cannot be applied on non-remote procedure",
11386 L
:= Parameter_Specifications
(Parent
(Nm
));
11387 Process_Async_Pragma
;
11390 elsif Ekind
(Nm
) = E_Function
then
11392 ("pragma% cannot be applied to function", Arg1
);
11394 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11395 if Is_Record_Type
(Nm
) then
11397 -- A record type that is the Equivalent_Type for a remote
11398 -- access-to-subprogram type.
11400 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11403 -- A non-expanded RAS type (distribution is not enabled)
11405 N
:= Declaration_Node
(Nm
);
11408 if Nkind
(N
) = N_Full_Type_Declaration
11409 and then Nkind
(Type_Definition
(N
)) =
11410 N_Access_Procedure_Definition
11412 L
:= Parameter_Specifications
(Type_Definition
(N
));
11413 Process_Async_Pragma
;
11415 if Is_Asynchronous
(Nm
)
11416 and then Expander_Active
11417 and then Get_PCS_Name
/= Name_No_DSA
11419 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11424 ("pragma% cannot reference access-to-function type",
11428 -- Only other possibility is Access-to-class-wide type
11430 elsif Is_Access_Type
(Nm
)
11431 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11433 Check_First_Subtype
(Arg1
);
11434 Set_Is_Asynchronous
(Nm
);
11435 if Expander_Active
then
11436 RACW_Type_Is_Asynchronous
(Nm
);
11440 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11448 -- pragma Atomic (LOCAL_NAME);
11450 when Pragma_Atomic
=>
11451 Process_Atomic_Independent_Shared_Volatile
;
11453 -----------------------
11454 -- Atomic_Components --
11455 -----------------------
11457 -- pragma Atomic_Components (array_LOCAL_NAME);
11459 -- This processing is shared by Volatile_Components
11461 when Pragma_Atomic_Components |
11462 Pragma_Volatile_Components
=>
11464 Atomic_Components
: declare
11471 Check_Ada_83_Warning
;
11472 Check_No_Identifiers
;
11473 Check_Arg_Count
(1);
11474 Check_Arg_Is_Local_Name
(Arg1
);
11475 E_Id
:= Get_Pragma_Arg
(Arg1
);
11477 if Etype
(E_Id
) = Any_Type
then
11481 E
:= Entity
(E_Id
);
11483 Check_Duplicate_Pragma
(E
);
11485 if Rep_Item_Too_Early
(E
, N
)
11487 Rep_Item_Too_Late
(E
, N
)
11492 D
:= Declaration_Node
(E
);
11495 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11497 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11498 and then Nkind
(D
) = N_Object_Declaration
11499 and then Nkind
(Object_Definition
(D
)) =
11500 N_Constrained_Array_Definition
)
11502 -- The flag is set on the object, or on the base type
11504 if Nkind
(D
) /= N_Object_Declaration
then
11505 E
:= Base_Type
(E
);
11508 -- Atomic implies both Independent and Volatile
11510 if Prag_Id
= Pragma_Atomic_Components
then
11511 Set_Has_Atomic_Components
(E
);
11512 Set_Has_Independent_Components
(E
);
11515 Set_Has_Volatile_Components
(E
);
11518 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11520 end Atomic_Components
;
11522 --------------------
11523 -- Attach_Handler --
11524 --------------------
11526 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11528 when Pragma_Attach_Handler
=>
11529 Check_Ada_83_Warning
;
11530 Check_No_Identifiers
;
11531 Check_Arg_Count
(2);
11533 if No_Run_Time_Mode
then
11534 Error_Msg_CRT
("Attach_Handler pragma", N
);
11536 Check_Interrupt_Or_Attach_Handler
;
11538 -- The expression that designates the attribute may depend on a
11539 -- discriminant, and is therefore a per-object expression, to
11540 -- be expanded in the init proc. If expansion is enabled, then
11541 -- perform semantic checks on a copy only.
11546 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11549 -- In Relaxed_RM_Semantics mode, we allow any static
11550 -- integer value, for compatibility with other compilers.
11552 if Relaxed_RM_Semantics
11553 and then Nkind
(Parg2
) = N_Integer_Literal
11555 Typ
:= Standard_Integer
;
11557 Typ
:= RTE
(RE_Interrupt_ID
);
11560 if Expander_Active
then
11561 Temp
:= New_Copy_Tree
(Parg2
);
11562 Set_Parent
(Temp
, N
);
11563 Preanalyze_And_Resolve
(Temp
, Typ
);
11566 Resolve
(Parg2
, Typ
);
11570 Process_Interrupt_Or_Attach_Handler
;
11573 --------------------
11574 -- C_Pass_By_Copy --
11575 --------------------
11577 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11579 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11585 Check_Valid_Configuration_Pragma
;
11586 Check_Arg_Count
(1);
11587 Check_Optional_Identifier
(Arg1
, "max_size");
11589 Arg
:= Get_Pragma_Arg
(Arg1
);
11590 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11592 Val
:= Expr_Value
(Arg
);
11596 ("maximum size for pragma% must be positive", Arg1
);
11598 elsif UI_Is_In_Int_Range
(Val
) then
11599 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11601 -- If a giant value is given, Int'Last will do well enough.
11602 -- If sometime someone complains that a record larger than
11603 -- two gigabytes is not copied, we will worry about it then.
11606 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11608 end C_Pass_By_Copy
;
11614 -- pragma Check ([Name =>] CHECK_KIND,
11615 -- [Check =>] Boolean_EXPRESSION
11616 -- [,[Message =>] String_EXPRESSION]);
11618 -- CHECK_KIND ::= IDENTIFIER |
11621 -- Invariant'Class |
11622 -- Type_Invariant'Class
11624 -- The identifiers Assertions and Statement_Assertions are not
11625 -- allowed, since they have special meaning for Check_Policy.
11627 when Pragma_Check
=> Check
: declare
11635 Check_At_Least_N_Arguments
(2);
11636 Check_At_Most_N_Arguments
(3);
11637 Check_Optional_Identifier
(Arg1
, Name_Name
);
11638 Check_Optional_Identifier
(Arg2
, Name_Check
);
11640 if Arg_Count
= 3 then
11641 Check_Optional_Identifier
(Arg3
, Name_Message
);
11642 Str
:= Get_Pragma_Arg
(Arg3
);
11645 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11646 Check_Arg_Is_Identifier
(Arg1
);
11647 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11649 -- Check forbidden name Assertions or Statement_Assertions
11652 when Name_Assertions
=>
11654 ("""Assertions"" is not allowed as a check kind "
11655 & "for pragma%", Arg1
);
11657 when Name_Statement_Assertions
=>
11659 ("""Statement_Assertions"" is not allowed as a check kind "
11660 & "for pragma%", Arg1
);
11666 -- Check applicable policy. We skip this if Checked/Ignored status
11667 -- is already set (e.g. in the casse of a pragma from an aspect).
11669 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11672 -- For a non-source pragma that is a rewriting of another pragma,
11673 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11675 elsif Is_Rewrite_Substitution
(N
)
11676 and then Nkind
(Original_Node
(N
)) = N_Pragma
11677 and then Original_Node
(N
) /= N
11679 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11680 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11682 -- Otherwise query the applicable policy at this point
11685 case Check_Kind
(Cname
) is
11686 when Name_Ignore
=>
11687 Set_Is_Ignored
(N
, True);
11688 Set_Is_Checked
(N
, False);
11691 Set_Is_Ignored
(N
, False);
11692 Set_Is_Checked
(N
, True);
11694 -- For disable, rewrite pragma as null statement and skip
11695 -- rest of the analysis of the pragma.
11697 when Name_Disable
=>
11698 Rewrite
(N
, Make_Null_Statement
(Loc
));
11702 -- No other possibilities
11705 raise Program_Error
;
11709 -- If check kind was not Disable, then continue pragma analysis
11711 Expr
:= Get_Pragma_Arg
(Arg2
);
11713 -- Deal with SCO generation
11716 when Name_Predicate |
11719 -- Nothing to do: since checks occur in client units,
11720 -- the SCO for the aspect in the declaration unit is
11721 -- conservatively always enabled.
11727 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11729 -- Mark aspect/pragma SCO as enabled
11731 Set_SCO_Pragma_Enabled
(Loc
);
11735 -- Deal with analyzing the string argument.
11737 if Arg_Count
= 3 then
11739 -- If checks are not on we don't want any expansion (since
11740 -- such expansion would not get properly deleted) but
11741 -- we do want to analyze (to get proper references).
11742 -- The Preanalyze_And_Resolve routine does just what we want
11744 if Is_Ignored
(N
) then
11745 Preanalyze_And_Resolve
(Str
, Standard_String
);
11747 -- Otherwise we need a proper analysis and expansion
11750 Analyze_And_Resolve
(Str
, Standard_String
);
11754 -- Now you might think we could just do the same with the Boolean
11755 -- expression if checks are off (and expansion is on) and then
11756 -- rewrite the check as a null statement. This would work but we
11757 -- would lose the useful warnings about an assertion being bound
11758 -- to fail even if assertions are turned off.
11760 -- So instead we wrap the boolean expression in an if statement
11761 -- that looks like:
11763 -- if False and then condition then
11767 -- The reason we do this rewriting during semantic analysis rather
11768 -- than as part of normal expansion is that we cannot analyze and
11769 -- expand the code for the boolean expression directly, or it may
11770 -- cause insertion of actions that would escape the attempt to
11771 -- suppress the check code.
11773 -- Note that the Sloc for the if statement corresponds to the
11774 -- argument condition, not the pragma itself. The reason for
11775 -- this is that we may generate a warning if the condition is
11776 -- False at compile time, and we do not want to delete this
11777 -- warning when we delete the if statement.
11779 if Expander_Active
and Is_Ignored
(N
) then
11780 Eloc
:= Sloc
(Expr
);
11783 Make_If_Statement
(Eloc
,
11785 Make_And_Then
(Eloc
,
11786 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
11787 Right_Opnd
=> Expr
),
11788 Then_Statements
=> New_List
(
11789 Make_Null_Statement
(Eloc
))));
11791 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11793 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11795 -- Check is active or expansion not active. In these cases we can
11796 -- just go ahead and analyze the boolean with no worries.
11799 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11800 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11801 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11805 --------------------------
11806 -- Check_Float_Overflow --
11807 --------------------------
11809 -- pragma Check_Float_Overflow;
11811 when Pragma_Check_Float_Overflow
=>
11813 Check_Valid_Configuration_Pragma
;
11814 Check_Arg_Count
(0);
11815 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11821 -- pragma Check_Name (check_IDENTIFIER);
11823 when Pragma_Check_Name
=>
11825 Check_No_Identifiers
;
11826 Check_Valid_Configuration_Pragma
;
11827 Check_Arg_Count
(1);
11828 Check_Arg_Is_Identifier
(Arg1
);
11831 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11834 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11835 if Check_Names
.Table
(J
) = Nam
then
11840 Check_Names
.Append
(Nam
);
11847 -- This is the old style syntax, which is still allowed in all modes:
11849 -- pragma Check_Policy ([Name =>] CHECK_KIND
11850 -- [Policy =>] POLICY_IDENTIFIER);
11852 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11854 -- CHECK_KIND ::= IDENTIFIER |
11857 -- Type_Invariant'Class |
11860 -- This is the new style syntax, compatible with Assertion_Policy
11861 -- and also allowed in all modes.
11863 -- Pragma Check_Policy (
11864 -- CHECK_KIND => POLICY_IDENTIFIER
11865 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11867 -- Note: the identifiers Name and Policy are not allowed as
11868 -- Check_Kind values. This avoids ambiguities between the old and
11869 -- new form syntax.
11871 when Pragma_Check_Policy
=> Check_Policy
: declare
11877 Check_At_Least_N_Arguments
(1);
11879 -- A Check_Policy pragma can appear either as a configuration
11880 -- pragma, or in a declarative part or a package spec (see RM
11881 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11882 -- followed for Check_Policy).
11884 if not Is_Configuration_Pragma
then
11885 Check_Is_In_Decl_Part_Or_Package_Spec
;
11888 -- Figure out if we have the old or new syntax. We have the
11889 -- old syntax if the first argument has no identifier, or the
11890 -- identifier is Name.
11892 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11893 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11897 Check_Arg_Count
(2);
11898 Check_Optional_Identifier
(Arg1
, Name_Name
);
11899 Kind
:= Get_Pragma_Arg
(Arg1
);
11900 Rewrite_Assertion_Kind
(Kind
);
11901 Check_Arg_Is_Identifier
(Arg1
);
11903 -- Check forbidden check kind
11905 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11906 Error_Msg_Name_2
:= Chars
(Kind
);
11908 ("pragma% does not allow% as check name", Arg1
);
11913 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11914 Check_Arg_Is_One_Of
11916 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11917 Ident
:= Get_Pragma_Arg
(Arg2
);
11919 if Chars
(Kind
) = Name_Ghost
then
11921 -- Pragma Check_Policy specifying a Ghost policy cannot
11922 -- occur within a ghost subprogram or package.
11924 if Ghost_Mode
> None
then
11926 ("pragma % cannot appear within ghost subprogram or "
11929 -- The policy identifier of pragma Ghost must be either
11930 -- Check or Ignore (SPARK RM 6.9(7)).
11932 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11936 ("argument of pragma % Ghost must be Check or Ignore",
11941 -- And chain pragma on the Check_Policy_List for search
11943 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11944 Opt
.Check_Policy_List
:= N
;
11946 -- For the new syntax, what we do is to convert each argument to
11947 -- an old syntax equivalent. We do that because we want to chain
11948 -- old style Check_Policy pragmas for the search (we don't want
11949 -- to have to deal with multiple arguments in the search).
11959 while Present
(Arg
) loop
11960 LocP
:= Sloc
(Arg
);
11961 Argx
:= Get_Pragma_Arg
(Arg
);
11963 -- Kind must be specified
11965 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11966 or else Chars
(Arg
) = No_Name
11969 ("missing assertion kind for pragma%", Arg
);
11972 -- Construct equivalent old form syntax Check_Policy
11973 -- pragma and insert it to get remaining checks.
11977 Chars
=> Name_Check_Policy
,
11978 Pragma_Argument_Associations
=> New_List
(
11979 Make_Pragma_Argument_Association
(LocP
,
11981 Make_Identifier
(LocP
, Chars
(Arg
))),
11982 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11983 Expression
=> Argx
))));
11988 -- Rewrite original Check_Policy pragma to null, since we
11989 -- have converted it into a series of old syntax pragmas.
11991 Rewrite
(N
, Make_Null_Statement
(Loc
));
11997 ---------------------
11998 -- CIL_Constructor --
11999 ---------------------
12001 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12003 -- Processing for this pragma is shared with Java_Constructor
12009 -- pragma Comment (static_string_EXPRESSION)
12011 -- Processing for pragma Comment shares the circuitry for pragma
12012 -- Ident. The only differences are that Ident enforces a limit of 31
12013 -- characters on its argument, and also enforces limitations on
12014 -- placement for DEC compatibility. Pragma Comment shares neither of
12015 -- these restrictions.
12017 -------------------
12018 -- Common_Object --
12019 -------------------
12021 -- pragma Common_Object (
12022 -- [Internal =>] LOCAL_NAME
12023 -- [, [External =>] EXTERNAL_SYMBOL]
12024 -- [, [Size =>] EXTERNAL_SYMBOL]);
12026 -- Processing for this pragma is shared with Psect_Object
12028 ------------------------
12029 -- Compile_Time_Error --
12030 ------------------------
12032 -- pragma Compile_Time_Error
12033 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12035 when Pragma_Compile_Time_Error
=>
12037 Process_Compile_Time_Warning_Or_Error
;
12039 --------------------------
12040 -- Compile_Time_Warning --
12041 --------------------------
12043 -- pragma Compile_Time_Warning
12044 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12046 when Pragma_Compile_Time_Warning
=>
12048 Process_Compile_Time_Warning_Or_Error
;
12050 ---------------------------
12051 -- Compiler_Unit_Warning --
12052 ---------------------------
12054 -- pragma Compiler_Unit_Warning;
12058 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12059 -- errors not warnings. This means that we had introduced a big extra
12060 -- inertia to compiler changes, since even if we implemented a new
12061 -- feature, and even if all versions to be used for bootstrapping
12062 -- implemented this new feature, we could not use it, since old
12063 -- compilers would give errors for using this feature in units
12064 -- having Compiler_Unit pragmas.
12066 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12067 -- problem. We no longer have any units mentioning Compiler_Unit,
12068 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12069 -- and thus generates a warning which can be ignored. So that deals
12070 -- with the problem of old compilers not implementing the newer form
12073 -- Newer compilers recognize the new pragma, but generate warning
12074 -- messages instead of errors, which again can be ignored in the
12075 -- case of an old compiler which implements a wanted new feature
12076 -- but at the time felt like warning about it for older compilers.
12078 -- We retain Compiler_Unit so that new compilers can be used to build
12079 -- older run-times that use this pragma. That's an unusual case, but
12080 -- it's easy enough to handle, so why not?
12082 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12084 Check_Arg_Count
(0);
12086 -- Only recognized in main unit
12088 if Current_Sem_Unit
= Main_Unit
then
12089 Compiler_Unit
:= True;
12092 -----------------------------
12093 -- Complete_Representation --
12094 -----------------------------
12096 -- pragma Complete_Representation;
12098 when Pragma_Complete_Representation
=>
12100 Check_Arg_Count
(0);
12102 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12104 ("pragma & must appear within record representation clause");
12107 ----------------------------
12108 -- Complex_Representation --
12109 ----------------------------
12111 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12113 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12120 Check_Arg_Count
(1);
12121 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12122 Check_Arg_Is_Local_Name
(Arg1
);
12123 E_Id
:= Get_Pragma_Arg
(Arg1
);
12125 if Etype
(E_Id
) = Any_Type
then
12129 E
:= Entity
(E_Id
);
12131 if not Is_Record_Type
(E
) then
12133 ("argument for pragma% must be record type", Arg1
);
12136 Ent
:= First_Entity
(E
);
12139 or else No
(Next_Entity
(Ent
))
12140 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12141 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12142 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12145 ("record for pragma% must have two fields of the same "
12146 & "floating-point type", Arg1
);
12149 Set_Has_Complex_Representation
(Base_Type
(E
));
12151 -- We need to treat the type has having a non-standard
12152 -- representation, for back-end purposes, even though in
12153 -- general a complex will have the default representation
12154 -- of a record with two real components.
12156 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12158 end Complex_Representation
;
12160 -------------------------
12161 -- Component_Alignment --
12162 -------------------------
12164 -- pragma Component_Alignment (
12165 -- [Form =>] ALIGNMENT_CHOICE
12166 -- [, [Name =>] type_LOCAL_NAME]);
12168 -- ALIGNMENT_CHOICE ::=
12170 -- | Component_Size_4
12174 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12175 Args
: Args_List
(1 .. 2);
12176 Names
: constant Name_List
(1 .. 2) := (
12180 Form
: Node_Id
renames Args
(1);
12181 Name
: Node_Id
renames Args
(2);
12183 Atype
: Component_Alignment_Kind
;
12188 Gather_Associations
(Names
, Args
);
12191 Error_Pragma
("missing Form argument for pragma%");
12194 Check_Arg_Is_Identifier
(Form
);
12196 -- Get proper alignment, note that Default = Component_Size on all
12197 -- machines we have so far, and we want to set this value rather
12198 -- than the default value to indicate that it has been explicitly
12199 -- set (and thus will not get overridden by the default component
12200 -- alignment for the current scope)
12202 if Chars
(Form
) = Name_Component_Size
then
12203 Atype
:= Calign_Component_Size
;
12205 elsif Chars
(Form
) = Name_Component_Size_4
then
12206 Atype
:= Calign_Component_Size_4
;
12208 elsif Chars
(Form
) = Name_Default
then
12209 Atype
:= Calign_Component_Size
;
12211 elsif Chars
(Form
) = Name_Storage_Unit
then
12212 Atype
:= Calign_Storage_Unit
;
12216 ("invalid Form parameter for pragma%", Form
);
12219 -- Case with no name, supplied, affects scope table entry
12223 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12225 -- Case of name supplied
12228 Check_Arg_Is_Local_Name
(Name
);
12230 Typ
:= Entity
(Name
);
12233 or else Rep_Item_Too_Early
(Typ
, N
)
12237 Typ
:= Underlying_Type
(Typ
);
12240 if not Is_Record_Type
(Typ
)
12241 and then not Is_Array_Type
(Typ
)
12244 ("Name parameter of pragma% must identify record or "
12245 & "array type", Name
);
12248 -- An explicit Component_Alignment pragma overrides an
12249 -- implicit pragma Pack, but not an explicit one.
12251 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12252 Set_Is_Packed
(Base_Type
(Typ
), False);
12253 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12256 end Component_AlignmentP
;
12258 --------------------
12259 -- Contract_Cases --
12260 --------------------
12262 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12264 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12266 -- CASE_GUARD ::= boolean_EXPRESSION | others
12268 -- CONSEQUENCE ::= boolean_EXPRESSION
12270 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12271 Subp_Decl
: Node_Id
;
12275 Check_No_Identifiers
;
12276 Check_Arg_Count
(1);
12277 Ensure_Aggregate_Form
(Arg1
);
12279 -- The pragma is analyzed at the end of the declarative part which
12280 -- contains the related subprogram. Reset the analyzed flag.
12282 Set_Analyzed
(N
, False);
12284 -- Ensure the proper placement of the pragma. Contract_Cases must
12285 -- be associated with a subprogram declaration or a body that acts
12289 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12291 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12294 -- Body acts as spec
12296 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12297 and then No
(Corresponding_Spec
(Subp_Decl
))
12301 -- Body stub acts as spec
12303 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12304 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12313 -- When the pragma appears on a subprogram body, perform the full
12316 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12317 Analyze_Contract_Cases_In_Decl_Part
(N
);
12319 -- When Contract_Cases applies to a subprogram compilation unit,
12320 -- the corresponding pragma is placed after the unit's declaration
12321 -- node and needs to be analyzed immediately.
12323 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
12324 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
12326 Analyze_Contract_Cases_In_Decl_Part
(N
);
12329 -- Chain the pragma on the contract for further processing
12331 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12332 end Contract_Cases
;
12338 -- pragma Controlled (first_subtype_LOCAL_NAME);
12340 when Pragma_Controlled
=> Controlled
: declare
12344 Check_No_Identifiers
;
12345 Check_Arg_Count
(1);
12346 Check_Arg_Is_Local_Name
(Arg1
);
12347 Arg
:= Get_Pragma_Arg
(Arg1
);
12349 if not Is_Entity_Name
(Arg
)
12350 or else not Is_Access_Type
(Entity
(Arg
))
12352 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12354 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12362 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12363 -- [Entity =>] LOCAL_NAME);
12365 when Pragma_Convention
=> Convention
: declare
12368 pragma Warnings
(Off
, C
);
12369 pragma Warnings
(Off
, E
);
12371 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12372 Check_Ada_83_Warning
;
12373 Check_Arg_Count
(2);
12374 Process_Convention
(C
, E
);
12377 ---------------------------
12378 -- Convention_Identifier --
12379 ---------------------------
12381 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12382 -- [Convention =>] convention_IDENTIFIER);
12384 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12390 Check_Arg_Order
((Name_Name
, Name_Convention
));
12391 Check_Arg_Count
(2);
12392 Check_Optional_Identifier
(Arg1
, Name_Name
);
12393 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12394 Check_Arg_Is_Identifier
(Arg1
);
12395 Check_Arg_Is_Identifier
(Arg2
);
12396 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12397 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12399 if Is_Convention_Name
(Cname
) then
12400 Record_Convention_Identifier
12401 (Idnam
, Get_Convention_Id
(Cname
));
12404 ("second arg for % pragma must be convention", Arg2
);
12406 end Convention_Identifier
;
12412 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12414 when Pragma_CPP_Class
=> CPP_Class
: declare
12418 if Warn_On_Obsolescent_Feature
then
12420 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12421 & "effect; replace it by pragma import?j?", N
);
12424 Check_Arg_Count
(1);
12428 Chars
=> Name_Import
,
12429 Pragma_Argument_Associations
=> New_List
(
12430 Make_Pragma_Argument_Association
(Loc
,
12431 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12432 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12436 ---------------------
12437 -- CPP_Constructor --
12438 ---------------------
12440 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12441 -- [, [External_Name =>] static_string_EXPRESSION ]
12442 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12444 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12447 Def_Id
: Entity_Id
;
12448 Tag_Typ
: Entity_Id
;
12452 Check_At_Least_N_Arguments
(1);
12453 Check_At_Most_N_Arguments
(3);
12454 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12455 Check_Arg_Is_Local_Name
(Arg1
);
12457 Id
:= Get_Pragma_Arg
(Arg1
);
12458 Find_Program_Unit_Name
(Id
);
12460 -- If we did not find the name, we are done
12462 if Etype
(Id
) = Any_Type
then
12466 Def_Id
:= Entity
(Id
);
12468 -- Check if already defined as constructor
12470 if Is_Constructor
(Def_Id
) then
12472 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12476 if Ekind
(Def_Id
) = E_Function
12477 and then (Is_CPP_Class
(Etype
(Def_Id
))
12478 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12480 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12482 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12484 ("'C'P'P constructor must be defined in the scope of "
12485 & "its returned type", Arg1
);
12488 if Arg_Count
>= 2 then
12489 Set_Imported
(Def_Id
);
12490 Set_Is_Public
(Def_Id
);
12491 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12494 Set_Has_Completion
(Def_Id
);
12495 Set_Is_Constructor
(Def_Id
);
12496 Set_Convention
(Def_Id
, Convention_CPP
);
12498 -- Imported C++ constructors are not dispatching primitives
12499 -- because in C++ they don't have a dispatch table slot.
12500 -- However, in Ada the constructor has the profile of a
12501 -- function that returns a tagged type and therefore it has
12502 -- been treated as a primitive operation during semantic
12503 -- analysis. We now remove it from the list of primitive
12504 -- operations of the type.
12506 if Is_Tagged_Type
(Etype
(Def_Id
))
12507 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12508 and then Is_Dispatching_Operation
(Def_Id
)
12510 Tag_Typ
:= Etype
(Def_Id
);
12512 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12513 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12517 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12518 Set_Is_Dispatching_Operation
(Def_Id
, False);
12521 -- For backward compatibility, if the constructor returns a
12522 -- class wide type, and we internally change the return type to
12523 -- the corresponding root type.
12525 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12526 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12530 ("pragma% requires function returning a 'C'P'P_Class type",
12533 end CPP_Constructor
;
12539 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12543 if Warn_On_Obsolescent_Feature
then
12545 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12554 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12558 if Warn_On_Obsolescent_Feature
then
12560 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12569 -- pragma CPU (EXPRESSION);
12571 when Pragma_CPU
=> CPU
: declare
12572 P
: constant Node_Id
:= Parent
(N
);
12578 Check_No_Identifiers
;
12579 Check_Arg_Count
(1);
12583 if Nkind
(P
) = N_Subprogram_Body
then
12584 Check_In_Main_Program
;
12586 Arg
:= Get_Pragma_Arg
(Arg1
);
12587 Analyze_And_Resolve
(Arg
, Any_Integer
);
12589 Ent
:= Defining_Unit_Name
(Specification
(P
));
12591 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12592 Ent
:= Defining_Identifier
(Ent
);
12597 if not Is_OK_Static_Expression
(Arg
) then
12598 Flag_Non_Static_Expr
12599 ("main subprogram affinity is not static!", Arg
);
12602 -- If constraint error, then we already signalled an error
12604 elsif Raises_Constraint_Error
(Arg
) then
12607 -- Otherwise check in range
12611 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12612 -- This is the entity System.Multiprocessors.CPU_Range;
12614 Val
: constant Uint
:= Expr_Value
(Arg
);
12617 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12619 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12622 ("main subprogram CPU is out of range", Arg1
);
12628 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12632 elsif Nkind
(P
) = N_Task_Definition
then
12633 Arg
:= Get_Pragma_Arg
(Arg1
);
12634 Ent
:= Defining_Identifier
(Parent
(P
));
12636 -- The expression must be analyzed in the special manner
12637 -- described in "Handling of Default and Per-Object
12638 -- Expressions" in sem.ads.
12640 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12642 -- Anything else is incorrect
12648 -- Check duplicate pragma before we chain the pragma in the Rep
12649 -- Item chain of Ent.
12651 Check_Duplicate_Pragma
(Ent
);
12652 Record_Rep_Item
(Ent
, N
);
12659 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12661 when Pragma_Debug
=> Debug
: declare
12668 -- The condition for executing the call is that the expander
12669 -- is active and that we are not ignoring this debug pragma.
12674 (Expander_Active
and then not Is_Ignored
(N
)),
12677 if not Is_Ignored
(N
) then
12678 Set_SCO_Pragma_Enabled
(Loc
);
12681 if Arg_Count
= 2 then
12683 Make_And_Then
(Loc
,
12684 Left_Opnd
=> Relocate_Node
(Cond
),
12685 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12686 Call
:= Get_Pragma_Arg
(Arg2
);
12688 Call
:= Get_Pragma_Arg
(Arg1
);
12692 N_Indexed_Component
,
12696 N_Selected_Component
)
12698 -- If this pragma Debug comes from source, its argument was
12699 -- parsed as a name form (which is syntactically identical).
12700 -- In a generic context a parameterless call will be left as
12701 -- an expanded name (if global) or selected_component if local.
12702 -- Change it to a procedure call statement now.
12704 Change_Name_To_Procedure_Call_Statement
(Call
);
12706 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12708 -- Already in the form of a procedure call statement: nothing
12709 -- to do (could happen in case of an internally generated
12715 -- All other cases: diagnose error
12718 ("argument of pragma ""Debug"" is not procedure call",
12723 -- Rewrite into a conditional with an appropriate condition. We
12724 -- wrap the procedure call in a block so that overhead from e.g.
12725 -- use of the secondary stack does not generate execution overhead
12726 -- for suppressed conditions.
12728 -- Normally the analysis that follows will freeze the subprogram
12729 -- being called. However, if the call is to a null procedure,
12730 -- we want to freeze it before creating the block, because the
12731 -- analysis that follows may be done with expansion disabled, in
12732 -- which case the body will not be generated, leading to spurious
12735 if Nkind
(Call
) = N_Procedure_Call_Statement
12736 and then Is_Entity_Name
(Name
(Call
))
12738 Analyze
(Name
(Call
));
12739 Freeze_Before
(N
, Entity
(Name
(Call
)));
12743 Make_Implicit_If_Statement
(N
,
12745 Then_Statements
=> New_List
(
12746 Make_Block_Statement
(Loc
,
12747 Handled_Statement_Sequence
=>
12748 Make_Handled_Sequence_Of_Statements
(Loc
,
12749 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12752 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12753 -- after analysis of the normally rewritten node, to capture all
12754 -- references to entities, which avoids issuing wrong warnings
12755 -- about unused entities.
12757 if GNATprove_Mode
then
12758 Rewrite
(N
, Make_Null_Statement
(Loc
));
12766 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12768 when Pragma_Debug_Policy
=>
12770 Check_Arg_Count
(1);
12771 Check_No_Identifiers
;
12772 Check_Arg_Is_Identifier
(Arg1
);
12774 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12775 -- rewrite it that way, and let the rest of the checking come
12776 -- from analyzing the rewritten pragma.
12780 Chars
=> Name_Check_Policy
,
12781 Pragma_Argument_Associations
=> New_List
(
12782 Make_Pragma_Argument_Association
(Loc
,
12783 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12785 Make_Pragma_Argument_Association
(Loc
,
12786 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12789 -------------------------------
12790 -- Default_Initial_Condition --
12791 -------------------------------
12793 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12795 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12802 Check_No_Identifiers
;
12803 Check_At_Most_N_Arguments
(1);
12806 while Present
(Stmt
) loop
12808 -- Skip prior pragmas, but check for duplicates
12810 if Nkind
(Stmt
) = N_Pragma
then
12811 if Pragma_Name
(Stmt
) = Pname
then
12812 Error_Msg_Name_1
:= Pname
;
12813 Error_Msg_Sloc
:= Sloc
(Stmt
);
12814 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12817 -- Skip internally generated code
12819 elsif not Comes_From_Source
(Stmt
) then
12822 -- The associated private type [extension] has been found, stop
12825 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12826 N_Private_Type_Declaration
)
12828 Typ
:= Defining_Entity
(Stmt
);
12831 -- The pragma does not apply to a legal construct, issue an
12832 -- error and stop the analysis.
12839 Stmt
:= Prev
(Stmt
);
12842 Set_Has_Default_Init_Cond
(Typ
);
12843 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12845 -- Chain the pragma on the rep item chain for further processing
12847 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12848 end Default_Init_Cond
;
12850 ----------------------------------
12851 -- Default_Scalar_Storage_Order --
12852 ----------------------------------
12854 -- pragma Default_Scalar_Storage_Order
12855 -- (High_Order_First | Low_Order_First);
12857 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12858 Default
: Character;
12862 Check_Arg_Count
(1);
12864 -- Default_Scalar_Storage_Order can appear as a configuration
12865 -- pragma, or in a declarative part of a package spec.
12867 if not Is_Configuration_Pragma
then
12868 Check_Is_In_Decl_Part_Or_Package_Spec
;
12871 Check_No_Identifiers
;
12872 Check_Arg_Is_One_Of
12873 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12874 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12875 Default
:= Fold_Upper
(Name_Buffer
(1));
12877 if not Support_Nondefault_SSO_On_Target
12878 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12880 if Warn_On_Unrecognized_Pragma
then
12882 ("non-default Scalar_Storage_Order not supported "
12883 & "on target?g?", N
);
12885 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12888 -- Here set the specified default
12891 Opt
.Default_SSO
:= Default
;
12895 --------------------------
12896 -- Default_Storage_Pool --
12897 --------------------------
12899 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12901 when Pragma_Default_Storage_Pool
=>
12903 Check_Arg_Count
(1);
12905 -- Default_Storage_Pool can appear as a configuration pragma, or
12906 -- in a declarative part of a package spec.
12908 if not Is_Configuration_Pragma
then
12909 Check_Is_In_Decl_Part_Or_Package_Spec
;
12912 -- Case of Default_Storage_Pool (null);
12914 if Nkind
(Expression
(Arg1
)) = N_Null
then
12915 Analyze
(Expression
(Arg1
));
12917 -- This is an odd case, this is not really an expression, so
12918 -- we don't have a type for it. So just set the type to Empty.
12920 Set_Etype
(Expression
(Arg1
), Empty
);
12922 -- Case of Default_Storage_Pool (storage_pool_NAME);
12925 -- If it's a configuration pragma, then the only allowed
12926 -- argument is "null".
12928 if Is_Configuration_Pragma
then
12929 Error_Pragma_Arg
("NULL expected", Arg1
);
12932 -- The expected type for a non-"null" argument is
12933 -- Root_Storage_Pool'Class, and the pool must be a variable.
12935 Analyze_And_Resolve
12936 (Get_Pragma_Arg
(Arg1
),
12937 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12939 if not Is_Variable
(Expression
(Arg1
)) then
12941 ("default storage pool must be a variable", Arg1
);
12945 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12946 -- for an access type will use this information to set the
12947 -- appropriate attributes of the access type.
12949 Default_Pool
:= Expression
(Arg1
);
12955 -- pragma Depends (DEPENDENCY_RELATION);
12957 -- DEPENDENCY_RELATION ::=
12959 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12961 -- DEPENDENCY_CLAUSE ::=
12962 -- OUTPUT_LIST =>[+] INPUT_LIST
12963 -- | NULL_DEPENDENCY_CLAUSE
12965 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12967 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12969 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12971 -- OUTPUT ::= NAME | FUNCTION_RESULT
12974 -- where FUNCTION_RESULT is a function Result attribute_reference
12976 when Pragma_Depends
=> Depends
: declare
12977 Subp_Decl
: Node_Id
;
12981 Check_Arg_Count
(1);
12982 Ensure_Aggregate_Form
(Arg1
);
12984 -- Ensure the proper placement of the pragma. Depends must be
12985 -- associated with a subprogram declaration or a body that acts
12989 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12991 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12994 -- Body acts as spec
12996 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12997 and then No
(Corresponding_Spec
(Subp_Decl
))
13001 -- Body stub acts as spec
13003 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13004 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13013 -- When the pragma appears on a subprogram body, perform the full
13016 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
13017 Analyze_Depends_In_Decl_Part
(N
);
13019 -- When Depends applies to a subprogram compilation unit, the
13020 -- corresponding pragma is placed after the unit's declaration
13021 -- node and needs to be analyzed immediately.
13023 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13024 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
13026 Analyze_Depends_In_Decl_Part
(N
);
13029 -- Chain the pragma on the contract for further processing
13031 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13034 ---------------------
13035 -- Detect_Blocking --
13036 ---------------------
13038 -- pragma Detect_Blocking;
13040 when Pragma_Detect_Blocking
=>
13042 Check_Arg_Count
(0);
13043 Check_Valid_Configuration_Pragma
;
13044 Detect_Blocking
:= True;
13046 ------------------------------------
13047 -- Disable_Atomic_Synchronization --
13048 ------------------------------------
13050 -- pragma Disable_Atomic_Synchronization [(Entity)];
13052 when Pragma_Disable_Atomic_Synchronization
=>
13054 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13056 -------------------
13057 -- Discard_Names --
13058 -------------------
13060 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13062 when Pragma_Discard_Names
=> Discard_Names
: declare
13067 Check_Ada_83_Warning
;
13069 -- Deal with configuration pragma case
13071 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13072 Global_Discard_Names
:= True;
13075 -- Otherwise, check correct appropriate context
13078 Check_Is_In_Decl_Part_Or_Package_Spec
;
13080 if Arg_Count
= 0 then
13082 -- If there is no parameter, then from now on this pragma
13083 -- applies to any enumeration, exception or tagged type
13084 -- defined in the current declarative part, and recursively
13085 -- to any nested scope.
13087 Set_Discard_Names
(Current_Scope
);
13091 Check_Arg_Count
(1);
13092 Check_Optional_Identifier
(Arg1
, Name_On
);
13093 Check_Arg_Is_Local_Name
(Arg1
);
13095 E_Id
:= Get_Pragma_Arg
(Arg1
);
13097 if Etype
(E_Id
) = Any_Type
then
13100 E
:= Entity
(E_Id
);
13103 if (Is_First_Subtype
(E
)
13105 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13106 or else Ekind
(E
) = E_Exception
13108 Set_Discard_Names
(E
);
13109 Record_Rep_Item
(E
, N
);
13113 ("inappropriate entity for pragma%", Arg1
);
13120 ------------------------
13121 -- Dispatching_Domain --
13122 ------------------------
13124 -- pragma Dispatching_Domain (EXPRESSION);
13126 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13127 P
: constant Node_Id
:= Parent
(N
);
13133 Check_No_Identifiers
;
13134 Check_Arg_Count
(1);
13136 -- This pragma is born obsolete, but not the aspect
13138 if not From_Aspect_Specification
(N
) then
13140 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13143 if Nkind
(P
) = N_Task_Definition
then
13144 Arg
:= Get_Pragma_Arg
(Arg1
);
13145 Ent
:= Defining_Identifier
(Parent
(P
));
13147 -- The expression must be analyzed in the special manner
13148 -- described in "Handling of Default and Per-Object
13149 -- Expressions" in sem.ads.
13151 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13153 -- Check duplicate pragma before we chain the pragma in the Rep
13154 -- Item chain of Ent.
13156 Check_Duplicate_Pragma
(Ent
);
13157 Record_Rep_Item
(Ent
, N
);
13159 -- Anything else is incorrect
13164 end Dispatching_Domain
;
13170 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13172 when Pragma_Elaborate
=> Elaborate
: declare
13177 -- Pragma must be in context items list of a compilation unit
13179 if not Is_In_Context_Clause
then
13183 -- Must be at least one argument
13185 if Arg_Count
= 0 then
13186 Error_Pragma
("pragma% requires at least one argument");
13189 -- In Ada 83 mode, there can be no items following it in the
13190 -- context list except other pragmas and implicit with clauses
13191 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13192 -- placement rule does not apply.
13194 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13196 while Present
(Citem
) loop
13197 if Nkind
(Citem
) = N_Pragma
13198 or else (Nkind
(Citem
) = N_With_Clause
13199 and then Implicit_With
(Citem
))
13204 ("(Ada 83) pragma% must be at end of context clause");
13211 -- Finally, the arguments must all be units mentioned in a with
13212 -- clause in the same context clause. Note we already checked (in
13213 -- Par.Prag) that the arguments are all identifiers or selected
13217 Outer
: while Present
(Arg
) loop
13218 Citem
:= First
(List_Containing
(N
));
13219 Inner
: while Citem
/= N
loop
13220 if Nkind
(Citem
) = N_With_Clause
13221 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13223 Set_Elaborate_Present
(Citem
, True);
13224 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13226 -- With the pragma present, elaboration calls on
13227 -- subprograms from the named unit need no further
13228 -- checks, as long as the pragma appears in the current
13229 -- compilation unit. If the pragma appears in some unit
13230 -- in the context, there might still be a need for an
13231 -- Elaborate_All_Desirable from the current compilation
13232 -- to the named unit, so we keep the check enabled.
13234 if In_Extended_Main_Source_Unit
(N
) then
13236 -- This does not apply in SPARK mode, where we allow
13237 -- pragma Elaborate, but we don't trust it to be right
13238 -- so we will still insist on the Elaborate_All.
13240 if SPARK_Mode
/= On
then
13241 Set_Suppress_Elaboration_Warnings
13242 (Entity
(Name
(Citem
)));
13254 ("argument of pragma% is not withed unit", Arg
);
13260 -- Give a warning if operating in static mode with one of the
13261 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13264 and not Dynamic_Elaboration_Checks
13266 -- pragma Elaborate not allowed in SPARK mode anyway. We
13267 -- already complained about it, no point in generating any
13268 -- further complaint.
13270 and SPARK_Mode
/= On
13273 ("?l?use of pragma Elaborate may not be safe", N
);
13275 ("?l?use pragma Elaborate_All instead if possible", N
);
13279 -------------------
13280 -- Elaborate_All --
13281 -------------------
13283 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13285 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13290 Check_Ada_83_Warning
;
13292 -- Pragma must be in context items list of a compilation unit
13294 if not Is_In_Context_Clause
then
13298 -- Must be at least one argument
13300 if Arg_Count
= 0 then
13301 Error_Pragma
("pragma% requires at least one argument");
13304 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13305 -- have to appear at the end of the context clause, but may
13306 -- appear mixed in with other items, even in Ada 83 mode.
13308 -- Final check: the arguments must all be units mentioned in
13309 -- a with clause in the same context clause. Note that we
13310 -- already checked (in Par.Prag) that all the arguments are
13311 -- either identifiers or selected components.
13314 Outr
: while Present
(Arg
) loop
13315 Citem
:= First
(List_Containing
(N
));
13316 Innr
: while Citem
/= N
loop
13317 if Nkind
(Citem
) = N_With_Clause
13318 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13320 Set_Elaborate_All_Present
(Citem
, True);
13321 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13323 -- Suppress warnings and elaboration checks on the named
13324 -- unit if the pragma is in the current compilation, as
13325 -- for pragma Elaborate.
13327 if In_Extended_Main_Source_Unit
(N
) then
13328 Set_Suppress_Elaboration_Warnings
13329 (Entity
(Name
(Citem
)));
13338 Set_Error_Posted
(N
);
13340 ("argument of pragma% is not withed unit", Arg
);
13347 --------------------
13348 -- Elaborate_Body --
13349 --------------------
13351 -- pragma Elaborate_Body [( library_unit_NAME )];
13353 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13354 Cunit_Node
: Node_Id
;
13355 Cunit_Ent
: Entity_Id
;
13358 Check_Ada_83_Warning
;
13359 Check_Valid_Library_Unit_Pragma
;
13361 if Nkind
(N
) = N_Null_Statement
then
13365 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13366 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13368 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13371 Error_Pragma
("pragma% must refer to a spec, not a body");
13373 Set_Body_Required
(Cunit_Node
, True);
13374 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13376 -- If we are in dynamic elaboration mode, then we suppress
13377 -- elaboration warnings for the unit, since it is definitely
13378 -- fine NOT to do dynamic checks at the first level (and such
13379 -- checks will be suppressed because no elaboration boolean
13380 -- is created for Elaborate_Body packages).
13382 -- But in the static model of elaboration, Elaborate_Body is
13383 -- definitely NOT good enough to ensure elaboration safety on
13384 -- its own, since the body may WITH other units that are not
13385 -- safe from an elaboration point of view, so a client must
13386 -- still do an Elaborate_All on such units.
13388 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13389 -- Elaborate_Body always suppressed elab warnings.
13391 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13392 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13395 end Elaborate_Body
;
13397 ------------------------
13398 -- Elaboration_Checks --
13399 ------------------------
13401 -- pragma Elaboration_Checks (Static | Dynamic);
13403 when Pragma_Elaboration_Checks
=>
13405 Check_Arg_Count
(1);
13406 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13408 -- Set flag accordingly (ignore attempt at dynamic elaboration
13409 -- checks in SPARK mode).
13411 Dynamic_Elaboration_Checks
:=
13412 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13413 and then SPARK_Mode
/= On
;
13419 -- pragma Eliminate (
13420 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13421 -- [,[Entity =>] IDENTIFIER |
13422 -- SELECTED_COMPONENT |
13424 -- [, OVERLOADING_RESOLUTION]);
13426 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13429 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13430 -- FUNCTION_PROFILE
13432 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13434 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13435 -- Result_Type => result_SUBTYPE_NAME]
13437 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13438 -- SUBTYPE_NAME ::= STRING_LITERAL
13440 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13441 -- SOURCE_TRACE ::= STRING_LITERAL
13443 when Pragma_Eliminate
=> Eliminate
: declare
13444 Args
: Args_List
(1 .. 5);
13445 Names
: constant Name_List
(1 .. 5) := (
13448 Name_Parameter_Types
,
13450 Name_Source_Location
);
13452 Unit_Name
: Node_Id
renames Args
(1);
13453 Entity
: Node_Id
renames Args
(2);
13454 Parameter_Types
: Node_Id
renames Args
(3);
13455 Result_Type
: Node_Id
renames Args
(4);
13456 Source_Location
: Node_Id
renames Args
(5);
13460 Check_Valid_Configuration_Pragma
;
13461 Gather_Associations
(Names
, Args
);
13463 if No
(Unit_Name
) then
13464 Error_Pragma
("missing Unit_Name argument for pragma%");
13468 and then (Present
(Parameter_Types
)
13470 Present
(Result_Type
)
13472 Present
(Source_Location
))
13474 Error_Pragma
("missing Entity argument for pragma%");
13477 if (Present
(Parameter_Types
)
13479 Present
(Result_Type
))
13481 Present
(Source_Location
)
13484 ("parameter profile and source location cannot be used "
13485 & "together in pragma%");
13488 Process_Eliminate_Pragma
13497 -----------------------------------
13498 -- Enable_Atomic_Synchronization --
13499 -----------------------------------
13501 -- pragma Enable_Atomic_Synchronization [(Entity)];
13503 when Pragma_Enable_Atomic_Synchronization
=>
13505 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13512 -- [ Convention =>] convention_IDENTIFIER,
13513 -- [ Entity =>] LOCAL_NAME
13514 -- [, [External_Name =>] static_string_EXPRESSION ]
13515 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13517 when Pragma_Export
=> Export
: declare
13519 Def_Id
: Entity_Id
;
13521 pragma Warnings
(Off
, C
);
13524 Check_Ada_83_Warning
;
13528 Name_External_Name
,
13531 Check_At_Least_N_Arguments
(2);
13532 Check_At_Most_N_Arguments
(4);
13534 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13535 -- pragma Export (Entity, "external name");
13537 if Relaxed_RM_Semantics
13538 and then Arg_Count
= 2
13539 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13542 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13545 if not Is_Entity_Name
(Def_Id
) then
13546 Error_Pragma_Arg
("entity name required", Arg1
);
13549 Def_Id
:= Entity
(Def_Id
);
13550 Set_Exported
(Def_Id
, Arg1
);
13553 Process_Convention
(C
, Def_Id
);
13555 if Ekind
(Def_Id
) /= E_Constant
then
13556 Note_Possible_Modification
13557 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13560 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13561 Set_Exported
(Def_Id
, Arg2
);
13564 -- If the entity is a deferred constant, propagate the information
13565 -- to the full view, because gigi elaborates the full view only.
13567 if Ekind
(Def_Id
) = E_Constant
13568 and then Present
(Full_View
(Def_Id
))
13571 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13573 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13574 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13575 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13580 ---------------------
13581 -- Export_Function --
13582 ---------------------
13584 -- pragma Export_Function (
13585 -- [Internal =>] LOCAL_NAME
13586 -- [, [External =>] EXTERNAL_SYMBOL]
13587 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13588 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13589 -- [, [Mechanism =>] MECHANISM]
13590 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13592 -- EXTERNAL_SYMBOL ::=
13594 -- | static_string_EXPRESSION
13596 -- PARAMETER_TYPES ::=
13598 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13600 -- TYPE_DESIGNATOR ::=
13602 -- | subtype_Name ' Access
13606 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13608 -- MECHANISM_ASSOCIATION ::=
13609 -- [formal_parameter_NAME =>] MECHANISM_NAME
13611 -- MECHANISM_NAME ::=
13615 when Pragma_Export_Function
=> Export_Function
: declare
13616 Args
: Args_List
(1 .. 6);
13617 Names
: constant Name_List
(1 .. 6) := (
13620 Name_Parameter_Types
,
13623 Name_Result_Mechanism
);
13625 Internal
: Node_Id
renames Args
(1);
13626 External
: Node_Id
renames Args
(2);
13627 Parameter_Types
: Node_Id
renames Args
(3);
13628 Result_Type
: Node_Id
renames Args
(4);
13629 Mechanism
: Node_Id
renames Args
(5);
13630 Result_Mechanism
: Node_Id
renames Args
(6);
13634 Gather_Associations
(Names
, Args
);
13635 Process_Extended_Import_Export_Subprogram_Pragma
(
13636 Arg_Internal
=> Internal
,
13637 Arg_External
=> External
,
13638 Arg_Parameter_Types
=> Parameter_Types
,
13639 Arg_Result_Type
=> Result_Type
,
13640 Arg_Mechanism
=> Mechanism
,
13641 Arg_Result_Mechanism
=> Result_Mechanism
);
13642 end Export_Function
;
13644 -------------------
13645 -- Export_Object --
13646 -------------------
13648 -- pragma Export_Object (
13649 -- [Internal =>] LOCAL_NAME
13650 -- [, [External =>] EXTERNAL_SYMBOL]
13651 -- [, [Size =>] EXTERNAL_SYMBOL]);
13653 -- EXTERNAL_SYMBOL ::=
13655 -- | static_string_EXPRESSION
13657 -- PARAMETER_TYPES ::=
13659 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13661 -- TYPE_DESIGNATOR ::=
13663 -- | subtype_Name ' Access
13667 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13669 -- MECHANISM_ASSOCIATION ::=
13670 -- [formal_parameter_NAME =>] MECHANISM_NAME
13672 -- MECHANISM_NAME ::=
13676 when Pragma_Export_Object
=> Export_Object
: declare
13677 Args
: Args_List
(1 .. 3);
13678 Names
: constant Name_List
(1 .. 3) := (
13683 Internal
: Node_Id
renames Args
(1);
13684 External
: Node_Id
renames Args
(2);
13685 Size
: Node_Id
renames Args
(3);
13689 Gather_Associations
(Names
, Args
);
13690 Process_Extended_Import_Export_Object_Pragma
(
13691 Arg_Internal
=> Internal
,
13692 Arg_External
=> External
,
13696 ----------------------
13697 -- Export_Procedure --
13698 ----------------------
13700 -- pragma Export_Procedure (
13701 -- [Internal =>] LOCAL_NAME
13702 -- [, [External =>] EXTERNAL_SYMBOL]
13703 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13704 -- [, [Mechanism =>] MECHANISM]);
13706 -- EXTERNAL_SYMBOL ::=
13708 -- | static_string_EXPRESSION
13710 -- PARAMETER_TYPES ::=
13712 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13714 -- TYPE_DESIGNATOR ::=
13716 -- | subtype_Name ' Access
13720 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13722 -- MECHANISM_ASSOCIATION ::=
13723 -- [formal_parameter_NAME =>] MECHANISM_NAME
13725 -- MECHANISM_NAME ::=
13729 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13730 Args
: Args_List
(1 .. 4);
13731 Names
: constant Name_List
(1 .. 4) := (
13734 Name_Parameter_Types
,
13737 Internal
: Node_Id
renames Args
(1);
13738 External
: Node_Id
renames Args
(2);
13739 Parameter_Types
: Node_Id
renames Args
(3);
13740 Mechanism
: Node_Id
renames Args
(4);
13744 Gather_Associations
(Names
, Args
);
13745 Process_Extended_Import_Export_Subprogram_Pragma
(
13746 Arg_Internal
=> Internal
,
13747 Arg_External
=> External
,
13748 Arg_Parameter_Types
=> Parameter_Types
,
13749 Arg_Mechanism
=> Mechanism
);
13750 end Export_Procedure
;
13756 -- pragma Export_Value (
13757 -- [Value =>] static_integer_EXPRESSION,
13758 -- [Link_Name =>] static_string_EXPRESSION);
13760 when Pragma_Export_Value
=>
13762 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13763 Check_Arg_Count
(2);
13765 Check_Optional_Identifier
(Arg1
, Name_Value
);
13766 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13768 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13769 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13771 -----------------------------
13772 -- Export_Valued_Procedure --
13773 -----------------------------
13775 -- pragma Export_Valued_Procedure (
13776 -- [Internal =>] LOCAL_NAME
13777 -- [, [External =>] EXTERNAL_SYMBOL,]
13778 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13779 -- [, [Mechanism =>] MECHANISM]);
13781 -- EXTERNAL_SYMBOL ::=
13783 -- | static_string_EXPRESSION
13785 -- PARAMETER_TYPES ::=
13787 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13789 -- TYPE_DESIGNATOR ::=
13791 -- | subtype_Name ' Access
13795 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13797 -- MECHANISM_ASSOCIATION ::=
13798 -- [formal_parameter_NAME =>] MECHANISM_NAME
13800 -- MECHANISM_NAME ::=
13804 when Pragma_Export_Valued_Procedure
=>
13805 Export_Valued_Procedure
: declare
13806 Args
: Args_List
(1 .. 4);
13807 Names
: constant Name_List
(1 .. 4) := (
13810 Name_Parameter_Types
,
13813 Internal
: Node_Id
renames Args
(1);
13814 External
: Node_Id
renames Args
(2);
13815 Parameter_Types
: Node_Id
renames Args
(3);
13816 Mechanism
: Node_Id
renames Args
(4);
13820 Gather_Associations
(Names
, Args
);
13821 Process_Extended_Import_Export_Subprogram_Pragma
(
13822 Arg_Internal
=> Internal
,
13823 Arg_External
=> External
,
13824 Arg_Parameter_Types
=> Parameter_Types
,
13825 Arg_Mechanism
=> Mechanism
);
13826 end Export_Valued_Procedure
;
13828 -------------------
13829 -- Extend_System --
13830 -------------------
13832 -- pragma Extend_System ([Name =>] Identifier);
13834 when Pragma_Extend_System
=> Extend_System
: declare
13837 Check_Valid_Configuration_Pragma
;
13838 Check_Arg_Count
(1);
13839 Check_Optional_Identifier
(Arg1
, Name_Name
);
13840 Check_Arg_Is_Identifier
(Arg1
);
13842 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13845 and then Name_Buffer
(1 .. 4) = "aux_"
13847 if Present
(System_Extend_Pragma_Arg
) then
13848 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13849 Chars
(Expression
(System_Extend_Pragma_Arg
))
13853 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13854 Error_Pragma
("pragma% conflicts with that #");
13858 System_Extend_Pragma_Arg
:= Arg1
;
13860 if not GNAT_Mode
then
13861 System_Extend_Unit
:= Arg1
;
13865 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13869 ------------------------
13870 -- Extensions_Allowed --
13871 ------------------------
13873 -- pragma Extensions_Allowed (ON | OFF);
13875 when Pragma_Extensions_Allowed
=>
13877 Check_Arg_Count
(1);
13878 Check_No_Identifiers
;
13879 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13881 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13882 Extensions_Allowed
:= True;
13883 Ada_Version
:= Ada_Version_Type
'Last;
13886 Extensions_Allowed
:= False;
13887 Ada_Version
:= Ada_Version_Explicit
;
13888 Ada_Version_Pragma
:= Empty
;
13891 ------------------------
13892 -- Extensions_Visible --
13893 ------------------------
13895 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13897 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13898 Context
: constant Node_Id
:= Parent
(N
);
13900 Formal
: Entity_Id
;
13901 Orig_Stmt
: Node_Id
;
13905 Has_OK_Formal
: Boolean := False;
13909 Check_No_Identifiers
;
13910 Check_At_Most_N_Arguments
(1);
13914 while Present
(Stmt
) loop
13916 -- Skip prior pragmas, but check for duplicates
13918 if Nkind
(Stmt
) = N_Pragma
then
13919 if Pragma_Name
(Stmt
) = Pname
then
13920 Error_Msg_Name_1
:= Pname
;
13921 Error_Msg_Sloc
:= Sloc
(Stmt
);
13922 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13925 -- Skip internally generated code
13927 elsif not Comes_From_Source
(Stmt
) then
13928 Orig_Stmt
:= Original_Node
(Stmt
);
13930 -- When pragma Ghost applies to an expression function, the
13931 -- expression function is transformed into a subprogram.
13933 if Nkind
(Stmt
) = N_Subprogram_Declaration
13934 and then Comes_From_Source
(Orig_Stmt
)
13935 and then Nkind
(Orig_Stmt
) = N_Expression_Function
13937 Subp
:= Defining_Entity
(Stmt
);
13941 -- The associated [generic] subprogram declaration has been
13942 -- found, stop the search.
13944 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
13945 N_Subprogram_Declaration
)
13947 Subp
:= Defining_Entity
(Stmt
);
13950 -- The pragma does not apply to a legal construct, issue an
13951 -- error and stop the analysis.
13954 Error_Pragma
("pragma % must apply to a subprogram");
13958 Stmt
:= Prev
(Stmt
);
13961 -- When the pragma applies to a stand alone subprogram body, it
13962 -- appears within the declarations of the body. In that case the
13963 -- enclosing construct is the proper context. This check is done
13964 -- after the traversal above to allow for duplicate detection.
13967 and then Nkind
(Context
) = N_Subprogram_Body
13968 and then No
(Corresponding_Spec
(Context
))
13970 Subp
:= Defining_Entity
(Context
);
13974 Error_Pragma
("pragma % must apply to a subprogram");
13978 -- Examine the formals of the related subprogram
13980 Formal
:= First_Formal
(Subp
);
13981 while Present
(Formal
) loop
13983 -- At least one of the formals is of a specific tagged type,
13984 -- the pragma is legal.
13986 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13987 Has_OK_Formal
:= True;
13990 -- A generic subprogram with at least one formal of a private
13991 -- type ensures the legality of the pragma because the actual
13992 -- may be specifically tagged. Note that this is verified by
13993 -- the check above at instantiation time.
13995 elsif Is_Private_Type
(Etype
(Formal
))
13996 and then Is_Generic_Type
(Etype
(Formal
))
13998 Has_OK_Formal
:= True;
14002 Next_Formal
(Formal
);
14005 if not Has_OK_Formal
then
14006 Error_Msg_Name_1
:= Pname
;
14007 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
14009 ("\subprogram & lacks parameter of specific tagged or "
14010 & "generic private type", N
, Subp
);
14014 -- Analyze the Boolean expression (if any)
14016 if Present
(Arg1
) then
14017 Expr
:= Get_Pragma_Arg
(Arg1
);
14019 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14021 if not Is_OK_Static_Expression
(Expr
) then
14023 ("expression of pragma % must be static", Expr
);
14028 -- Chain the pragma on the contract for further processing
14030 Add_Contract_Item
(N
, Subp
);
14031 end Extensions_Visible
;
14037 -- pragma External (
14038 -- [ Convention =>] convention_IDENTIFIER,
14039 -- [ Entity =>] LOCAL_NAME
14040 -- [, [External_Name =>] static_string_EXPRESSION ]
14041 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14043 when Pragma_External
=> External
: declare
14044 Def_Id
: Entity_Id
;
14047 pragma Warnings
(Off
, C
);
14054 Name_External_Name
,
14056 Check_At_Least_N_Arguments
(2);
14057 Check_At_Most_N_Arguments
(4);
14058 Process_Convention
(C
, Def_Id
);
14059 Note_Possible_Modification
14060 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14061 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14062 Set_Exported
(Def_Id
, Arg2
);
14065 --------------------------
14066 -- External_Name_Casing --
14067 --------------------------
14069 -- pragma External_Name_Casing (
14070 -- UPPERCASE | LOWERCASE
14071 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14073 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14076 Check_No_Identifiers
;
14078 if Arg_Count
= 2 then
14079 Check_Arg_Is_One_Of
14080 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14082 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14084 Opt
.External_Name_Exp_Casing
:= As_Is
;
14086 when Name_Uppercase
=>
14087 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14089 when Name_Lowercase
=>
14090 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14097 Check_Arg_Count
(1);
14100 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14102 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14103 when Name_Uppercase
=>
14104 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14106 when Name_Lowercase
=>
14107 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14112 end External_Name_Casing
;
14118 -- pragma Fast_Math;
14120 when Pragma_Fast_Math
=>
14122 Check_No_Identifiers
;
14123 Check_Valid_Configuration_Pragma
;
14126 --------------------------
14127 -- Favor_Top_Level --
14128 --------------------------
14130 -- pragma Favor_Top_Level (type_NAME);
14132 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14133 Named_Entity
: Entity_Id
;
14137 Check_No_Identifiers
;
14138 Check_Arg_Count
(1);
14139 Check_Arg_Is_Local_Name
(Arg1
);
14140 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14142 -- If it's an access-to-subprogram type (in particular, not a
14143 -- subtype), set the flag on that type.
14145 if Is_Access_Subprogram_Type
(Named_Entity
) then
14146 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14148 -- Otherwise it's an error (name denotes the wrong sort of entity)
14152 ("access-to-subprogram type expected",
14153 Get_Pragma_Arg
(Arg1
));
14155 end Favor_Top_Level
;
14157 ---------------------------
14158 -- Finalize_Storage_Only --
14159 ---------------------------
14161 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14163 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14164 Assoc
: constant Node_Id
:= Arg1
;
14165 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14170 Check_No_Identifiers
;
14171 Check_Arg_Count
(1);
14172 Check_Arg_Is_Local_Name
(Arg1
);
14174 Find_Type
(Type_Id
);
14175 Typ
:= Entity
(Type_Id
);
14178 or else Rep_Item_Too_Early
(Typ
, N
)
14182 Typ
:= Underlying_Type
(Typ
);
14185 if not Is_Controlled
(Typ
) then
14186 Error_Pragma
("pragma% must specify controlled type");
14189 Check_First_Subtype
(Arg1
);
14191 if Finalize_Storage_Only
(Typ
) then
14192 Error_Pragma
("duplicate pragma%, only one allowed");
14194 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14195 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14197 end Finalize_Storage
;
14203 -- pragma Ghost [ (boolean_EXPRESSION) ];
14205 when Pragma_Ghost
=> Ghost
: declare
14209 Orig_Stmt
: Node_Id
;
14210 Prev_Id
: Entity_Id
;
14215 Check_No_Identifiers
;
14216 Check_At_Most_N_Arguments
(1);
14218 Context
:= Parent
(N
);
14220 -- Handle compilation units
14222 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14223 Context
:= Unit
(Parent
(Context
));
14228 while Present
(Stmt
) loop
14230 -- Skip prior pragmas, but check for duplicates
14232 if Nkind
(Stmt
) = N_Pragma
then
14233 if Pragma_Name
(Stmt
) = Pname
then
14234 Error_Msg_Name_1
:= Pname
;
14235 Error_Msg_Sloc
:= Sloc
(Stmt
);
14236 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14239 -- Protected and task types cannot be subject to pragma Ghost
14241 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
14242 Error_Pragma
("pragma % cannot apply to a protected type");
14245 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
14246 Error_Pragma
("pragma % cannot apply to a task type");
14249 -- Skip internally generated code
14251 elsif not Comes_From_Source
(Stmt
) then
14252 Orig_Stmt
:= Original_Node
(Stmt
);
14254 -- When pragma Ghost applies to an untagged derivation, the
14255 -- derivation is transformed into a [sub]type declaration.
14257 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14258 N_Subtype_Declaration
)
14259 and then Comes_From_Source
(Orig_Stmt
)
14260 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14261 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14262 N_Derived_Type_Definition
14264 Id
:= Defining_Entity
(Stmt
);
14267 -- When pragma Ghost applies to an expression function, the
14268 -- expression function is transformed into a subprogram.
14270 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14271 and then Comes_From_Source
(Orig_Stmt
)
14272 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14274 Id
:= Defining_Entity
(Stmt
);
14278 -- The pragma applies to a legal construct, stop the traversal
14280 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14281 N_Full_Type_Declaration
,
14282 N_Generic_Subprogram_Declaration
,
14283 N_Object_Declaration
,
14284 N_Private_Extension_Declaration
,
14285 N_Private_Type_Declaration
,
14286 N_Subprogram_Declaration
,
14287 N_Subtype_Declaration
)
14289 Id
:= Defining_Entity
(Stmt
);
14292 -- The pragma does not apply to a legal construct, issue an
14293 -- error and stop the analysis.
14297 ("pragma % must apply to an object, package, subprogram "
14302 Stmt
:= Prev
(Stmt
);
14307 -- When pragma Ghost is associated with a [generic] package, it
14308 -- appears in the visible declarations.
14310 if Nkind
(Context
) = N_Package_Specification
14311 and then Present
(Visible_Declarations
(Context
))
14312 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14314 Id
:= Defining_Entity
(Context
);
14316 -- Pragma Ghost applies to a stand alone subprogram body
14318 elsif Nkind
(Context
) = N_Subprogram_Body
14319 and then No
(Corresponding_Spec
(Context
))
14321 Id
:= Defining_Entity
(Context
);
14327 ("pragma % must apply to an object, package, subprogram or "
14332 -- A derived type or type extension cannot be subject to pragma
14333 -- Ghost if either the parent type or one of the progenitor types
14334 -- is not Ghost (SPARK RM 6.9(9)).
14336 if Is_Derived_Type
(Id
) then
14337 Check_Ghost_Derivation
(Id
);
14340 -- Handle completions of types and constants that are subject to
14343 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14344 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14346 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14347 Error_Msg_Name_1
:= Pname
;
14349 -- The full declaration of a deferred constant cannot be
14350 -- subject to pragma Ghost unless the deferred declaration
14351 -- is also Ghost (SPARK RM 6.9(10)).
14353 if Ekind
(Prev_Id
) = E_Constant
then
14354 Error_Msg_Name_1
:= Pname
;
14355 Error_Msg_NE
(Fix_Error
14356 ("pragma % must apply to declaration of deferred "
14357 & "constant &"), N
, Id
);
14360 -- Pragma Ghost may appear on the full view of an incomplete
14361 -- type because the incomplete declaration lacks aspects and
14362 -- cannot be subject to pragma Ghost.
14364 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14367 -- The full declaration of a type cannot be subject to
14368 -- pragma Ghost unless the partial view is also Ghost
14369 -- (SPARK RM 6.9(10)).
14372 Error_Msg_NE
(Fix_Error
14373 ("pragma % must apply to partial view of type &"),
14380 -- Analyze the Boolean expression (if any)
14382 if Present
(Arg1
) then
14383 Expr
:= Get_Pragma_Arg
(Arg1
);
14385 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14387 if Is_OK_Static_Expression
(Expr
) then
14389 -- "Ghostness" cannot be turned off once enabled within a
14390 -- region (SPARK RM 6.9(7)).
14392 if Is_False
(Expr_Value
(Expr
))
14393 and then Ghost_Mode
> None
14396 ("pragma % with value False cannot appear in enabled "
14401 -- Otherwie the expression is not static
14405 ("expression of pragma % must be static", Expr
);
14410 Set_Is_Ghost_Entity
(Id
);
14417 -- pragma Global (GLOBAL_SPECIFICATION);
14419 -- GLOBAL_SPECIFICATION ::=
14422 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14424 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14426 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14427 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14428 -- GLOBAL_ITEM ::= NAME
14430 when Pragma_Global
=> Global
: declare
14431 Subp_Decl
: Node_Id
;
14435 Check_Arg_Count
(1);
14436 Ensure_Aggregate_Form
(Arg1
);
14438 -- Ensure the proper placement of the pragma. Global must be
14439 -- associated with a subprogram declaration or a body that acts
14443 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14445 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14448 -- Body acts as spec
14450 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14451 and then No
(Corresponding_Spec
(Subp_Decl
))
14455 -- Body stub acts as spec
14457 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14458 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14467 -- When the pragma appears on a subprogram body, perform the full
14470 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14471 Analyze_Global_In_Decl_Part
(N
);
14473 -- When Global applies to a subprogram compilation unit, the
14474 -- corresponding pragma is placed after the unit's declaration
14475 -- node and needs to be analyzed immediately.
14477 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
14478 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
14480 Analyze_Global_In_Decl_Part
(N
);
14483 -- Chain the pragma on the contract for further processing
14485 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14492 -- pragma Ident (static_string_EXPRESSION)
14494 -- Note: pragma Comment shares this processing. Pragma Ident is
14495 -- identical in effect to pragma Commment.
14497 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14502 Check_Arg_Count
(1);
14503 Check_No_Identifiers
;
14504 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14507 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14514 GP
:= Parent
(Parent
(N
));
14516 if Nkind_In
(GP
, N_Package_Declaration
,
14517 N_Generic_Package_Declaration
)
14522 -- If we have a compilation unit, then record the ident value,
14523 -- checking for improper duplication.
14525 if Nkind
(GP
) = N_Compilation_Unit
then
14526 CS
:= Ident_String
(Current_Sem_Unit
);
14528 if Present
(CS
) then
14530 -- If we have multiple instances, concatenate them, but
14531 -- not in ASIS, where we want the original tree.
14533 if not ASIS_Mode
then
14534 Start_String
(Strval
(CS
));
14535 Store_String_Char
(' ');
14536 Store_String_Chars
(Strval
(Str
));
14537 Set_Strval
(CS
, End_String
);
14541 Set_Ident_String
(Current_Sem_Unit
, Str
);
14544 -- For subunits, we just ignore the Ident, since in GNAT these
14545 -- are not separate object files, and hence not separate units
14546 -- in the unit table.
14548 elsif Nkind
(GP
) = N_Subunit
then
14554 ----------------------------
14555 -- Implementation_Defined --
14556 ----------------------------
14558 -- pragma Implementation_Defined (LOCAL_NAME);
14560 -- Marks previously declared entity as implementation defined. For
14561 -- an overloaded entity, applies to the most recent homonym.
14563 -- pragma Implementation_Defined;
14565 -- The form with no arguments appears anywhere within a scope, most
14566 -- typically a package spec, and indicates that all entities that are
14567 -- defined within the package spec are Implementation_Defined.
14569 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14574 Check_No_Identifiers
;
14576 -- Form with no arguments
14578 if Arg_Count
= 0 then
14579 Set_Is_Implementation_Defined
(Current_Scope
);
14581 -- Form with one argument
14584 Check_Arg_Count
(1);
14585 Check_Arg_Is_Local_Name
(Arg1
);
14586 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14587 Set_Is_Implementation_Defined
(Ent
);
14589 end Implementation_Defined
;
14595 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14597 -- IMPLEMENTATION_KIND ::=
14598 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14600 -- "By_Any" and "Optional" are treated as synonyms in order to
14601 -- support Ada 2012 aspect Synchronization.
14603 when Pragma_Implemented
=> Implemented
: declare
14604 Proc_Id
: Entity_Id
;
14609 Check_Arg_Count
(2);
14610 Check_No_Identifiers
;
14611 Check_Arg_Is_Identifier
(Arg1
);
14612 Check_Arg_Is_Local_Name
(Arg1
);
14613 Check_Arg_Is_One_Of
(Arg2
,
14616 Name_By_Protected_Procedure
,
14619 -- Extract the name of the local procedure
14621 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14623 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14624 -- primitive procedure of a synchronized tagged type.
14626 if Ekind
(Proc_Id
) = E_Procedure
14627 and then Is_Primitive
(Proc_Id
)
14628 and then Present
(First_Formal
(Proc_Id
))
14630 Typ
:= Etype
(First_Formal
(Proc_Id
));
14632 if Is_Tagged_Type
(Typ
)
14635 -- Check for a protected, a synchronized or a task interface
14637 ((Is_Interface
(Typ
)
14638 and then Is_Synchronized_Interface
(Typ
))
14640 -- Check for a protected type or a task type that implements
14644 (Is_Concurrent_Record_Type
(Typ
)
14645 and then Present
(Interfaces
(Typ
)))
14647 -- In analysis-only mode, examine original protected type
14650 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
14651 and then Present
(Interface_List
(Parent
(Typ
))))
14653 -- Check for a private record extension with keyword
14657 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14658 E_Record_Subtype_With_Private
)
14659 and then Synchronized_Present
(Parent
(Typ
))))
14664 ("controlling formal must be of synchronized tagged type",
14669 -- Procedures declared inside a protected type must be accepted
14671 elsif Ekind
(Proc_Id
) = E_Procedure
14672 and then Is_Protected_Type
(Scope
(Proc_Id
))
14676 -- The first argument is not a primitive procedure
14680 ("pragma % must be applied to a primitive procedure", Arg1
);
14684 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14685 -- By_Protected_Procedure to the primitive procedure of a task
14688 if Chars
(Arg2
) = Name_By_Protected_Procedure
14689 and then Is_Interface
(Typ
)
14690 and then Is_Task_Interface
(Typ
)
14693 ("implementation kind By_Protected_Procedure cannot be "
14694 & "applied to a task interface primitive", Arg2
);
14698 Record_Rep_Item
(Proc_Id
, N
);
14701 ----------------------
14702 -- Implicit_Packing --
14703 ----------------------
14705 -- pragma Implicit_Packing;
14707 when Pragma_Implicit_Packing
=>
14709 Check_Arg_Count
(0);
14710 Implicit_Packing
:= True;
14717 -- [Convention =>] convention_IDENTIFIER,
14718 -- [Entity =>] LOCAL_NAME
14719 -- [, [External_Name =>] static_string_EXPRESSION ]
14720 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14722 when Pragma_Import
=>
14723 Check_Ada_83_Warning
;
14727 Name_External_Name
,
14730 Check_At_Least_N_Arguments
(2);
14731 Check_At_Most_N_Arguments
(4);
14732 Process_Import_Or_Interface
;
14734 ---------------------
14735 -- Import_Function --
14736 ---------------------
14738 -- pragma Import_Function (
14739 -- [Internal =>] LOCAL_NAME,
14740 -- [, [External =>] EXTERNAL_SYMBOL]
14741 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14742 -- [, [Result_Type =>] SUBTYPE_MARK]
14743 -- [, [Mechanism =>] MECHANISM]
14744 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14746 -- EXTERNAL_SYMBOL ::=
14748 -- | static_string_EXPRESSION
14750 -- PARAMETER_TYPES ::=
14752 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14754 -- TYPE_DESIGNATOR ::=
14756 -- | subtype_Name ' Access
14760 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14762 -- MECHANISM_ASSOCIATION ::=
14763 -- [formal_parameter_NAME =>] MECHANISM_NAME
14765 -- MECHANISM_NAME ::=
14769 when Pragma_Import_Function
=> Import_Function
: declare
14770 Args
: Args_List
(1 .. 6);
14771 Names
: constant Name_List
(1 .. 6) := (
14774 Name_Parameter_Types
,
14777 Name_Result_Mechanism
);
14779 Internal
: Node_Id
renames Args
(1);
14780 External
: Node_Id
renames Args
(2);
14781 Parameter_Types
: Node_Id
renames Args
(3);
14782 Result_Type
: Node_Id
renames Args
(4);
14783 Mechanism
: Node_Id
renames Args
(5);
14784 Result_Mechanism
: Node_Id
renames Args
(6);
14788 Gather_Associations
(Names
, Args
);
14789 Process_Extended_Import_Export_Subprogram_Pragma
(
14790 Arg_Internal
=> Internal
,
14791 Arg_External
=> External
,
14792 Arg_Parameter_Types
=> Parameter_Types
,
14793 Arg_Result_Type
=> Result_Type
,
14794 Arg_Mechanism
=> Mechanism
,
14795 Arg_Result_Mechanism
=> Result_Mechanism
);
14796 end Import_Function
;
14798 -------------------
14799 -- Import_Object --
14800 -------------------
14802 -- pragma Import_Object (
14803 -- [Internal =>] LOCAL_NAME
14804 -- [, [External =>] EXTERNAL_SYMBOL]
14805 -- [, [Size =>] EXTERNAL_SYMBOL]);
14807 -- EXTERNAL_SYMBOL ::=
14809 -- | static_string_EXPRESSION
14811 when Pragma_Import_Object
=> Import_Object
: declare
14812 Args
: Args_List
(1 .. 3);
14813 Names
: constant Name_List
(1 .. 3) := (
14818 Internal
: Node_Id
renames Args
(1);
14819 External
: Node_Id
renames Args
(2);
14820 Size
: Node_Id
renames Args
(3);
14824 Gather_Associations
(Names
, Args
);
14825 Process_Extended_Import_Export_Object_Pragma
(
14826 Arg_Internal
=> Internal
,
14827 Arg_External
=> External
,
14831 ----------------------
14832 -- Import_Procedure --
14833 ----------------------
14835 -- pragma Import_Procedure (
14836 -- [Internal =>] LOCAL_NAME
14837 -- [, [External =>] EXTERNAL_SYMBOL]
14838 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14839 -- [, [Mechanism =>] MECHANISM]);
14841 -- EXTERNAL_SYMBOL ::=
14843 -- | static_string_EXPRESSION
14845 -- PARAMETER_TYPES ::=
14847 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14849 -- TYPE_DESIGNATOR ::=
14851 -- | subtype_Name ' Access
14855 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14857 -- MECHANISM_ASSOCIATION ::=
14858 -- [formal_parameter_NAME =>] MECHANISM_NAME
14860 -- MECHANISM_NAME ::=
14864 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14865 Args
: Args_List
(1 .. 4);
14866 Names
: constant Name_List
(1 .. 4) := (
14869 Name_Parameter_Types
,
14872 Internal
: Node_Id
renames Args
(1);
14873 External
: Node_Id
renames Args
(2);
14874 Parameter_Types
: Node_Id
renames Args
(3);
14875 Mechanism
: Node_Id
renames Args
(4);
14879 Gather_Associations
(Names
, Args
);
14880 Process_Extended_Import_Export_Subprogram_Pragma
(
14881 Arg_Internal
=> Internal
,
14882 Arg_External
=> External
,
14883 Arg_Parameter_Types
=> Parameter_Types
,
14884 Arg_Mechanism
=> Mechanism
);
14885 end Import_Procedure
;
14887 -----------------------------
14888 -- Import_Valued_Procedure --
14889 -----------------------------
14891 -- pragma Import_Valued_Procedure (
14892 -- [Internal =>] LOCAL_NAME
14893 -- [, [External =>] EXTERNAL_SYMBOL]
14894 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14895 -- [, [Mechanism =>] MECHANISM]);
14897 -- EXTERNAL_SYMBOL ::=
14899 -- | static_string_EXPRESSION
14901 -- PARAMETER_TYPES ::=
14903 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14905 -- TYPE_DESIGNATOR ::=
14907 -- | subtype_Name ' Access
14911 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14913 -- MECHANISM_ASSOCIATION ::=
14914 -- [formal_parameter_NAME =>] MECHANISM_NAME
14916 -- MECHANISM_NAME ::=
14920 when Pragma_Import_Valued_Procedure
=>
14921 Import_Valued_Procedure
: declare
14922 Args
: Args_List
(1 .. 4);
14923 Names
: constant Name_List
(1 .. 4) := (
14926 Name_Parameter_Types
,
14929 Internal
: Node_Id
renames Args
(1);
14930 External
: Node_Id
renames Args
(2);
14931 Parameter_Types
: Node_Id
renames Args
(3);
14932 Mechanism
: Node_Id
renames Args
(4);
14936 Gather_Associations
(Names
, Args
);
14937 Process_Extended_Import_Export_Subprogram_Pragma
(
14938 Arg_Internal
=> Internal
,
14939 Arg_External
=> External
,
14940 Arg_Parameter_Types
=> Parameter_Types
,
14941 Arg_Mechanism
=> Mechanism
);
14942 end Import_Valued_Procedure
;
14948 -- pragma Independent (LOCAL_NAME);
14950 when Pragma_Independent
=>
14951 Process_Atomic_Independent_Shared_Volatile
;
14953 ----------------------------
14954 -- Independent_Components --
14955 ----------------------------
14957 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
14959 when Pragma_Independent_Components
=> Independent_Components
: declare
14967 Check_Ada_83_Warning
;
14969 Check_No_Identifiers
;
14970 Check_Arg_Count
(1);
14971 Check_Arg_Is_Local_Name
(Arg1
);
14972 E_Id
:= Get_Pragma_Arg
(Arg1
);
14974 if Etype
(E_Id
) = Any_Type
then
14978 E
:= Entity
(E_Id
);
14980 -- Check duplicate before we chain ourselves
14982 Check_Duplicate_Pragma
(E
);
14984 -- Check appropriate entity
14986 if Rep_Item_Too_Early
(E
, N
)
14988 Rep_Item_Too_Late
(E
, N
)
14993 D
:= Declaration_Node
(E
);
14996 -- The flag is set on the base type, or on the object
14998 if K
= N_Full_Type_Declaration
14999 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15001 Set_Has_Independent_Components
(Base_Type
(E
));
15002 Independence_Checks
.Append
((N
, Base_Type
(E
)));
15004 -- For record type, set all components independent
15006 if Is_Record_Type
(E
) then
15007 C
:= First_Component
(E
);
15008 while Present
(C
) loop
15009 Set_Is_Independent
(C
);
15010 Next_Component
(C
);
15014 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15015 and then Nkind
(D
) = N_Object_Declaration
15016 and then Nkind
(Object_Definition
(D
)) =
15017 N_Constrained_Array_Definition
15019 Set_Has_Independent_Components
(E
);
15020 Independence_Checks
.Append
((N
, E
));
15023 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15025 end Independent_Components
;
15027 -----------------------
15028 -- Initial_Condition --
15029 -----------------------
15031 -- pragma Initial_Condition (boolean_EXPRESSION);
15033 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15034 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15035 Pack_Id
: Entity_Id
;
15040 Check_No_Identifiers
;
15041 Check_Arg_Count
(1);
15043 -- Ensure the proper placement of the pragma. Initial_Condition
15044 -- must be associated with a package declaration.
15046 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15047 N_Package_Declaration
)
15054 while Present
(Stmt
) loop
15056 -- Skip prior pragmas, but check for duplicates
15058 if Nkind
(Stmt
) = N_Pragma
then
15059 if Pragma_Name
(Stmt
) = Pname
then
15060 Error_Msg_Name_1
:= Pname
;
15061 Error_Msg_Sloc
:= Sloc
(Stmt
);
15062 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15065 -- Skip internally generated code
15067 elsif not Comes_From_Source
(Stmt
) then
15070 -- The pragma does not apply to a legal construct, issue an
15071 -- error and stop the analysis.
15078 Stmt
:= Prev
(Stmt
);
15081 -- The pragma must be analyzed at the end of the visible
15082 -- declarations of the related package. Save the pragma for later
15083 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15084 -- the contract of the package.
15086 Pack_Id
:= Defining_Entity
(Context
);
15087 Add_Contract_Item
(N
, Pack_Id
);
15089 -- Verify the declaration order of pragma Initial_Condition with
15090 -- respect to pragmas Abstract_State and Initializes when SPARK
15091 -- checks are enabled.
15093 if SPARK_Mode
/= Off
then
15094 Check_Declaration_Order
15095 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15098 Check_Declaration_Order
15099 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
15102 end Initial_Condition
;
15104 ------------------------
15105 -- Initialize_Scalars --
15106 ------------------------
15108 -- pragma Initialize_Scalars;
15110 when Pragma_Initialize_Scalars
=>
15112 Check_Arg_Count
(0);
15113 Check_Valid_Configuration_Pragma
;
15114 Check_Restriction
(No_Initialize_Scalars
, N
);
15116 -- Initialize_Scalars creates false positives in CodePeer, and
15117 -- incorrect negative results in GNATprove mode, so ignore this
15118 -- pragma in these modes.
15120 if not Restriction_Active
(No_Initialize_Scalars
)
15121 and then not (CodePeer_Mode
or GNATprove_Mode
)
15123 Init_Or_Norm_Scalars
:= True;
15124 Initialize_Scalars
:= True;
15131 -- pragma Initializes (INITIALIZATION_SPEC);
15133 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15135 -- INITIALIZATION_LIST ::=
15136 -- INITIALIZATION_ITEM
15137 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15139 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15144 -- | (INPUT {, INPUT})
15148 when Pragma_Initializes
=> Initializes
: declare
15149 Context
: constant Node_Id
:= Parent
(Parent
(N
));
15150 Pack_Id
: Entity_Id
;
15155 Check_No_Identifiers
;
15156 Check_Arg_Count
(1);
15157 Ensure_Aggregate_Form
(Arg1
);
15159 -- Ensure the proper placement of the pragma. Initializes must be
15160 -- associated with a package declaration.
15162 if not Nkind_In
(Context
, N_Generic_Package_Declaration
,
15163 N_Package_Declaration
)
15170 while Present
(Stmt
) loop
15172 -- Skip prior pragmas, but check for duplicates
15174 if Nkind
(Stmt
) = N_Pragma
then
15175 if Pragma_Name
(Stmt
) = Pname
then
15176 Error_Msg_Name_1
:= Pname
;
15177 Error_Msg_Sloc
:= Sloc
(Stmt
);
15178 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
15181 -- Skip internally generated code
15183 elsif not Comes_From_Source
(Stmt
) then
15186 -- The pragma does not apply to a legal construct, issue an
15187 -- error and stop the analysis.
15194 Stmt
:= Prev
(Stmt
);
15197 -- The pragma must be analyzed at the end of the visible
15198 -- declarations of the related package. Save the pragma for later
15199 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15200 -- contract of the package.
15202 Pack_Id
:= Defining_Entity
(Context
);
15203 Add_Contract_Item
(N
, Pack_Id
);
15205 -- Verify the declaration order of pragmas Abstract_State and
15206 -- Initializes when SPARK checks are enabled.
15208 if SPARK_Mode
/= Off
then
15209 Check_Declaration_Order
15210 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15219 -- pragma Inline ( NAME {, NAME} );
15221 when Pragma_Inline
=>
15223 -- Pragma always active unless in GNATprove mode. It is disabled
15224 -- in GNATprove mode because frontend inlining is applied
15225 -- independently of pragmas Inline and Inline_Always for
15226 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15229 if not GNATprove_Mode
then
15231 -- Inline status is Enabled if inlining option is active
15233 if Inline_Active
then
15234 Process_Inline
(Enabled
);
15236 Process_Inline
(Disabled
);
15240 -------------------
15241 -- Inline_Always --
15242 -------------------
15244 -- pragma Inline_Always ( NAME {, NAME} );
15246 when Pragma_Inline_Always
=>
15249 -- Pragma always active unless in CodePeer mode or GNATprove
15250 -- mode. It is disabled in CodePeer mode because inlining is
15251 -- not helpful, and enabling it caused walk order issues. It
15252 -- is disabled in GNATprove mode because frontend inlining is
15253 -- applied independently of pragmas Inline and Inline_Always for
15254 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15257 if not CodePeer_Mode
and not GNATprove_Mode
then
15258 Process_Inline
(Enabled
);
15261 --------------------
15262 -- Inline_Generic --
15263 --------------------
15265 -- pragma Inline_Generic (NAME {, NAME});
15267 when Pragma_Inline_Generic
=>
15269 Process_Generic_List
;
15271 ----------------------
15272 -- Inspection_Point --
15273 ----------------------
15275 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15277 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15284 if Arg_Count
> 0 then
15287 Exp
:= Get_Pragma_Arg
(Arg
);
15290 if not Is_Entity_Name
(Exp
)
15291 or else not Is_Object
(Entity
(Exp
))
15293 Error_Pragma_Arg
("object name required", Arg
);
15297 exit when No
(Arg
);
15300 end Inspection_Point
;
15306 -- pragma Interface (
15307 -- [ Convention =>] convention_IDENTIFIER,
15308 -- [ Entity =>] LOCAL_NAME
15309 -- [, [External_Name =>] static_string_EXPRESSION ]
15310 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15312 when Pragma_Interface
=>
15317 Name_External_Name
,
15319 Check_At_Least_N_Arguments
(2);
15320 Check_At_Most_N_Arguments
(4);
15321 Process_Import_Or_Interface
;
15323 -- In Ada 2005, the permission to use Interface (a reserved word)
15324 -- as a pragma name is considered an obsolescent feature, and this
15325 -- pragma was already obsolescent in Ada 95.
15327 if Ada_Version
>= Ada_95
then
15329 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15331 if Warn_On_Obsolescent_Feature
then
15333 ("pragma Interface is an obsolescent feature?j?", N
);
15335 ("|use pragma Import instead?j?", N
);
15339 --------------------
15340 -- Interface_Name --
15341 --------------------
15343 -- pragma Interface_Name (
15344 -- [ Entity =>] LOCAL_NAME
15345 -- [,[External_Name =>] static_string_EXPRESSION ]
15346 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15348 when Pragma_Interface_Name
=> Interface_Name
: declare
15350 Def_Id
: Entity_Id
;
15351 Hom_Id
: Entity_Id
;
15357 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15358 Check_At_Least_N_Arguments
(2);
15359 Check_At_Most_N_Arguments
(3);
15360 Id
:= Get_Pragma_Arg
(Arg1
);
15363 -- This is obsolete from Ada 95 on, but it is an implementation
15364 -- defined pragma, so we do not consider that it violates the
15365 -- restriction (No_Obsolescent_Features).
15367 if Ada_Version
>= Ada_95
then
15368 if Warn_On_Obsolescent_Feature
then
15370 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15372 ("|use pragma Import instead?j?", N
);
15376 if not Is_Entity_Name
(Id
) then
15378 ("first argument for pragma% must be entity name", Arg1
);
15379 elsif Etype
(Id
) = Any_Type
then
15382 Def_Id
:= Entity
(Id
);
15385 -- Special DEC-compatible processing for the object case, forces
15386 -- object to be imported.
15388 if Ekind
(Def_Id
) = E_Variable
then
15389 Kill_Size_Check_Code
(Def_Id
);
15390 Note_Possible_Modification
(Id
, Sure
=> False);
15392 -- Initialization is not allowed for imported variable
15394 if Present
(Expression
(Parent
(Def_Id
)))
15395 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15397 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15399 ("no initialization allowed for declaration of& #",
15403 -- For compatibility, support VADS usage of providing both
15404 -- pragmas Interface and Interface_Name to obtain the effect
15405 -- of a single Import pragma.
15407 if Is_Imported
(Def_Id
)
15408 and then Present
(First_Rep_Item
(Def_Id
))
15409 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15411 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15415 Set_Imported
(Def_Id
);
15418 Set_Is_Public
(Def_Id
);
15419 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15422 -- Otherwise must be subprogram
15424 elsif not Is_Subprogram
(Def_Id
) then
15426 ("argument of pragma% is not subprogram", Arg1
);
15429 Check_At_Most_N_Arguments
(3);
15433 -- Loop through homonyms
15436 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15438 if Is_Imported
(Def_Id
) then
15439 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15443 exit when From_Aspect_Specification
(N
);
15444 Hom_Id
:= Homonym
(Hom_Id
);
15446 exit when No
(Hom_Id
)
15447 or else Scope
(Hom_Id
) /= Current_Scope
;
15452 ("argument of pragma% is not imported subprogram",
15456 end Interface_Name
;
15458 -----------------------
15459 -- Interrupt_Handler --
15460 -----------------------
15462 -- pragma Interrupt_Handler (handler_NAME);
15464 when Pragma_Interrupt_Handler
=>
15465 Check_Ada_83_Warning
;
15466 Check_Arg_Count
(1);
15467 Check_No_Identifiers
;
15469 if No_Run_Time_Mode
then
15470 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15472 Check_Interrupt_Or_Attach_Handler
;
15473 Process_Interrupt_Or_Attach_Handler
;
15476 ------------------------
15477 -- Interrupt_Priority --
15478 ------------------------
15480 -- pragma Interrupt_Priority [(EXPRESSION)];
15482 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15483 P
: constant Node_Id
:= Parent
(N
);
15488 Check_Ada_83_Warning
;
15490 if Arg_Count
/= 0 then
15491 Arg
:= Get_Pragma_Arg
(Arg1
);
15492 Check_Arg_Count
(1);
15493 Check_No_Identifiers
;
15495 -- The expression must be analyzed in the special manner
15496 -- described in "Handling of Default and Per-Object
15497 -- Expressions" in sem.ads.
15499 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15502 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15507 Ent
:= Defining_Identifier
(Parent
(P
));
15509 -- Check duplicate pragma before we chain the pragma in the Rep
15510 -- Item chain of Ent.
15512 Check_Duplicate_Pragma
(Ent
);
15513 Record_Rep_Item
(Ent
, N
);
15515 end Interrupt_Priority
;
15517 ---------------------
15518 -- Interrupt_State --
15519 ---------------------
15521 -- pragma Interrupt_State (
15522 -- [Name =>] INTERRUPT_ID,
15523 -- [State =>] INTERRUPT_STATE);
15525 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15526 -- INTERRUPT_STATE => System | Runtime | User
15528 -- Note: if the interrupt id is given as an identifier, then it must
15529 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15530 -- given as a static integer expression which must be in the range of
15531 -- Ada.Interrupts.Interrupt_ID.
15533 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15534 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15535 -- This is the entity Ada.Interrupts.Interrupt_ID;
15537 State_Type
: Character;
15538 -- Set to 's'/'r'/'u' for System/Runtime/User
15541 -- Index to entry in Interrupt_States table
15544 -- Value of interrupt
15546 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15547 -- The first argument to the pragma
15549 Int_Ent
: Entity_Id
;
15550 -- Interrupt entity in Ada.Interrupts.Names
15554 Check_Arg_Order
((Name_Name
, Name_State
));
15555 Check_Arg_Count
(2);
15557 Check_Optional_Identifier
(Arg1
, Name_Name
);
15558 Check_Optional_Identifier
(Arg2
, Name_State
);
15559 Check_Arg_Is_Identifier
(Arg2
);
15561 -- First argument is identifier
15563 if Nkind
(Arg1X
) = N_Identifier
then
15565 -- Search list of names in Ada.Interrupts.Names
15567 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15569 if No
(Int_Ent
) then
15570 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15572 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15573 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15577 Next_Entity
(Int_Ent
);
15580 -- First argument is not an identifier, so it must be a static
15581 -- expression of type Ada.Interrupts.Interrupt_ID.
15584 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15585 Int_Val
:= Expr_Value
(Arg1X
);
15587 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15589 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15592 ("value not in range of type "
15593 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15599 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15600 when Name_Runtime
=> State_Type
:= 'r';
15601 when Name_System
=> State_Type
:= 's';
15602 when Name_User
=> State_Type
:= 'u';
15605 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15608 -- Check if entry is already stored
15610 IST_Num
:= Interrupt_States
.First
;
15612 -- If entry not found, add it
15614 if IST_Num
> Interrupt_States
.Last
then
15615 Interrupt_States
.Append
15616 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15617 Interrupt_State
=> State_Type
,
15618 Pragma_Loc
=> Loc
));
15621 -- Case of entry for the same entry
15623 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15626 -- If state matches, done, no need to make redundant entry
15629 State_Type
= Interrupt_States
.Table
(IST_Num
).
15632 -- Otherwise if state does not match, error
15635 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15637 ("state conflicts with that given #", Arg2
);
15641 IST_Num
:= IST_Num
+ 1;
15643 end Interrupt_State
;
15649 -- pragma Invariant
15650 -- ([Entity =>] type_LOCAL_NAME,
15651 -- [Check =>] EXPRESSION
15652 -- [,[Message =>] String_Expression]);
15654 when Pragma_Invariant
=> Invariant
: declare
15661 Check_At_Least_N_Arguments
(2);
15662 Check_At_Most_N_Arguments
(3);
15663 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15664 Check_Optional_Identifier
(Arg2
, Name_Check
);
15666 if Arg_Count
= 3 then
15667 Check_Optional_Identifier
(Arg3
, Name_Message
);
15668 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15671 Check_Arg_Is_Local_Name
(Arg1
);
15673 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15674 Find_Type
(Type_Id
);
15675 Typ
:= Entity
(Type_Id
);
15677 if Typ
= Any_Type
then
15680 -- An invariant must apply to a private type, or appear in the
15681 -- private part of a package spec and apply to a completion.
15682 -- a class-wide invariant can only appear on a private declaration
15683 -- or private extension, not a completion.
15685 elsif Ekind_In
(Typ
, E_Private_Type
,
15686 E_Record_Type_With_Private
,
15687 E_Limited_Private_Type
)
15691 elsif In_Private_Part
(Current_Scope
)
15692 and then Has_Private_Declaration
(Typ
)
15693 and then not Class_Present
(N
)
15697 elsif In_Private_Part
(Current_Scope
) then
15699 ("pragma% only allowed for private type declared in "
15700 & "visible part", Arg1
);
15704 ("pragma% only allowed for private type", Arg1
);
15707 -- Not allowed for abstract type
15709 if Is_Abstract_Type
(Typ
) then
15711 ("pragma% not allowed for abstract type", Arg1
);
15714 -- Note that the type has at least one invariant, and also that
15715 -- it has inheritable invariants if we have Invariant'Class
15716 -- or Type_Invariant'Class. Build the corresponding invariant
15717 -- procedure declaration, so that calls to it can be generated
15718 -- before the body is built (e.g. within an expression function).
15720 Insert_After_And_Analyze
15721 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15723 if Class_Present
(N
) then
15724 Set_Has_Inheritable_Invariants
(Typ
);
15727 -- The remaining processing is simply to link the pragma on to
15728 -- the rep item chain, for processing when the type is frozen.
15729 -- This is accomplished by a call to Rep_Item_Too_Late.
15731 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15734 ----------------------
15735 -- Java_Constructor --
15736 ----------------------
15738 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15740 -- Also handles pragma CIL_Constructor
15742 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15743 Java_Constructor
: declare
15744 Convention
: Convention_Id
;
15745 Def_Id
: Entity_Id
;
15746 Hom_Id
: Entity_Id
;
15748 This_Formal
: Entity_Id
;
15752 Check_Arg_Count
(1);
15753 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15754 Check_Arg_Is_Local_Name
(Arg1
);
15756 Id
:= Get_Pragma_Arg
(Arg1
);
15757 Find_Program_Unit_Name
(Id
);
15759 -- If we did not find the name, we are done
15761 if Etype
(Id
) = Any_Type
then
15765 -- Check wrong use of pragma in wrong VM target
15767 if VM_Target
= No_VM
then
15770 elsif VM_Target
= CLI_Target
15771 and then Prag_Id
= Pragma_Java_Constructor
15773 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15775 elsif VM_Target
= JVM_Target
15776 and then Prag_Id
= Pragma_CIL_Constructor
15778 Error_Pragma
("must use pragma 'Java_'Constructor");
15782 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15783 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15784 when others => null;
15787 Hom_Id
:= Entity
(Id
);
15789 -- Loop through homonyms
15792 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15794 -- The constructor is required to be a function
15796 if Ekind
(Def_Id
) /= E_Function
then
15797 if VM_Target
= JVM_Target
then
15799 ("pragma% requires function returning a 'Java access "
15803 ("pragma% requires function returning a 'C'I'L access "
15808 -- Check arguments: For tagged type the first formal must be
15809 -- named "this" and its type must be a named access type
15810 -- designating a class-wide tagged type that has convention
15811 -- CIL/Java. The first formal must also have a null default
15812 -- value. For example:
15814 -- type Typ is tagged ...
15815 -- type Ref is access all Typ;
15816 -- pragma Convention (CIL, Typ);
15818 -- function New_Typ (This : Ref) return Ref;
15819 -- function New_Typ (This : Ref; I : Integer) return Ref;
15820 -- pragma Cil_Constructor (New_Typ);
15822 -- Reason: The first formal must NOT be a primitive of the
15825 -- This rule also applies to constructors of delegates used
15826 -- to interface with standard target libraries. For example:
15828 -- type Delegate is access procedure ...
15829 -- pragma Import (CIL, Delegate, ...);
15831 -- function new_Delegate
15832 -- (This : Delegate := null; ... ) return Delegate;
15834 -- For value-types this rule does not apply.
15836 if not Is_Value_Type
(Etype
(Def_Id
)) then
15837 if No
(First_Formal
(Def_Id
)) then
15838 Error_Msg_Name_1
:= Pname
;
15839 Error_Msg_N
("% function must have parameters", Def_Id
);
15843 -- In the JRE library we have several occurrences in which
15844 -- the "this" parameter is not the first formal.
15846 This_Formal
:= First_Formal
(Def_Id
);
15848 -- In the JRE library we have several occurrences in which
15849 -- the "this" parameter is not the first formal. Search for
15852 if VM_Target
= JVM_Target
then
15853 while Present
(This_Formal
)
15854 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15856 Next_Formal
(This_Formal
);
15859 if No
(This_Formal
) then
15860 This_Formal
:= First_Formal
(Def_Id
);
15864 -- Warning: The first parameter should be named "this".
15865 -- We temporarily allow it because we have the following
15866 -- case in the Java runtime (file s-osinte.ads) ???
15868 -- function new_Thread
15869 -- (Self_Id : System.Address) return Thread_Id;
15870 -- pragma Java_Constructor (new_Thread);
15872 if VM_Target
= JVM_Target
15873 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15875 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15879 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15880 Error_Msg_Name_1
:= Pname
;
15882 ("first formal of % function must be named `this`",
15883 Parent
(This_Formal
));
15885 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15886 Error_Msg_Name_1
:= Pname
;
15888 ("first formal of % function must be an access type",
15889 Parameter_Type
(Parent
(This_Formal
)));
15891 -- For delegates the type of the first formal must be a
15892 -- named access-to-subprogram type (see previous example)
15894 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15895 and then Ekind
(Etype
(This_Formal
))
15896 /= E_Access_Subprogram_Type
15898 Error_Msg_Name_1
:= Pname
;
15900 ("first formal of % function must be a named access "
15901 & "to subprogram type",
15902 Parameter_Type
(Parent
(This_Formal
)));
15904 -- Warning: We should reject anonymous access types because
15905 -- the constructor must not be handled as a primitive of the
15906 -- tagged type. We temporarily allow it because this profile
15907 -- is currently generated by cil2ada???
15909 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15910 and then not Ekind_In
(Etype
(This_Formal
),
15912 E_General_Access_Type
,
15913 E_Anonymous_Access_Type
)
15915 Error_Msg_Name_1
:= Pname
;
15917 ("first formal of % function must be a named access "
15918 & "type", Parameter_Type
(Parent
(This_Formal
)));
15920 elsif Atree
.Convention
15921 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15923 Error_Msg_Name_1
:= Pname
;
15925 if Convention
= Convention_Java
then
15927 ("pragma% requires convention 'Cil in designated "
15928 & "type", Parameter_Type
(Parent
(This_Formal
)));
15931 ("pragma% requires convention 'Java in designated "
15932 & "type", Parameter_Type
(Parent
(This_Formal
)));
15935 elsif No
(Expression
(Parent
(This_Formal
)))
15936 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15938 Error_Msg_Name_1
:= Pname
;
15940 ("pragma% requires first formal with default `null`",
15941 Parameter_Type
(Parent
(This_Formal
)));
15945 -- Check result type: the constructor must be a function
15947 -- * a value type (only allowed in the CIL compiler)
15948 -- * an access-to-subprogram type with convention Java/CIL
15949 -- * an access-type designating a type that has convention
15952 if Is_Value_Type
(Etype
(Def_Id
)) then
15955 -- Access-to-subprogram type with convention Java/CIL
15957 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15958 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15959 if Convention
= Convention_Java
then
15961 ("pragma% requires function returning a 'Java "
15962 & "access type", Arg1
);
15964 pragma Assert
(Convention
= Convention_CIL
);
15966 ("pragma% requires function returning a 'C'I'L "
15967 & "access type", Arg1
);
15971 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15972 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15973 E_General_Access_Type
)
15976 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15978 Error_Msg_Name_1
:= Pname
;
15980 if Convention
= Convention_Java
then
15982 ("pragma% requires function returning a named "
15983 & "'Java access type", Arg1
);
15986 ("pragma% requires function returning a named "
15987 & "'C'I'L access type", Arg1
);
15992 Set_Is_Constructor
(Def_Id
);
15993 Set_Convention
(Def_Id
, Convention
);
15994 Set_Is_Imported
(Def_Id
);
15996 exit when From_Aspect_Specification
(N
);
15997 Hom_Id
:= Homonym
(Hom_Id
);
15999 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
16001 end Java_Constructor
;
16003 ----------------------
16004 -- Java_Interface --
16005 ----------------------
16007 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16009 when Pragma_Java_Interface
=> Java_Interface
: declare
16015 Check_Arg_Count
(1);
16016 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16017 Check_Arg_Is_Local_Name
(Arg1
);
16019 Arg
:= Get_Pragma_Arg
(Arg1
);
16022 if Etype
(Arg
) = Any_Type
then
16026 if not Is_Entity_Name
(Arg
)
16027 or else not Is_Type
(Entity
(Arg
))
16029 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
16032 Typ
:= Underlying_Type
(Entity
(Arg
));
16034 -- For now simply check some of the semantic constraints on the
16035 -- type. This currently leaves out some restrictions on interface
16036 -- types, namely that the parent type must be java.lang.Object.Typ
16037 -- and that all primitives of the type should be declared
16040 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
16042 ("pragma% requires an abstract tagged type", Arg1
);
16044 elsif not Has_Discriminants
(Typ
)
16045 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
16046 /= E_Anonymous_Access_Type
16048 not Is_Class_Wide_Type
16049 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
16052 ("type must have a class-wide access discriminant", Arg1
);
16054 end Java_Interface
;
16060 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16062 when Pragma_Keep_Names
=> Keep_Names
: declare
16067 Check_Arg_Count
(1);
16068 Check_Optional_Identifier
(Arg1
, Name_On
);
16069 Check_Arg_Is_Local_Name
(Arg1
);
16071 Arg
:= Get_Pragma_Arg
(Arg1
);
16074 if Etype
(Arg
) = Any_Type
then
16078 if not Is_Entity_Name
(Arg
)
16079 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16082 ("pragma% requires a local enumeration type", Arg1
);
16085 Set_Discard_Names
(Entity
(Arg
), False);
16092 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16094 when Pragma_License
=>
16097 -- Do not analyze pragma any further in CodePeer mode, to avoid
16098 -- extraneous errors in this implementation-dependent pragma,
16099 -- which has a different profile on other compilers.
16101 if CodePeer_Mode
then
16105 Check_Arg_Count
(1);
16106 Check_No_Identifiers
;
16107 Check_Valid_Configuration_Pragma
;
16108 Check_Arg_Is_Identifier
(Arg1
);
16111 Sind
: constant Source_File_Index
:=
16112 Source_Index
(Current_Sem_Unit
);
16115 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16117 Set_License
(Sind
, GPL
);
16119 when Name_Modified_GPL
=>
16120 Set_License
(Sind
, Modified_GPL
);
16122 when Name_Restricted
=>
16123 Set_License
(Sind
, Restricted
);
16125 when Name_Unrestricted
=>
16126 Set_License
(Sind
, Unrestricted
);
16129 Error_Pragma_Arg
("invalid license name", Arg1
);
16137 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16139 when Pragma_Link_With
=> Link_With
: declare
16145 if Operating_Mode
= Generate_Code
16146 and then In_Extended_Main_Source_Unit
(N
)
16148 Check_At_Least_N_Arguments
(1);
16149 Check_No_Identifiers
;
16150 Check_Is_In_Decl_Part_Or_Package_Spec
;
16151 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16155 while Present
(Arg
) loop
16156 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16158 -- Store argument, converting sequences of spaces to a
16159 -- single null character (this is one of the differences
16160 -- in processing between Link_With and Linker_Options).
16162 Arg_Store
: declare
16163 C
: constant Char_Code
:= Get_Char_Code
(' ');
16164 S
: constant String_Id
:=
16165 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16166 L
: constant Nat
:= String_Length
(S
);
16169 procedure Skip_Spaces
;
16170 -- Advance F past any spaces
16176 procedure Skip_Spaces
is
16178 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16183 -- Start of processing for Arg_Store
16186 Skip_Spaces
; -- skip leading spaces
16188 -- Loop through characters, changing any embedded
16189 -- sequence of spaces to a single null character (this
16190 -- is how Link_With/Linker_Options differ)
16193 if Get_String_Char
(S
, F
) = C
then
16196 Store_String_Char
(ASCII
.NUL
);
16199 Store_String_Char
(Get_String_Char
(S
, F
));
16207 if Present
(Arg
) then
16208 Store_String_Char
(ASCII
.NUL
);
16212 Store_Linker_Option_String
(End_String
);
16220 -- pragma Linker_Alias (
16221 -- [Entity =>] LOCAL_NAME
16222 -- [Target =>] static_string_EXPRESSION);
16224 when Pragma_Linker_Alias
=>
16226 Check_Arg_Order
((Name_Entity
, Name_Target
));
16227 Check_Arg_Count
(2);
16228 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16229 Check_Optional_Identifier
(Arg2
, Name_Target
);
16230 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16231 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16233 -- The only processing required is to link this item on to the
16234 -- list of rep items for the given entity. This is accomplished
16235 -- by the call to Rep_Item_Too_Late (when no error is detected
16236 -- and False is returned).
16238 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16241 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16244 ------------------------
16245 -- Linker_Constructor --
16246 ------------------------
16248 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16250 -- Code is shared with Linker_Destructor
16252 -----------------------
16253 -- Linker_Destructor --
16254 -----------------------
16256 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16258 when Pragma_Linker_Constructor |
16259 Pragma_Linker_Destructor
=>
16260 Linker_Constructor
: declare
16266 Check_Arg_Count
(1);
16267 Check_No_Identifiers
;
16268 Check_Arg_Is_Local_Name
(Arg1
);
16269 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16271 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16273 if not Is_Library_Level_Entity
(Proc
) then
16275 ("argument for pragma% must be library level entity", Arg1
);
16278 -- The only processing required is to link this item on to the
16279 -- list of rep items for the given entity. This is accomplished
16280 -- by the call to Rep_Item_Too_Late (when no error is detected
16281 -- and False is returned).
16283 if Rep_Item_Too_Late
(Proc
, N
) then
16286 Set_Has_Gigi_Rep_Item
(Proc
);
16288 end Linker_Constructor
;
16290 --------------------
16291 -- Linker_Options --
16292 --------------------
16294 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16296 when Pragma_Linker_Options
=> Linker_Options
: declare
16300 Check_Ada_83_Warning
;
16301 Check_No_Identifiers
;
16302 Check_Arg_Count
(1);
16303 Check_Is_In_Decl_Part_Or_Package_Spec
;
16304 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16305 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16308 while Present
(Arg
) loop
16309 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16310 Store_String_Char
(ASCII
.NUL
);
16312 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16316 if Operating_Mode
= Generate_Code
16317 and then In_Extended_Main_Source_Unit
(N
)
16319 Store_Linker_Option_String
(End_String
);
16321 end Linker_Options
;
16323 --------------------
16324 -- Linker_Section --
16325 --------------------
16327 -- pragma Linker_Section (
16328 -- [Entity =>] LOCAL_NAME
16329 -- [Section =>] static_string_EXPRESSION);
16331 when Pragma_Linker_Section
=> Linker_Section
: declare
16338 Check_Arg_Order
((Name_Entity
, Name_Section
));
16339 Check_Arg_Count
(2);
16340 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16341 Check_Optional_Identifier
(Arg2
, Name_Section
);
16342 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16343 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16345 -- Check kind of entity
16347 Arg
:= Get_Pragma_Arg
(Arg1
);
16348 Ent
:= Entity
(Arg
);
16350 case Ekind
(Ent
) is
16352 -- Objects (constants and variables) and types. For these cases
16353 -- all we need to do is to set the Linker_Section_pragma field,
16354 -- checking that we do not have a duplicate.
16356 when E_Constant | E_Variable | Type_Kind
=>
16357 LPE
:= Linker_Section_Pragma
(Ent
);
16359 if Present
(LPE
) then
16360 Error_Msg_Sloc
:= Sloc
(LPE
);
16362 ("Linker_Section already specified for &#", Arg1
, Ent
);
16365 Set_Linker_Section_Pragma
(Ent
, N
);
16369 when Subprogram_Kind
=>
16371 -- Aspect case, entity already set
16373 if From_Aspect_Specification
(N
) then
16374 Set_Linker_Section_Pragma
16375 (Entity
(Corresponding_Aspect
(N
)), N
);
16377 -- Pragma case, we must climb the homonym chain, but skip
16378 -- any for which the linker section is already set.
16382 if No
(Linker_Section_Pragma
(Ent
)) then
16383 Set_Linker_Section_Pragma
(Ent
, N
);
16386 Ent
:= Homonym
(Ent
);
16388 or else Scope
(Ent
) /= Current_Scope
;
16392 -- All other cases are illegal
16396 ("pragma% applies only to objects, subprograms, and types",
16399 end Linker_Section
;
16405 -- pragma List (On | Off)
16407 -- There is nothing to do here, since we did all the processing for
16408 -- this pragma in Par.Prag (so that it works properly even in syntax
16411 when Pragma_List
=>
16418 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16420 when Pragma_Lock_Free
=> Lock_Free
: declare
16421 P
: constant Node_Id
:= Parent
(N
);
16427 Check_No_Identifiers
;
16428 Check_At_Most_N_Arguments
(1);
16430 -- Protected definition case
16432 if Nkind
(P
) = N_Protected_Definition
then
16433 Ent
:= Defining_Identifier
(Parent
(P
));
16437 if Arg_Count
= 1 then
16438 Arg
:= Get_Pragma_Arg
(Arg1
);
16439 Val
:= Is_True
(Static_Boolean
(Arg
));
16441 -- No arguments (expression is considered to be True)
16447 -- Check duplicate pragma before we chain the pragma in the Rep
16448 -- Item chain of Ent.
16450 Check_Duplicate_Pragma
(Ent
);
16451 Record_Rep_Item
(Ent
, N
);
16452 Set_Uses_Lock_Free
(Ent
, Val
);
16454 -- Anything else is incorrect placement
16461 --------------------
16462 -- Locking_Policy --
16463 --------------------
16465 -- pragma Locking_Policy (policy_IDENTIFIER);
16467 when Pragma_Locking_Policy
=> declare
16468 subtype LP_Range
is Name_Id
16469 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16474 Check_Ada_83_Warning
;
16475 Check_Arg_Count
(1);
16476 Check_No_Identifiers
;
16477 Check_Arg_Is_Locking_Policy
(Arg1
);
16478 Check_Valid_Configuration_Pragma
;
16479 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16482 when Name_Ceiling_Locking
=>
16484 when Name_Inheritance_Locking
=>
16486 when Name_Concurrent_Readers_Locking
=>
16490 if Locking_Policy
/= ' '
16491 and then Locking_Policy
/= LP
16493 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16494 Error_Pragma
("locking policy incompatible with policy#");
16496 -- Set new policy, but always preserve System_Location since we
16497 -- like the error message with the run time name.
16500 Locking_Policy
:= LP
;
16502 if Locking_Policy_Sloc
/= System_Location
then
16503 Locking_Policy_Sloc
:= Loc
;
16508 -------------------
16509 -- Loop_Optimize --
16510 -------------------
16512 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16514 -- OPTIMIZATION_HINT ::=
16515 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16517 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16522 Check_At_Least_N_Arguments
(1);
16523 Check_No_Identifiers
;
16525 Hint
:= First
(Pragma_Argument_Associations
(N
));
16526 while Present
(Hint
) loop
16527 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16535 Check_Loop_Pragma_Placement
;
16542 -- pragma Loop_Variant
16543 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16545 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16547 -- CHANGE_DIRECTION ::= Increases | Decreases
16549 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16554 Check_At_Least_N_Arguments
(1);
16555 Check_Loop_Pragma_Placement
;
16557 -- Process all increasing / decreasing expressions
16559 Variant
:= First
(Pragma_Argument_Associations
(N
));
16560 while Present
(Variant
) loop
16561 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16564 Error_Pragma_Arg
("wrong change modifier", Variant
);
16567 Preanalyze_Assert_Expression
16568 (Expression
(Variant
), Any_Discrete
);
16574 -----------------------
16575 -- Machine_Attribute --
16576 -----------------------
16578 -- pragma Machine_Attribute (
16579 -- [Entity =>] LOCAL_NAME,
16580 -- [Attribute_Name =>] static_string_EXPRESSION
16581 -- [, [Info =>] static_EXPRESSION] );
16583 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16584 Def_Id
: Entity_Id
;
16588 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16590 if Arg_Count
= 3 then
16591 Check_Optional_Identifier
(Arg3
, Name_Info
);
16592 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16594 Check_Arg_Count
(2);
16597 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16598 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16599 Check_Arg_Is_Local_Name
(Arg1
);
16600 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16601 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16603 if Is_Access_Type
(Def_Id
) then
16604 Def_Id
:= Designated_Type
(Def_Id
);
16607 if Rep_Item_Too_Early
(Def_Id
, N
) then
16611 Def_Id
:= Underlying_Type
(Def_Id
);
16613 -- The only processing required is to link this item on to the
16614 -- list of rep items for the given entity. This is accomplished
16615 -- by the call to Rep_Item_Too_Late (when no error is detected
16616 -- and False is returned).
16618 if Rep_Item_Too_Late
(Def_Id
, N
) then
16621 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16623 end Machine_Attribute
;
16630 -- (MAIN_OPTION [, MAIN_OPTION]);
16633 -- [STACK_SIZE =>] static_integer_EXPRESSION
16634 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16635 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16637 when Pragma_Main
=> Main
: declare
16638 Args
: Args_List
(1 .. 3);
16639 Names
: constant Name_List
(1 .. 3) := (
16641 Name_Task_Stack_Size_Default
,
16642 Name_Time_Slicing_Enabled
);
16648 Gather_Associations
(Names
, Args
);
16650 for J
in 1 .. 2 loop
16651 if Present
(Args
(J
)) then
16652 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16656 if Present
(Args
(3)) then
16657 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16661 while Present
(Nod
) loop
16662 if Nkind
(Nod
) = N_Pragma
16663 and then Pragma_Name
(Nod
) = Name_Main
16665 Error_Msg_Name_1
:= Pname
;
16666 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16677 -- pragma Main_Storage
16678 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16680 -- MAIN_STORAGE_OPTION ::=
16681 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16682 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16684 when Pragma_Main_Storage
=> Main_Storage
: declare
16685 Args
: Args_List
(1 .. 2);
16686 Names
: constant Name_List
(1 .. 2) := (
16687 Name_Working_Storage
,
16694 Gather_Associations
(Names
, Args
);
16696 for J
in 1 .. 2 loop
16697 if Present
(Args
(J
)) then
16698 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16702 Check_In_Main_Program
;
16705 while Present
(Nod
) loop
16706 if Nkind
(Nod
) = N_Pragma
16707 and then Pragma_Name
(Nod
) = Name_Main_Storage
16709 Error_Msg_Name_1
:= Pname
;
16710 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16721 -- pragma Memory_Size (NUMERIC_LITERAL)
16723 when Pragma_Memory_Size
=>
16726 -- Memory size is simply ignored
16728 Check_No_Identifiers
;
16729 Check_Arg_Count
(1);
16730 Check_Arg_Is_Integer_Literal
(Arg1
);
16738 -- The only correct use of this pragma is on its own in a file, in
16739 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16740 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16741 -- check for a file containing nothing but a No_Body pragma). If we
16742 -- attempt to process it during normal semantics processing, it means
16743 -- it was misplaced.
16745 when Pragma_No_Body
=>
16749 -----------------------------
16750 -- No_Elaboration_Code_All --
16751 -----------------------------
16753 -- pragma No_Elaboration_Code_All;
16755 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16758 Check_Valid_Library_Unit_Pragma
;
16760 if Nkind
(N
) = N_Null_Statement
then
16764 -- Must appear for a spec or generic spec
16766 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16767 N_Generic_Package_Declaration
,
16768 N_Generic_Subprogram_Declaration
,
16769 N_Package_Declaration
,
16770 N_Subprogram_Declaration
)
16774 ("pragma% can only occur for package "
16775 & "or subprogram spec"));
16778 -- Set flag in unit table
16780 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16782 -- Set restriction No_Elaboration_Code if this is the main unit
16784 if Current_Sem_Unit
= Main_Unit
then
16785 Set_Restriction
(No_Elaboration_Code
, N
);
16788 -- If we are in the main unit or in an extended main source unit,
16789 -- then we also add it to the configuration restrictions so that
16790 -- it will apply to all units in the extended main source.
16792 if Current_Sem_Unit
= Main_Unit
16793 or else In_Extended_Main_Source_Unit
(N
)
16795 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16798 -- If in main extended unit, activate transitive with test
16800 if In_Extended_Main_Source_Unit
(N
) then
16801 Opt
.No_Elab_Code_All_Pragma
:= N
;
16809 -- pragma No_Inline ( NAME {, NAME} );
16811 when Pragma_No_Inline
=>
16813 Process_Inline
(Suppressed
);
16819 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16821 when Pragma_No_Return
=> No_Return
: declare
16829 Check_At_Least_N_Arguments
(1);
16831 -- Loop through arguments of pragma
16834 while Present
(Arg
) loop
16835 Check_Arg_Is_Local_Name
(Arg
);
16836 Id
:= Get_Pragma_Arg
(Arg
);
16839 if not Is_Entity_Name
(Id
) then
16840 Error_Pragma_Arg
("entity name required", Arg
);
16843 if Etype
(Id
) = Any_Type
then
16847 -- Loop to find matching procedures
16852 and then Scope
(E
) = Current_Scope
16854 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16857 -- Set flag on any alias as well
16859 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16860 Set_No_Return
(Alias
(E
));
16866 exit when From_Aspect_Specification
(N
);
16870 -- If entity in not in current scope it may be the enclosing
16871 -- suprogram body to which the aspect applies.
16874 if Entity
(Id
) = Current_Scope
16875 and then From_Aspect_Specification
(N
)
16877 Set_No_Return
(Entity
(Id
));
16879 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16891 -- pragma No_Run_Time;
16893 -- Note: this pragma is retained for backwards compatibility. See
16894 -- body of Rtsfind for full details on its handling.
16896 when Pragma_No_Run_Time
=>
16898 Check_Valid_Configuration_Pragma
;
16899 Check_Arg_Count
(0);
16901 No_Run_Time_Mode
:= True;
16902 Configurable_Run_Time_Mode
:= True;
16904 -- Set Duration to 32 bits if word size is 32
16906 if Ttypes
.System_Word_Size
= 32 then
16907 Duration_32_Bits_On_Target
:= True;
16910 -- Set appropriate restrictions
16912 Set_Restriction
(No_Finalization
, N
);
16913 Set_Restriction
(No_Exception_Handlers
, N
);
16914 Set_Restriction
(Max_Tasks
, N
, 0);
16915 Set_Restriction
(No_Tasking
, N
);
16917 -----------------------
16918 -- No_Tagged_Streams --
16919 -----------------------
16921 -- pragma No_Tagged_Streams;
16922 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16924 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16930 Check_At_Most_N_Arguments
(1);
16932 -- One argument case
16934 if Arg_Count
= 1 then
16935 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16936 Check_Arg_Is_Local_Name
(Arg1
);
16937 E_Id
:= Get_Pragma_Arg
(Arg1
);
16939 if Etype
(E_Id
) = Any_Type
then
16943 E
:= Entity
(E_Id
);
16945 Check_Duplicate_Pragma
(E
);
16947 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16949 ("argument for pragma% must be root tagged type", Arg1
);
16952 if Rep_Item_Too_Early
(E
, N
)
16954 Rep_Item_Too_Late
(E
, N
)
16958 Set_No_Tagged_Streams_Pragma
(E
, N
);
16961 -- Zero argument case
16964 Check_Is_In_Decl_Part_Or_Package_Spec
;
16965 No_Tagged_Streams
:= N
;
16967 end No_Tagged_Strms
;
16969 ------------------------
16970 -- No_Strict_Aliasing --
16971 ------------------------
16973 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16975 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16980 Check_At_Most_N_Arguments
(1);
16982 if Arg_Count
= 0 then
16983 Check_Valid_Configuration_Pragma
;
16984 Opt
.No_Strict_Aliasing
:= True;
16987 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16988 Check_Arg_Is_Local_Name
(Arg1
);
16989 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16991 if E_Id
= Any_Type
then
16993 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16994 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16997 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16999 end No_Strict_Aliasing
;
17001 -----------------------
17002 -- Normalize_Scalars --
17003 -----------------------
17005 -- pragma Normalize_Scalars;
17007 when Pragma_Normalize_Scalars
=>
17008 Check_Ada_83_Warning
;
17009 Check_Arg_Count
(0);
17010 Check_Valid_Configuration_Pragma
;
17012 -- Normalize_Scalars creates false positives in CodePeer, and
17013 -- incorrect negative results in GNATprove mode, so ignore this
17014 -- pragma in these modes.
17016 if not (CodePeer_Mode
or GNATprove_Mode
) then
17017 Normalize_Scalars
:= True;
17018 Init_Or_Norm_Scalars
:= True;
17025 -- pragma Obsolescent;
17027 -- pragma Obsolescent (
17028 -- [Message =>] static_string_EXPRESSION
17029 -- [,[Version =>] Ada_05]]);
17031 -- pragma Obsolescent (
17032 -- [Entity =>] NAME
17033 -- [,[Message =>] static_string_EXPRESSION
17034 -- [,[Version =>] Ada_05]] );
17036 when Pragma_Obsolescent
=> Obsolescent
: declare
17040 procedure Set_Obsolescent
(E
: Entity_Id
);
17041 -- Given an entity Ent, mark it as obsolescent if appropriate
17043 ---------------------
17044 -- Set_Obsolescent --
17045 ---------------------
17047 procedure Set_Obsolescent
(E
: Entity_Id
) is
17056 -- Entity name was given
17058 if Present
(Ename
) then
17060 -- If entity name matches, we are fine. Save entity in
17061 -- pragma argument, for ASIS use.
17063 if Chars
(Ename
) = Chars
(Ent
) then
17064 Set_Entity
(Ename
, Ent
);
17065 Generate_Reference
(Ent
, Ename
);
17067 -- If entity name does not match, only possibility is an
17068 -- enumeration literal from an enumeration type declaration.
17070 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17072 ("pragma % entity name does not match declaration");
17075 Ent
:= First_Literal
(E
);
17079 ("pragma % entity name does not match any "
17080 & "enumeration literal");
17082 elsif Chars
(Ent
) = Chars
(Ename
) then
17083 Set_Entity
(Ename
, Ent
);
17084 Generate_Reference
(Ent
, Ename
);
17088 Ent
:= Next_Literal
(Ent
);
17094 -- Ent points to entity to be marked
17096 if Arg_Count
>= 1 then
17098 -- Deal with static string argument
17100 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17101 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17103 for J
in 1 .. String_Length
(S
) loop
17104 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17106 ("pragma% argument does not allow wide characters",
17111 Obsolescent_Warnings
.Append
17112 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17114 -- Check for Ada_05 parameter
17116 if Arg_Count
/= 1 then
17117 Check_Arg_Count
(2);
17120 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17123 Check_Arg_Is_Identifier
(Argx
);
17125 if Chars
(Argx
) /= Name_Ada_05
then
17126 Error_Msg_Name_2
:= Name_Ada_05
;
17128 ("only allowed argument for pragma% is %", Argx
);
17131 if Ada_Version_Explicit
< Ada_2005
17132 or else not Warn_On_Ada_2005_Compatibility
17140 -- Set flag if pragma active
17143 Set_Is_Obsolescent
(Ent
);
17147 end Set_Obsolescent
;
17149 -- Start of processing for pragma Obsolescent
17154 Check_At_Most_N_Arguments
(3);
17156 -- See if first argument specifies an entity name
17160 (Chars
(Arg1
) = Name_Entity
17162 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17164 N_Operator_Symbol
))
17166 Ename
:= Get_Pragma_Arg
(Arg1
);
17168 -- Eliminate first argument, so we can share processing
17172 Arg_Count
:= Arg_Count
- 1;
17174 -- No Entity name argument given
17180 if Arg_Count
>= 1 then
17181 Check_Optional_Identifier
(Arg1
, Name_Message
);
17183 if Arg_Count
= 2 then
17184 Check_Optional_Identifier
(Arg2
, Name_Version
);
17188 -- Get immediately preceding declaration
17191 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17195 -- Cases where we do not follow anything other than another pragma
17199 -- First case: library level compilation unit declaration with
17200 -- the pragma immediately following the declaration.
17202 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17204 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17207 -- Case 2: library unit placement for package
17211 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17213 if Is_Package_Or_Generic_Package
(Ent
) then
17214 Set_Obsolescent
(Ent
);
17220 -- Cases where we must follow a declaration
17223 if Nkind
(Decl
) not in N_Declaration
17224 and then Nkind
(Decl
) not in N_Later_Decl_Item
17225 and then Nkind
(Decl
) not in N_Generic_Declaration
17226 and then Nkind
(Decl
) not in N_Renaming_Declaration
17229 ("pragma% misplaced, "
17230 & "must immediately follow a declaration");
17233 Set_Obsolescent
(Defining_Entity
(Decl
));
17243 -- pragma Optimize (Time | Space | Off);
17245 -- The actual check for optimize is done in Gigi. Note that this
17246 -- pragma does not actually change the optimization setting, it
17247 -- simply checks that it is consistent with the pragma.
17249 when Pragma_Optimize
=>
17250 Check_No_Identifiers
;
17251 Check_Arg_Count
(1);
17252 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17254 ------------------------
17255 -- Optimize_Alignment --
17256 ------------------------
17258 -- pragma Optimize_Alignment (Time | Space | Off);
17260 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17262 Check_No_Identifiers
;
17263 Check_Arg_Count
(1);
17264 Check_Valid_Configuration_Pragma
;
17267 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17271 Opt
.Optimize_Alignment
:= 'T';
17273 Opt
.Optimize_Alignment
:= 'S';
17275 Opt
.Optimize_Alignment
:= 'O';
17277 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17281 -- Set indication that mode is set locally. If we are in fact in a
17282 -- configuration pragma file, this setting is harmless since the
17283 -- switch will get reset anyway at the start of each unit.
17285 Optimize_Alignment_Local
:= True;
17286 end Optimize_Alignment
;
17292 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17294 when Pragma_Ordered
=> Ordered
: declare
17295 Assoc
: constant Node_Id
:= Arg1
;
17301 Check_No_Identifiers
;
17302 Check_Arg_Count
(1);
17303 Check_Arg_Is_Local_Name
(Arg1
);
17305 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17306 Find_Type
(Type_Id
);
17307 Typ
:= Entity
(Type_Id
);
17309 if Typ
= Any_Type
then
17312 Typ
:= Underlying_Type
(Typ
);
17315 if not Is_Enumeration_Type
(Typ
) then
17316 Error_Pragma
("pragma% must specify enumeration type");
17319 Check_First_Subtype
(Arg1
);
17320 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17323 -------------------
17324 -- Overflow_Mode --
17325 -------------------
17327 -- pragma Overflow_Mode
17328 -- ([General => ] MODE [, [Assertions => ] MODE]);
17330 -- MODE := STRICT | MINIMIZED | ELIMINATED
17332 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17333 -- since System.Bignums makes this assumption. This is true of nearly
17334 -- all (all?) targets.
17336 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17337 function Get_Overflow_Mode
17339 Arg
: Node_Id
) return Overflow_Mode_Type
;
17340 -- Function to process one pragma argument, Arg. If an identifier
17341 -- is present, it must be Name. Mode type is returned if a valid
17342 -- argument exists, otherwise an error is signalled.
17344 -----------------------
17345 -- Get_Overflow_Mode --
17346 -----------------------
17348 function Get_Overflow_Mode
17350 Arg
: Node_Id
) return Overflow_Mode_Type
17352 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17355 Check_Optional_Identifier
(Arg
, Name
);
17356 Check_Arg_Is_Identifier
(Argx
);
17358 if Chars
(Argx
) = Name_Strict
then
17361 elsif Chars
(Argx
) = Name_Minimized
then
17364 elsif Chars
(Argx
) = Name_Eliminated
then
17365 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17367 ("Eliminated not implemented on this target", Argx
);
17373 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17375 end Get_Overflow_Mode
;
17377 -- Start of processing for Overflow_Mode
17381 Check_At_Least_N_Arguments
(1);
17382 Check_At_Most_N_Arguments
(2);
17384 -- Process first argument
17386 Scope_Suppress
.Overflow_Mode_General
:=
17387 Get_Overflow_Mode
(Name_General
, Arg1
);
17389 -- Case of only one argument
17391 if Arg_Count
= 1 then
17392 Scope_Suppress
.Overflow_Mode_Assertions
:=
17393 Scope_Suppress
.Overflow_Mode_General
;
17395 -- Case of two arguments present
17398 Scope_Suppress
.Overflow_Mode_Assertions
:=
17399 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17403 --------------------------
17404 -- Overriding Renamings --
17405 --------------------------
17407 -- pragma Overriding_Renamings;
17409 when Pragma_Overriding_Renamings
=>
17411 Check_Arg_Count
(0);
17412 Check_Valid_Configuration_Pragma
;
17413 Overriding_Renamings
:= True;
17419 -- pragma Pack (first_subtype_LOCAL_NAME);
17421 when Pragma_Pack
=> Pack
: declare
17422 Assoc
: constant Node_Id
:= Arg1
;
17426 Ignore
: Boolean := False;
17429 Check_No_Identifiers
;
17430 Check_Arg_Count
(1);
17431 Check_Arg_Is_Local_Name
(Arg1
);
17432 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17434 if not Is_Entity_Name
(Type_Id
)
17435 or else not Is_Type
(Entity
(Type_Id
))
17438 ("argument for pragma% must be type or subtype", Arg1
);
17441 Find_Type
(Type_Id
);
17442 Typ
:= Entity
(Type_Id
);
17445 or else Rep_Item_Too_Early
(Typ
, N
)
17449 Typ
:= Underlying_Type
(Typ
);
17452 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17453 Error_Pragma
("pragma% must specify array or record type");
17456 Check_First_Subtype
(Arg1
);
17457 Check_Duplicate_Pragma
(Typ
);
17461 if Is_Array_Type
(Typ
) then
17462 Ctyp
:= Component_Type
(Typ
);
17464 -- Ignore pack that does nothing
17466 if Known_Static_Esize
(Ctyp
)
17467 and then Known_Static_RM_Size
(Ctyp
)
17468 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17469 and then Addressable
(Esize
(Ctyp
))
17474 -- Process OK pragma Pack. Note that if there is a separate
17475 -- component clause present, the Pack will be cancelled. This
17476 -- processing is in Freeze.
17478 if not Rep_Item_Too_Late
(Typ
, N
) then
17480 -- In CodePeer mode, we do not need complex front-end
17481 -- expansions related to pragma Pack, so disable handling
17484 if CodePeer_Mode
then
17487 -- Don't attempt any packing for VM targets. We possibly
17488 -- could deal with some cases of array bit-packing, but we
17489 -- don't bother, since this is not a typical kind of
17490 -- representation in the VM context anyway (and would not
17491 -- for example work nicely with the debugger).
17493 elsif VM_Target
/= No_VM
then
17494 if not GNAT_Mode
then
17496 ("??pragma% ignored in this configuration");
17499 -- Normal case where we do the pack action
17503 Set_Is_Packed
(Base_Type
(Typ
));
17504 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17507 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17511 -- For record types, the pack is always effective
17513 else pragma Assert
(Is_Record_Type
(Typ
));
17514 if not Rep_Item_Too_Late
(Typ
, N
) then
17516 -- Ignore pack request with warning in VM mode (skip warning
17517 -- if we are compiling GNAT run time library).
17519 if VM_Target
/= No_VM
then
17520 if not GNAT_Mode
then
17522 ("??pragma% ignored in this configuration");
17525 -- Normal case of pack request active
17528 Set_Is_Packed
(Base_Type
(Typ
));
17529 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17530 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17542 -- There is nothing to do here, since we did all the processing for
17543 -- this pragma in Par.Prag (so that it works properly even in syntax
17546 when Pragma_Page
=>
17553 -- pragma Part_Of (ABSTRACT_STATE);
17555 -- ABSTRACT_STATE ::= NAME
17557 when Pragma_Part_Of
=> Part_Of
: declare
17558 procedure Propagate_Part_Of
17559 (Pack_Id
: Entity_Id
;
17560 State_Id
: Entity_Id
;
17561 Instance
: Node_Id
);
17562 -- Propagate the Part_Of indicator to all abstract states and
17563 -- variables declared in the visible state space of a package
17564 -- denoted by Pack_Id. State_Id is the encapsulating state.
17565 -- Instance is the package instantiation node.
17567 -----------------------
17568 -- Propagate_Part_Of --
17569 -----------------------
17571 procedure Propagate_Part_Of
17572 (Pack_Id
: Entity_Id
;
17573 State_Id
: Entity_Id
;
17574 Instance
: Node_Id
)
17576 Has_Item
: Boolean := False;
17577 -- Flag set when the visible state space contains at least one
17578 -- abstract state or variable.
17580 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17581 -- Propagate the Part_Of indicator to all abstract states and
17582 -- variables declared in the visible state space of a package
17583 -- denoted by Pack_Id.
17585 -----------------------
17586 -- Propagate_Part_Of --
17587 -----------------------
17589 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17590 Item_Id
: Entity_Id
;
17593 -- Traverse the entity chain of the package and set relevant
17594 -- attributes of abstract states and variables declared in
17595 -- the visible state space of the package.
17597 Item_Id
:= First_Entity
(Pack_Id
);
17598 while Present
(Item_Id
)
17599 and then not In_Private_Part
(Item_Id
)
17601 -- Do not consider internally generated items
17603 if not Comes_From_Source
(Item_Id
) then
17606 -- The Part_Of indicator turns an abstract state or
17607 -- variable into a constituent of the encapsulating
17610 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17615 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17616 Set_Encapsulating_State
(Item_Id
, State_Id
);
17618 -- Recursively handle nested packages and instantiations
17620 elsif Ekind
(Item_Id
) = E_Package
then
17621 Propagate_Part_Of
(Item_Id
);
17624 Next_Entity
(Item_Id
);
17626 end Propagate_Part_Of
;
17628 -- Start of processing for Propagate_Part_Of
17631 Propagate_Part_Of
(Pack_Id
);
17633 -- Detect a package instantiation that is subject to a Part_Of
17634 -- indicator, but has no visible state.
17636 if not Has_Item
then
17638 ("package instantiation & has Part_Of indicator but "
17639 & "lacks visible state", Instance
, Pack_Id
);
17641 end Propagate_Part_Of
;
17645 Item_Id
: Entity_Id
;
17648 State_Id
: Entity_Id
;
17651 -- Start of processing for Part_Of
17655 Check_No_Identifiers
;
17656 Check_Arg_Count
(1);
17658 -- Ensure the proper placement of the pragma. Part_Of must appear
17659 -- on a variable declaration or a package instantiation.
17662 while Present
(Stmt
) loop
17664 -- Skip prior pragmas, but check for duplicates
17666 if Nkind
(Stmt
) = N_Pragma
then
17667 if Pragma_Name
(Stmt
) = Pname
then
17668 Error_Msg_Name_1
:= Pname
;
17669 Error_Msg_Sloc
:= Sloc
(Stmt
);
17670 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17673 -- Skip internally generated code
17675 elsif not Comes_From_Source
(Stmt
) then
17678 -- The pragma applies to an object declaration (possibly a
17679 -- variable) or a package instantiation. Stop the traversal
17680 -- and continue the analysis.
17682 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17683 N_Package_Instantiation
)
17687 -- The pragma does not apply to a legal construct, issue an
17688 -- error and stop the analysis.
17695 Stmt
:= Prev
(Stmt
);
17698 -- When the context is an object declaration, ensure that we are
17699 -- dealing with a variable.
17701 if Nkind
(Stmt
) = N_Object_Declaration
17702 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17704 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17708 -- Extract the entity of the related object declaration or package
17709 -- instantiation. In the case of the instantiation, use the entity
17710 -- of the instance spec.
17712 if Nkind
(Stmt
) = N_Package_Instantiation
then
17713 Stmt
:= Instance_Spec
(Stmt
);
17716 Item_Id
:= Defining_Entity
(Stmt
);
17717 State
:= Get_Pragma_Arg
(Arg1
);
17719 -- Detect any discrepancies between the placement of the object
17720 -- or package instantiation with respect to state space and the
17721 -- encapsulating state.
17724 (Item_Id
=> Item_Id
,
17730 State_Id
:= Entity
(State
);
17732 -- Add the pragma to the contract of the item. This aids with
17733 -- the detection of a missing but required Part_Of indicator.
17735 Add_Contract_Item
(N
, Item_Id
);
17737 -- The Part_Of indicator turns a variable into a constituent
17738 -- of the encapsulating state.
17740 if Ekind
(Item_Id
) = E_Variable
then
17741 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17742 Set_Encapsulating_State
(Item_Id
, State_Id
);
17744 -- Propagate the Part_Of indicator to the visible state space
17745 -- of the package instantiation.
17749 (Pack_Id
=> Item_Id
,
17750 State_Id
=> State_Id
,
17756 ----------------------------------
17757 -- Partition_Elaboration_Policy --
17758 ----------------------------------
17760 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17762 when Pragma_Partition_Elaboration_Policy
=> declare
17763 subtype PEP_Range
is Name_Id
17764 range First_Partition_Elaboration_Policy_Name
17765 .. Last_Partition_Elaboration_Policy_Name
;
17766 PEP_Val
: PEP_Range
;
17771 Check_Arg_Count
(1);
17772 Check_No_Identifiers
;
17773 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17774 Check_Valid_Configuration_Pragma
;
17775 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17778 when Name_Concurrent
=>
17780 when Name_Sequential
=>
17784 if Partition_Elaboration_Policy
/= ' '
17785 and then Partition_Elaboration_Policy
/= PEP
17787 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17789 ("partition elaboration policy incompatible with policy#");
17791 -- Set new policy, but always preserve System_Location since we
17792 -- like the error message with the run time name.
17795 Partition_Elaboration_Policy
:= PEP
;
17797 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17798 Partition_Elaboration_Policy_Sloc
:= Loc
;
17807 -- pragma Passive [(PASSIVE_FORM)];
17809 -- PASSIVE_FORM ::= Semaphore | No
17811 when Pragma_Passive
=>
17814 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17815 Error_Pragma
("pragma% must be within task definition");
17818 if Arg_Count
/= 0 then
17819 Check_Arg_Count
(1);
17820 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17823 ----------------------------------
17824 -- Preelaborable_Initialization --
17825 ----------------------------------
17827 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17829 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17834 Check_Arg_Count
(1);
17835 Check_No_Identifiers
;
17836 Check_Arg_Is_Identifier
(Arg1
);
17837 Check_Arg_Is_Local_Name
(Arg1
);
17838 Check_First_Subtype
(Arg1
);
17839 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17841 -- The pragma may come from an aspect on a private declaration,
17842 -- even if the freeze point at which this is analyzed in the
17843 -- private part after the full view.
17845 if Has_Private_Declaration
(Ent
)
17846 and then From_Aspect_Specification
(N
)
17850 -- Check appropriate type argument
17852 elsif Is_Private_Type
(Ent
)
17853 or else Is_Protected_Type
(Ent
)
17854 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17856 -- AI05-0028: The pragma applies to all composite types. Note
17857 -- that we apply this binding interpretation to earlier versions
17858 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
17859 -- choice since there are other compilers that do the same.
17861 or else Is_Composite_Type
(Ent
)
17867 ("pragma % can only be applied to private, formal derived, "
17868 & "protected, or composite type", Arg1
);
17871 -- Give an error if the pragma is applied to a protected type that
17872 -- does not qualify (due to having entries, or due to components
17873 -- that do not qualify).
17875 if Is_Protected_Type
(Ent
)
17876 and then not Has_Preelaborable_Initialization
(Ent
)
17879 ("protected type & does not have preelaborable "
17880 & "initialization", Ent
);
17882 -- Otherwise mark the type as definitely having preelaborable
17886 Set_Known_To_Have_Preelab_Init
(Ent
);
17889 if Has_Pragma_Preelab_Init
(Ent
)
17890 and then Warn_On_Redundant_Constructs
17892 Error_Pragma
("?r?duplicate pragma%!");
17894 Set_Has_Pragma_Preelab_Init
(Ent
);
17898 --------------------
17899 -- Persistent_BSS --
17900 --------------------
17902 -- pragma Persistent_BSS [(object_NAME)];
17904 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17911 Check_At_Most_N_Arguments
(1);
17913 -- Case of application to specific object (one argument)
17915 if Arg_Count
= 1 then
17916 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17918 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17920 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17923 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17926 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17927 Decl
:= Parent
(Ent
);
17929 -- Check for duplication before inserting in list of
17930 -- representation items.
17932 Check_Duplicate_Pragma
(Ent
);
17934 if Rep_Item_Too_Late
(Ent
, N
) then
17938 if Present
(Expression
(Decl
)) then
17940 ("object for pragma% cannot have initialization", Arg1
);
17943 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17945 ("object type for pragma% is not potentially persistent",
17950 Make_Linker_Section_Pragma
17951 (Ent
, Sloc
(N
), ".persistent.bss");
17952 Insert_After
(N
, Prag
);
17955 -- Case of use as configuration pragma with no arguments
17958 Check_Valid_Configuration_Pragma
;
17959 Persistent_BSS_Mode
:= True;
17961 end Persistent_BSS
;
17967 -- pragma Polling (ON | OFF);
17969 when Pragma_Polling
=>
17971 Check_Arg_Count
(1);
17972 Check_No_Identifiers
;
17973 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17974 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17980 -- pragma Post (Boolean_EXPRESSION);
17981 -- pragma Post_Class (Boolean_EXPRESSION);
17983 when Pragma_Post | Pragma_Post_Class
=> Post
: declare
17984 PC_Pragma
: Node_Id
;
17988 Check_Arg_Count
(1);
17989 Check_No_Identifiers
;
17992 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
17993 -- flag Class_Present to True for the Post_Class case.
17995 Set_Class_Present
(N
, Prag_Id
= Pragma_Post_Class
);
17996 PC_Pragma
:= New_Copy
(N
);
17997 Set_Pragma_Identifier
17998 (PC_Pragma
, Make_Identifier
(Loc
, Name_Postcondition
));
17999 Rewrite
(N
, PC_Pragma
);
18000 Set_Analyzed
(N
, False);
18004 -------------------
18005 -- Postcondition --
18006 -------------------
18008 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18009 -- [,[Message =>] String_EXPRESSION]);
18011 when Pragma_Postcondition
=> Postcondition
: declare
18016 Check_At_Least_N_Arguments
(1);
18017 Check_At_Most_N_Arguments
(2);
18018 Check_Optional_Identifier
(Arg1
, Name_Check
);
18020 -- Verify the proper placement of the pragma. The remainder of the
18021 -- processing is found in Sem_Ch6/Sem_Ch7.
18023 Check_Precondition_Postcondition
(In_Body
);
18025 -- When the pragma is a source construct appearing inside a body,
18026 -- preanalyze the boolean_expression to detect illegal forward
18030 -- pragma Postcondition (X'Old ...);
18033 if Comes_From_Source
(N
) and then In_Body
then
18034 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
18042 -- pragma Pre (Boolean_EXPRESSION);
18043 -- pragma Pre_Class (Boolean_EXPRESSION);
18045 when Pragma_Pre | Pragma_Pre_Class
=> Pre
: declare
18046 PC_Pragma
: Node_Id
;
18050 Check_Arg_Count
(1);
18051 Check_No_Identifiers
;
18054 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
18055 -- flag Class_Present to True for the Pre_Class case.
18057 Set_Class_Present
(N
, Prag_Id
= Pragma_Pre_Class
);
18058 PC_Pragma
:= New_Copy
(N
);
18059 Set_Pragma_Identifier
18060 (PC_Pragma
, Make_Identifier
(Loc
, Name_Precondition
));
18061 Rewrite
(N
, PC_Pragma
);
18062 Set_Analyzed
(N
, False);
18070 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18071 -- [,[Message =>] String_EXPRESSION]);
18073 when Pragma_Precondition
=> Precondition
: declare
18078 Check_At_Least_N_Arguments
(1);
18079 Check_At_Most_N_Arguments
(2);
18080 Check_Optional_Identifier
(Arg1
, Name_Check
);
18081 Check_Precondition_Postcondition
(In_Body
);
18083 -- If in spec, nothing more to do. If in body, then we convert
18084 -- the pragma to an equivalent pragma Check. That works fine since
18085 -- pragma Check will analyze the condition in the proper context.
18087 -- The form of the pragma Check is either:
18089 -- pragma Check (Precondition, cond [, msg])
18091 -- pragma Check (Pre, cond [, msg])
18093 -- We use the Pre form if this pragma derived from a Pre aspect.
18094 -- This is needed to make sure that the right set of Policy
18095 -- pragmas are checked.
18099 -- Rewrite as Check pragma
18103 Chars
=> Name_Check
,
18104 Pragma_Argument_Associations
=> New_List
(
18105 Make_Pragma_Argument_Association
(Loc
,
18106 Expression
=> Make_Identifier
(Loc
, Pname
)),
18108 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
18110 Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
18112 if Arg_Count
= 2 then
18113 Append_To
(Pragma_Argument_Associations
(N
),
18114 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
18116 Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
18127 -- pragma Predicate
18128 -- ([Entity =>] type_LOCAL_NAME,
18129 -- [Check =>] boolean_EXPRESSION);
18131 when Pragma_Predicate
=> Predicate
: declare
18138 Check_Arg_Count
(2);
18139 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18140 Check_Optional_Identifier
(Arg2
, Name_Check
);
18142 Check_Arg_Is_Local_Name
(Arg1
);
18144 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18145 Find_Type
(Type_Id
);
18146 Typ
:= Entity
(Type_Id
);
18148 if Typ
= Any_Type
then
18152 -- The remaining processing is simply to link the pragma on to
18153 -- the rep item chain, for processing when the type is frozen.
18154 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18155 -- mark the type as having predicates.
18157 Set_Has_Predicates
(Typ
);
18158 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18165 -- pragma Preelaborate [(library_unit_NAME)];
18167 -- Set the flag Is_Preelaborated of program unit name entity
18169 when Pragma_Preelaborate
=> Preelaborate
: declare
18170 Pa
: constant Node_Id
:= Parent
(N
);
18171 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18175 Check_Ada_83_Warning
;
18176 Check_Valid_Library_Unit_Pragma
;
18178 if Nkind
(N
) = N_Null_Statement
then
18182 Ent
:= Find_Lib_Unit_Name
;
18183 Check_Duplicate_Pragma
(Ent
);
18185 -- This filters out pragmas inside generic parents that show up
18186 -- inside instantiations. Pragmas that come from aspects in the
18187 -- unit are not ignored.
18189 if Present
(Ent
) then
18190 if Pk
= N_Package_Specification
18191 and then Present
(Generic_Parent
(Pa
))
18192 and then not From_Aspect_Specification
(N
)
18197 if not Debug_Flag_U
then
18198 Set_Is_Preelaborated
(Ent
);
18199 Set_Suppress_Elaboration_Warnings
(Ent
);
18205 -------------------------------
18206 -- Prefix_Exception_Messages --
18207 -------------------------------
18209 -- pragma Prefix_Exception_Messages;
18211 when Pragma_Prefix_Exception_Messages
=>
18213 Check_Valid_Configuration_Pragma
;
18214 Check_Arg_Count
(0);
18215 Prefix_Exception_Messages
:= True;
18221 -- pragma Priority (EXPRESSION);
18223 when Pragma_Priority
=> Priority
: declare
18224 P
: constant Node_Id
:= Parent
(N
);
18229 Check_No_Identifiers
;
18230 Check_Arg_Count
(1);
18234 if Nkind
(P
) = N_Subprogram_Body
then
18235 Check_In_Main_Program
;
18237 Ent
:= Defining_Unit_Name
(Specification
(P
));
18239 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18240 Ent
:= Defining_Identifier
(Ent
);
18243 Arg
:= Get_Pragma_Arg
(Arg1
);
18244 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18248 if not Is_OK_Static_Expression
(Arg
) then
18249 Flag_Non_Static_Expr
18250 ("main subprogram priority is not static!", Arg
);
18253 -- If constraint error, then we already signalled an error
18255 elsif Raises_Constraint_Error
(Arg
) then
18258 -- Otherwise check in range except if Relaxed_RM_Semantics
18259 -- where we ignore the value if out of range.
18263 Val
: constant Uint
:= Expr_Value
(Arg
);
18265 if not Relaxed_RM_Semantics
18268 or else Val
> Expr_Value
(Expression
18269 (Parent
(RTE
(RE_Max_Priority
)))))
18272 ("main subprogram priority is out of range", Arg1
);
18275 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18280 -- Load an arbitrary entity from System.Tasking.Stages or
18281 -- System.Tasking.Restricted.Stages (depending on the
18282 -- supported profile) to make sure that one of these packages
18283 -- is implicitly with'ed, since we need to have the tasking
18284 -- run time active for the pragma Priority to have any effect.
18285 -- Previously we with'ed the package System.Tasking, but this
18286 -- package does not trigger the required initialization of the
18287 -- run-time library.
18290 Discard
: Entity_Id
;
18291 pragma Warnings
(Off
, Discard
);
18293 if Restricted_Profile
then
18294 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18296 Discard
:= RTE
(RE_Activate_Tasks
);
18300 -- Task or Protected, must be of type Integer
18302 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18303 Arg
:= Get_Pragma_Arg
(Arg1
);
18304 Ent
:= Defining_Identifier
(Parent
(P
));
18306 -- The expression must be analyzed in the special manner
18307 -- described in "Handling of Default and Per-Object
18308 -- Expressions" in sem.ads.
18310 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18312 if not Is_OK_Static_Expression
(Arg
) then
18313 Check_Restriction
(Static_Priorities
, Arg
);
18316 -- Anything else is incorrect
18322 -- Check duplicate pragma before we chain the pragma in the Rep
18323 -- Item chain of Ent.
18325 Check_Duplicate_Pragma
(Ent
);
18326 Record_Rep_Item
(Ent
, N
);
18329 -----------------------------------
18330 -- Priority_Specific_Dispatching --
18331 -----------------------------------
18333 -- pragma Priority_Specific_Dispatching (
18334 -- policy_IDENTIFIER,
18335 -- first_priority_EXPRESSION,
18336 -- last_priority_EXPRESSION);
18338 when Pragma_Priority_Specific_Dispatching
=>
18339 Priority_Specific_Dispatching
: declare
18340 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18341 -- This is the entity System.Any_Priority;
18344 Lower_Bound
: Node_Id
;
18345 Upper_Bound
: Node_Id
;
18351 Check_Arg_Count
(3);
18352 Check_No_Identifiers
;
18353 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18354 Check_Valid_Configuration_Pragma
;
18355 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18356 DP
:= Fold_Upper
(Name_Buffer
(1));
18358 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18359 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18360 Lower_Val
:= Expr_Value
(Lower_Bound
);
18362 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18363 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18364 Upper_Val
:= Expr_Value
(Upper_Bound
);
18366 -- It is not allowed to use Task_Dispatching_Policy and
18367 -- Priority_Specific_Dispatching in the same partition.
18369 if Task_Dispatching_Policy
/= ' ' then
18370 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18372 ("pragma% incompatible with Task_Dispatching_Policy#");
18374 -- Check lower bound in range
18376 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18378 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18381 ("first_priority is out of range", Arg2
);
18383 -- Check upper bound in range
18385 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18387 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18390 ("last_priority is out of range", Arg3
);
18392 -- Check that the priority range is valid
18394 elsif Lower_Val
> Upper_Val
then
18396 ("last_priority_expression must be greater than or equal to "
18397 & "first_priority_expression");
18399 -- Store the new policy, but always preserve System_Location since
18400 -- we like the error message with the run-time name.
18403 -- Check overlapping in the priority ranges specified in other
18404 -- Priority_Specific_Dispatching pragmas within the same
18405 -- partition. We can only check those we know about.
18408 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18410 if Specific_Dispatching
.Table
(J
).First_Priority
in
18411 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18412 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18413 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18416 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18418 ("priority range overlaps with "
18419 & "Priority_Specific_Dispatching#");
18423 -- The use of Priority_Specific_Dispatching is incompatible
18424 -- with Task_Dispatching_Policy.
18426 if Task_Dispatching_Policy
/= ' ' then
18427 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18429 ("Priority_Specific_Dispatching incompatible "
18430 & "with Task_Dispatching_Policy#");
18433 -- The use of Priority_Specific_Dispatching forces ceiling
18436 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18437 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18439 ("Priority_Specific_Dispatching incompatible "
18440 & "with Locking_Policy#");
18442 -- Set the Ceiling_Locking policy, but preserve System_Location
18443 -- since we like the error message with the run time name.
18446 Locking_Policy
:= 'C';
18448 if Locking_Policy_Sloc
/= System_Location
then
18449 Locking_Policy_Sloc
:= Loc
;
18453 -- Add entry in the table
18455 Specific_Dispatching
.Append
18456 ((Dispatching_Policy
=> DP
,
18457 First_Priority
=> UI_To_Int
(Lower_Val
),
18458 Last_Priority
=> UI_To_Int
(Upper_Val
),
18459 Pragma_Loc
=> Loc
));
18461 end Priority_Specific_Dispatching
;
18467 -- pragma Profile (profile_IDENTIFIER);
18469 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18471 when Pragma_Profile
=>
18473 Check_Arg_Count
(1);
18474 Check_Valid_Configuration_Pragma
;
18475 Check_No_Identifiers
;
18478 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18481 if Chars
(Argx
) = Name_Ravenscar
then
18482 Set_Ravenscar_Profile
(N
);
18484 elsif Chars
(Argx
) = Name_Restricted
then
18485 Set_Profile_Restrictions
18487 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18489 elsif Chars
(Argx
) = Name_Rational
then
18490 Set_Rational_Profile
;
18492 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18493 Set_Profile_Restrictions
18494 (No_Implementation_Extensions
,
18495 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18498 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18502 ----------------------
18503 -- Profile_Warnings --
18504 ----------------------
18506 -- pragma Profile_Warnings (profile_IDENTIFIER);
18508 -- profile_IDENTIFIER => Restricted | Ravenscar
18510 when Pragma_Profile_Warnings
=>
18512 Check_Arg_Count
(1);
18513 Check_Valid_Configuration_Pragma
;
18514 Check_No_Identifiers
;
18517 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18520 if Chars
(Argx
) = Name_Ravenscar
then
18521 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18523 elsif Chars
(Argx
) = Name_Restricted
then
18524 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18526 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18527 Set_Profile_Restrictions
18528 (No_Implementation_Extensions
, N
, Warn
=> True);
18531 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18535 --------------------------
18536 -- Propagate_Exceptions --
18537 --------------------------
18539 -- pragma Propagate_Exceptions;
18541 -- Note: this pragma is obsolete and has no effect
18543 when Pragma_Propagate_Exceptions
=>
18545 Check_Arg_Count
(0);
18547 if Warn_On_Obsolescent_Feature
then
18549 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18550 "and has no effect?j?", N
);
18553 -----------------------------
18554 -- Provide_Shift_Operators --
18555 -----------------------------
18557 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18559 when Pragma_Provide_Shift_Operators
=>
18560 Provide_Shift_Operators
: declare
18563 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18564 -- Insert declaration and pragma Instrinsic for named shift op
18566 ----------------------------
18567 -- Declare_Shift_Operator --
18568 ----------------------------
18570 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18576 Make_Subprogram_Declaration
(Loc
,
18577 Make_Function_Specification
(Loc
,
18578 Defining_Unit_Name
=>
18579 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18581 Result_Definition
=>
18582 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18584 Parameter_Specifications
=> New_List
(
18585 Make_Parameter_Specification
(Loc
,
18586 Defining_Identifier
=>
18587 Make_Defining_Identifier
(Loc
, Name_Value
),
18589 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18591 Make_Parameter_Specification
(Loc
,
18592 Defining_Identifier
=>
18593 Make_Defining_Identifier
(Loc
, Name_Amount
),
18595 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18599 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18600 Pragma_Argument_Associations
=> New_List
(
18601 Make_Pragma_Argument_Association
(Loc
,
18602 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18603 Make_Pragma_Argument_Association
(Loc
,
18604 Expression
=> Make_Identifier
(Loc
, Nam
))));
18606 Insert_After
(N
, Import
);
18607 Insert_After
(N
, Func
);
18608 end Declare_Shift_Operator
;
18610 -- Start of processing for Provide_Shift_Operators
18614 Check_Arg_Count
(1);
18615 Check_Arg_Is_Local_Name
(Arg1
);
18617 Arg1
:= Get_Pragma_Arg
(Arg1
);
18619 -- We must have an entity name
18621 if not Is_Entity_Name
(Arg1
) then
18623 ("pragma % must apply to integer first subtype", Arg1
);
18626 -- If no Entity, means there was a prior error so ignore
18628 if Present
(Entity
(Arg1
)) then
18629 Ent
:= Entity
(Arg1
);
18631 -- Apply error checks
18633 if not Is_First_Subtype
(Ent
) then
18635 ("cannot apply pragma %",
18636 "\& is not a first subtype",
18639 elsif not Is_Integer_Type
(Ent
) then
18641 ("cannot apply pragma %",
18642 "\& is not an integer type",
18645 elsif Has_Shift_Operator
(Ent
) then
18647 ("cannot apply pragma %",
18648 "\& already has declared shift operators",
18651 elsif Is_Frozen
(Ent
) then
18653 ("pragma % appears too late",
18654 "\& is already frozen",
18658 -- Now declare the operators. We do this during analysis rather
18659 -- than expansion, since we want the operators available if we
18660 -- are operating in -gnatc or ASIS mode.
18662 Declare_Shift_Operator
(Name_Rotate_Left
);
18663 Declare_Shift_Operator
(Name_Rotate_Right
);
18664 Declare_Shift_Operator
(Name_Shift_Left
);
18665 Declare_Shift_Operator
(Name_Shift_Right
);
18666 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18668 end Provide_Shift_Operators
;
18674 -- pragma Psect_Object (
18675 -- [Internal =>] LOCAL_NAME,
18676 -- [, [External =>] EXTERNAL_SYMBOL]
18677 -- [, [Size =>] EXTERNAL_SYMBOL]);
18679 when Pragma_Psect_Object | Pragma_Common_Object
=>
18680 Psect_Object
: declare
18681 Args
: Args_List
(1 .. 3);
18682 Names
: constant Name_List
(1 .. 3) := (
18687 Internal
: Node_Id
renames Args
(1);
18688 External
: Node_Id
renames Args
(2);
18689 Size
: Node_Id
renames Args
(3);
18691 Def_Id
: Entity_Id
;
18693 procedure Check_Arg
(Arg
: Node_Id
);
18694 -- Checks that argument is either a string literal or an
18695 -- identifier, and posts error message if not.
18701 procedure Check_Arg
(Arg
: Node_Id
) is
18703 if not Nkind_In
(Original_Node
(Arg
),
18708 ("inappropriate argument for pragma %", Arg
);
18712 -- Start of processing for Common_Object/Psect_Object
18716 Gather_Associations
(Names
, Args
);
18717 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18719 Def_Id
:= Entity
(Internal
);
18721 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18723 ("pragma% must designate an object", Internal
);
18726 Check_Arg
(Internal
);
18728 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18730 ("cannot use pragma% for imported/exported object",
18734 if Is_Concurrent_Type
(Etype
(Internal
)) then
18736 ("cannot specify pragma % for task/protected object",
18740 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18742 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18744 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18747 if Ekind
(Def_Id
) = E_Constant
then
18749 ("cannot specify pragma % for a constant", Internal
);
18752 if Is_Record_Type
(Etype
(Internal
)) then
18758 Ent
:= First_Entity
(Etype
(Internal
));
18759 while Present
(Ent
) loop
18760 Decl
:= Declaration_Node
(Ent
);
18762 if Ekind
(Ent
) = E_Component
18763 and then Nkind
(Decl
) = N_Component_Declaration
18764 and then Present
(Expression
(Decl
))
18765 and then Warn_On_Export_Import
18768 ("?x?object for pragma % has defaults", Internal
);
18778 if Present
(Size
) then
18782 if Present
(External
) then
18783 Check_Arg_Is_External_Name
(External
);
18786 -- If all error tests pass, link pragma on to the rep item chain
18788 Record_Rep_Item
(Def_Id
, N
);
18795 -- pragma Pure [(library_unit_NAME)];
18797 when Pragma_Pure
=> Pure
: declare
18801 Check_Ada_83_Warning
;
18802 Check_Valid_Library_Unit_Pragma
;
18804 if Nkind
(N
) = N_Null_Statement
then
18808 Ent
:= Find_Lib_Unit_Name
;
18810 Set_Has_Pragma_Pure
(Ent
);
18811 Set_Suppress_Elaboration_Warnings
(Ent
);
18814 -------------------
18815 -- Pure_Function --
18816 -------------------
18818 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18820 when Pragma_Pure_Function
=> Pure_Function
: declare
18823 Def_Id
: Entity_Id
;
18824 Effective
: Boolean := False;
18828 Check_Arg_Count
(1);
18829 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18830 Check_Arg_Is_Local_Name
(Arg1
);
18831 E_Id
:= Get_Pragma_Arg
(Arg1
);
18833 if Error_Posted
(E_Id
) then
18837 -- Loop through homonyms (overloadings) of referenced entity
18839 E
:= Entity
(E_Id
);
18841 if Present
(E
) then
18843 Def_Id
:= Get_Base_Subprogram
(E
);
18845 if not Ekind_In
(Def_Id
, E_Function
,
18846 E_Generic_Function
,
18850 ("pragma% requires a function name", Arg1
);
18853 Set_Is_Pure
(Def_Id
);
18855 if not Has_Pragma_Pure_Function
(Def_Id
) then
18856 Set_Has_Pragma_Pure_Function
(Def_Id
);
18860 exit when From_Aspect_Specification
(N
);
18862 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18866 and then Warn_On_Redundant_Constructs
18869 ("pragma Pure_Function on& is redundant?r?",
18875 --------------------
18876 -- Queuing_Policy --
18877 --------------------
18879 -- pragma Queuing_Policy (policy_IDENTIFIER);
18881 when Pragma_Queuing_Policy
=> declare
18885 Check_Ada_83_Warning
;
18886 Check_Arg_Count
(1);
18887 Check_No_Identifiers
;
18888 Check_Arg_Is_Queuing_Policy
(Arg1
);
18889 Check_Valid_Configuration_Pragma
;
18890 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18891 QP
:= Fold_Upper
(Name_Buffer
(1));
18893 if Queuing_Policy
/= ' '
18894 and then Queuing_Policy
/= QP
18896 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18897 Error_Pragma
("queuing policy incompatible with policy#");
18899 -- Set new policy, but always preserve System_Location since we
18900 -- like the error message with the run time name.
18903 Queuing_Policy
:= QP
;
18905 if Queuing_Policy_Sloc
/= System_Location
then
18906 Queuing_Policy_Sloc
:= Loc
;
18915 -- pragma Rational, for compatibility with foreign compiler
18917 when Pragma_Rational
=>
18918 Set_Rational_Profile
;
18920 ------------------------------------
18921 -- Refined_Depends/Refined_Global --
18922 ------------------------------------
18924 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18926 -- DEPENDENCY_RELATION ::=
18928 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18930 -- DEPENDENCY_CLAUSE ::=
18931 -- OUTPUT_LIST =>[+] INPUT_LIST
18932 -- | NULL_DEPENDENCY_CLAUSE
18934 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18936 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18938 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18940 -- OUTPUT ::= NAME | FUNCTION_RESULT
18943 -- where FUNCTION_RESULT is a function Result attribute_reference
18945 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18947 -- GLOBAL_SPECIFICATION ::=
18950 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18952 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18954 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18955 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18956 -- GLOBAL_ITEM ::= NAME
18958 when Pragma_Refined_Depends |
18959 Pragma_Refined_Global
=> Refined_Depends_Global
:
18961 Body_Id
: Entity_Id
;
18963 Spec_Id
: Entity_Id
;
18966 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18968 -- Save the pragma in the contract of the subprogram body. The
18969 -- remaining analysis is performed at the end of the enclosing
18973 Add_Contract_Item
(N
, Body_Id
);
18975 end Refined_Depends_Global
;
18981 -- pragma Refined_Post (boolean_EXPRESSION);
18983 when Pragma_Refined_Post
=> Refined_Post
: declare
18984 Body_Id
: Entity_Id
;
18986 Result_Seen
: Boolean := False;
18987 Spec_Id
: Entity_Id
;
18990 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18992 -- Analyze the boolean expression as a "spec expression"
18995 Analyze_Pre_Post_Condition_In_Decl_Part
(N
, Spec_Id
);
18997 -- Verify that the refined postcondition mentions attribute
18998 -- 'Result and its expression introduces a post-state.
19000 if Warn_On_Suspicious_Contract
19001 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
19003 Check_Result_And_Post_State
(N
, Result_Seen
);
19005 if not Result_Seen
then
19007 ("pragma % does not mention function result?T?");
19011 -- Chain the pragma on the contract for easy retrieval
19013 Add_Contract_Item
(N
, Body_Id
);
19017 -------------------
19018 -- Refined_State --
19019 -------------------
19021 -- pragma Refined_State (REFINEMENT_LIST);
19023 -- REFINEMENT_LIST ::=
19024 -- REFINEMENT_CLAUSE
19025 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19027 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19029 -- CONSTITUENT_LIST ::=
19032 -- | (CONSTITUENT {, CONSTITUENT})
19034 -- CONSTITUENT ::= object_NAME | state_NAME
19036 when Pragma_Refined_State
=> Refined_State
: declare
19037 Context
: constant Node_Id
:= Parent
(N
);
19038 Spec_Id
: Entity_Id
;
19043 Check_No_Identifiers
;
19044 Check_Arg_Count
(1);
19046 -- Ensure the proper placement of the pragma. Refined states must
19047 -- be associated with a package body.
19049 if Nkind
(Context
) /= N_Package_Body
then
19055 while Present
(Stmt
) loop
19057 -- Skip prior pragmas, but check for duplicates
19059 if Nkind
(Stmt
) = N_Pragma
then
19060 if Pragma_Name
(Stmt
) = Pname
then
19061 Error_Msg_Name_1
:= Pname
;
19062 Error_Msg_Sloc
:= Sloc
(Stmt
);
19063 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
19066 -- Skip internally generated code
19068 elsif not Comes_From_Source
(Stmt
) then
19071 -- The pragma does not apply to a legal construct, issue an
19072 -- error and stop the analysis.
19079 Stmt
:= Prev
(Stmt
);
19082 Spec_Id
:= Corresponding_Spec
(Context
);
19084 -- State refinement is allowed only when the corresponding package
19085 -- declaration has non-null pragma Abstract_State. Refinement not
19086 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19088 if SPARK_Mode
/= Off
19090 (No
(Abstract_States
(Spec_Id
))
19091 or else Has_Null_Abstract_State
(Spec_Id
))
19094 ("useless refinement, package & does not define abstract "
19095 & "states", N
, Spec_Id
);
19099 -- The pragma must be analyzed at the end of the declarations as
19100 -- it has visibility over the whole declarative region. Save the
19101 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19102 -- adding it to the contract of the package body.
19104 Add_Contract_Item
(N
, Defining_Entity
(Context
));
19107 -----------------------
19108 -- Relative_Deadline --
19109 -----------------------
19111 -- pragma Relative_Deadline (time_span_EXPRESSION);
19113 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19114 P
: constant Node_Id
:= Parent
(N
);
19119 Check_No_Identifiers
;
19120 Check_Arg_Count
(1);
19122 Arg
:= Get_Pragma_Arg
(Arg1
);
19124 -- The expression must be analyzed in the special manner described
19125 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19127 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19131 if Nkind
(P
) = N_Subprogram_Body
then
19132 Check_In_Main_Program
;
19134 -- Only Task and subprogram cases allowed
19136 elsif Nkind
(P
) /= N_Task_Definition
then
19140 -- Check duplicate pragma before we set the corresponding flag
19142 if Has_Relative_Deadline_Pragma
(P
) then
19143 Error_Pragma
("duplicate pragma% not allowed");
19146 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19147 -- Relative_Deadline pragma node cannot be inserted in the Rep
19148 -- Item chain of Ent since it is rewritten by the expander as a
19149 -- procedure call statement that will break the chain.
19151 Set_Has_Relative_Deadline_Pragma
(P
, True);
19152 end Relative_Deadline
;
19154 ------------------------
19155 -- Remote_Access_Type --
19156 ------------------------
19158 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19160 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19165 Check_Arg_Count
(1);
19166 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19167 Check_Arg_Is_Local_Name
(Arg1
);
19169 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19171 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19172 and then Ekind
(E
) = E_General_Access_Type
19173 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19174 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19176 and then Is_Valid_Remote_Object_Type
19177 (Root_Type
(Directly_Designated_Type
(E
)))
19179 Set_Is_Remote_Types
(E
);
19183 ("pragma% applies only to formal access to classwide types",
19186 end Remote_Access_Type
;
19188 ---------------------------
19189 -- Remote_Call_Interface --
19190 ---------------------------
19192 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19194 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19195 Cunit_Node
: Node_Id
;
19196 Cunit_Ent
: Entity_Id
;
19200 Check_Ada_83_Warning
;
19201 Check_Valid_Library_Unit_Pragma
;
19203 if Nkind
(N
) = N_Null_Statement
then
19207 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19208 K
:= Nkind
(Unit
(Cunit_Node
));
19209 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19211 if K
= N_Package_Declaration
19212 or else K
= N_Generic_Package_Declaration
19213 or else K
= N_Subprogram_Declaration
19214 or else K
= N_Generic_Subprogram_Declaration
19215 or else (K
= N_Subprogram_Body
19216 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19221 "pragma% must apply to package or subprogram declaration");
19224 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19225 end Remote_Call_Interface
;
19231 -- pragma Remote_Types [(library_unit_NAME)];
19233 when Pragma_Remote_Types
=> Remote_Types
: declare
19234 Cunit_Node
: Node_Id
;
19235 Cunit_Ent
: Entity_Id
;
19238 Check_Ada_83_Warning
;
19239 Check_Valid_Library_Unit_Pragma
;
19241 if Nkind
(N
) = N_Null_Statement
then
19245 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19246 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19248 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19249 N_Generic_Package_Declaration
)
19252 ("pragma% can only apply to a package declaration");
19255 Set_Is_Remote_Types
(Cunit_Ent
);
19262 -- pragma Ravenscar;
19264 when Pragma_Ravenscar
=>
19266 Check_Arg_Count
(0);
19267 Check_Valid_Configuration_Pragma
;
19268 Set_Ravenscar_Profile
(N
);
19270 if Warn_On_Obsolescent_Feature
then
19272 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19274 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19277 -------------------------
19278 -- Restricted_Run_Time --
19279 -------------------------
19281 -- pragma Restricted_Run_Time;
19283 when Pragma_Restricted_Run_Time
=>
19285 Check_Arg_Count
(0);
19286 Check_Valid_Configuration_Pragma
;
19287 Set_Profile_Restrictions
19288 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19290 if Warn_On_Obsolescent_Feature
then
19292 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19295 ("|use pragma Profile (Restricted) instead?j?", N
);
19302 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19305 -- restriction_IDENTIFIER
19306 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19308 when Pragma_Restrictions
=>
19309 Process_Restrictions_Or_Restriction_Warnings
19310 (Warn
=> Treat_Restrictions_As_Warnings
);
19312 --------------------------
19313 -- Restriction_Warnings --
19314 --------------------------
19316 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19319 -- restriction_IDENTIFIER
19320 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19322 when Pragma_Restriction_Warnings
=>
19324 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19330 -- pragma Reviewable;
19332 when Pragma_Reviewable
=>
19333 Check_Ada_83_Warning
;
19334 Check_Arg_Count
(0);
19336 -- Call dummy debugging function rv. This is done to assist front
19337 -- end debugging. By placing a Reviewable pragma in the source
19338 -- program, a breakpoint on rv catches this place in the source,
19339 -- allowing convenient stepping to the point of interest.
19343 --------------------------
19344 -- Short_Circuit_And_Or --
19345 --------------------------
19347 -- pragma Short_Circuit_And_Or;
19349 when Pragma_Short_Circuit_And_Or
=>
19351 Check_Arg_Count
(0);
19352 Check_Valid_Configuration_Pragma
;
19353 Short_Circuit_And_Or
:= True;
19355 -------------------
19356 -- Share_Generic --
19357 -------------------
19359 -- pragma Share_Generic (GNAME {, GNAME});
19361 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19363 when Pragma_Share_Generic
=>
19365 Process_Generic_List
;
19371 -- pragma Shared (LOCAL_NAME);
19373 when Pragma_Shared
=>
19375 Process_Atomic_Independent_Shared_Volatile
;
19377 --------------------
19378 -- Shared_Passive --
19379 --------------------
19381 -- pragma Shared_Passive [(library_unit_NAME)];
19383 -- Set the flag Is_Shared_Passive of program unit name entity
19385 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19386 Cunit_Node
: Node_Id
;
19387 Cunit_Ent
: Entity_Id
;
19390 Check_Ada_83_Warning
;
19391 Check_Valid_Library_Unit_Pragma
;
19393 if Nkind
(N
) = N_Null_Statement
then
19397 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19398 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19400 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19401 N_Generic_Package_Declaration
)
19404 ("pragma% can only apply to a package declaration");
19407 Set_Is_Shared_Passive
(Cunit_Ent
);
19408 end Shared_Passive
;
19410 -----------------------
19411 -- Short_Descriptors --
19412 -----------------------
19414 -- pragma Short_Descriptors;
19416 -- Recognize and validate, but otherwise ignore
19418 when Pragma_Short_Descriptors
=>
19420 Check_Arg_Count
(0);
19421 Check_Valid_Configuration_Pragma
;
19423 ------------------------------
19424 -- Simple_Storage_Pool_Type --
19425 ------------------------------
19427 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19429 when Pragma_Simple_Storage_Pool_Type
=>
19430 Simple_Storage_Pool_Type
: declare
19436 Check_Arg_Count
(1);
19437 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19439 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19440 Find_Type
(Type_Id
);
19441 Typ
:= Entity
(Type_Id
);
19443 if Typ
= Any_Type
then
19447 -- We require the pragma to apply to a type declared in a package
19448 -- declaration, but not (immediately) within a package body.
19450 if Ekind
(Current_Scope
) /= E_Package
19451 or else In_Package_Body
(Current_Scope
)
19454 ("pragma% can only apply to type declared immediately "
19455 & "within a package declaration");
19458 -- A simple storage pool type must be an immutably limited record
19459 -- or private type. If the pragma is given for a private type,
19460 -- the full type is similarly restricted (which is checked later
19461 -- in Freeze_Entity).
19463 if Is_Record_Type
(Typ
)
19464 and then not Is_Limited_View
(Typ
)
19467 ("pragma% can only apply to explicitly limited record type");
19469 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19471 ("pragma% can only apply to a private type that is limited");
19473 elsif not Is_Record_Type
(Typ
)
19474 and then not Is_Private_Type
(Typ
)
19477 ("pragma% can only apply to limited record or private type");
19480 Record_Rep_Item
(Typ
, N
);
19481 end Simple_Storage_Pool_Type
;
19483 ----------------------
19484 -- Source_File_Name --
19485 ----------------------
19487 -- There are five forms for this pragma:
19489 -- pragma Source_File_Name (
19490 -- [UNIT_NAME =>] unit_NAME,
19491 -- BODY_FILE_NAME => STRING_LITERAL
19492 -- [, [INDEX =>] INTEGER_LITERAL]);
19494 -- pragma Source_File_Name (
19495 -- [UNIT_NAME =>] unit_NAME,
19496 -- SPEC_FILE_NAME => STRING_LITERAL
19497 -- [, [INDEX =>] INTEGER_LITERAL]);
19499 -- pragma Source_File_Name (
19500 -- BODY_FILE_NAME => STRING_LITERAL
19501 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19502 -- [, CASING => CASING_SPEC]);
19504 -- pragma Source_File_Name (
19505 -- SPEC_FILE_NAME => STRING_LITERAL
19506 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19507 -- [, CASING => CASING_SPEC]);
19509 -- pragma Source_File_Name (
19510 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19511 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19512 -- [, CASING => CASING_SPEC]);
19514 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19516 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19517 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19518 -- only be used when no project file is used, while SFNP can only be
19519 -- used when a project file is used.
19521 -- No processing here. Processing was completed during parsing, since
19522 -- we need to have file names set as early as possible. Units are
19523 -- loaded well before semantic processing starts.
19525 -- The only processing we defer to this point is the check for
19526 -- correct placement.
19528 when Pragma_Source_File_Name
=>
19530 Check_Valid_Configuration_Pragma
;
19532 ------------------------------
19533 -- Source_File_Name_Project --
19534 ------------------------------
19536 -- See Source_File_Name for syntax
19538 -- No processing here. Processing was completed during parsing, since
19539 -- we need to have file names set as early as possible. Units are
19540 -- loaded well before semantic processing starts.
19542 -- The only processing we defer to this point is the check for
19543 -- correct placement.
19545 when Pragma_Source_File_Name_Project
=>
19547 Check_Valid_Configuration_Pragma
;
19549 -- Check that a pragma Source_File_Name_Project is used only in a
19550 -- configuration pragmas file.
19552 -- Pragmas Source_File_Name_Project should only be generated by
19553 -- the Project Manager in configuration pragmas files.
19555 -- This is really an ugly test. It seems to depend on some
19556 -- accidental and undocumented property. At the very least it
19557 -- needs to be documented, but it would be better to have a
19558 -- clean way of testing if we are in a configuration file???
19560 if Present
(Parent
(N
)) then
19562 ("pragma% can only appear in a configuration pragmas file");
19565 ----------------------
19566 -- Source_Reference --
19567 ----------------------
19569 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19571 -- Nothing to do, all processing completed in Par.Prag, since we need
19572 -- the information for possible parser messages that are output.
19574 when Pragma_Source_Reference
=>
19581 -- pragma SPARK_Mode [(On | Off)];
19583 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19584 Mode_Id
: SPARK_Mode_Type
;
19586 procedure Check_Pragma_Conformance
19587 (Context_Pragma
: Node_Id
;
19588 Entity_Pragma
: Node_Id
;
19589 Entity
: Entity_Id
);
19590 -- If Context_Pragma is not Empty, verify that the new pragma N
19591 -- is compatible with the pragma Context_Pragma that was inherited
19592 -- from the context:
19593 -- . if Context_Pragma is ON, then the new mode can be anything
19594 -- . if Context_Pragma is OFF, then the only allowed new mode is
19597 -- If Entity is not Empty, verify that the new pragma N is
19598 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19599 -- for Entity (which may be Empty):
19600 -- . if Entity_Pragma is ON, then the new mode can be anything
19601 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19603 -- . if Entity_Pragma is Empty, we always issue an error, as this
19604 -- corresponds to a case where a previous section of Entity
19605 -- had no SPARK_Mode set.
19607 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19608 -- Verify that pragma is applied to library-level entity E
19610 procedure Set_SPARK_Flags
;
19611 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19612 -- and ensures that Dynamic_Elaboration_Checks are off if the
19613 -- call sets SPARK_Mode On.
19615 ------------------------------
19616 -- Check_Pragma_Conformance --
19617 ------------------------------
19619 procedure Check_Pragma_Conformance
19620 (Context_Pragma
: Node_Id
;
19621 Entity_Pragma
: Node_Id
;
19622 Entity
: Entity_Id
)
19624 Arg
: Node_Id
:= Arg1
;
19627 -- The current pragma may appear without an argument. If this
19628 -- is the case, associate all error messages with the pragma
19635 -- The mode of the current pragma is compared against that of
19636 -- an enclosing context.
19638 if Present
(Context_Pragma
) then
19639 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19641 -- Issue an error if the new mode is less restrictive than
19642 -- that of the context.
19644 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19645 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19648 ("cannot change SPARK_Mode from Off to On", Arg
);
19649 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19650 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg
);
19655 -- The mode of the current pragma is compared against that of
19656 -- an initial package/subprogram declaration.
19658 if Present
(Entity
) then
19660 -- Both the initial declaration and the completion carry
19661 -- SPARK_Mode pragmas.
19663 if Present
(Entity_Pragma
) then
19664 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
19666 -- Issue an error if the new mode is less restrictive
19667 -- than that of the initial declaration.
19669 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19670 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19672 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19673 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19675 ("\value Off was set for SPARK_Mode on&#",
19680 -- Otherwise the initial declaration lacks a SPARK_Mode
19681 -- pragma in which case the current pragma is illegal as
19682 -- it cannot "complete".
19685 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19686 Error_Msg_Sloc
:= Sloc
(Entity
);
19688 ("\no value was set for SPARK_Mode on&#",
19693 end Check_Pragma_Conformance
;
19695 --------------------------------
19696 -- Check_Library_Level_Entity --
19697 --------------------------------
19699 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19700 MsgF
: constant String := "incorrect placement of pragma%";
19703 if not Is_Library_Level_Entity
(E
) then
19704 Error_Msg_Name_1
:= Pname
;
19705 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19707 if Ekind_In
(E
, E_Generic_Package
,
19712 ("\& is not a library-level package", N
, E
);
19715 ("\& is not a library-level subprogram", N
, E
);
19720 end Check_Library_Level_Entity
;
19722 ---------------------
19723 -- Set_SPARK_Flags --
19724 ---------------------
19726 procedure Set_SPARK_Flags
is
19728 SPARK_Mode
:= Mode_Id
;
19729 SPARK_Mode_Pragma
:= N
;
19731 if SPARK_Mode
= On
then
19732 Dynamic_Elaboration_Checks
:= False;
19734 end Set_SPARK_Flags
;
19738 Body_Id
: Entity_Id
;
19741 Spec_Id
: Entity_Id
;
19744 -- Start of processing for Do_SPARK_Mode
19747 -- When a SPARK_Mode pragma appears inside an instantiation whose
19748 -- enclosing context has SPARK_Mode set to "off", the pragma has
19749 -- no semantic effect.
19751 if Ignore_Pragma_SPARK_Mode
then
19752 Rewrite
(N
, Make_Null_Statement
(Loc
));
19758 Check_No_Identifiers
;
19759 Check_At_Most_N_Arguments
(1);
19761 -- Check the legality of the mode (no argument = ON)
19763 if Arg_Count
= 1 then
19764 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19765 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19770 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19771 Context
:= Parent
(N
);
19773 -- The pragma appears in a configuration pragmas file
19775 if No
(Context
) then
19776 Check_Valid_Configuration_Pragma
;
19778 if Present
(SPARK_Mode_Pragma
) then
19779 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19780 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19786 -- The pragma acts as a configuration pragma in a compilation unit
19788 -- pragma SPARK_Mode ...;
19789 -- package Pack is ...;
19791 elsif Nkind
(Context
) = N_Compilation_Unit
19792 and then List_Containing
(N
) = Context_Items
(Context
)
19794 Check_Valid_Configuration_Pragma
;
19797 -- Otherwise the placement of the pragma within the tree dictates
19798 -- its associated construct. Inspect the declarative list where
19799 -- the pragma resides to find a potential construct.
19803 while Present
(Stmt
) loop
19805 -- Skip prior pragmas, but check for duplicates
19807 if Nkind
(Stmt
) = N_Pragma
then
19808 if Pragma_Name
(Stmt
) = Pname
then
19809 Error_Msg_Name_1
:= Pname
;
19810 Error_Msg_Sloc
:= Sloc
(Stmt
);
19811 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19815 -- The pragma applies to a [generic] subprogram declaration.
19816 -- Note that this case covers an internally generated spec
19817 -- for a stand alone body.
19820 -- procedure Proc ...;
19821 -- pragma SPARK_Mode ..;
19823 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19824 N_Subprogram_Declaration
)
19826 Spec_Id
:= Defining_Entity
(Stmt
);
19827 Check_Library_Level_Entity
(Spec_Id
);
19828 Check_Pragma_Conformance
19829 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19830 Entity_Pragma
=> Empty
,
19833 Set_SPARK_Pragma
(Spec_Id
, N
);
19834 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19837 -- Skip internally generated code
19839 elsif not Comes_From_Source
(Stmt
) then
19842 -- Otherwise the pragma does not apply to a legal construct
19843 -- or it does not appear at the top of a declarative or a
19844 -- statement list. Issue an error and stop the analysis.
19854 -- The pragma applies to a package or a subprogram that acts as
19855 -- a compilation unit.
19857 -- procedure Proc ...;
19858 -- pragma SPARK_Mode ...;
19860 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19861 Context
:= Unit
(Parent
(Context
));
19864 -- The pragma appears within package declarations
19866 if Nkind
(Context
) = N_Package_Specification
then
19867 Spec_Id
:= Defining_Entity
(Context
);
19868 Check_Library_Level_Entity
(Spec_Id
);
19870 -- The pragma is at the top of the visible declarations
19873 -- pragma SPARK_Mode ...;
19875 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19876 Check_Pragma_Conformance
19877 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19878 Entity_Pragma
=> Empty
,
19882 Set_SPARK_Pragma
(Spec_Id
, N
);
19883 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19884 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19885 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19887 -- The pragma is at the top of the private declarations
19891 -- pragma SPARK_Mode ...;
19894 Check_Pragma_Conformance
19895 (Context_Pragma
=> Empty
,
19896 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19897 Entity
=> Spec_Id
);
19900 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19901 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19904 -- The pragma appears at the top of package body declarations
19906 -- package body Pack is
19907 -- pragma SPARK_Mode ...;
19909 elsif Nkind
(Context
) = N_Package_Body
then
19910 Spec_Id
:= Corresponding_Spec
(Context
);
19911 Body_Id
:= Defining_Entity
(Context
);
19912 Check_Library_Level_Entity
(Body_Id
);
19913 Check_Pragma_Conformance
19914 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19915 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19916 Entity
=> Spec_Id
);
19919 Set_SPARK_Pragma
(Body_Id
, N
);
19920 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19921 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19922 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19924 -- The pragma appears at the top of package body statements
19926 -- package body Pack is
19928 -- pragma SPARK_Mode;
19930 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19931 and then Nkind
(Parent
(Context
)) = N_Package_Body
19933 Context
:= Parent
(Context
);
19934 Spec_Id
:= Corresponding_Spec
(Context
);
19935 Body_Id
:= Defining_Entity
(Context
);
19936 Check_Library_Level_Entity
(Body_Id
);
19937 Check_Pragma_Conformance
19938 (Context_Pragma
=> Empty
,
19939 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19940 Entity
=> Body_Id
);
19943 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19944 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19946 -- The pragma appeared as an aspect of a [generic] subprogram
19947 -- declaration that acts as a compilation unit.
19950 -- procedure Proc ...;
19951 -- pragma SPARK_Mode ...;
19953 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19954 N_Subprogram_Declaration
)
19956 Spec_Id
:= Defining_Entity
(Context
);
19957 Check_Library_Level_Entity
(Spec_Id
);
19958 Check_Pragma_Conformance
19959 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19960 Entity_Pragma
=> Empty
,
19963 Set_SPARK_Pragma
(Spec_Id
, N
);
19964 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19966 -- The pragma appears at the top of subprogram body
19969 -- procedure Proc ... is
19970 -- pragma SPARK_Mode;
19972 elsif Nkind
(Context
) = N_Subprogram_Body
then
19973 Spec_Id
:= Corresponding_Spec
(Context
);
19974 Context
:= Specification
(Context
);
19975 Body_Id
:= Defining_Entity
(Context
);
19977 -- Ignore pragma when applied to the special body created
19978 -- for inlining, recognized by its internal name _Parent.
19980 if Chars
(Body_Id
) = Name_uParent
then
19984 Check_Library_Level_Entity
(Body_Id
);
19986 -- The body is a completion of a previous declaration
19988 if Present
(Spec_Id
) then
19989 Check_Pragma_Conformance
19990 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19991 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19992 Entity
=> Spec_Id
);
19994 -- The body acts as spec
19997 Check_Pragma_Conformance
19998 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19999 Entity_Pragma
=> Empty
,
20005 Set_SPARK_Pragma
(Body_Id
, N
);
20006 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20008 -- The pragma does not apply to a legal construct, issue error
20016 --------------------------------
20017 -- Static_Elaboration_Desired --
20018 --------------------------------
20020 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20022 when Pragma_Static_Elaboration_Desired
=>
20024 Check_At_Most_N_Arguments
(1);
20026 if Is_Compilation_Unit
(Current_Scope
)
20027 and then Ekind
(Current_Scope
) = E_Package
20029 Set_Static_Elaboration_Desired
(Current_Scope
, True);
20031 Error_Pragma
("pragma% must apply to a library-level package");
20038 -- pragma Storage_Size (EXPRESSION);
20040 when Pragma_Storage_Size
=> Storage_Size
: declare
20041 P
: constant Node_Id
:= Parent
(N
);
20045 Check_No_Identifiers
;
20046 Check_Arg_Count
(1);
20048 -- The expression must be analyzed in the special manner described
20049 -- in "Handling of Default Expressions" in sem.ads.
20051 Arg
:= Get_Pragma_Arg
(Arg1
);
20052 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20054 if not Is_OK_Static_Expression
(Arg
) then
20055 Check_Restriction
(Static_Storage_Size
, Arg
);
20058 if Nkind
(P
) /= N_Task_Definition
then
20063 if Has_Storage_Size_Pragma
(P
) then
20064 Error_Pragma
("duplicate pragma% not allowed");
20066 Set_Has_Storage_Size_Pragma
(P
, True);
20069 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20077 -- pragma Storage_Unit (NUMERIC_LITERAL);
20079 -- Only permitted argument is System'Storage_Unit value
20081 when Pragma_Storage_Unit
=>
20082 Check_No_Identifiers
;
20083 Check_Arg_Count
(1);
20084 Check_Arg_Is_Integer_Literal
(Arg1
);
20086 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20087 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20089 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20091 ("the only allowed argument for pragma% is ^", Arg1
);
20094 --------------------
20095 -- Stream_Convert --
20096 --------------------
20098 -- pragma Stream_Convert (
20099 -- [Entity =>] type_LOCAL_NAME,
20100 -- [Read =>] function_NAME,
20101 -- [Write =>] function NAME);
20103 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20105 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20106 -- Check that the given argument is the name of a local function
20107 -- of one argument that is not overloaded earlier in the current
20108 -- local scope. A check is also made that the argument is a
20109 -- function with one parameter.
20111 --------------------------------------
20112 -- Check_OK_Stream_Convert_Function --
20113 --------------------------------------
20115 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20119 Check_Arg_Is_Local_Name
(Arg
);
20120 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20122 if Has_Homonym
(Ent
) then
20124 ("argument for pragma% may not be overloaded", Arg
);
20127 if Ekind
(Ent
) /= E_Function
20128 or else No
(First_Formal
(Ent
))
20129 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20132 ("argument for pragma% must be function of one argument",
20135 end Check_OK_Stream_Convert_Function
;
20137 -- Start of processing for Stream_Convert
20141 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20142 Check_Arg_Count
(3);
20143 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20144 Check_Optional_Identifier
(Arg2
, Name_Read
);
20145 Check_Optional_Identifier
(Arg3
, Name_Write
);
20146 Check_Arg_Is_Local_Name
(Arg1
);
20147 Check_OK_Stream_Convert_Function
(Arg2
);
20148 Check_OK_Stream_Convert_Function
(Arg3
);
20151 Typ
: constant Entity_Id
:=
20152 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20153 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20154 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20157 Check_First_Subtype
(Arg1
);
20159 -- Check for too early or too late. Note that we don't enforce
20160 -- the rule about primitive operations in this case, since, as
20161 -- is the case for explicit stream attributes themselves, these
20162 -- restrictions are not appropriate. Note that the chaining of
20163 -- the pragma by Rep_Item_Too_Late is actually the critical
20164 -- processing done for this pragma.
20166 if Rep_Item_Too_Early
(Typ
, N
)
20168 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20173 -- Return if previous error
20175 if Etype
(Typ
) = Any_Type
20177 Etype
(Read
) = Any_Type
20179 Etype
(Write
) = Any_Type
20186 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20188 ("incorrect return type for function&", Arg2
);
20191 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20193 ("incorrect parameter type for function&", Arg3
);
20196 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20197 Underlying_Type
(Etype
(Write
))
20200 ("result type of & does not match Read parameter type",
20204 end Stream_Convert
;
20210 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20212 -- This is processed by the parser since some of the style checks
20213 -- take place during source scanning and parsing. This means that
20214 -- we don't need to issue error messages here.
20216 when Pragma_Style_Checks
=> Style_Checks
: declare
20217 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20223 Check_No_Identifiers
;
20225 -- Two argument form
20227 if Arg_Count
= 2 then
20228 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20235 E_Id
:= Get_Pragma_Arg
(Arg2
);
20238 if not Is_Entity_Name
(E_Id
) then
20240 ("second argument of pragma% must be entity name",
20244 E
:= Entity
(E_Id
);
20246 if not Ignore_Style_Checks_Pragmas
then
20251 Set_Suppress_Style_Checks
20252 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20253 exit when No
(Homonym
(E
));
20260 -- One argument form
20263 Check_Arg_Count
(1);
20265 if Nkind
(A
) = N_String_Literal
then
20269 Slen
: constant Natural := Natural (String_Length
(S
));
20270 Options
: String (1 .. Slen
);
20276 C
:= Get_String_Char
(S
, Int
(J
));
20277 exit when not In_Character_Range
(C
);
20278 Options
(J
) := Get_Character
(C
);
20280 -- If at end of string, set options. As per discussion
20281 -- above, no need to check for errors, since we issued
20282 -- them in the parser.
20285 if not Ignore_Style_Checks_Pragmas
then
20286 Set_Style_Check_Options
(Options
);
20296 elsif Nkind
(A
) = N_Identifier
then
20297 if Chars
(A
) = Name_All_Checks
then
20298 if not Ignore_Style_Checks_Pragmas
then
20300 Set_GNAT_Style_Check_Options
;
20302 Set_Default_Style_Check_Options
;
20306 elsif Chars
(A
) = Name_On
then
20307 if not Ignore_Style_Checks_Pragmas
then
20308 Style_Check
:= True;
20311 elsif Chars
(A
) = Name_Off
then
20312 if not Ignore_Style_Checks_Pragmas
then
20313 Style_Check
:= False;
20324 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20326 when Pragma_Subtitle
=>
20328 Check_Arg_Count
(1);
20329 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20330 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20337 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20339 when Pragma_Suppress
=>
20340 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
20346 -- pragma Suppress_All;
20348 -- The only check made here is that the pragma has no arguments.
20349 -- There are no placement rules, and the processing required (setting
20350 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20351 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20352 -- then creates and inserts a pragma Suppress (All_Checks).
20354 when Pragma_Suppress_All
=>
20356 Check_Arg_Count
(0);
20358 -------------------------
20359 -- Suppress_Debug_Info --
20360 -------------------------
20362 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20364 when Pragma_Suppress_Debug_Info
=>
20366 Check_Arg_Count
(1);
20367 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20368 Check_Arg_Is_Local_Name
(Arg1
);
20369 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20371 ----------------------------------
20372 -- Suppress_Exception_Locations --
20373 ----------------------------------
20375 -- pragma Suppress_Exception_Locations;
20377 when Pragma_Suppress_Exception_Locations
=>
20379 Check_Arg_Count
(0);
20380 Check_Valid_Configuration_Pragma
;
20381 Exception_Locations_Suppressed
:= True;
20383 -----------------------------
20384 -- Suppress_Initialization --
20385 -----------------------------
20387 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20389 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20395 Check_Arg_Count
(1);
20396 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20397 Check_Arg_Is_Local_Name
(Arg1
);
20399 E_Id
:= Get_Pragma_Arg
(Arg1
);
20401 if Etype
(E_Id
) = Any_Type
then
20405 E
:= Entity
(E_Id
);
20407 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20409 ("pragma% requires variable, type or subtype", Arg1
);
20412 if Rep_Item_Too_Early
(E
, N
)
20414 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20419 -- For incomplete/private type, set flag on full view
20421 if Is_Incomplete_Or_Private_Type
(E
) then
20422 if No
(Full_View
(Base_Type
(E
))) then
20424 ("argument of pragma% cannot be an incomplete type", Arg1
);
20426 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20429 -- For first subtype, set flag on base type
20431 elsif Is_First_Subtype
(E
) then
20432 Set_Suppress_Initialization
(Base_Type
(E
));
20434 -- For other than first subtype, set flag on subtype or variable
20437 Set_Suppress_Initialization
(E
);
20445 -- pragma System_Name (DIRECT_NAME);
20447 -- Syntax check: one argument, which must be the identifier GNAT or
20448 -- the identifier GCC, no other identifiers are acceptable.
20450 when Pragma_System_Name
=>
20452 Check_No_Identifiers
;
20453 Check_Arg_Count
(1);
20454 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20456 -----------------------------
20457 -- Task_Dispatching_Policy --
20458 -----------------------------
20460 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20462 when Pragma_Task_Dispatching_Policy
=> declare
20466 Check_Ada_83_Warning
;
20467 Check_Arg_Count
(1);
20468 Check_No_Identifiers
;
20469 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20470 Check_Valid_Configuration_Pragma
;
20471 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20472 DP
:= Fold_Upper
(Name_Buffer
(1));
20474 if Task_Dispatching_Policy
/= ' '
20475 and then Task_Dispatching_Policy
/= DP
20477 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20479 ("task dispatching policy incompatible with policy#");
20481 -- Set new policy, but always preserve System_Location since we
20482 -- like the error message with the run time name.
20485 Task_Dispatching_Policy
:= DP
;
20487 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20488 Task_Dispatching_Policy_Sloc
:= Loc
;
20497 -- pragma Task_Info (EXPRESSION);
20499 when Pragma_Task_Info
=> Task_Info
: declare
20500 P
: constant Node_Id
:= Parent
(N
);
20506 if Warn_On_Obsolescent_Feature
then
20508 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20509 & "instead?j?", N
);
20512 if Nkind
(P
) /= N_Task_Definition
then
20513 Error_Pragma
("pragma% must appear in task definition");
20516 Check_No_Identifiers
;
20517 Check_Arg_Count
(1);
20519 Analyze_And_Resolve
20520 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20522 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20526 Ent
:= Defining_Identifier
(Parent
(P
));
20528 -- Check duplicate pragma before we chain the pragma in the Rep
20529 -- Item chain of Ent.
20532 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20534 Error_Pragma
("duplicate pragma% not allowed");
20537 Record_Rep_Item
(Ent
, N
);
20544 -- pragma Task_Name (string_EXPRESSION);
20546 when Pragma_Task_Name
=> Task_Name
: declare
20547 P
: constant Node_Id
:= Parent
(N
);
20552 Check_No_Identifiers
;
20553 Check_Arg_Count
(1);
20555 Arg
:= Get_Pragma_Arg
(Arg1
);
20557 -- The expression is used in the call to Create_Task, and must be
20558 -- expanded there, not in the context of the current spec. It must
20559 -- however be analyzed to capture global references, in case it
20560 -- appears in a generic context.
20562 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20564 if Nkind
(P
) /= N_Task_Definition
then
20568 Ent
:= Defining_Identifier
(Parent
(P
));
20570 -- Check duplicate pragma before we chain the pragma in the Rep
20571 -- Item chain of Ent.
20574 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20576 Error_Pragma
("duplicate pragma% not allowed");
20579 Record_Rep_Item
(Ent
, N
);
20586 -- pragma Task_Storage (
20587 -- [Task_Type =>] LOCAL_NAME,
20588 -- [Top_Guard =>] static_integer_EXPRESSION);
20590 when Pragma_Task_Storage
=> Task_Storage
: declare
20591 Args
: Args_List
(1 .. 2);
20592 Names
: constant Name_List
(1 .. 2) := (
20596 Task_Type
: Node_Id
renames Args
(1);
20597 Top_Guard
: Node_Id
renames Args
(2);
20603 Gather_Associations
(Names
, Args
);
20605 if No
(Task_Type
) then
20607 ("missing task_type argument for pragma%");
20610 Check_Arg_Is_Local_Name
(Task_Type
);
20612 Ent
:= Entity
(Task_Type
);
20614 if not Is_Task_Type
(Ent
) then
20616 ("argument for pragma% must be task type", Task_Type
);
20619 if No
(Top_Guard
) then
20621 ("pragma% takes two arguments", Task_Type
);
20623 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20626 Check_First_Subtype
(Task_Type
);
20628 if Rep_Item_Too_Late
(Ent
, N
) then
20637 -- pragma Test_Case
20638 -- ([Name =>] Static_String_EXPRESSION
20639 -- ,[Mode =>] MODE_TYPE
20640 -- [, Requires => Boolean_EXPRESSION]
20641 -- [, Ensures => Boolean_EXPRESSION]);
20643 -- MODE_TYPE ::= Nominal | Robustness
20645 when Pragma_Test_Case
=>
20649 --------------------------
20650 -- Thread_Local_Storage --
20651 --------------------------
20653 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20655 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20661 Check_Arg_Count
(1);
20662 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20663 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20665 Id
:= Get_Pragma_Arg
(Arg1
);
20668 if not Is_Entity_Name
(Id
)
20669 or else Ekind
(Entity
(Id
)) /= E_Variable
20671 Error_Pragma_Arg
("local variable name required", Arg1
);
20676 if Rep_Item_Too_Early
(E
, N
)
20677 or else Rep_Item_Too_Late
(E
, N
)
20682 Set_Has_Pragma_Thread_Local_Storage
(E
);
20683 Set_Has_Gigi_Rep_Item
(E
);
20684 end Thread_Local_Storage
;
20690 -- pragma Time_Slice (static_duration_EXPRESSION);
20692 when Pragma_Time_Slice
=> Time_Slice
: declare
20698 Check_Arg_Count
(1);
20699 Check_No_Identifiers
;
20700 Check_In_Main_Program
;
20701 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20703 if not Error_Posted
(Arg1
) then
20705 while Present
(Nod
) loop
20706 if Nkind
(Nod
) = N_Pragma
20707 and then Pragma_Name
(Nod
) = Name_Time_Slice
20709 Error_Msg_Name_1
:= Pname
;
20710 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20717 -- Process only if in main unit
20719 if Get_Source_Unit
(Loc
) = Main_Unit
then
20720 Opt
.Time_Slice_Set
:= True;
20721 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20723 if Val
<= Ureal_0
then
20724 Opt
.Time_Slice_Value
:= 0;
20726 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20727 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20730 Opt
.Time_Slice_Value
:=
20731 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20740 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20742 -- TITLING_OPTION ::=
20743 -- [Title =>] STRING_LITERAL
20744 -- | [Subtitle =>] STRING_LITERAL
20746 when Pragma_Title
=> Title
: declare
20747 Args
: Args_List
(1 .. 2);
20748 Names
: constant Name_List
(1 .. 2) := (
20754 Gather_Associations
(Names
, Args
);
20757 for J
in 1 .. 2 loop
20758 if Present
(Args
(J
)) then
20759 Check_Arg_Is_OK_Static_Expression
20760 (Args
(J
), Standard_String
);
20765 ----------------------------
20766 -- Type_Invariant[_Class] --
20767 ----------------------------
20769 -- pragma Type_Invariant[_Class]
20770 -- ([Entity =>] type_LOCAL_NAME,
20771 -- [Check =>] EXPRESSION);
20773 when Pragma_Type_Invariant |
20774 Pragma_Type_Invariant_Class
=>
20775 Type_Invariant
: declare
20776 I_Pragma
: Node_Id
;
20779 Check_Arg_Count
(2);
20781 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20782 -- setting Class_Present for the Type_Invariant_Class case.
20784 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20785 I_Pragma
:= New_Copy
(N
);
20786 Set_Pragma_Identifier
20787 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20788 Rewrite
(N
, I_Pragma
);
20789 Set_Analyzed
(N
, False);
20791 end Type_Invariant
;
20793 ---------------------
20794 -- Unchecked_Union --
20795 ---------------------
20797 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20799 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20800 Assoc
: constant Node_Id
:= Arg1
;
20801 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20811 Check_No_Identifiers
;
20812 Check_Arg_Count
(1);
20813 Check_Arg_Is_Local_Name
(Arg1
);
20815 Find_Type
(Type_Id
);
20817 Typ
:= Entity
(Type_Id
);
20820 or else Rep_Item_Too_Early
(Typ
, N
)
20824 Typ
:= Underlying_Type
(Typ
);
20827 if Rep_Item_Too_Late
(Typ
, N
) then
20831 Check_First_Subtype
(Arg1
);
20833 -- Note remaining cases are references to a type in the current
20834 -- declarative part. If we find an error, we post the error on
20835 -- the relevant type declaration at an appropriate point.
20837 if not Is_Record_Type
(Typ
) then
20838 Error_Msg_N
("unchecked union must be record type", Typ
);
20841 elsif Is_Tagged_Type
(Typ
) then
20842 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20845 elsif not Has_Discriminants
(Typ
) then
20847 ("unchecked union must have one discriminant", Typ
);
20850 -- Note: in previous versions of GNAT we used to check for limited
20851 -- types and give an error, but in fact the standard does allow
20852 -- Unchecked_Union on limited types, so this check was removed.
20854 -- Similarly, GNAT used to require that all discriminants have
20855 -- default values, but this is not mandated by the RM.
20857 -- Proceed with basic error checks completed
20860 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20861 Clist
:= Component_List
(Tdef
);
20863 -- Check presence of component list and variant part
20865 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20867 ("unchecked union must have variant part", Tdef
);
20871 -- Check components
20873 Comp
:= First
(Component_Items
(Clist
));
20874 while Present
(Comp
) loop
20875 Check_Component
(Comp
, Typ
);
20879 -- Check variant part
20881 Vpart
:= Variant_Part
(Clist
);
20883 Variant
:= First
(Variants
(Vpart
));
20884 while Present
(Variant
) loop
20885 Check_Variant
(Variant
, Typ
);
20890 Set_Is_Unchecked_Union
(Typ
);
20891 Set_Convention
(Typ
, Convention_C
);
20892 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20893 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20894 end Unchecked_Union
;
20896 ------------------------
20897 -- Unimplemented_Unit --
20898 ------------------------
20900 -- pragma Unimplemented_Unit;
20902 -- Note: this only gives an error if we are generating code, or if
20903 -- we are in a generic library unit (where the pragma appears in the
20904 -- body, not in the spec).
20906 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20907 Cunitent
: constant Entity_Id
:=
20908 Cunit_Entity
(Get_Source_Unit
(Loc
));
20909 Ent_Kind
: constant Entity_Kind
:=
20914 Check_Arg_Count
(0);
20916 if Operating_Mode
= Generate_Code
20917 or else Ent_Kind
= E_Generic_Function
20918 or else Ent_Kind
= E_Generic_Procedure
20919 or else Ent_Kind
= E_Generic_Package
20921 Get_Name_String
(Chars
(Cunitent
));
20922 Set_Casing
(Mixed_Case
);
20923 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20924 Write_Str
(" is not supported in this configuration");
20926 raise Unrecoverable_Error
;
20928 end Unimplemented_Unit
;
20930 ------------------------
20931 -- Universal_Aliasing --
20932 ------------------------
20934 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20936 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20941 Check_Arg_Count
(1);
20942 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20943 Check_Arg_Is_Local_Name
(Arg1
);
20944 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20946 if E_Id
= Any_Type
then
20948 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20949 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20952 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20953 Record_Rep_Item
(E_Id
, N
);
20954 end Universal_Alias
;
20956 --------------------
20957 -- Universal_Data --
20958 --------------------
20960 -- pragma Universal_Data [(library_unit_NAME)];
20962 when Pragma_Universal_Data
=>
20965 -- If this is a configuration pragma, then set the universal
20966 -- addressing option, otherwise confirm that the pragma satisfies
20967 -- the requirements of library unit pragma placement and leave it
20968 -- to the GNAAMP back end to detect the pragma (avoids transitive
20969 -- setting of the option due to withed units).
20971 if Is_Configuration_Pragma
then
20972 Universal_Addressing_On_AAMP
:= True;
20974 Check_Valid_Library_Unit_Pragma
;
20977 if not AAMP_On_Target
then
20978 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20985 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20987 when Pragma_Unmodified
=> Unmodified
: declare
20988 Arg_Node
: Node_Id
;
20989 Arg_Expr
: Node_Id
;
20990 Arg_Ent
: Entity_Id
;
20994 Check_At_Least_N_Arguments
(1);
20996 -- Loop through arguments
20999 while Present
(Arg_Node
) loop
21000 Check_No_Identifier
(Arg_Node
);
21002 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21003 -- in fact generate reference, so that the entity will have a
21004 -- reference, which will inhibit any warnings about it not
21005 -- being referenced, and also properly show up in the ali file
21006 -- as a reference. But this reference is recorded before the
21007 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21008 -- generated for this reference.
21010 Check_Arg_Is_Local_Name
(Arg_Node
);
21011 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21013 if Is_Entity_Name
(Arg_Expr
) then
21014 Arg_Ent
:= Entity
(Arg_Expr
);
21016 if not Is_Assignable
(Arg_Ent
) then
21018 ("pragma% can only be applied to a variable",
21021 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21033 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21035 -- or when used in a context clause:
21037 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21039 when Pragma_Unreferenced
=> Unreferenced
: declare
21040 Arg_Node
: Node_Id
;
21041 Arg_Expr
: Node_Id
;
21042 Arg_Ent
: Entity_Id
;
21047 Check_At_Least_N_Arguments
(1);
21049 -- Check case of appearing within context clause
21051 if Is_In_Context_Clause
then
21053 -- The arguments must all be units mentioned in a with clause
21054 -- in the same context clause. Note we already checked (in
21055 -- Par.Prag) that the arguments are either identifiers or
21056 -- selected components.
21059 while Present
(Arg_Node
) loop
21060 Citem
:= First
(List_Containing
(N
));
21061 while Citem
/= N
loop
21062 if Nkind
(Citem
) = N_With_Clause
21064 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21066 Set_Has_Pragma_Unreferenced
21069 (Library_Unit
(Citem
))));
21071 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21080 ("argument of pragma% is not withed unit", Arg_Node
);
21086 -- Case of not in list of context items
21090 while Present
(Arg_Node
) loop
21091 Check_No_Identifier
(Arg_Node
);
21093 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21094 -- will in fact generate reference, so that the entity will
21095 -- have a reference, which will inhibit any warnings about
21096 -- it not being referenced, and also properly show up in the
21097 -- ali file as a reference. But this reference is recorded
21098 -- before the Has_Pragma_Unreferenced flag is set, so that
21099 -- no warning is generated for this reference.
21101 Check_Arg_Is_Local_Name
(Arg_Node
);
21102 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21104 if Is_Entity_Name
(Arg_Expr
) then
21105 Arg_Ent
:= Entity
(Arg_Expr
);
21107 -- If the entity is overloaded, the pragma applies to the
21108 -- most recent overloading, as documented. In this case,
21109 -- name resolution does not generate a reference, so it
21110 -- must be done here explicitly.
21112 if Is_Overloaded
(Arg_Expr
) then
21113 Generate_Reference
(Arg_Ent
, N
);
21116 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21124 --------------------------
21125 -- Unreferenced_Objects --
21126 --------------------------
21128 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21130 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21131 Arg_Node
: Node_Id
;
21132 Arg_Expr
: Node_Id
;
21136 Check_At_Least_N_Arguments
(1);
21139 while Present
(Arg_Node
) loop
21140 Check_No_Identifier
(Arg_Node
);
21141 Check_Arg_Is_Local_Name
(Arg_Node
);
21142 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21144 if not Is_Entity_Name
(Arg_Expr
)
21145 or else not Is_Type
(Entity
(Arg_Expr
))
21148 ("argument for pragma% must be type or subtype", Arg_Node
);
21151 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21154 end Unreferenced_Objects
;
21156 ------------------------------
21157 -- Unreserve_All_Interrupts --
21158 ------------------------------
21160 -- pragma Unreserve_All_Interrupts;
21162 when Pragma_Unreserve_All_Interrupts
=>
21164 Check_Arg_Count
(0);
21166 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21167 Unreserve_All_Interrupts
:= True;
21174 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21176 when Pragma_Unsuppress
=>
21178 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
21180 ----------------------------
21181 -- Unevaluated_Use_Of_Old --
21182 ----------------------------
21184 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21186 when Pragma_Unevaluated_Use_Of_Old
=>
21188 Check_Arg_Count
(1);
21189 Check_No_Identifiers
;
21190 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
21192 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21193 -- a declarative part or a package spec.
21195 if not Is_Configuration_Pragma
then
21196 Check_Is_In_Decl_Part_Or_Package_Spec
;
21199 -- Store proper setting of Uneval_Old
21201 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21202 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
21204 -------------------
21205 -- Use_VADS_Size --
21206 -------------------
21208 -- pragma Use_VADS_Size;
21210 when Pragma_Use_VADS_Size
=>
21212 Check_Arg_Count
(0);
21213 Check_Valid_Configuration_Pragma
;
21214 Use_VADS_Size
:= True;
21216 ---------------------
21217 -- Validity_Checks --
21218 ---------------------
21220 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21222 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21223 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21229 Check_Arg_Count
(1);
21230 Check_No_Identifiers
;
21232 -- Pragma always active unless in CodePeer or GNATprove modes,
21233 -- which use a fixed configuration of validity checks.
21235 if not (CodePeer_Mode
or GNATprove_Mode
) then
21236 if Nkind
(A
) = N_String_Literal
then
21240 Slen
: constant Natural := Natural (String_Length
(S
));
21241 Options
: String (1 .. Slen
);
21245 -- Couldn't we use a for loop here over Options'Range???
21249 C
:= Get_String_Char
(S
, Int
(J
));
21251 -- This is a weird test, it skips setting validity
21252 -- checks entirely if any element of S is out of
21253 -- range of Character, what is that about ???
21255 exit when not In_Character_Range
(C
);
21256 Options
(J
) := Get_Character
(C
);
21259 Set_Validity_Check_Options
(Options
);
21267 elsif Nkind
(A
) = N_Identifier
then
21268 if Chars
(A
) = Name_All_Checks
then
21269 Set_Validity_Check_Options
("a");
21270 elsif Chars
(A
) = Name_On
then
21271 Validity_Checks_On
:= True;
21272 elsif Chars
(A
) = Name_Off
then
21273 Validity_Checks_On
:= False;
21277 end Validity_Checks
;
21283 -- pragma Volatile (LOCAL_NAME);
21285 when Pragma_Volatile
=>
21286 Process_Atomic_Independent_Shared_Volatile
;
21288 -------------------------
21289 -- Volatile_Components --
21290 -------------------------
21292 -- pragma Volatile_Components (array_LOCAL_NAME);
21294 -- Volatile is handled by the same circuit as Atomic_Components
21296 ----------------------
21297 -- Warning_As_Error --
21298 ----------------------
21300 -- pragma Warning_As_Error (static_string_EXPRESSION);
21302 when Pragma_Warning_As_Error
=>
21304 Check_Arg_Count
(1);
21305 Check_No_Identifiers
;
21306 Check_Valid_Configuration_Pragma
;
21308 if not Is_Static_String_Expression
(Arg1
) then
21310 ("argument of pragma% must be static string expression",
21313 -- OK static string expression
21316 Acquire_Warning_Match_String
(Arg1
);
21317 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21318 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21319 new String'(Name_Buffer (1 .. Name_Len));
21326 -- pragma Warnings ([TOOL_NAME,] On | Off [,REASON]);
21327 -- pragma Warnings ([TOOL_NAME,] On | Off, LOCAL_NAME [,REASON]);
21328 -- pragma Warnings ([TOOL_NAME,] static_string_EXPRESSION [,REASON]);
21329 -- pragma Warnings ([TOOL_NAME,] On | Off,
21330 -- static_string_EXPRESSION [,REASON]);
21332 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
21334 -- If present, TOOL_NAME refers to a tool, currently either GNAT
21335 -- or GNATprove. If an identifier is a static string expression,
21336 -- the form of pragma Warnings that starts with a static string
21337 -- expression is used.
21339 when Pragma_Warnings => Warnings : declare
21340 Reason : String_Id;
21344 Check_At_Least_N_Arguments (1);
21346 -- See if last argument is labeled Reason. If so, make sure we
21347 -- have a string literal or a concatenation of string literals,
21348 -- and acquire the REASON string. Then remove the REASON argument
21349 -- by decreasing Num_Args by one; Remaining processing looks only
21350 -- at first Num_Args arguments).
21353 Last_Arg : constant Node_Id :=
21354 Last (Pragma_Argument_Associations (N));
21357 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21358 and then Chars (Last_Arg) = Name_Reason
21361 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21362 Reason := End_String;
21363 Arg_Count := Arg_Count - 1;
21365 -- Not allowed in compiler units (bootstrap issues)
21367 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21369 -- No REASON string, set null string as reason
21372 Reason := Null_String_Id;
21376 -- Now proceed with REASON taken care of and eliminated
21378 Check_No_Identifiers;
21380 -- If debug flag -gnatd.i is set, pragma is ignored
21382 if Debug_Flag_Dot_I then
21386 -- Process various forms of the pragma
21389 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21390 Shifted_Args : List_Id;
21393 -- See if first argument is a tool name, currently either
21394 -- GNAT or GNATprove. If so, either ignore the pragma if the
21395 -- tool used does not match, or continue as if no tool name
21396 -- was given otherwise, by shifting the arguments.
21398 if Nkind (Argx) = N_Identifier
21399 and then not Nam_In (Chars (Argx), Name_On, Name_Off)
21400 and then not Is_Static_String_Expression (Arg1)
21401 -- How can this possibly work e.g. for GNATprove???
21403 if Chars (Argx) = Name_Gnat then
21404 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
21405 Rewrite (N, Make_Null_Statement (Loc));
21410 elsif Chars (Argx) = Name_Gnatprove then
21411 if not GNATprove_Mode then
21412 Rewrite (N, Make_Null_Statement (Loc));
21419 ("argument of pragma% must be On/Off or tool name "
21420 & "or static string expression", Arg1);
21423 -- At this point, the pragma Warnings applies to the tool,
21424 -- so continue with shifted arguments.
21426 Arg_Count := Arg_Count - 1;
21428 if Arg_Count = 1 then
21429 Shifted_Args := New_List (New_Copy (Arg2));
21430 elsif Arg_Count = 2 then
21431 Shifted_Args := New_List (New_Copy (Arg2),
21433 elsif Arg_Count = 3 then
21434 Shifted_Args := New_List (New_Copy (Arg2),
21438 raise Program_Error;
21441 Rewrite (N, Make_Pragma (Loc,
21442 Chars => Name_Warnings,
21443 Pragma_Argument_Associations => Shifted_Args));
21448 -- One argument case
21450 if Arg_Count = 1 then
21452 -- On/Off one argument case was processed by parser
21454 if Nkind (Argx) = N_Identifier
21455 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21459 -- One argument case must be ON/OFF or static string expr
21461 elsif not Is_Static_String_Expression (Arg1) then
21463 ("argument of pragma% must be On/Off or static string "
21464 & "expression", Arg1);
21466 -- One argument string expression case
21470 Lit : constant Node_Id := Expr_Value_S (Argx);
21471 Str : constant String_Id := Strval (Lit);
21472 Len : constant Nat := String_Length (Str);
21480 while J <= Len loop
21481 C := Get_String_Char (Str, J);
21482 OK := In_Character_Range (C);
21485 Chr := Get_Character (C);
21487 -- Dash case: only -Wxxx is accepted
21494 C := Get_String_Char (Str, J);
21495 Chr := Get_Character (C);
21496 exit when Chr = 'W
';
21501 elsif J < Len and then Chr = '.' then
21503 C := Get_String_Char (Str, J);
21504 Chr := Get_Character (C);
21506 if not Set_Dot_Warning_Switch (Chr) then
21508 ("invalid warning switch character "
21509 & '.' & Chr, Arg1);
21515 OK := Set_Warning_Switch (Chr);
21521 ("invalid warning switch character " & Chr,
21530 -- Two or more arguments (must be two)
21533 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21534 Check_Arg_Count (2);
21542 E_Id := Get_Pragma_Arg (Arg2);
21545 -- In the expansion of an inlined body, a reference to
21546 -- the formal may be wrapped in a conversion if the
21547 -- actual is a conversion. Retrieve the real entity name.
21549 if (In_Instance_Body or In_Inlined_Body)
21550 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21552 E_Id := Expression (E_Id);
21555 -- Entity name case
21557 if Is_Entity_Name (E_Id) then
21558 E := Entity (E_Id);
21565 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21568 -- For OFF case, make entry in warnings off
21569 -- pragma table for later processing. But we do
21570 -- not do that within an instance, since these
21571 -- warnings are about what is needed in the
21572 -- template, not an instance of it.
21574 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21575 and then Warn_On_Warnings_Off
21576 and then not In_Instance
21578 Warnings_Off_Pragmas.Append ((N, E, Reason));
21581 if Is_Enumeration_Type (E) then
21585 Lit := First_Literal (E);
21586 while Present (Lit) loop
21587 Set_Warnings_Off (Lit);
21588 Next_Literal (Lit);
21593 exit when No (Homonym (E));
21598 -- Error if not entity or static string expression case
21600 elsif not Is_Static_String_Expression (Arg2) then
21602 ("second argument of pragma% must be entity name "
21603 & "or static string expression", Arg2);
21605 -- Static string expression case
21608 Acquire_Warning_Match_String (Arg2);
21610 -- Note on configuration pragma case: If this is a
21611 -- configuration pragma, then for an OFF pragma, we
21612 -- just set Config True in the call, which is all
21613 -- that needs to be done. For the case of ON, this
21614 -- is normally an error, unless it is canceling the
21615 -- effect of a previous OFF pragma in the same file.
21616 -- In any other case, an error will be signalled (ON
21617 -- with no matching OFF).
21619 -- Note: We set Used if we are inside a generic to
21620 -- disable the test that the non-config case actually
21621 -- cancels a warning. That's because we can't be sure
21622 -- there isn't an instantiation in some other unit
21623 -- where a warning is suppressed.
21625 -- We could do a little better here by checking if the
21626 -- generic unit we are inside is public, but for now
21627 -- we don't bother with that refinement.
21629 if Chars (Argx) = Name_Off then
21630 Set_Specific_Warning_Off
21631 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21632 Config => Is_Configuration_Pragma,
21633 Used => Inside_A_Generic or else In_Instance);
21635 elsif Chars (Argx) = Name_On then
21636 Set_Specific_Warning_On
21637 (Loc, Name_Buffer (1 .. Name_Len), Err);
21641 ("??pragma Warnings On with no matching "
21642 & "Warnings Off", Loc);
21651 -------------------
21652 -- Weak_External --
21653 -------------------
21655 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21657 when Pragma_Weak_External => Weak_External : declare
21662 Check_Arg_Count (1);
21663 Check_Optional_Identifier (Arg1, Name_Entity);
21664 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21665 Ent := Entity (Get_Pragma_Arg (Arg1));
21667 if Rep_Item_Too_Early (Ent, N) then
21670 Ent := Underlying_Type (Ent);
21673 -- The only processing required is to link this item on to the
21674 -- list of rep items for the given entity. This is accomplished
21675 -- by the call to Rep_Item_Too_Late (when no error is detected
21676 -- and False is returned).
21678 if Rep_Item_Too_Late (Ent, N) then
21681 Set_Has_Gigi_Rep_Item (Ent);
21685 -----------------------------
21686 -- Wide_Character_Encoding --
21687 -----------------------------
21689 -- pragma Wide_Character_Encoding (IDENTIFIER);
21691 when Pragma_Wide_Character_Encoding =>
21694 -- Nothing to do, handled in parser. Note that we do not enforce
21695 -- configuration pragma placement, this pragma can appear at any
21696 -- place in the source, allowing mixed encodings within a single
21701 --------------------
21702 -- Unknown_Pragma --
21703 --------------------
21705 -- Should be impossible, since the case of an unknown pragma is
21706 -- separately processed before the case statement is entered.
21708 when Unknown_Pragma =>
21709 raise Program_Error;
21712 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21713 -- until AI is formally approved.
21715 -- Check_Order_Dependence;
21718 when Pragma_Exit => null;
21719 end Analyze_Pragma;
21721 ---------------------------------------------
21722 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21723 ---------------------------------------------
21725 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21727 Subp_Id : Entity_Id)
21729 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21730 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21733 Restore_Scope : Boolean := False;
21734 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21737 -- Ensure that the subprogram and its formals are visible when analyzing
21738 -- the expression of the pragma.
21740 if not In_Open_Scopes (Subp_Id) then
21741 Restore_Scope := True;
21742 Push_Scope (Subp_Id);
21743 Install_Formals (Subp_Id);
21746 -- Preanalyze the boolean expression, we treat this as a spec expression
21747 -- (i.e. similar to a default expression).
21749 Expr := Get_Pragma_Arg (Arg1);
21751 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21752 -- the original aspect expression, which is shared with the generated
21755 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21756 Expr := Expression (Corresponding_Aspect (Prag));
21759 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21761 -- For a class-wide condition, a reference to a controlling formal must
21762 -- be interpreted as having the class-wide type (or an access to such)
21763 -- so that the inherited condition can be properly applied to any
21764 -- overriding operation (see ARM12 6.6.1 (7)).
21766 if Class_Present (Prag) then
21767 Class_Wide_Condition : declare
21768 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21770 ACW : Entity_Id := Empty;
21771 -- Access to T'class, created if there is a controlling formal
21772 -- that is an access parameter.
21774 function Get_ACW return Entity_Id;
21775 -- If the expression has a reference to an controlling access
21776 -- parameter, create an access to T'class for the necessary
21777 -- conversions if one does not exist.
21779 function Process (N : Node_Id) return Traverse_Result;
21780 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21781 -- aspect for a primitive subprogram of a tagged type T, a name
21782 -- that denotes a formal parameter of type T is interpreted as
21783 -- having type T'Class. Similarly, a name that denotes a formal
21784 -- accessparameter of type access-to-T is interpreted as having
21785 -- type access-to-T'Class. This ensures the expression is well-
21786 -- defined for a primitive subprogram of a type descended from T.
21787 -- Note that this replacement is not done for selector names in
21788 -- parameter associations. These carry an entity for reference
21789 -- purposes, but semantically they are just identifiers.
21795 function Get_ACW return Entity_Id is
21796 Loc : constant Source_Ptr := Sloc (Prag);
21802 Make_Full_Type_Declaration (Loc,
21803 Defining_Identifier => Make_Temporary (Loc, 'T
'),
21805 Make_Access_To_Object_Definition (Loc,
21806 Subtype_Indication =>
21807 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21808 All_Present => True));
21810 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21812 ACW := Defining_Identifier (Decl);
21813 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21823 function Process (N : Node_Id) return Traverse_Result is
21824 Loc : constant Source_Ptr := Sloc (N);
21828 if Is_Entity_Name (N)
21829 and then Present (Entity (N))
21830 and then Is_Formal (Entity (N))
21831 and then Nkind (Parent (N)) /= N_Type_Conversion
21833 (Nkind (Parent (N)) /= N_Parameter_Association
21834 or else N /= Selector_Name (Parent (N)))
21836 if Etype (Entity (N)) = T then
21837 Typ := Class_Wide_Type (T);
21839 elsif Is_Access_Type (Etype (Entity (N)))
21840 and then Designated_Type (Etype (Entity (N))) = T
21847 if Present (Typ) then
21849 Make_Type_Conversion (Loc,
21851 New_Occurrence_Of (Typ, Loc),
21852 Expression => New_Occurrence_Of (Entity (N), Loc)));
21853 Set_Etype (N, Typ);
21860 procedure Replace_Type is new Traverse_Proc (Process);
21862 -- Start of processing for Class_Wide_Condition
21865 if not Present (T) then
21867 -- Pre'Class/Post'Class aspect cases
21869 if From_Aspect_Specification (Prag) then
21870 if Nam = Name_uPre then
21871 Error_Msg_Name_1 := Name_Pre;
21873 Error_Msg_Name_1 := Name_Post;
21876 Error_Msg_Name_2 := Name_Class;
21879 ("aspect `%''%` can only be specified for a primitive "
21880 & "operation of a tagged type",
21881 Corresponding_Aspect (Prag));
21883 -- Pre_Class, Post_Class pragma cases
21886 if Nam = Name_uPre then
21887 Error_Msg_Name_1 := Name_Pre_Class;
21889 Error_Msg_Name_1 := Name_Post_Class;
21893 ("pragma% can only be specified for a primitive "
21894 & "operation of a tagged type",
21895 Corresponding_Aspect (Prag));
21899 Replace_Type (Get_Pragma_Arg (Arg1));
21900 end Class_Wide_Condition;
21903 -- Remove the subprogram from the scope stack now that the pre-analysis
21904 -- of the precondition/postcondition is done.
21906 if Restore_Scope then
21909 end Analyze_Pre_Post_Condition_In_Decl_Part;
21911 ------------------------------------------
21912 -- Analyze_Refined_Depends_In_Decl_Part --
21913 ------------------------------------------
21915 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21916 Body_Inputs : Elist_Id := No_Elist;
21917 Body_Outputs : Elist_Id := No_Elist;
21918 -- The inputs and outputs of the subprogram body synthesized from pragma
21919 -- Refined_Depends.
21921 Dependencies : List_Id := No_List;
21923 -- The corresponding Depends pragma along with its clauses
21925 Matched_Items : Elist_Id := No_Elist;
21926 -- A list containing the entities of all successfully matched items
21927 -- found in pragma Depends.
21929 Refinements : List_Id := No_List;
21930 -- The clauses of pragma Refined_Depends
21932 Spec_Id : Entity_Id;
21933 -- The entity of the subprogram subject to pragma Refined_Depends
21935 Spec_Inputs : Elist_Id := No_Elist;
21936 Spec_Outputs : Elist_Id := No_Elist;
21937 -- The inputs and outputs of the subprogram spec synthesized from pragma
21940 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21941 -- Try to match a single dependency clause Dep_Clause against one or
21942 -- more refinement clauses found in list Refinements. Each successful
21943 -- match eliminates at least one refinement clause from Refinements.
21945 procedure Check_Output_States;
21946 -- Determine whether pragma Depends contains an output state with a
21947 -- visible refinement and if so, ensure that pragma Refined_Depends
21948 -- mentions all its constituents as outputs.
21950 procedure Normalize_Clauses (Clauses : List_Id);
21951 -- Given a list of dependence or refinement clauses Clauses, normalize
21952 -- each clause by creating multiple dependencies with exactly one input
21955 procedure Report_Extra_Clauses;
21956 -- Emit an error for each extra clause found in list Refinements
21958 -----------------------------
21959 -- Check_Dependency_Clause --
21960 -----------------------------
21962 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21963 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21964 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21966 function Is_In_Out_State_Clause return Boolean;
21967 -- Determine whether dependence clause Dep_Clause denotes an abstract
21968 -- state that depends on itself (State => State).
21970 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21971 -- Determine whether item Item denotes an abstract state with visible
21972 -- null refinement.
21974 procedure Match_Items
21975 (Dep_Item : Node_Id;
21976 Ref_Item : Node_Id;
21977 Matched : out Boolean);
21978 -- Try to match dependence item Dep_Item against refinement item
21979 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21980 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21981 -- the following conformance scenarios is in effect:
21982 -- 1) Both items denote null
21983 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21984 -- 3) Both items denote attribute 'Result
21985 -- 4) Both items denote the same formal parameter
21986 -- 5) Both items denote the same variable
21987 -- 6) Dep_Item is an abstract state with visible null refinement
21988 -- and Ref_Item denotes null.
21989 -- 7) Dep_Item is an abstract state with visible null refinement
21990 -- and Ref_Item is Empty (special case).
21991 -- 8) Dep_Item is an abstract state with visible non-null
21992 -- refinement and Ref_Item denotes one of its constituents.
21993 -- 9) Dep_Item is an abstract state without a visible refinement
21994 -- and Ref_Item denotes the same state.
21995 -- When scenario 8 is in effect, the entity of the abstract state
21996 -- denoted by Dep_Item is added to list Refined_States.
21998 procedure Record_Item
(Item_Id
: Entity_Id
);
21999 -- Store the entity of an item denoted by Item_Id in Matched_Items
22001 ----------------------------
22002 -- Is_In_Out_State_Clause --
22003 ----------------------------
22005 function Is_In_Out_State_Clause
return Boolean is
22006 Dep_Input_Id
: Entity_Id
;
22007 Dep_Output_Id
: Entity_Id
;
22010 -- Detect the following clause:
22013 if Is_Entity_Name
(Dep_Input
)
22014 and then Is_Entity_Name
(Dep_Output
)
22016 -- Handle abstract views generated for limited with clauses
22018 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
22019 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
22022 Ekind
(Dep_Input_Id
) = E_Abstract_State
22023 and then Dep_Input_Id
= Dep_Output_Id
;
22027 end Is_In_Out_State_Clause
;
22029 ---------------------------
22030 -- Is_Null_Refined_State --
22031 ---------------------------
22033 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
22034 Item_Id
: Entity_Id
;
22037 if Is_Entity_Name
(Item
) then
22039 -- Handle abstract views generated for limited with clauses
22041 Item_Id
:= Available_View
(Entity_Of
(Item
));
22043 return Ekind
(Item_Id
) = E_Abstract_State
22044 and then Has_Null_Refinement
(Item_Id
);
22049 end Is_Null_Refined_State
;
22055 procedure Match_Items
22056 (Dep_Item
: Node_Id
;
22057 Ref_Item
: Node_Id
;
22058 Matched
: out Boolean)
22060 Dep_Item_Id
: Entity_Id
;
22061 Ref_Item_Id
: Entity_Id
;
22064 -- Assume that the two items do not match
22068 -- A null matches null or Empty (special case)
22070 if Nkind
(Dep_Item
) = N_Null
22071 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22075 -- Attribute 'Result matches attribute 'Result
22077 elsif Is_Attribute_Result
(Dep_Item
)
22078 and then Is_Attribute_Result
(Dep_Item
)
22082 -- Abstract states, formal parameters and variables
22084 elsif Is_Entity_Name
(Dep_Item
) then
22086 -- Handle abstract views generated for limited with clauses
22088 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
22090 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
22092 -- An abstract state with visible null refinement matches
22093 -- null or Empty (special case).
22095 if Has_Null_Refinement
(Dep_Item_Id
)
22096 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22098 Record_Item
(Dep_Item_Id
);
22101 -- An abstract state with visible non-null refinement
22102 -- matches one of its constituents.
22104 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
22105 if Is_Entity_Name
(Ref_Item
) then
22106 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
22108 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
, E_Variable
)
22109 and then Present
(Encapsulating_State
(Ref_Item_Id
))
22110 and then Encapsulating_State
(Ref_Item_Id
) =
22113 Record_Item
(Dep_Item_Id
);
22118 -- An abstract state without a visible refinement matches
22121 elsif Is_Entity_Name
(Ref_Item
)
22122 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22124 Record_Item
(Dep_Item_Id
);
22128 -- A formal parameter or a variable matches itself
22130 elsif Is_Entity_Name
(Ref_Item
)
22131 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22133 Record_Item
(Dep_Item_Id
);
22143 procedure Record_Item
(Item_Id
: Entity_Id
) is
22145 if not Contains
(Matched_Items
, Item_Id
) then
22146 Add_Item
(Item_Id
, Matched_Items
);
22152 Clause_Matched
: Boolean := False;
22153 Dummy
: Boolean := False;
22154 Inputs_Match
: Boolean;
22155 Next_Ref_Clause
: Node_Id
;
22156 Outputs_Match
: Boolean;
22157 Ref_Clause
: Node_Id
;
22158 Ref_Input
: Node_Id
;
22159 Ref_Output
: Node_Id
;
22161 -- Start of processing for Check_Dependency_Clause
22164 -- Examine all refinement clauses and compare them against the
22165 -- dependence clause.
22167 Ref_Clause
:= First
(Refinements
);
22168 while Present
(Ref_Clause
) loop
22169 Next_Ref_Clause
:= Next
(Ref_Clause
);
22171 -- Obtain the attributes of the current refinement clause
22173 Ref_Input
:= Expression
(Ref_Clause
);
22174 Ref_Output
:= First
(Choices
(Ref_Clause
));
22176 -- The current refinement clause matches the dependence clause
22177 -- when both outputs match and both inputs match. See routine
22178 -- Match_Items for all possible conformance scenarios.
22180 -- Depends Dep_Output => Dep_Input
22184 -- Refined_Depends Ref_Output => Ref_Input
22187 (Dep_Item
=> Dep_Input
,
22188 Ref_Item
=> Ref_Input
,
22189 Matched
=> Inputs_Match
);
22192 (Dep_Item
=> Dep_Output
,
22193 Ref_Item
=> Ref_Output
,
22194 Matched
=> Outputs_Match
);
22196 -- An In_Out state clause may be matched against a refinement with
22197 -- a null input or null output as long as the non-null side of the
22198 -- relation contains a valid constituent of the In_Out_State.
22200 if Is_In_Out_State_Clause
then
22202 -- Depends => (State => State)
22203 -- Refined_Depends => (null => Constit) -- OK
22206 and then not Outputs_Match
22207 and then Nkind
(Ref_Output
) = N_Null
22209 Outputs_Match
:= True;
22212 -- Depends => (State => State)
22213 -- Refined_Depends => (Constit => null) -- OK
22215 if not Inputs_Match
22216 and then Outputs_Match
22217 and then Nkind
(Ref_Input
) = N_Null
22219 Inputs_Match
:= True;
22223 -- The current refinement clause is legally constructed following
22224 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22225 -- the pool of candidates. The seach continues because a single
22226 -- dependence clause may have multiple matching refinements.
22228 if Inputs_Match
and then Outputs_Match
then
22229 Clause_Matched
:= True;
22230 Remove
(Ref_Clause
);
22233 Ref_Clause
:= Next_Ref_Clause
;
22236 -- Depending on the order or composition of refinement clauses, an
22237 -- In_Out state clause may not be directly refinable.
22239 -- Depends => ((Output, State) => (Input, State))
22240 -- Refined_State => (State => (Constit_1, Constit_2))
22241 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22243 -- Matching normalized clause (State => State) fails because there is
22244 -- no direct refinement capable of satisfying this relation. Another
22245 -- similar case arises when clauses (Constit_1 => Input) and (Output
22246 -- => Constit_2) are matched first, leaving no candidates for clause
22247 -- (State => State). Both scenarios are legal as long as one of the
22248 -- previous clauses mentioned a valid constituent of State.
22250 if not Clause_Matched
22251 and then Is_In_Out_State_Clause
22253 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22255 Clause_Matched
:= True;
22258 -- A clause where the input is an abstract state with visible null
22259 -- refinement is implicitly matched when the output has already been
22260 -- matched in a previous clause.
22262 -- Depends => (Output => State) -- implicitly OK
22263 -- Refined_State => (State => null)
22264 -- Refined_Depends => (Output => ...)
22266 if not Clause_Matched
22267 and then Is_Null_Refined_State
(Dep_Input
)
22268 and then Is_Entity_Name
(Dep_Output
)
22270 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
22272 Clause_Matched
:= True;
22275 -- A clause where the output is an abstract state with visible null
22276 -- refinement is implicitly matched when the input has already been
22277 -- matched in a previous clause.
22279 -- Depends => (State => Input) -- implicitly OK
22280 -- Refined_State => (State => null)
22281 -- Refined_Depends => (... => Input)
22283 if not Clause_Matched
22284 and then Is_Null_Refined_State
(Dep_Output
)
22285 and then Is_Entity_Name
(Dep_Input
)
22287 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22289 Clause_Matched
:= True;
22292 -- At this point either all refinement clauses have been examined or
22293 -- pragma Refined_Depends contains a solitary null. Only an abstract
22294 -- state with null refinement can possibly match these cases.
22296 -- Depends => (State => null)
22297 -- Refined_State => (State => null)
22298 -- Refined_Depends => null -- OK
22300 if not Clause_Matched
then
22302 (Dep_Item
=> Dep_Input
,
22304 Matched
=> Inputs_Match
);
22307 (Dep_Item
=> Dep_Output
,
22309 Matched
=> Outputs_Match
);
22311 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
22314 -- If the contents of Refined_Depends are legal, then the current
22315 -- dependence clause should be satisfied either by an explicit match
22316 -- or by one of the special cases.
22318 if not Clause_Matched
then
22320 ("dependence clause of subprogram & has no matching refinement "
22321 & "in body", Dep_Clause
, Spec_Id
);
22323 end Check_Dependency_Clause
;
22325 -------------------------
22326 -- Check_Output_States --
22327 -------------------------
22329 procedure Check_Output_States
is
22330 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22331 -- Determine whether all constituents of state State_Id with visible
22332 -- refinement are used as outputs in pragma Refined_Depends. Emit an
22333 -- error if this is not the case.
22335 -----------------------------
22336 -- Check_Constituent_Usage --
22337 -----------------------------
22339 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22340 Constit_Elmt
: Elmt_Id
;
22341 Constit_Id
: Entity_Id
;
22342 Posted
: Boolean := False;
22345 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22346 while Present
(Constit_Elmt
) loop
22347 Constit_Id
:= Node
(Constit_Elmt
);
22349 -- The constituent acts as an input (SPARK RM 7.2.5(3))
22351 if Present
(Body_Inputs
)
22352 and then Appears_In
(Body_Inputs
, Constit_Id
)
22354 Error_Msg_Name_1
:= Chars
(State_Id
);
22356 ("constituent & of state % must act as output in "
22357 & "dependence refinement", N
, Constit_Id
);
22359 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22361 elsif No
(Body_Outputs
)
22362 or else not Appears_In
(Body_Outputs
, Constit_Id
)
22367 ("output state & must be replaced by all its "
22368 & "constituents in dependence refinement",
22373 ("\constituent & is missing in output list",
22377 Next_Elmt
(Constit_Elmt
);
22379 end Check_Constituent_Usage
;
22384 Item_Elmt
: Elmt_Id
;
22385 Item_Id
: Entity_Id
;
22387 -- Start of processing for Check_Output_States
22390 -- Inspect the outputs of pragma Depends looking for a state with a
22391 -- visible refinement.
22393 if Present
(Spec_Outputs
) then
22394 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
22395 while Present
(Item_Elmt
) loop
22396 Item
:= Node
(Item_Elmt
);
22398 -- Deal with the mixed nature of the input and output lists
22400 if Nkind
(Item
) = N_Defining_Identifier
then
22403 Item_Id
:= Available_View
(Entity_Of
(Item
));
22406 if Ekind
(Item_Id
) = E_Abstract_State
then
22408 -- The state acts as an input-output, skip it
22410 if Present
(Spec_Inputs
)
22411 and then Appears_In
(Spec_Inputs
, Item_Id
)
22415 -- Ensure that all of the constituents are utilized as
22416 -- outputs in pragma Refined_Depends.
22418 elsif Has_Non_Null_Refinement
(Item_Id
) then
22419 Check_Constituent_Usage
(Item_Id
);
22423 Next_Elmt
(Item_Elmt
);
22426 end Check_Output_States
;
22428 -----------------------
22429 -- Normalize_Clauses --
22430 -----------------------
22432 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22433 procedure Normalize_Inputs
(Clause
: Node_Id
);
22434 -- Normalize clause Clause by creating multiple clauses for each
22435 -- input item of Clause. It is assumed that Clause has exactly one
22436 -- output. The transformation is as follows:
22438 -- Output => (Input_1, Input_2) -- original
22440 -- Output => Input_1 -- normalizations
22441 -- Output => Input_2
22443 procedure Normalize_Outputs
(Clause
: Node_Id
);
22444 -- Normalize clause Clause by creating multiple clause for each
22445 -- output item of Clause. The transformation is as follows:
22447 -- (Output_1, Output_2) => Input -- original
22449 -- Output_1 => Input -- normalization
22450 -- Output_2 => Input
22452 ----------------------
22453 -- Normalize_Inputs --
22454 ----------------------
22456 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22457 Inputs
: constant Node_Id
:= Expression
(Clause
);
22458 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22459 Output
: constant List_Id
:= Choices
(Clause
);
22460 Last_Input
: Node_Id
;
22462 New_Clause
: Node_Id
;
22463 Next_Input
: Node_Id
;
22466 -- Normalization is performed only when the original clause has
22467 -- more than one input. Multiple inputs appear as an aggregate.
22469 if Nkind
(Inputs
) = N_Aggregate
then
22470 Last_Input
:= Last
(Expressions
(Inputs
));
22472 -- Create a new clause for each input
22474 Input
:= First
(Expressions
(Inputs
));
22475 while Present
(Input
) loop
22476 Next_Input
:= Next
(Input
);
22478 -- Unhook the current input from the original input list
22479 -- because it will be relocated to a new clause.
22483 -- Special processing for the last input. At this point the
22484 -- original aggregate has been stripped down to one element.
22485 -- Replace the aggregate by the element itself.
22487 if Input
= Last_Input
then
22488 Rewrite
(Inputs
, Input
);
22490 -- Generate a clause of the form:
22495 Make_Component_Association
(Loc
,
22496 Choices
=> New_Copy_List_Tree
(Output
),
22497 Expression
=> Input
);
22499 -- The new clause contains replicated content that has
22500 -- already been analyzed, mark the clause as analyzed.
22502 Set_Analyzed
(New_Clause
);
22503 Insert_After
(Clause
, New_Clause
);
22506 Input
:= Next_Input
;
22509 end Normalize_Inputs
;
22511 -----------------------
22512 -- Normalize_Outputs --
22513 -----------------------
22515 procedure Normalize_Outputs
(Clause
: Node_Id
) is
22516 Inputs
: constant Node_Id
:= Expression
(Clause
);
22517 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22518 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
22519 Last_Output
: Node_Id
;
22520 New_Clause
: Node_Id
;
22521 Next_Output
: Node_Id
;
22525 -- Multiple outputs appear as an aggregate. Nothing to do when
22526 -- the clause has exactly one output.
22528 if Nkind
(Outputs
) = N_Aggregate
then
22529 Last_Output
:= Last
(Expressions
(Outputs
));
22531 -- Create a clause for each output. Note that each time a new
22532 -- clause is created, the original output list slowly shrinks
22533 -- until there is one item left.
22535 Output
:= First
(Expressions
(Outputs
));
22536 while Present
(Output
) loop
22537 Next_Output
:= Next
(Output
);
22539 -- Unhook the output from the original output list as it
22540 -- will be relocated to a new clause.
22544 -- Special processing for the last output. At this point
22545 -- the original aggregate has been stripped down to one
22546 -- element. Replace the aggregate by the element itself.
22548 if Output
= Last_Output
then
22549 Rewrite
(Outputs
, Output
);
22552 -- Generate a clause of the form:
22553 -- (Output => Inputs)
22556 Make_Component_Association
(Loc
,
22557 Choices
=> New_List
(Output
),
22558 Expression
=> New_Copy_Tree
(Inputs
));
22560 -- The new clause contains replicated content that has
22561 -- already been analyzed. There is not need to reanalyze
22564 Set_Analyzed
(New_Clause
);
22565 Insert_After
(Clause
, New_Clause
);
22568 Output
:= Next_Output
;
22571 end Normalize_Outputs
;
22577 -- Start of processing for Normalize_Clauses
22580 Clause
:= First
(Clauses
);
22581 while Present
(Clause
) loop
22582 Normalize_Outputs
(Clause
);
22586 Clause
:= First
(Clauses
);
22587 while Present
(Clause
) loop
22588 Normalize_Inputs
(Clause
);
22591 end Normalize_Clauses
;
22593 --------------------------
22594 -- Report_Extra_Clauses --
22595 --------------------------
22597 procedure Report_Extra_Clauses
is
22601 if Present
(Refinements
) then
22602 Clause
:= First
(Refinements
);
22603 while Present
(Clause
) loop
22605 -- Do not complain about a null input refinement, since a null
22606 -- input legitimately matches anything.
22608 if Nkind
(Clause
) /= N_Component_Association
22609 or else Nkind
(Expression
(Clause
)) /= N_Null
22612 ("unmatched or extra clause in dependence refinement",
22619 end Report_Extra_Clauses
;
22623 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22624 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
22625 Errors
: constant Nat
:= Serious_Errors_Detected
;
22626 Refs
: constant Node_Id
:=
22627 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
22632 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22635 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22636 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22638 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22641 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22643 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22644 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22646 if No
(Depends
) then
22648 ("useless refinement, declaration of subprogram & lacks aspect or "
22649 & "pragma Depends", N
, Spec_Id
);
22653 Deps
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
22655 -- A null dependency relation renders the refinement useless because it
22656 -- cannot possibly mention abstract states with visible refinement. Note
22657 -- that the inverse is not true as states may be refined to null
22658 -- (SPARK RM 7.2.5(2)).
22660 if Nkind
(Deps
) = N_Null
then
22662 ("useless refinement, subprogram & does not depend on abstract "
22663 & "state with visible refinement", N
, Spec_Id
);
22667 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22668 -- This ensures that the categorization of all refined dependency items
22669 -- is consistent with their role.
22671 Analyze_Depends_In_Decl_Part
(N
);
22673 -- Do not match dependencies against refinements if Refined_Depends is
22674 -- illegal to avoid emitting misleading error.
22676 if Serious_Errors_Detected
= Errors
then
22678 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
22679 -- the inputs and outputs of the subprogram spec and body to verify
22680 -- the use of states with visible refinement and their constituents.
22682 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
22683 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
22685 Collect_Subprogram_Inputs_Outputs
22686 (Subp_Id
=> Spec_Id
,
22687 Synthesize
=> True,
22688 Subp_Inputs
=> Spec_Inputs
,
22689 Subp_Outputs
=> Spec_Outputs
,
22690 Global_Seen
=> Dummy
);
22692 Collect_Subprogram_Inputs_Outputs
22693 (Subp_Id
=> Body_Id
,
22694 Synthesize
=> True,
22695 Subp_Inputs
=> Body_Inputs
,
22696 Subp_Outputs
=> Body_Outputs
,
22697 Global_Seen
=> Dummy
);
22699 -- For an output state with a visible refinement, ensure that all
22700 -- constituents appear as outputs in the dependency refinement.
22702 Check_Output_States
;
22705 -- Matching is disabled in ASIS because clauses are not normalized as
22706 -- this is a tree altering activity similar to expansion.
22712 -- Multiple dependency clauses appear as component associations of an
22713 -- aggregate. Note that the clauses are copied because the algorithm
22714 -- modifies them and this should not be visible in Depends.
22716 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22717 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22718 Normalize_Clauses
(Dependencies
);
22720 if Nkind
(Refs
) = N_Null
then
22721 Refinements
:= No_List
;
22723 -- Multiple dependency clauses appear as component associations of an
22724 -- aggregate. Note that the clauses are copied because the algorithm
22725 -- modifies them and this should not be visible in Refined_Depends.
22727 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22728 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22729 Normalize_Clauses
(Refinements
);
22732 -- At this point the clauses of pragmas Depends and Refined_Depends
22733 -- have been normalized into simple dependencies between one output
22734 -- and one input. Examine all clauses of pragma Depends looking for
22735 -- matching clauses in pragma Refined_Depends.
22737 Clause
:= First
(Dependencies
);
22738 while Present
(Clause
) loop
22739 Check_Dependency_Clause
(Clause
);
22743 if Serious_Errors_Detected
= Errors
then
22744 Report_Extra_Clauses
;
22747 end Analyze_Refined_Depends_In_Decl_Part
;
22749 -----------------------------------------
22750 -- Analyze_Refined_Global_In_Decl_Part --
22751 -----------------------------------------
22753 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22755 -- The corresponding Global pragma
22757 Has_In_State
: Boolean := False;
22758 Has_In_Out_State
: Boolean := False;
22759 Has_Out_State
: Boolean := False;
22760 Has_Proof_In_State
: Boolean := False;
22761 -- These flags are set when the corresponding Global pragma has a state
22762 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22765 Has_Null_State
: Boolean := False;
22766 -- This flag is set when the corresponding Global pragma has at least
22767 -- one state with a null refinement.
22769 In_Constits
: Elist_Id
:= No_Elist
;
22770 In_Out_Constits
: Elist_Id
:= No_Elist
;
22771 Out_Constits
: Elist_Id
:= No_Elist
;
22772 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22773 -- These lists contain the entities of all Input, In_Out, Output and
22774 -- Proof_In constituents that appear in Refined_Global and participate
22775 -- in state refinement.
22777 In_Items
: Elist_Id
:= No_Elist
;
22778 In_Out_Items
: Elist_Id
:= No_Elist
;
22779 Out_Items
: Elist_Id
:= No_Elist
;
22780 Proof_In_Items
: Elist_Id
:= No_Elist
;
22781 -- These list contain the entities of all Input, In_Out, Output and
22782 -- Proof_In items defined in the corresponding Global pragma.
22784 procedure Check_In_Out_States
;
22785 -- Determine whether the corresponding Global pragma mentions In_Out
22786 -- states with visible refinement and if so, ensure that one of the
22787 -- following completions apply to the constituents of the state:
22788 -- 1) there is at least one constituent of mode In_Out
22789 -- 2) there is at least one Input and one Output constituent
22790 -- 3) not all constituents are present and one of them is of mode
22792 -- This routine may remove elements from In_Constits, In_Out_Constits,
22793 -- Out_Constits and Proof_In_Constits.
22795 procedure Check_Input_States
;
22796 -- Determine whether the corresponding Global pragma mentions Input
22797 -- states with visible refinement and if so, ensure that at least one of
22798 -- its constituents appears as an Input item in Refined_Global.
22799 -- This routine may remove elements from In_Constits, In_Out_Constits,
22800 -- Out_Constits and Proof_In_Constits.
22802 procedure Check_Output_States
;
22803 -- Determine whether the corresponding Global pragma mentions Output
22804 -- states with visible refinement and if so, ensure that all of its
22805 -- constituents appear as Output items in Refined_Global.
22806 -- This routine may remove elements from In_Constits, In_Out_Constits,
22807 -- Out_Constits and Proof_In_Constits.
22809 procedure Check_Proof_In_States
;
22810 -- Determine whether the corresponding Global pragma mentions Proof_In
22811 -- states with visible refinement and if so, ensure that at least one of
22812 -- its constituents appears as a Proof_In item in Refined_Global.
22813 -- This routine may remove elements from In_Constits, In_Out_Constits,
22814 -- Out_Constits and Proof_In_Constits.
22816 procedure Check_Refined_Global_List
22818 Global_Mode
: Name_Id
:= Name_Input
);
22819 -- Verify the legality of a single global list declaration. Global_Mode
22820 -- denotes the current mode in effect.
22822 procedure Collect_Global_Items
(Prag
: Node_Id
);
22823 -- Gather all input, in out, output and Proof_In items of pragma Prag
22824 -- in lists In_Items, In_Out_Items, Out_Items and Proof_In_Items. Flags
22825 -- Has_In_State, Has_In_Out_State, Has_Out_State and Has_Proof_In_State
22826 -- are set when there is at least one abstract state with visible
22827 -- refinement available in the corresponding mode. Flag Has_Null_State
22828 -- is set when at least state has a null refinement.
22830 function Present_Then_Remove
22832 Item
: Entity_Id
) return Boolean;
22833 -- Search List for a particular entity Item. If Item has been found,
22834 -- remove it from List. This routine is used to strip lists In_Constits,
22835 -- In_Out_Constits and Out_Constits of valid constituents.
22837 procedure Report_Extra_Constituents
;
22838 -- Emit an error for each constituent found in lists In_Constits,
22839 -- In_Out_Constits and Out_Constits.
22841 -------------------------
22842 -- Check_In_Out_States --
22843 -------------------------
22845 procedure Check_In_Out_States
is
22846 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22847 -- Determine whether one of the following coverage scenarios is in
22849 -- 1) there is at least one constituent of mode In_Out
22850 -- 2) there is at least one Input and one Output constituent
22851 -- 3) not all constituents are present and one of them is of mode
22853 -- If this is not the case, emit an error.
22855 -----------------------------
22856 -- Check_Constituent_Usage --
22857 -----------------------------
22859 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22860 Constit_Elmt
: Elmt_Id
;
22861 Constit_Id
: Entity_Id
;
22862 Has_Missing
: Boolean := False;
22863 In_Out_Seen
: Boolean := False;
22864 In_Seen
: Boolean := False;
22865 Out_Seen
: Boolean := False;
22868 -- Process all the constituents of the state and note their modes
22869 -- within the global refinement.
22871 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22872 while Present
(Constit_Elmt
) loop
22873 Constit_Id
:= Node
(Constit_Elmt
);
22875 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22878 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22879 In_Out_Seen
:= True;
22881 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22884 -- A Proof_In constituent cannot participate in the completion
22885 -- of an Output state (SPARK RM 7.2.4(5)).
22887 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22888 Error_Msg_Name_1
:= Chars
(State_Id
);
22890 ("constituent & of state % must have mode Input, In_Out "
22891 & "or Output in global refinement",
22895 Has_Missing
:= True;
22898 Next_Elmt
(Constit_Elmt
);
22901 -- A single In_Out constituent is a valid completion
22903 if In_Out_Seen
then
22906 -- A pair of one Input and one Output constituent is a valid
22909 elsif In_Seen
and then Out_Seen
then
22912 -- A single Output constituent is a valid completion only when
22913 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22915 elsif Has_Missing
and then Out_Seen
then
22920 ("global refinement of state & redefines the mode of its "
22921 & "constituents", N
, State_Id
);
22923 end Check_Constituent_Usage
;
22927 Item_Elmt
: Elmt_Id
;
22928 Item_Id
: Entity_Id
;
22930 -- Start of processing for Check_In_Out_States
22933 -- Inspect the In_Out items of the corresponding Global pragma
22934 -- looking for a state with a visible refinement.
22936 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22937 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22938 while Present
(Item_Elmt
) loop
22939 Item_Id
:= Node
(Item_Elmt
);
22941 -- Ensure that one of the three coverage variants is satisfied
22943 if Ekind
(Item_Id
) = E_Abstract_State
22944 and then Has_Non_Null_Refinement
(Item_Id
)
22946 Check_Constituent_Usage
(Item_Id
);
22949 Next_Elmt
(Item_Elmt
);
22952 end Check_In_Out_States
;
22954 ------------------------
22955 -- Check_Input_States --
22956 ------------------------
22958 procedure Check_Input_States
is
22959 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22960 -- Determine whether at least one constituent of state State_Id with
22961 -- visible refinement is used and has mode Input. Ensure that the
22962 -- remaining constituents do not have In_Out, Output or Proof_In
22965 -----------------------------
22966 -- Check_Constituent_Usage --
22967 -----------------------------
22969 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22970 Constit_Elmt
: Elmt_Id
;
22971 Constit_Id
: Entity_Id
;
22972 In_Seen
: Boolean := False;
22975 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22976 while Present
(Constit_Elmt
) loop
22977 Constit_Id
:= Node
(Constit_Elmt
);
22979 -- At least one of the constituents appears as an Input
22981 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22984 -- The constituent appears in the global refinement, but has
22985 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22987 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22988 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22989 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22991 Error_Msg_Name_1
:= Chars
(State_Id
);
22993 ("constituent & of state % must have mode Input in global "
22994 & "refinement", N
, Constit_Id
);
22997 Next_Elmt
(Constit_Elmt
);
23000 -- Not one of the constituents appeared as Input
23002 if not In_Seen
then
23004 ("global refinement of state & must include at least one "
23005 & "constituent of mode Input", N
, State_Id
);
23007 end Check_Constituent_Usage
;
23011 Item_Elmt
: Elmt_Id
;
23012 Item_Id
: Entity_Id
;
23014 -- Start of processing for Check_Input_States
23017 -- Inspect the Input items of the corresponding Global pragma
23018 -- looking for a state with a visible refinement.
23020 if Has_In_State
and then Present
(In_Items
) then
23021 Item_Elmt
:= First_Elmt
(In_Items
);
23022 while Present
(Item_Elmt
) loop
23023 Item_Id
:= Node
(Item_Elmt
);
23025 -- Ensure that at least one of the constituents is utilized and
23026 -- is of mode Input.
23028 if Ekind
(Item_Id
) = E_Abstract_State
23029 and then Has_Non_Null_Refinement
(Item_Id
)
23031 Check_Constituent_Usage
(Item_Id
);
23034 Next_Elmt
(Item_Elmt
);
23037 end Check_Input_States
;
23039 -------------------------
23040 -- Check_Output_States --
23041 -------------------------
23043 procedure Check_Output_States
is
23044 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23045 -- Determine whether all constituents of state State_Id with visible
23046 -- refinement are used and have mode Output. Emit an error if this is
23049 -----------------------------
23050 -- Check_Constituent_Usage --
23051 -----------------------------
23053 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23054 Constit_Elmt
: Elmt_Id
;
23055 Constit_Id
: Entity_Id
;
23056 Posted
: Boolean := False;
23059 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23060 while Present
(Constit_Elmt
) loop
23061 Constit_Id
:= Node
(Constit_Elmt
);
23063 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
23066 -- The constituent appears in the global refinement, but has
23067 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
23069 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23070 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23071 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
23073 Error_Msg_Name_1
:= Chars
(State_Id
);
23075 ("constituent & of state % must have mode Output in "
23076 & "global refinement", N
, Constit_Id
);
23078 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23084 ("output state & must be replaced by all its "
23085 & "constituents in global refinement", N
, State_Id
);
23089 ("\constituent & is missing in output list",
23093 Next_Elmt
(Constit_Elmt
);
23095 end Check_Constituent_Usage
;
23099 Item_Elmt
: Elmt_Id
;
23100 Item_Id
: Entity_Id
;
23102 -- Start of processing for Check_Output_States
23105 -- Inspect the Output items of the corresponding Global pragma
23106 -- looking for a state with a visible refinement.
23108 if Has_Out_State
and then Present
(Out_Items
) then
23109 Item_Elmt
:= First_Elmt
(Out_Items
);
23110 while Present
(Item_Elmt
) loop
23111 Item_Id
:= Node
(Item_Elmt
);
23113 -- Ensure that all of the constituents are utilized and they
23114 -- have mode Output.
23116 if Ekind
(Item_Id
) = E_Abstract_State
23117 and then Has_Non_Null_Refinement
(Item_Id
)
23119 Check_Constituent_Usage
(Item_Id
);
23122 Next_Elmt
(Item_Elmt
);
23125 end Check_Output_States
;
23127 ---------------------------
23128 -- Check_Proof_In_States --
23129 ---------------------------
23131 procedure Check_Proof_In_States
is
23132 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23133 -- Determine whether at least one constituent of state State_Id with
23134 -- visible refinement is used and has mode Proof_In. Ensure that the
23135 -- remaining constituents do not have Input, In_Out or Output modes.
23137 -----------------------------
23138 -- Check_Constituent_Usage --
23139 -----------------------------
23141 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23142 Constit_Elmt
: Elmt_Id
;
23143 Constit_Id
: Entity_Id
;
23144 Proof_In_Seen
: Boolean := False;
23147 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23148 while Present
(Constit_Elmt
) loop
23149 Constit_Id
:= Node
(Constit_Elmt
);
23151 -- At least one of the constituents appears as Proof_In
23153 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23154 Proof_In_Seen
:= True;
23156 -- The constituent appears in the global refinement, but has
23157 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23159 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23160 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23161 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23163 Error_Msg_Name_1
:= Chars
(State_Id
);
23165 ("constituent & of state % must have mode Proof_In in "
23166 & "global refinement", N
, Constit_Id
);
23169 Next_Elmt
(Constit_Elmt
);
23172 -- Not one of the constituents appeared as Proof_In
23174 if not Proof_In_Seen
then
23176 ("global refinement of state & must include at least one "
23177 & "constituent of mode Proof_In", N
, State_Id
);
23179 end Check_Constituent_Usage
;
23183 Item_Elmt
: Elmt_Id
;
23184 Item_Id
: Entity_Id
;
23186 -- Start of processing for Check_Proof_In_States
23189 -- Inspect the Proof_In items of the corresponding Global pragma
23190 -- looking for a state with a visible refinement.
23192 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23193 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23194 while Present
(Item_Elmt
) loop
23195 Item_Id
:= Node
(Item_Elmt
);
23197 -- Ensure that at least one of the constituents is utilized and
23198 -- is of mode Proof_In
23200 if Ekind
(Item_Id
) = E_Abstract_State
23201 and then Has_Non_Null_Refinement
(Item_Id
)
23203 Check_Constituent_Usage
(Item_Id
);
23206 Next_Elmt
(Item_Elmt
);
23209 end Check_Proof_In_States
;
23211 -------------------------------
23212 -- Check_Refined_Global_List --
23213 -------------------------------
23215 procedure Check_Refined_Global_List
23217 Global_Mode
: Name_Id
:= Name_Input
)
23219 procedure Check_Refined_Global_Item
23221 Global_Mode
: Name_Id
);
23222 -- Verify the legality of a single global item declaration. Parameter
23223 -- Global_Mode denotes the current mode in effect.
23225 -------------------------------
23226 -- Check_Refined_Global_Item --
23227 -------------------------------
23229 procedure Check_Refined_Global_Item
23231 Global_Mode
: Name_Id
)
23233 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23235 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23236 -- Issue a common error message for all mode mismatches. Expect
23237 -- denotes the expected mode.
23239 -----------------------------
23240 -- Inconsistent_Mode_Error --
23241 -----------------------------
23243 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23246 ("global item & has inconsistent modes", Item
, Item_Id
);
23248 Error_Msg_Name_1
:= Global_Mode
;
23249 Error_Msg_Name_2
:= Expect
;
23250 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
23251 end Inconsistent_Mode_Error
;
23253 -- Start of processing for Check_Refined_Global_Item
23256 -- When the state or variable acts as a constituent of another
23257 -- state with a visible refinement, collect it for the state
23258 -- completeness checks performed later on.
23260 if Present
(Encapsulating_State
(Item_Id
))
23261 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23263 if Global_Mode
= Name_Input
then
23264 Add_Item
(Item_Id
, In_Constits
);
23266 elsif Global_Mode
= Name_In_Out
then
23267 Add_Item
(Item_Id
, In_Out_Constits
);
23269 elsif Global_Mode
= Name_Output
then
23270 Add_Item
(Item_Id
, Out_Constits
);
23272 elsif Global_Mode
= Name_Proof_In
then
23273 Add_Item
(Item_Id
, Proof_In_Constits
);
23276 -- When not a constituent, ensure that both occurrences of the
23277 -- item in pragmas Global and Refined_Global match.
23279 elsif Contains
(In_Items
, Item_Id
) then
23280 if Global_Mode
/= Name_Input
then
23281 Inconsistent_Mode_Error
(Name_Input
);
23284 elsif Contains
(In_Out_Items
, Item_Id
) then
23285 if Global_Mode
/= Name_In_Out
then
23286 Inconsistent_Mode_Error
(Name_In_Out
);
23289 elsif Contains
(Out_Items
, Item_Id
) then
23290 if Global_Mode
/= Name_Output
then
23291 Inconsistent_Mode_Error
(Name_Output
);
23294 elsif Contains
(Proof_In_Items
, Item_Id
) then
23297 -- The item does not appear in the corresponding Global pragma,
23298 -- it must be an extra (SPARK RM 7.2.4(3)).
23301 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
23303 end Check_Refined_Global_Item
;
23309 -- Start of processing for Check_Refined_Global_List
23312 if Nkind
(List
) = N_Null
then
23315 -- Single global item declaration
23317 elsif Nkind_In
(List
, N_Expanded_Name
,
23319 N_Selected_Component
)
23321 Check_Refined_Global_Item
(List
, Global_Mode
);
23323 -- Simple global list or moded global list declaration
23325 elsif Nkind
(List
) = N_Aggregate
then
23327 -- The declaration of a simple global list appear as a collection
23330 if Present
(Expressions
(List
)) then
23331 Item
:= First
(Expressions
(List
));
23332 while Present
(Item
) loop
23333 Check_Refined_Global_Item
(Item
, Global_Mode
);
23338 -- The declaration of a moded global list appears as a collection
23339 -- of component associations where individual choices denote
23342 elsif Present
(Component_Associations
(List
)) then
23343 Item
:= First
(Component_Associations
(List
));
23344 while Present
(Item
) loop
23345 Check_Refined_Global_List
23346 (List
=> Expression
(Item
),
23347 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23355 raise Program_Error
;
23361 raise Program_Error
;
23363 end Check_Refined_Global_List
;
23365 --------------------------
23366 -- Collect_Global_Items --
23367 --------------------------
23369 procedure Collect_Global_Items
(Prag
: Node_Id
) is
23370 procedure Process_Global_List
23372 Mode
: Name_Id
:= Name_Input
);
23373 -- Collect all items housed in a global list. Formal Mode denotes the
23374 -- current mode in effect.
23376 -------------------------
23377 -- Process_Global_List --
23378 -------------------------
23380 procedure Process_Global_List
23382 Mode
: Name_Id
:= Name_Input
)
23384 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
23385 -- Add a single item to the appropriate list. Formal Mode denotes
23386 -- the current mode in effect.
23388 -------------------------
23389 -- Process_Global_Item --
23390 -------------------------
23392 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
23393 Item_Id
: constant Entity_Id
:=
23394 Available_View
(Entity_Of
(Item
));
23395 -- The above handles abstract views of variables and states
23396 -- built for limited with clauses.
23399 -- Signal that the global list contains at least one abstract
23400 -- state with a visible refinement. Note that the refinement
23401 -- may be null in which case there are no constituents.
23403 if Ekind
(Item_Id
) = E_Abstract_State
then
23404 if Has_Null_Refinement
(Item_Id
) then
23405 Has_Null_State
:= True;
23407 elsif Has_Non_Null_Refinement
(Item_Id
) then
23408 if Mode
= Name_Input
then
23409 Has_In_State
:= True;
23410 elsif Mode
= Name_In_Out
then
23411 Has_In_Out_State
:= True;
23412 elsif Mode
= Name_Output
then
23413 Has_Out_State
:= True;
23414 elsif Mode
= Name_Proof_In
then
23415 Has_Proof_In_State
:= True;
23420 -- Add the item to the proper list
23422 if Mode
= Name_Input
then
23423 Add_Item
(Item_Id
, In_Items
);
23424 elsif Mode
= Name_In_Out
then
23425 Add_Item
(Item_Id
, In_Out_Items
);
23426 elsif Mode
= Name_Output
then
23427 Add_Item
(Item_Id
, Out_Items
);
23428 elsif Mode
= Name_Proof_In
then
23429 Add_Item
(Item_Id
, Proof_In_Items
);
23431 end Process_Global_Item
;
23437 -- Start of processing for Process_Global_List
23440 if Nkind
(List
) = N_Null
then
23443 -- Single global item declaration
23445 elsif Nkind_In
(List
, N_Expanded_Name
,
23447 N_Selected_Component
)
23449 Process_Global_Item
(List
, Mode
);
23451 -- Single global list or moded global list declaration
23453 elsif Nkind
(List
) = N_Aggregate
then
23455 -- The declaration of a simple global list appear as a
23456 -- collection of expressions.
23458 if Present
(Expressions
(List
)) then
23459 Item
:= First
(Expressions
(List
));
23460 while Present
(Item
) loop
23461 Process_Global_Item
(Item
, Mode
);
23465 -- The declaration of a moded global list appears as a
23466 -- collection of component associations where individual
23467 -- choices denote mode.
23469 elsif Present
(Component_Associations
(List
)) then
23470 Item
:= First
(Component_Associations
(List
));
23471 while Present
(Item
) loop
23472 Process_Global_List
23473 (List
=> Expression
(Item
),
23474 Mode
=> Chars
(First
(Choices
(Item
))));
23482 raise Program_Error
;
23485 -- To accomodate partial decoration of disabled SPARK features,
23486 -- this routine may be called with illegal input. If this is the
23487 -- case, do not raise Program_Error.
23492 end Process_Global_List
;
23494 -- Start of processing for Collect_Global_Items
23497 Process_Global_List
23498 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
))));
23499 end Collect_Global_Items
;
23501 -------------------------
23502 -- Present_Then_Remove --
23503 -------------------------
23505 function Present_Then_Remove
23507 Item
: Entity_Id
) return Boolean
23512 if Present
(List
) then
23513 Elmt
:= First_Elmt
(List
);
23514 while Present
(Elmt
) loop
23515 if Node
(Elmt
) = Item
then
23516 Remove_Elmt
(List
, Elmt
);
23525 end Present_Then_Remove
;
23527 -------------------------------
23528 -- Report_Extra_Constituents --
23529 -------------------------------
23531 procedure Report_Extra_Constituents
is
23532 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23533 -- Emit an error for every element of List
23535 ---------------------------------------
23536 -- Report_Extra_Constituents_In_List --
23537 ---------------------------------------
23539 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23540 Constit_Elmt
: Elmt_Id
;
23543 if Present
(List
) then
23544 Constit_Elmt
:= First_Elmt
(List
);
23545 while Present
(Constit_Elmt
) loop
23546 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23547 Next_Elmt
(Constit_Elmt
);
23550 end Report_Extra_Constituents_In_List
;
23552 -- Start of processing for Report_Extra_Constituents
23555 Report_Extra_Constituents_In_List
(In_Constits
);
23556 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23557 Report_Extra_Constituents_In_List
(Out_Constits
);
23558 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23559 end Report_Extra_Constituents
;
23563 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23564 Errors
: constant Nat
:= Serious_Errors_Detected
;
23565 Items
: constant Node_Id
:=
23566 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
23567 Spec_Id
: Entity_Id
;
23569 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23572 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23573 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23575 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23578 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23580 -- The subprogram declaration lacks pragma Global. This renders
23581 -- Refined_Global useless as there is nothing to refine.
23583 if No
(Global
) then
23585 ("useless refinement, declaration of subprogram & lacks aspect or "
23586 & "pragma Global", N
, Spec_Id
);
23590 -- Extract all relevant items from the corresponding Global pragma
23592 Collect_Global_Items
(Global
);
23594 -- Corresponding Global pragma must mention at least one state witha
23595 -- visible refinement at the point Refined_Global is processed. States
23596 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23598 if not Has_In_State
23599 and then not Has_In_Out_State
23600 and then not Has_Out_State
23601 and then not Has_Proof_In_State
23602 and then not Has_Null_State
23605 ("useless refinement, subprogram & does not depend on abstract "
23606 & "state with visible refinement", N
, Spec_Id
);
23610 -- The global refinement of inputs and outputs cannot be null when the
23611 -- corresponding Global pragma contains at least one item except in the
23612 -- case where we have states with null refinements.
23614 if Nkind
(Items
) = N_Null
23616 (Present
(In_Items
)
23617 or else Present
(In_Out_Items
)
23618 or else Present
(Out_Items
)
23619 or else Present
(Proof_In_Items
))
23620 and then not Has_Null_State
23623 ("refinement cannot be null, subprogram & has global items",
23628 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23629 -- This ensures that the categorization of all refined global items is
23630 -- consistent with their role.
23632 Analyze_Global_In_Decl_Part
(N
);
23634 -- Perform all refinement checks with respect to completeness and mode
23637 if Serious_Errors_Detected
= Errors
then
23638 Check_Refined_Global_List
(Items
);
23641 -- For Input states with visible refinement, at least one constituent
23642 -- must be used as an Input in the global refinement.
23644 if Serious_Errors_Detected
= Errors
then
23645 Check_Input_States
;
23648 -- Verify all possible completion variants for In_Out states with
23649 -- visible refinement.
23651 if Serious_Errors_Detected
= Errors
then
23652 Check_In_Out_States
;
23655 -- For Output states with visible refinement, all constituents must be
23656 -- used as Outputs in the global refinement.
23658 if Serious_Errors_Detected
= Errors
then
23659 Check_Output_States
;
23662 -- For Proof_In states with visible refinement, at least one constituent
23663 -- must be used as Proof_In in the global refinement.
23665 if Serious_Errors_Detected
= Errors
then
23666 Check_Proof_In_States
;
23669 -- Emit errors for all constituents that belong to other states with
23670 -- visible refinement that do not appear in Global.
23672 if Serious_Errors_Detected
= Errors
then
23673 Report_Extra_Constituents
;
23675 end Analyze_Refined_Global_In_Decl_Part
;
23677 ----------------------------------------
23678 -- Analyze_Refined_State_In_Decl_Part --
23679 ----------------------------------------
23681 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23682 Available_States
: Elist_Id
:= No_Elist
;
23683 -- A list of all abstract states defined in the package declaration that
23684 -- are available for refinement. The list is used to report unrefined
23687 Body_Id
: Entity_Id
;
23688 -- The body entity of the package subject to pragma Refined_State
23690 Body_States
: Elist_Id
:= No_Elist
;
23691 -- A list of all hidden states that appear in the body of the related
23692 -- package. The list is used to report unused hidden states.
23694 Constituents_Seen
: Elist_Id
:= No_Elist
;
23695 -- A list that contains all constituents processed so far. The list is
23696 -- used to detect multiple uses of the same constituent.
23698 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23699 -- A list that contains all refined states processed so far. The list is
23700 -- used to detect duplicate refinements.
23702 Spec_Id
: Entity_Id
;
23703 -- The spec entity of the package subject to pragma Refined_State
23705 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23706 -- Perform full analysis of a single refinement clause
23708 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23709 -- Gather the entities of all abstract states and variables declared in
23710 -- the body state space of package Pack_Id.
23712 procedure Report_Unrefined_States
(States
: Elist_Id
);
23713 -- Emit errors for all unrefined abstract states found in list States
23715 procedure Report_Unused_States
(States
: Elist_Id
);
23716 -- Emit errors for all unused states found in list States
23718 -------------------------------
23719 -- Analyze_Refinement_Clause --
23720 -------------------------------
23722 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23723 AR_Constit
: Entity_Id
:= Empty
;
23724 AW_Constit
: Entity_Id
:= Empty
;
23725 ER_Constit
: Entity_Id
:= Empty
;
23726 EW_Constit
: Entity_Id
:= Empty
;
23727 -- The entities of external constituents that contain one of the
23728 -- following enabled properties: Async_Readers, Async_Writers,
23729 -- Effective_Reads and Effective_Writes.
23731 External_Constit_Seen
: Boolean := False;
23732 -- Flag used to mark when at least one external constituent is part
23733 -- of the state refinement.
23735 Non_Null_Seen
: Boolean := False;
23736 Null_Seen
: Boolean := False;
23737 -- Flags used to detect multiple uses of null in a single clause or a
23738 -- mixture of null and non-null constituents.
23740 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23741 -- A list of all candidate constituents subject to indicator Part_Of
23742 -- where the encapsulating state is the current state.
23745 State_Id
: Entity_Id
;
23746 -- The current state being refined
23748 procedure Analyze_Constituent
(Constit
: Node_Id
);
23749 -- Perform full analysis of a single constituent
23751 procedure Check_External_Property
23752 (Prop_Nam
: Name_Id
;
23754 Constit
: Entity_Id
);
23755 -- Determine whether a property denoted by name Prop_Nam is present
23756 -- in both the refined state and constituent Constit. Flag Enabled
23757 -- should be set when the property applies to the refined state. If
23758 -- this is not the case, emit an error message.
23760 procedure Check_Matching_State
;
23761 -- Determine whether the state being refined appears in list
23762 -- Available_States. Emit an error when attempting to re-refine the
23763 -- state or when the state is not defined in the package declaration,
23764 -- otherwise remove the state from Available_States.
23766 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23767 -- Emit errors for all unused Part_Of constituents in list Constits
23769 -------------------------
23770 -- Analyze_Constituent --
23771 -------------------------
23773 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23774 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23775 -- Verify that the constituent Constit_Id is a Ghost entity if the
23776 -- abstract state being refined is also Ghost. If this is the case
23777 -- verify that the Ghost policy in effect at the point of state
23778 -- and constituent declaration is the same.
23780 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23781 -- Determine whether constituent Constit denoted by its entity
23782 -- Constit_Id appears in Hidden_States. Emit an error when the
23783 -- constituent is not a valid hidden state of the related package
23784 -- or when it is used more than once. Otherwise remove the
23785 -- constituent from Hidden_States.
23787 --------------------------------
23788 -- Check_Matching_Constituent --
23789 --------------------------------
23791 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23792 procedure Collect_Constituent
;
23793 -- Add constituent Constit_Id to the refinements of State_Id
23795 -------------------------
23796 -- Collect_Constituent --
23797 -------------------------
23799 procedure Collect_Constituent
is
23801 -- Add the constituent to the list of processed items to aid
23802 -- with the detection of duplicates.
23804 Add_Item
(Constit_Id
, Constituents_Seen
);
23806 -- Collect the constituent in the list of refinement items
23807 -- and establish a relation between the refined state and
23810 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23811 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23813 -- The state has at least one legal constituent, mark the
23814 -- start of the refinement region. The region ends when the
23815 -- body declarations end (see routine Analyze_Declarations).
23817 Set_Has_Visible_Refinement
(State_Id
);
23819 -- When the constituent is external, save its relevant
23820 -- property for further checks.
23822 if Async_Readers_Enabled
(Constit_Id
) then
23823 AR_Constit
:= Constit_Id
;
23824 External_Constit_Seen
:= True;
23827 if Async_Writers_Enabled
(Constit_Id
) then
23828 AW_Constit
:= Constit_Id
;
23829 External_Constit_Seen
:= True;
23832 if Effective_Reads_Enabled
(Constit_Id
) then
23833 ER_Constit
:= Constit_Id
;
23834 External_Constit_Seen
:= True;
23837 if Effective_Writes_Enabled
(Constit_Id
) then
23838 EW_Constit
:= Constit_Id
;
23839 External_Constit_Seen
:= True;
23841 end Collect_Constituent
;
23845 State_Elmt
: Elmt_Id
;
23847 -- Start of processing for Check_Matching_Constituent
23850 -- Detect a duplicate use of a constituent
23852 if Contains
(Constituents_Seen
, Constit_Id
) then
23854 ("duplicate use of constituent &", Constit
, Constit_Id
);
23858 -- The constituent is subject to a Part_Of indicator
23860 if Present
(Encapsulating_State
(Constit_Id
)) then
23861 if Encapsulating_State
(Constit_Id
) = State_Id
then
23862 Check_Ghost_Constituent
(Constit_Id
);
23863 Remove
(Part_Of_Constits
, Constit_Id
);
23864 Collect_Constituent
;
23866 -- The constituent is part of another state and is used
23867 -- incorrectly in the refinement of the current state.
23870 Error_Msg_Name_1
:= Chars
(State_Id
);
23872 ("& cannot act as constituent of state %",
23873 Constit
, Constit_Id
);
23875 ("\Part_Of indicator specifies & as encapsulating "
23876 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23879 -- The only other source of legal constituents is the body
23880 -- state space of the related package.
23883 if Present
(Body_States
) then
23884 State_Elmt
:= First_Elmt
(Body_States
);
23885 while Present
(State_Elmt
) loop
23887 -- Consume a valid constituent to signal that it has
23888 -- been encountered.
23890 if Node
(State_Elmt
) = Constit_Id
then
23891 Check_Ghost_Constituent
(Constit_Id
);
23893 Remove_Elmt
(Body_States
, State_Elmt
);
23894 Collect_Constituent
;
23898 Next_Elmt
(State_Elmt
);
23902 -- If we get here, then the constituent is not a hidden
23903 -- state of the related package and may not be used in a
23904 -- refinement (SPARK RM 7.2.2(9)).
23906 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23908 ("cannot use & in refinement, constituent is not a hidden "
23909 & "state of package %", Constit
, Constit_Id
);
23911 end Check_Matching_Constituent
;
23913 -----------------------------
23914 -- Check_Ghost_Constituent --
23915 -----------------------------
23917 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
23919 if Is_Ghost_Entity
(State_Id
) then
23920 if Is_Ghost_Entity
(Constit_Id
) then
23922 -- The Ghost policy in effect at the point of abstract
23923 -- state declaration and constituent must match
23924 -- (SPARK RM 6.9(16)).
23926 if Is_Checked_Ghost_Entity
(State_Id
)
23927 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
23929 Error_Msg_Sloc
:= Sloc
(Constit
);
23932 ("incompatible ghost policies in effect", State
);
23934 ("\abstract state & declared with ghost policy "
23935 & "Check", State
, State_Id
);
23937 ("\constituent & declared # with ghost policy "
23938 & "Ignore", State
, Constit_Id
);
23940 elsif Is_Ignored_Ghost_Entity
(State_Id
)
23941 and then Is_Checked_Ghost_Entity
(Constit_Id
)
23943 Error_Msg_Sloc
:= Sloc
(Constit
);
23946 ("incompatible ghost policies in effect", State
);
23948 ("\abstract state & declared with ghost policy "
23949 & "Ignore", State
, State_Id
);
23951 ("\constituent & declared # with ghost policy "
23952 & "Check", State
, Constit_Id
);
23955 -- A constituent of a Ghost abstract state must be a Ghost
23956 -- entity (SPARK RM 7.2.2(12)).
23960 ("constituent of ghost state & must be ghost",
23961 Constit
, State_Id
);
23964 end Check_Ghost_Constituent
;
23968 Constit_Id
: Entity_Id
;
23970 -- Start of processing for Analyze_Constituent
23973 -- Detect multiple uses of null in a single refinement clause or a
23974 -- mixture of null and non-null constituents.
23976 if Nkind
(Constit
) = N_Null
then
23979 ("multiple null constituents not allowed", Constit
);
23981 elsif Non_Null_Seen
then
23983 ("cannot mix null and non-null constituents", Constit
);
23988 -- Collect the constituent in the list of refinement items
23990 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23992 -- The state has at least one legal constituent, mark the
23993 -- start of the refinement region. The region ends when the
23994 -- body declarations end (see Analyze_Declarations).
23996 Set_Has_Visible_Refinement
(State_Id
);
23999 -- Non-null constituents
24002 Non_Null_Seen
:= True;
24006 ("cannot mix null and non-null constituents", Constit
);
24010 Resolve_State
(Constit
);
24012 -- Ensure that the constituent denotes a valid state or a
24015 if Is_Entity_Name
(Constit
) then
24016 Constit_Id
:= Entity_Of
(Constit
);
24018 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
24019 Check_Matching_Constituent
(Constit_Id
);
24023 ("constituent & must denote a variable or state (SPARK "
24024 & "RM 7.2.2(5))", Constit
, Constit_Id
);
24027 -- The constituent is illegal
24030 SPARK_Msg_N
("malformed constituent", Constit
);
24033 end Analyze_Constituent
;
24035 -----------------------------
24036 -- Check_External_Property --
24037 -----------------------------
24039 procedure Check_External_Property
24040 (Prop_Nam
: Name_Id
;
24042 Constit
: Entity_Id
)
24045 Error_Msg_Name_1
:= Prop_Nam
;
24047 -- The property is enabled in the related Abstract_State pragma
24048 -- that defines the state (SPARK RM 7.2.8(3)).
24051 if No
(Constit
) then
24053 ("external state & requires at least one constituent with "
24054 & "property %", State
, State_Id
);
24057 -- The property is missing in the declaration of the state, but
24058 -- a constituent is introducing it in the state refinement
24059 -- (SPARK RM 7.2.8(3)).
24061 elsif Present
(Constit
) then
24062 Error_Msg_Name_2
:= Chars
(Constit
);
24064 ("external state & lacks property % set by constituent %",
24067 end Check_External_Property
;
24069 --------------------------
24070 -- Check_Matching_State --
24071 --------------------------
24073 procedure Check_Matching_State
is
24074 State_Elmt
: Elmt_Id
;
24077 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
24079 if Contains
(Refined_States_Seen
, State_Id
) then
24081 ("duplicate refinement of state &", State
, State_Id
);
24085 -- Inspect the abstract states defined in the package declaration
24086 -- looking for a match.
24088 State_Elmt
:= First_Elmt
(Available_States
);
24089 while Present
(State_Elmt
) loop
24091 -- A valid abstract state is being refined in the body. Add
24092 -- the state to the list of processed refined states to aid
24093 -- with the detection of duplicate refinements. Remove the
24094 -- state from Available_States to signal that it has already
24097 if Node
(State_Elmt
) = State_Id
then
24098 Add_Item
(State_Id
, Refined_States_Seen
);
24099 Remove_Elmt
(Available_States
, State_Elmt
);
24103 Next_Elmt
(State_Elmt
);
24106 -- If we get here, we are refining a state that is not defined in
24107 -- the package declaration.
24109 Error_Msg_Name_1
:= Chars
(Spec_Id
);
24111 ("cannot refine state, & is not defined in package %",
24113 end Check_Matching_State
;
24115 --------------------------------
24116 -- Report_Unused_Constituents --
24117 --------------------------------
24119 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
24120 Constit_Elmt
: Elmt_Id
;
24121 Constit_Id
: Entity_Id
;
24122 Posted
: Boolean := False;
24125 if Present
(Constits
) then
24126 Constit_Elmt
:= First_Elmt
(Constits
);
24127 while Present
(Constit_Elmt
) loop
24128 Constit_Id
:= Node
(Constit_Elmt
);
24130 -- Generate an error message of the form:
24132 -- state ... has unused Part_Of constituents
24133 -- abstract state ... defined at ...
24134 -- variable ... defined at ...
24139 ("state & has unused Part_Of constituents",
24143 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
24145 if Ekind
(Constit_Id
) = E_Abstract_State
then
24147 ("\abstract state & defined #", State
, Constit_Id
);
24150 ("\variable & defined #", State
, Constit_Id
);
24153 Next_Elmt
(Constit_Elmt
);
24156 end Report_Unused_Constituents
;
24158 -- Local declarations
24160 Body_Ref
: Node_Id
;
24161 Body_Ref_Elmt
: Elmt_Id
;
24163 Extra_State
: Node_Id
;
24165 -- Start of processing for Analyze_Refinement_Clause
24168 -- A refinement clause appears as a component association where the
24169 -- sole choice is the state and the expressions are the constituents.
24170 -- This is a syntax error, always report.
24172 if Nkind
(Clause
) /= N_Component_Association
then
24173 Error_Msg_N
("malformed state refinement clause", Clause
);
24177 -- Analyze the state name of a refinement clause
24179 State
:= First
(Choices
(Clause
));
24182 Resolve_State
(State
);
24184 -- Ensure that the state name denotes a valid abstract state that is
24185 -- defined in the spec of the related package.
24187 if Is_Entity_Name
(State
) then
24188 State_Id
:= Entity_Of
(State
);
24190 -- Catch any attempts to re-refine a state or refine a state that
24191 -- is not defined in the package declaration.
24193 if Ekind
(State_Id
) = E_Abstract_State
then
24194 Check_Matching_State
;
24197 ("& must denote an abstract state", State
, State_Id
);
24201 -- References to a state with visible refinement are illegal.
24202 -- When nested packages are involved, detecting such references is
24203 -- tricky because pragma Refined_State is analyzed later than the
24204 -- offending pragma Depends or Global. References that occur in
24205 -- such nested context are stored in a list. Emit errors for all
24206 -- references found in Body_References (SPARK RM 6.1.4(8)).
24208 if Present
(Body_References
(State_Id
)) then
24209 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
24210 while Present
(Body_Ref_Elmt
) loop
24211 Body_Ref
:= Node
(Body_Ref_Elmt
);
24213 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
24214 Error_Msg_Sloc
:= Sloc
(State
);
24215 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
24217 Next_Elmt
(Body_Ref_Elmt
);
24221 -- The state name is illegal. This is a syntax error, always report.
24224 Error_Msg_N
("malformed state name in refinement clause", State
);
24228 -- A refinement clause may only refine one state at a time
24230 Extra_State
:= Next
(State
);
24232 if Present
(Extra_State
) then
24234 ("refinement clause cannot cover multiple states", Extra_State
);
24237 -- Replicate the Part_Of constituents of the refined state because
24238 -- the algorithm will consume items.
24240 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
24242 -- Analyze all constituents of the refinement. Multiple constituents
24243 -- appear as an aggregate.
24245 Constit
:= Expression
(Clause
);
24247 if Nkind
(Constit
) = N_Aggregate
then
24248 if Present
(Component_Associations
(Constit
)) then
24250 ("constituents of refinement clause must appear in "
24251 & "positional form", Constit
);
24253 else pragma Assert
(Present
(Expressions
(Constit
)));
24254 Constit
:= First
(Expressions
(Constit
));
24255 while Present
(Constit
) loop
24256 Analyze_Constituent
(Constit
);
24262 -- Various forms of a single constituent. Note that these may include
24263 -- malformed constituents.
24266 Analyze_Constituent
(Constit
);
24269 -- A refined external state is subject to special rules with respect
24270 -- to its properties and constituents.
24272 if Is_External_State
(State_Id
) then
24274 -- The set of properties that all external constituents yield must
24275 -- match that of the refined state. There are two cases to detect:
24276 -- the refined state lacks a property or has an extra property.
24278 if External_Constit_Seen
then
24279 Check_External_Property
24280 (Prop_Nam
=> Name_Async_Readers
,
24281 Enabled
=> Async_Readers_Enabled
(State_Id
),
24282 Constit
=> AR_Constit
);
24284 Check_External_Property
24285 (Prop_Nam
=> Name_Async_Writers
,
24286 Enabled
=> Async_Writers_Enabled
(State_Id
),
24287 Constit
=> AW_Constit
);
24289 Check_External_Property
24290 (Prop_Nam
=> Name_Effective_Reads
,
24291 Enabled
=> Effective_Reads_Enabled
(State_Id
),
24292 Constit
=> ER_Constit
);
24294 Check_External_Property
24295 (Prop_Nam
=> Name_Effective_Writes
,
24296 Enabled
=> Effective_Writes_Enabled
(State_Id
),
24297 Constit
=> EW_Constit
);
24299 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24301 elsif Null_Seen
then
24304 -- The external state has constituents, but none of them are
24305 -- external (SPARK RM 7.2.8(2)).
24309 ("external state & requires at least one external "
24310 & "constituent or null refinement", State
, State_Id
);
24313 -- When a refined state is not external, it should not have external
24314 -- constituents (SPARK RM 7.2.8(1)).
24316 elsif External_Constit_Seen
then
24318 ("non-external state & cannot contain external constituents in "
24319 & "refinement", State
, State_Id
);
24322 -- Ensure that all Part_Of candidate constituents have been mentioned
24323 -- in the refinement clause.
24325 Report_Unused_Constituents
(Part_Of_Constits
);
24326 end Analyze_Refinement_Clause
;
24328 -------------------------
24329 -- Collect_Body_States --
24330 -------------------------
24332 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24333 Result
: Elist_Id
:= No_Elist
;
24334 -- A list containing all body states of Pack_Id
24336 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24337 -- Gather the entities of all abstract states and variables declared
24338 -- in the visible state space of package Pack_Id.
24340 ----------------------------
24341 -- Collect_Visible_States --
24342 ----------------------------
24344 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24345 Item_Id
: Entity_Id
;
24348 -- Traverse the entity chain of the package and inspect all
24351 Item_Id
:= First_Entity
(Pack_Id
);
24352 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24354 -- Do not consider internally generated items as those cannot
24355 -- be named and participate in refinement.
24357 if not Comes_From_Source
(Item_Id
) then
24360 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24361 Add_Item
(Item_Id
, Result
);
24363 -- Recursively gather the visible states of a nested package
24365 elsif Ekind
(Item_Id
) = E_Package
then
24366 Collect_Visible_States
(Item_Id
);
24369 Next_Entity
(Item_Id
);
24371 end Collect_Visible_States
;
24375 Pack_Body
: constant Node_Id
:=
24376 Declaration_Node
(Body_Entity
(Pack_Id
));
24378 Item_Id
: Entity_Id
;
24380 -- Start of processing for Collect_Body_States
24383 -- Inspect the declarations of the body looking for source variables,
24384 -- packages and package instantiations.
24386 Decl
:= First
(Declarations
(Pack_Body
));
24387 while Present
(Decl
) loop
24388 if Nkind
(Decl
) = N_Object_Declaration
then
24389 Item_Id
:= Defining_Entity
(Decl
);
24391 -- Capture source variables only as internally generated
24392 -- temporaries cannot be named and participate in refinement.
24394 if Ekind
(Item_Id
) = E_Variable
24395 and then Comes_From_Source
(Item_Id
)
24397 Add_Item
(Item_Id
, Result
);
24400 elsif Nkind
(Decl
) = N_Package_Declaration
then
24401 Item_Id
:= Defining_Entity
(Decl
);
24403 -- Capture the visible abstract states and variables of a
24404 -- source package [instantiation].
24406 if Comes_From_Source
(Item_Id
) then
24407 Collect_Visible_States
(Item_Id
);
24415 end Collect_Body_States
;
24417 -----------------------------
24418 -- Report_Unrefined_States --
24419 -----------------------------
24421 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24422 State_Elmt
: Elmt_Id
;
24425 if Present
(States
) then
24426 State_Elmt
:= First_Elmt
(States
);
24427 while Present
(State_Elmt
) loop
24429 ("abstract state & must be refined", Node
(State_Elmt
));
24431 Next_Elmt
(State_Elmt
);
24434 end Report_Unrefined_States
;
24436 --------------------------
24437 -- Report_Unused_States --
24438 --------------------------
24440 procedure Report_Unused_States
(States
: Elist_Id
) is
24441 Posted
: Boolean := False;
24442 State_Elmt
: Elmt_Id
;
24443 State_Id
: Entity_Id
;
24446 if Present
(States
) then
24447 State_Elmt
:= First_Elmt
(States
);
24448 while Present
(State_Elmt
) loop
24449 State_Id
:= Node
(State_Elmt
);
24451 -- Generate an error message of the form:
24453 -- body of package ... has unused hidden states
24454 -- abstract state ... defined at ...
24455 -- variable ... defined at ...
24460 ("body of package & has unused hidden states", Body_Id
);
24463 Error_Msg_Sloc
:= Sloc
(State_Id
);
24465 if Ekind
(State_Id
) = E_Abstract_State
then
24467 ("\abstract state & defined #", Body_Id
, State_Id
);
24470 ("\variable & defined #", Body_Id
, State_Id
);
24473 Next_Elmt
(State_Elmt
);
24476 end Report_Unused_States
;
24478 -- Local declarations
24480 Body_Decl
: constant Node_Id
:= Parent
(N
);
24481 Clauses
: constant Node_Id
:=
24482 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
24485 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24490 Body_Id
:= Defining_Entity
(Body_Decl
);
24491 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
24493 -- Replicate the abstract states declared by the package because the
24494 -- matching algorithm will consume states.
24496 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24498 -- Gather all abstract states and variables declared in the visible
24499 -- state space of the package body. These items must be utilized as
24500 -- constituents in a state refinement.
24502 Body_States
:= Collect_Body_States
(Spec_Id
);
24504 -- Multiple non-null state refinements appear as an aggregate
24506 if Nkind
(Clauses
) = N_Aggregate
then
24507 if Present
(Expressions
(Clauses
)) then
24509 ("state refinements must appear as component associations",
24512 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24513 Clause
:= First
(Component_Associations
(Clauses
));
24514 while Present
(Clause
) loop
24515 Analyze_Refinement_Clause
(Clause
);
24521 -- Various forms of a single state refinement. Note that these may
24522 -- include malformed refinements.
24525 Analyze_Refinement_Clause
(Clauses
);
24528 -- List all abstract states that were left unrefined
24530 Report_Unrefined_States
(Available_States
);
24532 -- Ensure that all abstract states and variables declared in the body
24533 -- state space of the related package are utilized as constituents.
24535 Report_Unused_States
(Body_States
);
24536 end Analyze_Refined_State_In_Decl_Part
;
24538 ------------------------------------
24539 -- Analyze_Test_Case_In_Decl_Part --
24540 ------------------------------------
24542 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
24544 -- Install formals and push subprogram spec onto scope stack so that we
24545 -- can see the formals from the pragma.
24548 Install_Formals
(S
);
24550 -- Preanalyze the boolean expressions, we treat these as spec
24551 -- expressions (i.e. similar to a default expression).
24553 if Pragma_Name
(N
) = Name_Test_Case
then
24554 Preanalyze_CTC_Args
24556 Get_Requires_From_CTC_Pragma
(N
),
24557 Get_Ensures_From_CTC_Pragma
(N
));
24560 -- Remove the subprogram from the scope stack now that the pre-analysis
24561 -- of the expressions in the contract case or test case is done.
24564 end Analyze_Test_Case_In_Decl_Part
;
24570 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24575 if Present
(List
) then
24576 Elmt
:= First_Elmt
(List
);
24577 while Present
(Elmt
) loop
24578 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24581 Id
:= Entity_Of
(Node
(Elmt
));
24584 if Id
= Item_Id
then
24595 -----------------------------
24596 -- Check_Applicable_Policy --
24597 -----------------------------
24599 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24603 Ename
: constant Name_Id
:= Original_Aspect_Name
(N
);
24606 -- No effect if not valid assertion kind name
24608 if not Is_Valid_Assertion_Kind
(Ename
) then
24612 -- Loop through entries in check policy list
24614 PP
:= Opt
.Check_Policy_List
;
24615 while Present
(PP
) loop
24617 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24618 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24622 or else Pnm
= Name_Assertion
24623 or else (Pnm
= Name_Statement_Assertions
24624 and then Nam_In
(Ename
, Name_Assert
,
24625 Name_Assert_And_Cut
,
24627 Name_Loop_Invariant
,
24628 Name_Loop_Variant
))
24630 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24633 when Name_Off | Name_Ignore
=>
24634 Set_Is_Ignored
(N
, True);
24635 Set_Is_Checked
(N
, False);
24637 when Name_On | Name_Check
=>
24638 Set_Is_Checked
(N
, True);
24639 Set_Is_Ignored
(N
, False);
24641 when Name_Disable
=>
24642 Set_Is_Ignored
(N
, True);
24643 Set_Is_Checked
(N
, False);
24644 Set_Is_Disabled
(N
, True);
24646 -- That should be exhaustive, the null here is a defence
24647 -- against a malformed tree from previous errors.
24656 PP
:= Next_Pragma
(PP
);
24660 -- If there are no specific entries that matched, then we let the
24661 -- setting of assertions govern. Note that this provides the needed
24662 -- compatibility with the RM for the cases of assertion, invariant,
24663 -- precondition, predicate, and postcondition.
24665 if Assertions_Enabled
then
24666 Set_Is_Checked
(N
, True);
24667 Set_Is_Ignored
(N
, False);
24669 Set_Is_Checked
(N
, False);
24670 Set_Is_Ignored
(N
, True);
24672 end Check_Applicable_Policy
;
24674 -------------------------------
24675 -- Check_External_Properties --
24676 -------------------------------
24678 procedure Check_External_Properties
24686 -- All properties enabled
24688 if AR
and AW
and ER
and EW
then
24691 -- Async_Readers + Effective_Writes
24692 -- Async_Readers + Async_Writers + Effective_Writes
24694 elsif AR
and EW
and not ER
then
24697 -- Async_Writers + Effective_Reads
24698 -- Async_Readers + Async_Writers + Effective_Reads
24700 elsif AW
and ER
and not EW
then
24703 -- Async_Readers + Async_Writers
24705 elsif AR
and AW
and not ER
and not EW
then
24710 elsif AR
and not AW
and not ER
and not EW
then
24715 elsif AW
and not AR
and not ER
and not EW
then
24720 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24723 end Check_External_Properties
;
24729 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24733 -- Loop through entries in check policy list
24735 PP
:= Opt
.Check_Policy_List
;
24736 while Present
(PP
) loop
24738 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24739 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24743 or else (Pnm
= Name_Assertion
24744 and then Is_Valid_Assertion_Kind
(Nam
))
24745 or else (Pnm
= Name_Statement_Assertions
24746 and then Nam_In
(Nam
, Name_Assert
,
24747 Name_Assert_And_Cut
,
24749 Name_Loop_Invariant
,
24750 Name_Loop_Variant
))
24752 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24753 when Name_On | Name_Check
=>
24755 when Name_Off | Name_Ignore
=>
24756 return Name_Ignore
;
24757 when Name_Disable
=>
24758 return Name_Disable
;
24760 raise Program_Error
;
24764 PP
:= Next_Pragma
(PP
);
24769 -- If there are no specific entries that matched, then we let the
24770 -- setting of assertions govern. Note that this provides the needed
24771 -- compatibility with the RM for the cases of assertion, invariant,
24772 -- precondition, predicate, and postcondition.
24774 if Assertions_Enabled
then
24777 return Name_Ignore
;
24781 ---------------------------
24782 -- Check_Missing_Part_Of --
24783 ---------------------------
24785 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24786 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24787 -- Determine whether a package denoted by Pack_Id declares at least one
24790 -----------------------
24791 -- Has_Visible_State --
24792 -----------------------
24794 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24795 Item_Id
: Entity_Id
;
24798 -- Traverse the entity chain of the package trying to find at least
24799 -- one visible abstract state, variable or a package [instantiation]
24800 -- that declares a visible state.
24802 Item_Id
:= First_Entity
(Pack_Id
);
24803 while Present
(Item_Id
)
24804 and then not In_Private_Part
(Item_Id
)
24806 -- Do not consider internally generated items
24808 if not Comes_From_Source
(Item_Id
) then
24811 -- A visible state has been found
24813 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24816 -- Recursively peek into nested packages and instantiations
24818 elsif Ekind
(Item_Id
) = E_Package
24819 and then Has_Visible_State
(Item_Id
)
24824 Next_Entity
(Item_Id
);
24828 end Has_Visible_State
;
24832 Pack_Id
: Entity_Id
;
24833 Placement
: State_Space_Kind
;
24835 -- Start of processing for Check_Missing_Part_Of
24838 -- Do not consider abstract states, variables or package instantiations
24839 -- coming from an instance as those always inherit the Part_Of indicator
24840 -- of the instance itself.
24842 if In_Instance
then
24845 -- Do not consider internally generated entities as these can never
24846 -- have a Part_Of indicator.
24848 elsif not Comes_From_Source
(Item_Id
) then
24851 -- Perform these checks only when SPARK_Mode is enabled as they will
24852 -- interfere with standard Ada rules and produce false positives.
24854 elsif SPARK_Mode
/= On
then
24858 -- Find where the abstract state, variable or package instantiation
24859 -- lives with respect to the state space.
24861 Find_Placement_In_State_Space
24862 (Item_Id
=> Item_Id
,
24863 Placement
=> Placement
,
24864 Pack_Id
=> Pack_Id
);
24866 -- Items that appear in a non-package construct (subprogram, block, etc)
24867 -- do not require a Part_Of indicator because they can never act as a
24870 if Placement
= Not_In_Package
then
24873 -- An item declared in the body state space of a package always act as a
24874 -- constituent and does not need explicit Part_Of indicator.
24876 elsif Placement
= Body_State_Space
then
24879 -- In general an item declared in the visible state space of a package
24880 -- does not require a Part_Of indicator. The only exception is when the
24881 -- related package is a private child unit in which case Part_Of must
24882 -- denote a state in the parent unit or in one of its descendants.
24884 elsif Placement
= Visible_State_Space
then
24885 if Is_Child_Unit
(Pack_Id
)
24886 and then Is_Private_Descendant
(Pack_Id
)
24888 -- A package instantiation does not need a Part_Of indicator when
24889 -- the related generic template has no visible state.
24891 if Ekind
(Item_Id
) = E_Package
24892 and then Is_Generic_Instance
(Item_Id
)
24893 and then not Has_Visible_State
(Item_Id
)
24897 -- All other cases require Part_Of
24901 ("indicator Part_Of is required in this context "
24902 & "(SPARK RM 7.2.6(3))", Item_Id
);
24903 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24905 ("\& is declared in the visible part of private child "
24906 & "unit %", Item_Id
);
24910 -- When the item appears in the private state space of a packge, it must
24911 -- be a part of some state declared by the said package.
24913 else pragma Assert
(Placement
= Private_State_Space
);
24915 -- The related package does not declare a state, the item cannot act
24916 -- as a Part_Of constituent.
24918 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24921 -- A package instantiation does not need a Part_Of indicator when the
24922 -- related generic template has no visible state.
24924 elsif Ekind
(Pack_Id
) = E_Package
24925 and then Is_Generic_Instance
(Pack_Id
)
24926 and then not Has_Visible_State
(Pack_Id
)
24930 -- All other cases require Part_Of
24934 ("indicator Part_Of is required in this context "
24935 & "(SPARK RM 7.2.6(2))", Item_Id
);
24936 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24938 ("\& is declared in the private part of package %", Item_Id
);
24941 end Check_Missing_Part_Of
;
24943 ---------------------------------
24944 -- Check_SPARK_Aspect_For_ASIS --
24945 ---------------------------------
24947 procedure Check_SPARK_Aspect_For_ASIS
(N
: Node_Id
) is
24951 if ASIS_Mode
and then From_Aspect_Specification
(N
) then
24952 Expr
:= Expression
(Corresponding_Aspect
(N
));
24953 if Nkind
(Expr
) /= N_Aggregate
then
24954 Preanalyze_And_Resolve
(Expr
);
24958 Comps
: constant List_Id
:= Component_Associations
(Expr
);
24959 Exprs
: constant List_Id
:= Expressions
(Expr
);
24964 E
:= First
(Exprs
);
24965 while Present
(E
) loop
24970 C
:= First
(Comps
);
24971 while Present
(C
) loop
24972 Analyze
(Expression
(C
));
24978 end Check_SPARK_Aspect_For_ASIS
;
24980 -------------------------------------
24981 -- Check_State_And_Constituent_Use --
24982 -------------------------------------
24984 procedure Check_State_And_Constituent_Use
24985 (States
: Elist_Id
;
24986 Constits
: Elist_Id
;
24989 function Find_Encapsulating_State
24990 (Constit_Id
: Entity_Id
) return Entity_Id
;
24991 -- Given the entity of a constituent, try to find a corresponding
24992 -- encapsulating state that appears in the same context. The routine
24993 -- returns Empty is no such state is found.
24995 ------------------------------
24996 -- Find_Encapsulating_State --
24997 ------------------------------
24999 function Find_Encapsulating_State
25000 (Constit_Id
: Entity_Id
) return Entity_Id
25002 State_Id
: Entity_Id
;
25005 -- Since a constituent may be part of a larger constituent set, climb
25006 -- the encapsulated state chain looking for a state that appears in
25007 -- the same context.
25009 State_Id
:= Encapsulating_State
(Constit_Id
);
25010 while Present
(State_Id
) loop
25011 if Contains
(States
, State_Id
) then
25015 State_Id
:= Encapsulating_State
(State_Id
);
25019 end Find_Encapsulating_State
;
25023 Constit_Elmt
: Elmt_Id
;
25024 Constit_Id
: Entity_Id
;
25025 State_Id
: Entity_Id
;
25027 -- Start of processing for Check_State_And_Constituent_Use
25030 -- Nothing to do if there are no states or constituents
25032 if No
(States
) or else No
(Constits
) then
25036 -- Inspect the list of constituents and try to determine whether its
25037 -- encapsulating state is in list States.
25039 Constit_Elmt
:= First_Elmt
(Constits
);
25040 while Present
(Constit_Elmt
) loop
25041 Constit_Id
:= Node
(Constit_Elmt
);
25043 -- Determine whether the constituent is part of an encapsulating
25044 -- state that appears in the same context and if this is the case,
25045 -- emit an error (SPARK RM 7.2.6(7)).
25047 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
25049 if Present
(State_Id
) then
25050 Error_Msg_Name_1
:= Chars
(Constit_Id
);
25052 ("cannot mention state & and its constituent % in the same "
25053 & "context", Context
, State_Id
);
25057 Next_Elmt
(Constit_Elmt
);
25059 end Check_State_And_Constituent_Use
;
25061 ---------------------------------------
25062 -- Collect_Subprogram_Inputs_Outputs --
25063 ---------------------------------------
25065 procedure Collect_Subprogram_Inputs_Outputs
25066 (Subp_Id
: Entity_Id
;
25067 Synthesize
: Boolean := False;
25068 Subp_Inputs
: in out Elist_Id
;
25069 Subp_Outputs
: in out Elist_Id
;
25070 Global_Seen
: out Boolean)
25072 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
25073 -- Collect all relevant items from a dependency clause
25075 procedure Collect_Global_List
25077 Mode
: Name_Id
:= Name_Input
);
25078 -- Collect all relevant items from a global list
25080 -------------------------------
25081 -- Collect_Dependency_Clause --
25082 -------------------------------
25084 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
25085 procedure Collect_Dependency_Item
25087 Is_Input
: Boolean);
25088 -- Add an item to the proper subprogram input or output collection
25090 -----------------------------
25091 -- Collect_Dependency_Item --
25092 -----------------------------
25094 procedure Collect_Dependency_Item
25096 Is_Input
: Boolean)
25101 -- Nothing to collect when the item is null
25103 if Nkind
(Item
) = N_Null
then
25106 -- Ditto for attribute 'Result
25108 elsif Is_Attribute_Result
(Item
) then
25111 -- Multiple items appear as an aggregate
25113 elsif Nkind
(Item
) = N_Aggregate
then
25114 Extra
:= First
(Expressions
(Item
));
25115 while Present
(Extra
) loop
25116 Collect_Dependency_Item
(Extra
, Is_Input
);
25120 -- Otherwise this is a solitary item
25124 Add_Item
(Item
, Subp_Inputs
);
25126 Add_Item
(Item
, Subp_Outputs
);
25129 end Collect_Dependency_Item
;
25131 -- Start of processing for Collect_Dependency_Clause
25134 if Nkind
(Clause
) = N_Null
then
25137 -- A dependency cause appears as component association
25139 elsif Nkind
(Clause
) = N_Component_Association
then
25140 Collect_Dependency_Item
25141 (Expression
(Clause
), Is_Input
=> True);
25142 Collect_Dependency_Item
25143 (First
(Choices
(Clause
)), Is_Input
=> False);
25145 -- To accomodate partial decoration of disabled SPARK features, this
25146 -- routine may be called with illegal input. If this is the case, do
25147 -- not raise Program_Error.
25152 end Collect_Dependency_Clause
;
25154 -------------------------
25155 -- Collect_Global_List --
25156 -------------------------
25158 procedure Collect_Global_List
25160 Mode
: Name_Id
:= Name_Input
)
25162 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25163 -- Add an item to the proper subprogram input or output collection
25165 -------------------------
25166 -- Collect_Global_Item --
25167 -------------------------
25169 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25171 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
25172 Add_Item
(Item
, Subp_Inputs
);
25175 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
25176 Add_Item
(Item
, Subp_Outputs
);
25178 end Collect_Global_Item
;
25185 -- Start of processing for Collect_Global_List
25188 if Nkind
(List
) = N_Null
then
25191 -- Single global item declaration
25193 elsif Nkind_In
(List
, N_Expanded_Name
,
25195 N_Selected_Component
)
25197 Collect_Global_Item
(List
, Mode
);
25199 -- Simple global list or moded global list declaration
25201 elsif Nkind
(List
) = N_Aggregate
then
25202 if Present
(Expressions
(List
)) then
25203 Item
:= First
(Expressions
(List
));
25204 while Present
(Item
) loop
25205 Collect_Global_Item
(Item
, Mode
);
25210 Assoc
:= First
(Component_Associations
(List
));
25211 while Present
(Assoc
) loop
25212 Collect_Global_List
25213 (List
=> Expression
(Assoc
),
25214 Mode
=> Chars
(First
(Choices
(Assoc
))));
25219 -- To accomodate partial decoration of disabled SPARK features, this
25220 -- routine may be called with illegal input. If this is the case, do
25221 -- not raise Program_Error.
25226 end Collect_Global_List
;
25230 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
25234 Formal
: Entity_Id
;
25237 Spec_Id
: Entity_Id
;
25239 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25242 Global_Seen
:= False;
25244 -- Find the entity of the corresponding spec when processing a body
25246 if Nkind
(Subp_Decl
) = N_Subprogram_Body
25247 and then Present
(Corresponding_Spec
(Subp_Decl
))
25249 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
25251 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25252 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25254 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
25257 Spec_Id
:= Subp_Id
;
25260 -- Process all formal parameters
25262 Formal
:= First_Formal
(Spec_Id
);
25263 while Present
(Formal
) loop
25264 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
25265 Add_Item
(Formal
, Subp_Inputs
);
25268 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
25269 Add_Item
(Formal
, Subp_Outputs
);
25271 -- Out parameters can act as inputs when the related type is
25272 -- tagged, unconstrained array, unconstrained record or record
25273 -- with unconstrained components.
25275 if Ekind
(Formal
) = E_Out_Parameter
25276 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25278 Add_Item
(Formal
, Subp_Inputs
);
25282 Next_Formal
(Formal
);
25285 -- When processing a subprogram body, look for pragmas Refined_Depends
25286 -- and Refined_Global as they specify the inputs and outputs.
25288 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25289 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
25290 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25292 -- Subprogram declaration case, look for pragmas Depends and Global
25295 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25296 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25299 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
25300 -- because it provides finer granularity of inputs and outputs.
25302 if Present
(Global
) then
25303 Global_Seen
:= True;
25304 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
25306 -- The pragma may not have been analyzed because of the arbitrary
25307 -- declaration order of aspects. Make sure that it is analyzed for
25308 -- the purposes of item extraction.
25310 if not Analyzed
(List
) then
25311 if Pragma_Name
(Global
) = Name_Refined_Global
then
25312 Analyze_Refined_Global_In_Decl_Part
(Global
);
25314 Analyze_Global_In_Decl_Part
(Global
);
25318 Collect_Global_List
(List
);
25320 -- When the related subprogram lacks pragma [Refined_]Global, fall back
25321 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
25322 -- the inputs and outputs from [Refined_]Depends.
25324 elsif Synthesize
and then Present
(Depends
) then
25326 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Depends
)));
25328 -- Multiple dependency clauses appear as an aggregate
25330 if Nkind
(Clauses
) = N_Aggregate
then
25331 Clause
:= First
(Component_Associations
(Clauses
));
25332 while Present
(Clause
) loop
25333 Collect_Dependency_Clause
(Clause
);
25337 -- Otherwise this is a single dependency clause
25340 Collect_Dependency_Clause
(Clauses
);
25343 end Collect_Subprogram_Inputs_Outputs
;
25345 ---------------------------------
25346 -- Delay_Config_Pragma_Analyze --
25347 ---------------------------------
25349 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25351 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25352 Name_Priority_Specific_Dispatching
);
25353 end Delay_Config_Pragma_Analyze
;
25355 -------------------------------------
25356 -- Find_Related_Subprogram_Or_Body --
25357 -------------------------------------
25359 function Find_Related_Subprogram_Or_Body
25361 Do_Checks
: Boolean := False) return Node_Id
25363 Context
: constant Node_Id
:= Parent
(Prag
);
25364 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25367 Look_For_Body
: constant Boolean :=
25368 Nam_In
(Nam
, Name_Refined_Depends
,
25369 Name_Refined_Global
,
25370 Name_Refined_Post
);
25371 -- Refinement pragmas must be associated with a subprogram body [stub]
25374 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
25376 -- If the pragma is a byproduct of aspect expansion, return the related
25377 -- context of the original aspect.
25379 if Present
(Corresponding_Aspect
(Prag
)) then
25380 return Parent
(Corresponding_Aspect
(Prag
));
25383 -- Otherwise the pragma is a source construct, most likely part of a
25384 -- declarative list. Skip preceding declarations while looking for a
25385 -- proper subprogram declaration.
25387 pragma Assert
(Is_List_Member
(Prag
));
25389 Stmt
:= Prev
(Prag
);
25390 while Present
(Stmt
) loop
25392 -- Skip prior pragmas, but check for duplicates
25394 if Nkind
(Stmt
) = N_Pragma
then
25395 if Do_Checks
and then Pragma_Name
(Stmt
) = Nam
then
25396 Error_Msg_Name_1
:= Nam
;
25397 Error_Msg_Sloc
:= Sloc
(Stmt
);
25398 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25401 -- Emit an error when a refinement pragma appears on an expression
25402 -- function without a completion.
25405 and then Look_For_Body
25406 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25407 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25408 and then not Has_Completion
(Defining_Entity
(Stmt
))
25410 Error_Msg_Name_1
:= Nam
;
25412 ("pragma % cannot apply to a stand alone expression function",
25417 -- The refinement pragma applies to a subprogram body stub
25419 elsif Look_For_Body
25420 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25424 -- Skip internally generated code
25426 elsif not Comes_From_Source
(Stmt
) then
25429 -- Return the current construct which is either a subprogram body,
25430 -- a subprogram declaration or is illegal.
25439 -- If we fall through, then the pragma was either the first declaration
25440 -- or it was preceded by other pragmas and no source constructs.
25442 -- The pragma is associated with a library-level subprogram
25444 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25445 return Unit
(Parent
(Context
));
25447 -- The pragma appears inside the declarative part of a subprogram body
25449 elsif Nkind
(Context
) = N_Subprogram_Body
then
25452 -- No candidate subprogram [body] found
25457 end Find_Related_Subprogram_Or_Body
;
25459 -------------------------
25460 -- Get_Base_Subprogram --
25461 -------------------------
25463 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25464 Result
: Entity_Id
;
25467 -- Follow subprogram renaming chain
25471 if Is_Subprogram
(Result
)
25473 Nkind
(Parent
(Declaration_Node
(Result
))) =
25474 N_Subprogram_Renaming_Declaration
25475 and then Present
(Alias
(Result
))
25477 Result
:= Alias
(Result
);
25481 end Get_Base_Subprogram
;
25483 -----------------------
25484 -- Get_SPARK_Mode_Type --
25485 -----------------------
25487 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25489 if N
= Name_On
then
25491 elsif N
= Name_Off
then
25494 -- Any other argument is illegal
25497 raise Program_Error
;
25499 end Get_SPARK_Mode_Type
;
25501 --------------------------------
25502 -- Get_SPARK_Mode_From_Pragma --
25503 --------------------------------
25505 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25510 pragma Assert
(Nkind
(N
) = N_Pragma
);
25511 Args
:= Pragma_Argument_Associations
(N
);
25513 -- Extract the mode from the argument list
25515 if Present
(Args
) then
25516 Mode
:= First
(Pragma_Argument_Associations
(N
));
25517 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25519 -- If SPARK_Mode pragma has no argument, default is ON
25524 end Get_SPARK_Mode_From_Pragma
;
25526 ---------------------------
25527 -- Has_Extra_Parentheses --
25528 ---------------------------
25530 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25534 -- The aggregate should not have an expression list because a clause
25535 -- is always interpreted as a component association. The only way an
25536 -- expression list can sneak in is by adding extra parentheses around
25537 -- the individual clauses:
25539 -- Depends (Output => Input) -- proper form
25540 -- Depends ((Output => Input)) -- extra parentheses
25542 -- Since the extra parentheses are not allowed by the syntax of the
25543 -- pragma, flag them now to avoid emitting misleading errors down the
25546 if Nkind
(Clause
) = N_Aggregate
25547 and then Present
(Expressions
(Clause
))
25549 Expr
:= First
(Expressions
(Clause
));
25550 while Present
(Expr
) loop
25552 -- A dependency clause surrounded by extra parentheses appears
25553 -- as an aggregate of component associations with an optional
25554 -- Paren_Count set.
25556 if Nkind
(Expr
) = N_Aggregate
25557 and then Present
(Component_Associations
(Expr
))
25560 ("dependency clause contains extra parentheses", Expr
);
25562 -- Otherwise the expression is a malformed construct
25565 SPARK_Msg_N
("malformed dependency clause", Expr
);
25575 end Has_Extra_Parentheses
;
25581 procedure Initialize
is
25592 Dummy
:= Dummy
+ 1;
25595 -----------------------------
25596 -- Is_Config_Static_String --
25597 -----------------------------
25599 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25601 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25602 -- This is an internal recursive function that is just like the outer
25603 -- function except that it adds the string to the name buffer rather
25604 -- than placing the string in the name buffer.
25606 ------------------------------
25607 -- Add_Config_Static_String --
25608 ------------------------------
25610 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25617 if Nkind
(N
) = N_Op_Concat
then
25618 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25619 N
:= Right_Opnd
(N
);
25625 if Nkind
(N
) /= N_String_Literal
then
25626 Error_Msg_N
("string literal expected for pragma argument", N
);
25630 for J
in 1 .. String_Length
(Strval
(N
)) loop
25631 C
:= Get_String_Char
(Strval
(N
), J
);
25633 if not In_Character_Range
(C
) then
25635 ("string literal contains invalid wide character",
25636 Sloc
(N
) + 1 + Source_Ptr
(J
));
25640 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25645 end Add_Config_Static_String
;
25647 -- Start of processing for Is_Config_Static_String
25652 return Add_Config_Static_String
(Arg
);
25653 end Is_Config_Static_String
;
25655 -------------------------------
25656 -- Is_Elaboration_SPARK_Mode --
25657 -------------------------------
25659 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
25662 (Nkind
(N
) = N_Pragma
25663 and then Pragma_Name
(N
) = Name_SPARK_Mode
25664 and then Is_List_Member
(N
));
25666 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25667 -- appears in the statement part of the body.
25670 Present
(Parent
(N
))
25671 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
25672 and then List_Containing
(N
) = Statements
(Parent
(N
))
25673 and then Present
(Parent
(Parent
(N
)))
25674 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
25675 end Is_Elaboration_SPARK_Mode
;
25677 -----------------------------------------
25678 -- Is_Non_Significant_Pragma_Reference --
25679 -----------------------------------------
25681 -- This function makes use of the following static table which indicates
25682 -- whether appearance of some name in a given pragma is to be considered
25683 -- as a reference for the purposes of warnings about unreferenced objects.
25685 -- -1 indicates that appearence in any argument is significant
25686 -- 0 indicates that appearance in any argument is not significant
25687 -- +n indicates that appearance as argument n is significant, but all
25688 -- other arguments are not significant
25689 -- 9n arguments from n on are significant, before n inisignificant
25691 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
25692 (Pragma_Abort_Defer
=> -1,
25693 Pragma_Abstract_State
=> -1,
25694 Pragma_Ada_83
=> -1,
25695 Pragma_Ada_95
=> -1,
25696 Pragma_Ada_05
=> -1,
25697 Pragma_Ada_2005
=> -1,
25698 Pragma_Ada_12
=> -1,
25699 Pragma_Ada_2012
=> -1,
25700 Pragma_All_Calls_Remote
=> -1,
25701 Pragma_Allow_Integer_Address
=> -1,
25702 Pragma_Annotate
=> 93,
25703 Pragma_Assert
=> -1,
25704 Pragma_Assert_And_Cut
=> -1,
25705 Pragma_Assertion_Policy
=> 0,
25706 Pragma_Assume
=> -1,
25707 Pragma_Assume_No_Invalid_Values
=> 0,
25708 Pragma_Async_Readers
=> 0,
25709 Pragma_Async_Writers
=> 0,
25710 Pragma_Asynchronous
=> 0,
25711 Pragma_Atomic
=> 0,
25712 Pragma_Atomic_Components
=> 0,
25713 Pragma_Attach_Handler
=> -1,
25714 Pragma_Attribute_Definition
=> 92,
25715 Pragma_Check
=> -1,
25716 Pragma_Check_Float_Overflow
=> 0,
25717 Pragma_Check_Name
=> 0,
25718 Pragma_Check_Policy
=> 0,
25719 Pragma_CIL_Constructor
=> 0,
25720 Pragma_CPP_Class
=> 0,
25721 Pragma_CPP_Constructor
=> 0,
25722 Pragma_CPP_Virtual
=> 0,
25723 Pragma_CPP_Vtable
=> 0,
25725 Pragma_C_Pass_By_Copy
=> 0,
25726 Pragma_Comment
=> -1,
25727 Pragma_Common_Object
=> 0,
25728 Pragma_Compile_Time_Error
=> -1,
25729 Pragma_Compile_Time_Warning
=> -1,
25730 Pragma_Compiler_Unit
=> -1,
25731 Pragma_Compiler_Unit_Warning
=> -1,
25732 Pragma_Complete_Representation
=> 0,
25733 Pragma_Complex_Representation
=> 0,
25734 Pragma_Component_Alignment
=> 0,
25735 Pragma_Contract_Cases
=> -1,
25736 Pragma_Controlled
=> 0,
25737 Pragma_Convention
=> 0,
25738 Pragma_Convention_Identifier
=> 0,
25739 Pragma_Debug
=> -1,
25740 Pragma_Debug_Policy
=> 0,
25741 Pragma_Detect_Blocking
=> 0,
25742 Pragma_Default_Initial_Condition
=> -1,
25743 Pragma_Default_Scalar_Storage_Order
=> 0,
25744 Pragma_Default_Storage_Pool
=> 0,
25745 Pragma_Depends
=> -1,
25746 Pragma_Disable_Atomic_Synchronization
=> 0,
25747 Pragma_Discard_Names
=> 0,
25748 Pragma_Dispatching_Domain
=> -1,
25749 Pragma_Effective_Reads
=> 0,
25750 Pragma_Effective_Writes
=> 0,
25751 Pragma_Elaborate
=> 0,
25752 Pragma_Elaborate_All
=> 0,
25753 Pragma_Elaborate_Body
=> 0,
25754 Pragma_Elaboration_Checks
=> 0,
25755 Pragma_Eliminate
=> 0,
25756 Pragma_Enable_Atomic_Synchronization
=> 0,
25757 Pragma_Export
=> -1,
25758 Pragma_Export_Function
=> -1,
25759 Pragma_Export_Object
=> -1,
25760 Pragma_Export_Procedure
=> -1,
25761 Pragma_Export_Value
=> -1,
25762 Pragma_Export_Valued_Procedure
=> -1,
25763 Pragma_Extend_System
=> -1,
25764 Pragma_Extensions_Allowed
=> 0,
25765 Pragma_Extensions_Visible
=> 0,
25766 Pragma_External
=> -1,
25767 Pragma_Favor_Top_Level
=> 0,
25768 Pragma_External_Name_Casing
=> 0,
25769 Pragma_Fast_Math
=> 0,
25770 Pragma_Finalize_Storage_Only
=> 0,
25772 Pragma_Global
=> -1,
25773 Pragma_Ident
=> -1,
25774 Pragma_Implementation_Defined
=> -1,
25775 Pragma_Implemented
=> -1,
25776 Pragma_Implicit_Packing
=> 0,
25777 Pragma_Import
=> 93,
25778 Pragma_Import_Function
=> 0,
25779 Pragma_Import_Object
=> 0,
25780 Pragma_Import_Procedure
=> 0,
25781 Pragma_Import_Valued_Procedure
=> 0,
25782 Pragma_Independent
=> 0,
25783 Pragma_Independent_Components
=> 0,
25784 Pragma_Initial_Condition
=> -1,
25785 Pragma_Initialize_Scalars
=> 0,
25786 Pragma_Initializes
=> -1,
25787 Pragma_Inline
=> 0,
25788 Pragma_Inline_Always
=> 0,
25789 Pragma_Inline_Generic
=> 0,
25790 Pragma_Inspection_Point
=> -1,
25791 Pragma_Interface
=> 92,
25792 Pragma_Interface_Name
=> 0,
25793 Pragma_Interrupt_Handler
=> -1,
25794 Pragma_Interrupt_Priority
=> -1,
25795 Pragma_Interrupt_State
=> -1,
25796 Pragma_Invariant
=> -1,
25797 Pragma_Java_Constructor
=> -1,
25798 Pragma_Java_Interface
=> -1,
25799 Pragma_Keep_Names
=> 0,
25800 Pragma_License
=> 0,
25801 Pragma_Link_With
=> -1,
25802 Pragma_Linker_Alias
=> -1,
25803 Pragma_Linker_Constructor
=> -1,
25804 Pragma_Linker_Destructor
=> -1,
25805 Pragma_Linker_Options
=> -1,
25806 Pragma_Linker_Section
=> 0,
25808 Pragma_Lock_Free
=> 0,
25809 Pragma_Locking_Policy
=> 0,
25810 Pragma_Loop_Invariant
=> -1,
25811 Pragma_Loop_Optimize
=> 0,
25812 Pragma_Loop_Variant
=> -1,
25813 Pragma_Machine_Attribute
=> -1,
25815 Pragma_Main_Storage
=> -1,
25816 Pragma_Memory_Size
=> 0,
25817 Pragma_No_Return
=> 0,
25818 Pragma_No_Body
=> 0,
25819 Pragma_No_Elaboration_Code_All
=> 0,
25820 Pragma_No_Inline
=> 0,
25821 Pragma_No_Run_Time
=> -1,
25822 Pragma_No_Strict_Aliasing
=> -1,
25823 Pragma_No_Tagged_Streams
=> 0,
25824 Pragma_Normalize_Scalars
=> 0,
25825 Pragma_Obsolescent
=> 0,
25826 Pragma_Optimize
=> 0,
25827 Pragma_Optimize_Alignment
=> 0,
25828 Pragma_Overflow_Mode
=> 0,
25829 Pragma_Overriding_Renamings
=> 0,
25830 Pragma_Ordered
=> 0,
25833 Pragma_Part_Of
=> 0,
25834 Pragma_Partition_Elaboration_Policy
=> 0,
25835 Pragma_Passive
=> 0,
25836 Pragma_Persistent_BSS
=> 0,
25837 Pragma_Polling
=> 0,
25838 Pragma_Prefix_Exception_Messages
=> 0,
25840 Pragma_Postcondition
=> -1,
25841 Pragma_Post_Class
=> -1,
25843 Pragma_Precondition
=> -1,
25844 Pragma_Predicate
=> -1,
25845 Pragma_Preelaborable_Initialization
=> -1,
25846 Pragma_Preelaborate
=> 0,
25847 Pragma_Pre_Class
=> -1,
25848 Pragma_Priority
=> -1,
25849 Pragma_Priority_Specific_Dispatching
=> 0,
25850 Pragma_Profile
=> 0,
25851 Pragma_Profile_Warnings
=> 0,
25852 Pragma_Propagate_Exceptions
=> 0,
25853 Pragma_Provide_Shift_Operators
=> 0,
25854 Pragma_Psect_Object
=> 0,
25856 Pragma_Pure_Function
=> 0,
25857 Pragma_Queuing_Policy
=> 0,
25858 Pragma_Rational
=> 0,
25859 Pragma_Ravenscar
=> 0,
25860 Pragma_Refined_Depends
=> -1,
25861 Pragma_Refined_Global
=> -1,
25862 Pragma_Refined_Post
=> -1,
25863 Pragma_Refined_State
=> -1,
25864 Pragma_Relative_Deadline
=> 0,
25865 Pragma_Remote_Access_Type
=> -1,
25866 Pragma_Remote_Call_Interface
=> -1,
25867 Pragma_Remote_Types
=> -1,
25868 Pragma_Restricted_Run_Time
=> 0,
25869 Pragma_Restriction_Warnings
=> 0,
25870 Pragma_Restrictions
=> 0,
25871 Pragma_Reviewable
=> -1,
25872 Pragma_Short_Circuit_And_Or
=> 0,
25873 Pragma_Share_Generic
=> 0,
25874 Pragma_Shared
=> 0,
25875 Pragma_Shared_Passive
=> 0,
25876 Pragma_Short_Descriptors
=> 0,
25877 Pragma_Simple_Storage_Pool_Type
=> 0,
25878 Pragma_Source_File_Name
=> 0,
25879 Pragma_Source_File_Name_Project
=> 0,
25880 Pragma_Source_Reference
=> 0,
25881 Pragma_SPARK_Mode
=> 0,
25882 Pragma_Storage_Size
=> -1,
25883 Pragma_Storage_Unit
=> 0,
25884 Pragma_Static_Elaboration_Desired
=> 0,
25885 Pragma_Stream_Convert
=> 0,
25886 Pragma_Style_Checks
=> 0,
25887 Pragma_Subtitle
=> 0,
25888 Pragma_Suppress
=> 0,
25889 Pragma_Suppress_Exception_Locations
=> 0,
25890 Pragma_Suppress_All
=> 0,
25891 Pragma_Suppress_Debug_Info
=> 0,
25892 Pragma_Suppress_Initialization
=> 0,
25893 Pragma_System_Name
=> 0,
25894 Pragma_Task_Dispatching_Policy
=> 0,
25895 Pragma_Task_Info
=> -1,
25896 Pragma_Task_Name
=> -1,
25897 Pragma_Task_Storage
=> -1,
25898 Pragma_Test_Case
=> -1,
25899 Pragma_Thread_Local_Storage
=> -1,
25900 Pragma_Time_Slice
=> -1,
25902 Pragma_Type_Invariant
=> -1,
25903 Pragma_Type_Invariant_Class
=> -1,
25904 Pragma_Unchecked_Union
=> 0,
25905 Pragma_Unimplemented_Unit
=> 0,
25906 Pragma_Universal_Aliasing
=> 0,
25907 Pragma_Universal_Data
=> 0,
25908 Pragma_Unmodified
=> 0,
25909 Pragma_Unreferenced
=> 0,
25910 Pragma_Unreferenced_Objects
=> 0,
25911 Pragma_Unreserve_All_Interrupts
=> 0,
25912 Pragma_Unsuppress
=> 0,
25913 Pragma_Unevaluated_Use_Of_Old
=> 0,
25914 Pragma_Use_VADS_Size
=> 0,
25915 Pragma_Validity_Checks
=> 0,
25916 Pragma_Volatile
=> 0,
25917 Pragma_Volatile_Components
=> 0,
25918 Pragma_Warning_As_Error
=> 0,
25919 Pragma_Warnings
=> 0,
25920 Pragma_Weak_External
=> 0,
25921 Pragma_Wide_Character_Encoding
=> 0,
25922 Unknown_Pragma
=> 0);
25924 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25930 function Arg_No
return Nat
;
25931 -- Returns an integer showing what argument we are in. A value of
25932 -- zero means we are not in any of the arguments.
25938 function Arg_No
return Nat
is
25943 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25957 -- Start of processing for Non_Significant_Pragma_Reference
25962 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25966 Id
:= Get_Pragma_Id
(Parent
(P
));
25967 C
:= Sig_Flags
(Id
);
25982 return AN
< (C
- 90);
25988 end Is_Non_Significant_Pragma_Reference
;
25990 ------------------------------
25991 -- Is_Pragma_String_Literal --
25992 ------------------------------
25994 -- This function returns true if the corresponding pragma argument is a
25995 -- static string expression. These are the only cases in which string
25996 -- literals can appear as pragma arguments. We also allow a string literal
25997 -- as the first argument to pragma Assert (although it will of course
25998 -- always generate a type error).
26000 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
26001 Pragn
: constant Node_Id
:= Parent
(Par
);
26002 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
26003 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
26009 N
:= First
(Assoc
);
26016 if Pname
= Name_Assert
then
26019 elsif Pname
= Name_Export
then
26022 elsif Pname
= Name_Ident
then
26025 elsif Pname
= Name_Import
then
26028 elsif Pname
= Name_Interface_Name
then
26031 elsif Pname
= Name_Linker_Alias
then
26034 elsif Pname
= Name_Linker_Section
then
26037 elsif Pname
= Name_Machine_Attribute
then
26040 elsif Pname
= Name_Source_File_Name
then
26043 elsif Pname
= Name_Source_Reference
then
26046 elsif Pname
= Name_Title
then
26049 elsif Pname
= Name_Subtitle
then
26055 end Is_Pragma_String_Literal
;
26057 ---------------------------
26058 -- Is_Private_SPARK_Mode --
26059 ---------------------------
26061 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
26064 (Nkind
(N
) = N_Pragma
26065 and then Pragma_Name
(N
) = Name_SPARK_Mode
26066 and then Is_List_Member
(N
));
26068 -- For pragma SPARK_Mode to be private, it has to appear in the private
26069 -- declarations of a package.
26072 Present
(Parent
(N
))
26073 and then Nkind
(Parent
(N
)) = N_Package_Specification
26074 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
26075 end Is_Private_SPARK_Mode
;
26077 -------------------------------------
26078 -- Is_Unconstrained_Or_Tagged_Item --
26079 -------------------------------------
26081 function Is_Unconstrained_Or_Tagged_Item
26082 (Item
: Entity_Id
) return Boolean
26084 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
26085 -- Determine whether record type Typ has at least one unconstrained
26088 ---------------------------------
26089 -- Has_Unconstrained_Component --
26090 ---------------------------------
26092 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
26096 Comp
:= First_Component
(Typ
);
26097 while Present
(Comp
) loop
26098 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
26102 Next_Component
(Comp
);
26106 end Has_Unconstrained_Component
;
26110 Typ
: constant Entity_Id
:= Etype
(Item
);
26112 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26115 if Is_Tagged_Type
(Typ
) then
26118 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
26121 elsif Is_Record_Type
(Typ
) then
26122 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
26125 return Has_Unconstrained_Component
(Typ
);
26128 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
26134 end Is_Unconstrained_Or_Tagged_Item
;
26136 -----------------------------
26137 -- Is_Valid_Assertion_Kind --
26138 -----------------------------
26140 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
26147 Name_Static_Predicate |
26148 Name_Dynamic_Predicate |
26153 Name_Type_Invariant |
26154 Name_uType_Invariant |
26158 Name_Assert_And_Cut |
26160 Name_Contract_Cases |
26162 Name_Default_Initial_Condition |
26164 Name_Initial_Condition |
26167 Name_Loop_Invariant |
26168 Name_Loop_Variant |
26169 Name_Postcondition |
26170 Name_Precondition |
26172 Name_Refined_Post |
26173 Name_Statement_Assertions
=> return True;
26175 when others => return False;
26177 end Is_Valid_Assertion_Kind
;
26179 -----------------------------------------
26180 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
26181 -----------------------------------------
26183 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
26184 Aspects
: constant List_Id
:= New_List
;
26185 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
26186 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
26188 Original_Aspects
: List_Id
;
26189 -- To capture global references, a copy of the created aspects must be
26190 -- inserted in the original tree.
26193 Prag_Arg_Ass
: Node_Id
;
26194 Prag_Id
: Pragma_Id
;
26197 -- Check for any PPC pragmas that appear within Decl
26199 Prag
:= Next
(Decl
);
26200 while Nkind
(Prag
) = N_Pragma
loop
26201 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
26204 when Pragma_Postcondition | Pragma_Precondition
=>
26205 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
26207 -- Make an aspect from any PPC pragma
26209 Append_To
(Aspects
,
26210 Make_Aspect_Specification
(Loc
,
26212 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
26214 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
26216 -- Generate the analysis information in the pragma expression
26217 -- and then set the pragma node analyzed to avoid any further
26220 Analyze
(Expression
(Prag_Arg_Ass
));
26221 Set_Analyzed
(Prag
, True);
26223 when others => null;
26229 -- Set all new aspects into the generic declaration node
26231 if Is_Non_Empty_List
(Aspects
) then
26233 -- Create the list of aspects to be inserted in the original tree
26235 Original_Aspects
:= Copy_Separate_List
(Aspects
);
26237 -- Check if Decl already has aspects
26239 -- Attach the new lists of aspects to both the generic copy and the
26242 if Has_Aspects
(Decl
) then
26243 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
26244 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
26247 Set_Parent
(Aspects
, Decl
);
26248 Set_Aspect_Specifications
(Decl
, Aspects
);
26249 Set_Parent
(Original_Aspects
, Or_Decl
);
26250 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
26253 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
26255 -------------------------
26256 -- Preanalyze_CTC_Args --
26257 -------------------------
26259 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
26261 -- Preanalyze the boolean expressions, we treat these as spec
26262 -- expressions (i.e. similar to a default expression).
26264 if Present
(Arg_Req
) then
26265 Preanalyze_Assert_Expression
26266 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
26268 -- In ASIS mode, for a pragma generated from a source aspect, also
26269 -- analyze the original aspect expression.
26271 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26272 Preanalyze_Assert_Expression
26273 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
26277 if Present
(Arg_Ens
) then
26278 Preanalyze_Assert_Expression
26279 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
26281 -- In ASIS mode, for a pragma generated from a source aspect, also
26282 -- analyze the original aspect expression.
26284 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
26285 Preanalyze_Assert_Expression
26286 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
26289 end Preanalyze_CTC_Args
;
26291 --------------------------------------
26292 -- Process_Compilation_Unit_Pragmas --
26293 --------------------------------------
26295 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26297 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26298 -- strange because it comes at the end of the unit. Rational has the
26299 -- same name for a pragma, but treats it as a program unit pragma, In
26300 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26301 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26302 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26303 -- the context clause to ensure the correct processing.
26305 if Has_Pragma_Suppress_All
(N
) then
26306 Prepend_To
(Context_Items
(N
),
26307 Make_Pragma
(Sloc
(N
),
26308 Chars
=> Name_Suppress
,
26309 Pragma_Argument_Associations
=> New_List
(
26310 Make_Pragma_Argument_Association
(Sloc
(N
),
26311 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26314 -- Nothing else to do at the current time
26316 end Process_Compilation_Unit_Pragmas
;
26318 ------------------------------------
26319 -- Record_Possible_Body_Reference --
26320 ------------------------------------
26322 procedure Record_Possible_Body_Reference
26323 (State_Id
: Entity_Id
;
26327 Spec_Id
: Entity_Id
;
26330 -- Ensure that we are dealing with a reference to a state
26332 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26334 -- Climb the tree starting from the reference looking for a package body
26335 -- whose spec declares the referenced state. This criteria automatically
26336 -- excludes references in package specs which are legal. Note that it is
26337 -- not wise to emit an error now as the package body may lack pragma
26338 -- Refined_State or the referenced state may not be mentioned in the
26339 -- refinement. This approach avoids the generation of misleading errors.
26342 while Present
(Context
) loop
26343 if Nkind
(Context
) = N_Package_Body
then
26344 Spec_Id
:= Corresponding_Spec
(Context
);
26346 if Present
(Abstract_States
(Spec_Id
))
26347 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26349 if No
(Body_References
(State_Id
)) then
26350 Set_Body_References
(State_Id
, New_Elmt_List
);
26353 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
26358 Context
:= Parent
(Context
);
26360 end Record_Possible_Body_Reference
;
26362 ------------------------------
26363 -- Relocate_Pragmas_To_Body --
26364 ------------------------------
26366 procedure Relocate_Pragmas_To_Body
26367 (Subp_Body
: Node_Id
;
26368 Target_Body
: Node_Id
:= Empty
)
26370 procedure Relocate_Pragma
(Prag
: Node_Id
);
26371 -- Remove a single pragma from its current list and add it to the
26372 -- declarations of the proper body (either Subp_Body or Target_Body).
26374 ---------------------
26375 -- Relocate_Pragma --
26376 ---------------------
26378 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26383 -- When subprogram stubs or expression functions are involves, the
26384 -- destination declaration list belongs to the proper body.
26386 if Present
(Target_Body
) then
26387 Target
:= Target_Body
;
26389 Target
:= Subp_Body
;
26392 Decls
:= Declarations
(Target
);
26396 Set_Declarations
(Target
, Decls
);
26399 -- Unhook the pragma from its current list
26402 Prepend
(Prag
, Decls
);
26403 end Relocate_Pragma
;
26407 Body_Id
: constant Entity_Id
:=
26408 Defining_Unit_Name
(Specification
(Subp_Body
));
26409 Next_Stmt
: Node_Id
;
26412 -- Start of processing for Relocate_Pragmas_To_Body
26415 -- Do not process a body that comes from a separate unit as no construct
26416 -- can possibly follow it.
26418 if not Is_List_Member
(Subp_Body
) then
26421 -- Do not relocate pragmas that follow a stub if the stub does not have
26424 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26425 and then No
(Target_Body
)
26429 -- Do not process internally generated routine _Postconditions
26431 elsif Ekind
(Body_Id
) = E_Procedure
26432 and then Chars
(Body_Id
) = Name_uPostconditions
26437 -- Look at what is following the body. We are interested in certain kind
26438 -- of pragmas (either from source or byproducts of expansion) that can
26439 -- apply to a body [stub].
26441 Stmt
:= Next
(Subp_Body
);
26442 while Present
(Stmt
) loop
26444 -- Preserve the following statement for iteration purposes due to a
26445 -- possible relocation of a pragma.
26447 Next_Stmt
:= Next
(Stmt
);
26449 -- Move a candidate pragma following the body to the declarations of
26452 if Nkind
(Stmt
) = N_Pragma
26453 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26455 Relocate_Pragma
(Stmt
);
26457 -- Skip internally generated code
26459 elsif not Comes_From_Source
(Stmt
) then
26462 -- No candidate pragmas are available for relocation
26470 end Relocate_Pragmas_To_Body
;
26472 -------------------
26473 -- Resolve_State --
26474 -------------------
26476 procedure Resolve_State
(N
: Node_Id
) is
26481 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26482 Func
:= Entity
(N
);
26484 -- Handle overloading of state names by functions. Traverse the
26485 -- homonym chain looking for an abstract state.
26487 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26488 State
:= Homonym
(Func
);
26489 while Present
(State
) loop
26491 -- Resolve the overloading by setting the proper entity of the
26492 -- reference to that of the state.
26494 if Ekind
(State
) = E_Abstract_State
then
26495 Set_Etype
(N
, Standard_Void_Type
);
26496 Set_Entity
(N
, State
);
26497 Set_Associated_Node
(N
, State
);
26501 State
:= Homonym
(State
);
26504 -- A function can never act as a state. If the homonym chain does
26505 -- not contain a corresponding state, then something went wrong in
26506 -- the overloading mechanism.
26508 raise Program_Error
;
26513 ----------------------------
26514 -- Rewrite_Assertion_Kind --
26515 ----------------------------
26517 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26521 if Nkind
(N
) = N_Attribute_Reference
26522 and then Attribute_Name
(N
) = Name_Class
26523 and then Nkind
(Prefix
(N
)) = N_Identifier
26525 case Chars
(Prefix
(N
)) is
26530 when Name_Type_Invariant
=>
26531 Nam
:= Name_uType_Invariant
;
26532 when Name_Invariant
=>
26533 Nam
:= Name_uInvariant
;
26538 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26540 end Rewrite_Assertion_Kind
;
26548 Dummy
:= Dummy
+ 1;
26551 --------------------------------
26552 -- Set_Encoded_Interface_Name --
26553 --------------------------------
26555 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26556 Str
: constant String_Id
:= Strval
(S
);
26557 Len
: constant Int
:= String_Length
(Str
);
26562 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26565 -- Stores encoded value of character code CC. The encoding we use an
26566 -- underscore followed by four lower case hex digits.
26572 procedure Encode
is
26574 Store_String_Char
(Get_Char_Code
('_'));
26576 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26578 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26580 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26582 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26585 -- Start of processing for Set_Encoded_Interface_Name
26588 -- If first character is asterisk, this is a link name, and we leave it
26589 -- completely unmodified. We also ignore null strings (the latter case
26590 -- happens only in error cases) and no encoding should occur for Java or
26591 -- AAMP interface names.
26594 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26595 or else VM_Target
/= No_VM
26596 or else AAMP_On_Target
26598 Set_Interface_Name
(E
, S
);
26603 CC
:= Get_String_Char
(Str
, J
);
26605 exit when not In_Character_Range
(CC
);
26607 C
:= Get_Character
(CC
);
26609 exit when C
/= '_' and then C
/= '$'
26610 and then C
not in '0' .. '9'
26611 and then C
not in 'a' .. 'z'
26612 and then C
not in 'A' .. 'Z';
26615 Set_Interface_Name
(E
, S
);
26623 -- Here we need to encode. The encoding we use as follows:
26624 -- three underscores + four hex digits (lower case)
26628 for J
in 1 .. String_Length
(Str
) loop
26629 CC
:= Get_String_Char
(Str
, J
);
26631 if not In_Character_Range
(CC
) then
26634 C
:= Get_Character
(CC
);
26636 if C
= '_' or else C
= '$'
26637 or else C
in '0' .. '9'
26638 or else C
in 'a' .. 'z'
26639 or else C
in 'A' .. 'Z'
26641 Store_String_Char
(CC
);
26648 Set_Interface_Name
(E
,
26649 Make_String_Literal
(Sloc
(S
),
26650 Strval
=> End_String
));
26652 end Set_Encoded_Interface_Name
;
26654 ------------------------
26655 -- Set_Elab_Unit_Name --
26656 ------------------------
26658 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26663 if Nkind
(N
) = N_Identifier
26664 and then Nkind
(With_Item
) = N_Identifier
26666 Set_Entity
(N
, Entity
(With_Item
));
26668 elsif Nkind
(N
) = N_Selected_Component
then
26669 Change_Selected_Component_To_Expanded_Name
(N
);
26670 Set_Entity
(N
, Entity
(With_Item
));
26671 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26673 Pref
:= Prefix
(N
);
26674 Scop
:= Scope
(Entity
(N
));
26675 while Nkind
(Pref
) = N_Selected_Component
loop
26676 Change_Selected_Component_To_Expanded_Name
(Pref
);
26677 Set_Entity
(Selector_Name
(Pref
), Scop
);
26678 Set_Entity
(Pref
, Scop
);
26679 Pref
:= Prefix
(Pref
);
26680 Scop
:= Scope
(Scop
);
26683 Set_Entity
(Pref
, Scop
);
26686 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
26687 end Set_Elab_Unit_Name
;